psmile_check_action.F90

Go to the documentation of this file.
00001 #define __OLD_scheme
00002 !-----------------------------------------------------------------------
00003 ! Copyright 2006-2010, NEC Europe Ltd., London, UK.
00004 ! All rights reserved. Use is subject to OASIS4 license terms.
00005 !-----------------------------------------------------------------------
00006 !BOP
00007 !
00008 ! !ROUTINE: PSMILe_Create_timeaxis
00009 !
00010 ! !INTERFACE:
00011 !
00012 subroutine psmile_check_action ( var_id, task_id, precise, &
00013                                  julian_day, julian_dayb,  &
00014                                  julian_sec, julian_secb,  &
00015                                  action )
00016 !
00017 ! !USES:
00018 !
00019   use PSMILe, dummy_interface => psmile_check_action
00020   use PSMILe_SMIOC, only : sga_smioc_comp, transient
00021   use PRISM_constants
00022 
00023   implicit none
00024 !
00025 ! !INPUT PARAMETERS:
00026 !
00027   Integer, Intent (In)  :: var_id
00028   Integer, Intent (In)  :: task_id
00029 
00030   Double Precision, Intent (In) :: julian_day, julian_dayb(2)
00031   Double Precision, Intent (In) :: julian_sec, julian_secb(2)
00032 
00033   Logical, Intent (In)  :: precise
00034 !
00035 ! !OUTPUT PARAMETERS:
00036 !
00037   Logical, Intent (Out) :: action(3)  ! 1: coupling action
00038                                       ! 2: IO action
00039                                       ! 3: restart action
00040 !
00041 ! !LOCAL VARIABLES
00042 !
00043   Double Precision      :: upper_bnd, lower_bnd
00044   Double Precision      :: juday_axis
00045 
00046   Integer               :: i, imax, lag
00047   Logical               :: time_action 
00048 
00049   Type (transient), pointer :: sga_smioc_transi(:)
00050 !
00051 ! !DESCRIPTION:
00052 !
00053 !    Subroutine "psmile_create_timeaxis" generates the date and time for
00054 !    coupling and IO events for each field and task.
00055 !
00056 ! !REVISION HISTORY:
00057 !   Date      Programmer   Description
00058 ! ----------  ----------   -----------
00059 ! 04.01.26    R. Redler    created
00060 ! 11.02.24    R. Redler    revised
00061 !
00062 !EOP
00063 !------------------------------------------------------------------------
00064 !
00065 ! $Id: psmile_check_action.F90 3024 2011-03-17 11:28:47Z redler $
00066 ! $Author: redler $
00067 !
00068   Character(len=len_cvs_string), save :: mycvs = 
00069       '$Id: psmile_check_action.F90 3024 2011-03-17 11:28:47Z redler $'
00070 !
00071 !------------------------------------------------------------------------
00072 
00073 #ifdef VERBOSE
00074   print *, trim(ch_id), ': psmile_check_action: var_id ', var_id
00075 
00076   call psmile_flushstd
00077 #endif /* VERBOSE */
00078 
00079   !----------------------------------------------------------------------
00080   ! 1st   Initialisation
00081   !----------------------------------------------------------------------
00082 
00083   sga_smioc_transi => sga_smioc_comp(Fields(var_id)%comp_id)%sga_smioc_transi
00084 
00085   time_action = .false.
00086 
00087   lower_bnd  = julian_dayb(1) + julian_secb(1)/86400.0
00088   upper_bnd  = julian_dayb(2) + julian_secb(2)/86400.0
00089 
00090 #ifdef DEBUG
00091   print *, trim(ch_id), ': psmile_check_action: julian_dayb(1), julian_secb(1)', &
00092                                                 julian_dayb(1), julian_secb(1)
00093   print *, trim(ch_id), ': psmile_check_action: julian_dayb(2), julian_secb(2)', &
00094                                                 julian_dayb(2), julian_secb(2)
00095   call psmile_flushstd
00096 #endif
00097 
00098 #ifdef __NEW_scheme
00099 
00100   action = .false.
00101 
00102   !----------------------------------------------------------------------
00103   ! 2nd   Input section (PRISM_get)
00104   !----------------------------------------------------------------------
00105 
00106   if ( task_id == 0 ) then
00107 
00108      !-------------------------------------------------------------------
00109      ! ...   Check date and time
00110      !-------------------------------------------------------------------
00111 
00112 #ifdef DEBUG
00113      print *, trim(ch_id), ': psmile_check_action: Event at ',    &
00114                          Fields(var_id)%Taskin%Judate_Event%days, &
00115                          Fields(var_id)%Taskin%Judate_Event%secs
00116      call psmile_flushstd
00117 #endif
00118 
00119      if ( .not. precise ) then
00120 
00121         if ( lower_bnd > Fields(var_id)%Taskin%Judate_Stop%days &
00122                        + Fields(var_id)%Taskin%Judate_Stop%secs/86400.0 ) then
00123              time_action = .false.
00124         endif
00125 
00126         if ( upper_bnd < Fields(var_id)%Taskin%Judate_Start%days &
00127                        + Fields(var_id)%Taskin%Judate_Start%secs/86400.0 ) then
00128              time_action = .false.
00129         endif
00130 
00131         !----------------------------------------------------------------
00132         ! ...   Update Event if neccessary
00133         !----------------------------------------------------------------
00134 
00135         do while ( lower_bnd >= Fields(var_id)%Taskin%Judate_Event%days &
00136                              + Fields(var_id)%Taskin%Judate_Event%secs/86400.0 )
00137 
00138            call psmile_calc_new_date ( Fields(var_id)%Taskin%Judate_Event, &
00139                                        Fields(var_id)%Taskin%delta_time )
00140 #ifdef DEBUG
00141            print *, trim(ch_id), ': psmile_check_action: Event shifted to ', &
00142                                        Fields(var_id)%Taskin%Judate_Event%days, &
00143                                        Fields(var_id)%Taskin%Judate_Event%secs
00144            call psmile_flushstd
00145 #endif
00146         enddo
00147 
00148         juday_axis = Fields(var_id)%Taskin%Judate_Event%days &
00149                    + Fields(var_id)%Taskin%Judate_Event%secs/86400.0
00150 
00151         if ( lower_bnd < juday_axis .and. upper_bnd >= juday_axis ) then
00152 
00153            time_action = .true.
00154 
00155            !-------------------------------------------------------------
00156            ! ...   Set next event if neccessary
00157            !-------------------------------------------------------------
00158 
00159            call psmile_calc_new_date ( Fields(var_id)%Taskin%Judate_Event, &
00160                                        Fields(var_id)%Taskin%delta_time ) 
00161 #ifdef DEBUG
00162            print *, trim(ch_id), ': psmile_check_action: Event shifted after action to ', &
00163                                        Fields(var_id)%Taskin%Judate_Event%days, &
00164                                        Fields(var_id)%Taskin%Judate_Event%secs
00165            call psmile_flushstd
00166 #endif
00167 
00168         endif
00169 
00170         !----------------------------------------------------------------
00171         ! ...   Determine input path
00172         !----------------------------------------------------------------
00173 
00174         if ( time_action ) then
00175 
00176            do i = 1, sga_smioc_transi(Fields(var_id)%smioc_loc)%sg_transi_in%ig_nb_in_orig
00177 
00178               if ( sga_smioc_transi(Fields(var_id)%smioc_loc)%sg_transi_in%sga_in_orig(i)%ig_orig_type == PSMILe_comp ) &
00179                    action(1) = .true.
00180 
00181               if ( sga_smioc_transi(Fields(var_id)%smioc_loc)%sg_transi_in%sga_in_orig(i)%ig_orig_type == PSMILe_file ) &
00182                    action(2) = .true.
00183 
00184            enddo
00185 
00186         endif
00187 
00188      endif ! precise
00189 
00190   endif ! task_id
00191 
00192   !----------------------------------------------------------------------
00193   ! 3rd   Output section (PRISM_put)
00194   !----------------------------------------------------------------------
00195   
00196   if ( task_id > 0 ) then
00197 
00198 #ifdef DEBUG
00199      print *, trim(ch_id), ': psmile_check_action: Event at ',              &
00200                          Fields(var_id)%Taskout(task_id)%Judate_Event%days, &
00201                          Fields(var_id)%Taskout(task_id)%Judate_Event%secs
00202      call psmile_flushstd
00203 #endif
00204 
00205      lag = sga_smioc_transi(Fields(var_id)%smioc_loc)%sga_transi_out(task_id)%ig_lag
00206 
00207      !-------------------------------------------------------------------
00208      ! ...   Check date and time
00209      !-------------------------------------------------------------------
00210      
00211      if ( .not. precise ) then
00212 
00213         if ( lag == 0 .and. lag /= PSMILe_undef ) then
00214 
00215            if ( upper_bnd >= Fields(var_id)%Taskout(task_id)%Judate_Stop%days &
00216                            + Fields(var_id)%Taskout(task_id)%Judate_Stop%secs/86400.0 ) &
00217                 action(3) = .true.
00218 
00219         else if ( lag > 0 .and. lag /= PSMILe_undef ) then
00220 
00221            if ( upper_bnd > Fields(var_id)%Taskout(task_id)%Judate_Stop%days &
00222                           + Fields(var_id)%Taskout(task_id)%Judate_Stop%secs/86400.0 ) &
00223                 action(3) = .true.
00224         endif
00225 
00226         if ( lower_bnd > Fields(var_id)%Taskout(task_id)%Judate_Stop%days &
00227                        + Fields(var_id)%Taskout(task_id)%Judate_Stop%secs/86400.0 ) &
00228              time_action = .false.
00229 
00230         if ( upper_bnd < Fields(var_id)%Taskout(task_id)%Judate_Start%days &
00231                        + Fields(var_id)%Taskout(task_id)%Judate_Start%secs/86400.0 ) &
00232              time_action = .false.
00233 
00234         !----------------------------------------------------------------
00235         ! ...   Update Event if neccessary
00236         !----------------------------------------------------------------
00237 
00238         do while ( lower_bnd >= Fields(var_id)%Taskout(task_id)%Judate_Event%days &
00239                              + Fields(var_id)%Taskout(task_id)%Judate_Event%secs/86400.0 )
00240 
00241            call psmile_calc_new_date ( Fields(var_id)%Taskout(task_id)%Judate_Event, &
00242                                        Fields(var_id)%Taskout(task_id)%delta_time ) 
00243 #ifdef DEBUG
00244      print *, trim(ch_id), ': psmile_check_action: Event shifted to ',      &
00245                          Fields(var_id)%Taskout(task_id)%Judate_Event%days, &
00246                          Fields(var_id)%Taskout(task_id)%Judate_Event%secs
00247      call psmile_flushstd
00248 #endif
00249 
00250         enddo
00251 
00252         juday_axis = Fields(var_id)%Taskout(task_id)%Judate_Event%days &
00253                    + Fields(var_id)%Taskout(task_id)%Judate_Event%secs/86400.0
00254 
00255         !----------------------------------------------------------------
00256         ! ...   Check for an event
00257         !----------------------------------------------------------------
00258         
00259         if ( lower_bnd < juday_axis .and. upper_bnd >= juday_axis ) then
00260 
00261            time_action = .true.
00262 
00263            !-------------------------------------------------------------
00264            ! ...   Set next event if neccessary
00265            !-------------------------------------------------------------
00266 
00267            call psmile_calc_new_date ( Fields(var_id)%Taskout(task_id)%Judate_Event, &
00268                                        Fields(var_id)%Taskout(task_id)%delta_time ) 
00269 #ifdef DEBUG
00270            print *, trim(ch_id), ': psmile_check_action: Event shfted after action to ', &
00271                                   Fields(var_id)%Taskout(task_id)%Judate_Event%days,     &
00272                                   Fields(var_id)%Taskout(task_id)%Judate_Event%secs
00273            call psmile_flushstd
00274 #endif
00275 
00276         endif
00277 
00278         !----------------------------------------------------------------
00279         ! ...   Determine output path
00280         !----------------------------------------------------------------
00281         
00282         if ( time_action ) then
00283 
00284            if ( sga_smioc_transi(Fields(var_id)%smioc_loc)%sga_transi_out(task_id)%ig_dest_type == PSMILe_comp ) &
00285                 action(1) = .true.
00286 
00287            if ( sga_smioc_transi(Fields(var_id)%smioc_loc)%sga_transi_out(task_id)%ig_dest_type == PSMILe_file ) &
00288                 action(2) = .true.
00289         endif
00290 
00291         ! For lags > 0 we can either write a couling restart for a particular
00292         ! task or send it to a transformer or application process, but not 
00293         ! both at the same time. For lag == 0 suppress writing of restart file
00294         ! at coupling steps. 
00295 
00296         if ( lag == 0 .and. action(1) ) action(3) = .false.
00297         if ( lag  > 0 .and. action(3) ) action(1) = .false.
00298 
00299      endif ! precise
00300 
00301   endif ! task_id
00302 
00303 #endif /* __NEW_scheme */
00304 
00305 #ifdef __OLD_scheme
00306 
00307   !----------------------------------------------------------------------
00308   ! 2nd   Input section (PRISM_get)
00309   !----------------------------------------------------------------------
00310   
00311   if ( task_id == 0 ) then
00312 
00313      action  = .false.
00314 
00315      !-------------------------------------------------------------------
00316      ! ...   Check date and time
00317      !-------------------------------------------------------------------
00318 
00319      if ( .not. precise ) then
00320 
00321         imax = Fields(var_id)%Taskin%Time_length
00322 
00323         if ( imax > 0 ) then
00324 
00325            if ( lower_bnd > Fields(var_id)%Taskin%Judate_Axis(imax)%days &
00326                           + Fields(var_id)%Taskin%Judate_Axis(imax)%secs/86400.0 ) imax = 0
00327 
00328            if ( upper_bnd < Fields(var_id)%Taskin%Judate_Axis(1)%days &
00329                           + Fields(var_id)%Taskin%Judate_Axis(1)%secs/86400.0 ) imax = 0
00330         else
00331 
00332            print *, trim(ch_id), ': psmile_check_action: No time action specified. '
00333 
00334         endif
00335 
00336         do i = 1, imax
00337 
00338            juday_axis = Fields(var_id)%Taskin%Judate_Axis(i)%days &
00339                       + Fields(var_id)%Taskin%Judate_Axis(i)%secs/86400.0
00340 
00341            if ( lower_bnd < juday_axis .and. upper_bnd >= juday_axis ) then
00342               time_action = .true.
00343               exit
00344            endif
00345 
00346         enddo
00347 
00348      endif
00349 
00350      !-------------------------------------------------------------------
00351      ! ...   Determine input path
00352      !-------------------------------------------------------------------
00353 
00354      if ( time_action ) then
00355 
00356         do i = 1, sga_smioc_transi(Fields(var_id)%smioc_loc)%sg_transi_in%ig_nb_in_orig
00357 
00358            if ( sga_smioc_transi(Fields(var_id)%smioc_loc)%sg_transi_in%sga_in_orig(i)%ig_orig_type == PSMILe_comp ) &
00359                 action(1) = .true.
00360 
00361            if ( sga_smioc_transi(Fields(var_id)%smioc_loc)%sg_transi_in%sga_in_orig(i)%ig_orig_type == PSMILe_file ) &
00362                 action(2) = .true.
00363 
00364         enddo
00365 
00366      endif
00367 
00368   endif ! task_id
00369 
00370   !----------------------------------------------------------------------
00371   ! 3rd   Output section (PRISM_put)
00372   !----------------------------------------------------------------------
00373 
00374   if ( task_id > 0 ) then
00375 
00376      action  = .false.
00377 
00378      lag = sga_smioc_transi(Fields(var_id)%smioc_loc)%sga_transi_out(task_id)%ig_lag
00379 
00380      !-------------------------------------------------------------------
00381      ! ...   Check date and time
00382      !-------------------------------------------------------------------
00383 
00384      if ( .not. precise ) then
00385 
00386         imax = Fields(var_id)%Taskout(task_id)%Time_length
00387 
00388         if ( imax > 0 ) then
00389 
00390            if ( lag == 0 .and. lag /= PSMILe_undef ) then
00391 
00392               if ( upper_bnd >=  Fields(var_id)%Taskout(task_id)%Judate_Axis(imax)%days &
00393                                + Fields(var_id)%Taskout(task_id)%Judate_Axis(imax)%secs/86400.0 ) &
00394                    action(3) = .true.
00395 
00396            else if ( lag > 0 .and. lag /= PSMILe_undef ) then
00397 
00398               if ( upper_bnd >  Fields(var_id)%Taskout(task_id)%Judate_Axis(imax)%days &
00399                               + Fields(var_id)%Taskout(task_id)%Judate_Axis(imax)%secs/86400.0 ) &
00400                    action(3) = .true.
00401 
00402            endif
00403 
00404            if ( lower_bnd > Fields(var_id)%Taskout(task_id)%Judate_Axis(imax)%days &
00405                           + Fields(var_id)%Taskout(task_id)%Judate_Axis(imax)%secs/86400.0 ) imax = 0
00406 
00407            if ( upper_bnd < Fields(var_id)%Taskout(task_id)%Judate_Axis(1)%days &
00408                           + Fields(var_id)%Taskout(task_id)%Judate_Axis(1)%secs/86400.0 ) imax = 0
00409 
00410         else
00411 
00412            print *, trim(ch_id), ': psmile_check_action: No time action specified. '
00413 
00414         endif
00415 
00416         do i = 1, imax
00417 
00418            juday_axis = Fields(var_id)%Taskout(task_id)%Judate_Axis(i)%days &
00419                       + Fields(var_id)%Taskout(task_id)%Judate_Axis(i)%secs/86400.0
00420 
00421            if ( lower_bnd < juday_axis .and. upper_bnd >= juday_axis ) then
00422               time_action = .true.
00423               exit
00424            endif
00425 
00426         enddo
00427 
00428      endif
00429 
00430      !-------------------------------------------------------------------
00431      ! ...   Determine output path
00432      !-------------------------------------------------------------------
00433 
00434      if ( time_action ) then
00435 
00436         if ( sga_smioc_transi(Fields(var_id)%smioc_loc)%sga_transi_out(task_id)%ig_dest_type == PSMILe_comp ) &
00437              action(1) = .true.
00438 
00439         if ( sga_smioc_transi(Fields(var_id)%smioc_loc)%sga_transi_out(task_id)%ig_dest_type == PSMILe_file ) &
00440              action(2) = .true.
00441      endif
00442 
00443      ! For lags > 0 we can either write a couling restart for a particular
00444      ! task or send it to a transformer or application process, but not 
00445      ! both at the same time. For lag == 0 suppress writing of restart file
00446      ! at coupling steps. 
00447 
00448      if ( lag == 0 .and. action(1) ) action(3) = .false.
00449      if ( lag  > 0 .and. action(3) ) action(1) = .false.
00450 
00451   endif ! task_id
00452 
00453 #endif /* __OLD_scheme */
00454 
00455 #ifdef VERBOSE
00456   print *, trim(ch_id), ': psmile_check_action: ', 'Cpl=',  action(1), &
00457                                                    'IO=',   action(2), &
00458                                                    'Rest=', action(3)
00459   print *, trim(ch_id), ': psmile_check_action: end'
00460   call psmile_flushstd
00461 #endif /* VERBOSE */
00462 
00463 end subroutine psmile_check_action
00464 
00465 #ifdef __NEW_scheme
00466 
00467 subroutine psmile_calc_new_date ( date, delta_time )
00468   !
00469   ! !USES:
00470   !
00471   use PRISM_constants, ONLY : PRISM_Time_Struct
00472   use PSMILe, ONLY : PSMILe_Time_Struct
00473   use PRISM_calendar, ONLY : psmile_date2ju, psmile_ju2date
00474   !
00475   ! !INPUT/OUTOUT PARAMETERS:
00476   !
00477   Type(PSMILe_Time_Struct), INTENT(INOUT) :: date
00478   !
00479   ! !INPUT PARAMETERS:
00480   !
00481   Type(PRISM_Time_Struct), INTENT(IN)     :: delta_time
00482   !
00483   ! !LOCAL VARIABLES
00484   !
00485   Type(PRISM_Time_Struct ) :: tmp_date(2)
00486 
00487   Double Precision   :: temp_days
00488   Double Precision   :: temp_secs, secs
00489 
00490   Integer, Parameter :: iold = 1
00491   Integer, Parameter :: inew = 2
00492 
00493   Integer            :: add_days
00494   !
00495   ! !DESCRIPTION:
00496   !
00497   !    Subroutine "psmile_calc_new_date" updates the date/time
00498   !      provided as Julian data/time with the delta time provided
00499   !      by the user in the XML file.
00500   !
00501   ! !REVISION HISTORY:
00502   !   Date      Programmer   Description
00503   ! ----------  ----------   -----------
00504   ! 11.02.24    R. Redler    created
00505   !
00506   !EOP
00507   !----------------------------------------------------------------------
00508 
00509   !----------------------------------------------------------------------
00510   ! Convert Julian date/time into calendar
00511   !----------------------------------------------------------------------
00512 
00513   call psmile_ju2date ( tmp_date(iold), date%days, date%secs )
00514 
00515   !----------------------------------------------------------------------
00516   ! Update of years and months first
00517   !----------------------------------------------------------------------
00518 
00519   tmp_date(inew)%year  = tmp_date(iold)%year  + delta_time%year
00520   tmp_date(inew)%month = tmp_date(iold)%month + delta_time%month
00521 
00522   if ( tmp_date(inew)%month > 12 ) then
00523        tmp_date(inew)%month = tmp_date(inew)%month - 12
00524        tmp_date(inew)%year  = tmp_date(inew)%year  +  1
00525   endif
00526 
00527   !----------------------------------------------------------------------
00528   ! Updates of time in Julian time
00529   !----------------------------------------------------------------------
00530 
00531   tmp_date(inew)%day    = tmp_date(iold)%day
00532   tmp_date(inew)%hour   = tmp_date(iold)%hour
00533   tmp_date(inew)%minute = tmp_date(iold)%minute
00534   tmp_date(inew)%second = tmp_date(iold)%second
00535 
00536   call psmile_date2ju ( tmp_date(inew), temp_days, temp_secs )
00537 
00538   secs = delta_time%hour*3600.0 + delta_time%minute*60.0 &
00539        + delta_time%second      + temp_secs
00540 
00541   add_days = int(secs/86400.0)
00542 
00543   !----------------------------------------------------------------------
00544   ! Update input Julian date by adding days and seconds
00545   !----------------------------------------------------------------------
00546 
00547   date%days = temp_days + delta_time%day + add_days
00548   date%secs = secs - (float(add_days) * 86400.0)
00549 
00550 end subroutine psmile_calc_new_date
00551 
00552 #endif /* __NEW_scheme */