psmile_create_timeaxis.F90

Go to the documentation of this file.
00001 !-----------------------------------------------------------------------
00002 ! Copyright 2006-2010, NEC Europe Ltd., London, UK.
00003 ! All rights reserved. Use is subject to OASIS4 license terms.
00004 !-----------------------------------------------------------------------
00005 !BOP
00006 !
00007 ! !ROUTINE: PSMILe_Create_timeaxis
00008 !
00009 ! !INTERFACE:
00010 
00011    subroutine psmile_create_timeaxis (var_id, ierror )
00012 !
00013 ! !USES:
00014 !
00015       use PRISM_constants
00016       use PRISM_calendar
00017 
00018       use PSMILe
00019       use PSMILe_SMIOC, only : sga_smioc_comp, transient
00020 
00021       implicit none
00022 !
00023 ! !INPUT PARAMETERS:
00024 !
00025       Integer, Intent (In)                :: var_id
00026 
00027 !     Handle to the variable information
00028 
00029 !
00030 ! !OUTPUT PARAMETERS:
00031 !
00032       integer, Intent (Out)               :: ierror
00033 
00034 !     Returns the error code of prism_put;
00035 !             ierror = 0 : No error
00036 !             ierror > 0 : Severe error
00037 !
00038 ! !LOCAL VARIABLES
00039 !
00040       Type(PRISM_Time_Struct ) :: tmp_date(2)
00041       Type(PRISM_Time_Struct ) :: delta_time
00042 
00043       Type(PSMILe_Time_Struct), Pointer :: New_judateaxis(:)
00044 
00045       Double Precision   :: jd_start, jd_end, temp_days
00046       Double Precision   :: js_start, js_end, temp_secs, secs
00047 
00048       Integer            :: add_days
00049       Integer            :: ii, i, iold, inew, ndim, loopend
00050 
00051       Integer, Parameter :: nerrp = 2
00052       Integer            :: ierrp (nerrp)
00053 
00054       Type (transient), pointer :: sga_smioc_transi(:)
00055 !
00056 ! !DESCRIPTION:
00057 !
00058 !    Subroutine "psmile_create_timeaxis" create to time axis with dates
00059 !    at which action has to be performed for the particular field id.
00060 !
00061 ! !REVISION HISTORY:
00062 !   Date      Programmer   Description
00063 ! ----------  ----------   -----------
00064 ! 04.01.26    R. Redler    created
00065 !
00066 !EOP
00067 !----------------------------------------------------------------------
00068 !
00069 ! $Id: psmile_create_timeaxis.F90 2989 2011-02-24 16:29:52Z redler $
00070 ! $Author: redler $
00071 !
00072   Character(len=len_cvs_string), save :: mycvs = 
00073       '$Id: psmile_create_timeaxis.F90 2989 2011-02-24 16:29:52Z redler $'
00074 !
00075 !----------------------------------------------------------------------
00076 
00077    ierror = 0
00078 
00079    sga_smioc_transi => sga_smioc_comp(Fields(var_id)%comp_id)%sga_smioc_transi
00080 
00081 #ifdef VERBOSE
00082    print *, trim(ch_id), ': psmile_create_timeaxis: start'
00083    print *, trim(ch_id), ': psmile_create_timeaxis: var_id', var_id
00084 
00085    call psmile_flushstd
00086 #endif /* VERBOSE */
00087 
00088    if ( Fields(var_id)%smioc_loc == PRISM_UNDEFINED ) then
00089 
00090 #ifdef VERBOSE
00091       print *, trim(ch_id), ': psmile_create_timeaxis: no action for var_id', var_id
00092 
00093       call psmile_flushstd
00094 #endif /* VERBOSE */
00095       return
00096 
00097    endif
00098 
00099 !---------------------------------------------------------------------------
00100 !  Check whether there is something to do for this var_id, other wise return
00101 !---------------------------------------------------------------------------
00102 
00103    if ( sga_smioc_transi(Fields(var_id)%smioc_loc)%sg_transi_in%ig_nb_in_orig < 1 .and. &
00104         sga_smioc_transi(Fields(var_id)%smioc_loc)%ig_nb_transi_out           < 1 ) then
00105 #ifdef VERBOSE
00106       print *, trim(ch_id), ': psmile_create_timeaxis: early return eof ierror ', ierror
00107       call psmile_flushstd
00108 #endif /* VERBOSE */
00109       return
00110    endif
00111 
00112 !-----------------------------------------------------------------------
00113 !  1st Initialization
00114 !-----------------------------------------------------------------------
00115 
00116 #ifdef DEBUG
00117    print *, trim(ch_id), ': psmile_create_timeaxis: Job start date:'
00118    print *, trim(ch_id), ': psmile_create_timeaxis: yr ', PRISM_Jobstart_date%year
00119    print *, trim(ch_id), ': psmile_create_timeaxis: mo ', PRISM_Jobstart_date%month
00120    print *, trim(ch_id), ': psmile_create_timeaxis: d  ', PRISM_Jobstart_date%day
00121    print *, trim(ch_id), ': psmile_create_timeaxis: hr ', PRISM_Jobstart_date%hour
00122    print *, trim(ch_id), ': psmile_create_timeaxis: mi ', PRISM_Jobstart_date%minute
00123    print *, trim(ch_id), ': psmile_create_timeaxis: s  ', PRISM_Jobstart_date%second
00124    print *, trim(ch_id), ': psmile_create_timeaxis: Job end date:'
00125    print *, trim(ch_id), ': psmile_create_timeaxis: yr ', PRISM_Jobend_date%year
00126    print *, trim(ch_id), ': psmile_create_timeaxis: mo ', PRISM_Jobend_date%month
00127    print *, trim(ch_id), ': psmile_create_timeaxis: d  ', PRISM_Jobend_date%day
00128    print *, trim(ch_id), ': psmile_create_timeaxis: hr ', PRISM_Jobend_date%hour
00129    print *, trim(ch_id), ': psmile_create_timeaxis: mi ', PRISM_Jobend_date%minute
00130    print *, trim(ch_id), ': psmile_create_timeaxis: s  ', PRISM_Jobend_date%second
00131 #endif
00132 
00133    call psmile_date2ju (PRISM_Jobstart_date, jd_start, js_start) 
00134    call psmile_date2ju (PRISM_Jobend_date, jd_end, js_end)
00135 
00136    if ( ( jd_end < jd_start ) .or. &
00137         ( jd_end == jd_start .and. js_end < js_start ) ) then
00138 
00139      print *, trim(ch_id), ': psmile_create_timeaxis: job end date lt job start date'
00140      ierror = PRISM_Error_Date
00141      return
00142    endif
00143 
00144 !-----------------------------------------------------------------------
00145 !  2nd Work on transient out
00146 !     The requested output period can be differnt for each output
00147 !-----------------------------------------------------------------------
00148 
00149    do i = 1, sga_smioc_transi(Fields(var_id)%smioc_loc)%ig_nb_transi_out
00150       if ( sga_smioc_transi(Fields(var_id)%smioc_loc)%sga_transi_out(i)%ig_dest_type > 0 ) exit
00151    enddo
00152 
00153    if ( i > sga_smioc_transi(Fields(var_id)%smioc_loc)%ig_nb_transi_out ) then
00154       loopend = 0
00155    else
00156       loopend = sga_smioc_transi(Fields(var_id)%smioc_loc)%ig_nb_transi_out
00157    endif
00158 
00159    DO ii = 1, loopend
00160 
00161       ndim = 128
00162 
00163       if ( sga_smioc_transi(Fields(var_id)%smioc_loc)%sga_transi_out(ii)%ig_exch_date_type == PSMILe_period ) then
00164          delta_time = sga_smioc_transi(Fields(var_id)%smioc_loc)%sga_transi_out(ii)%sg_exch_date%sg_period
00165 
00166          if ( delta_time%year   ==  PSMILe_undef ) delta_time%year   = 0
00167          if ( delta_time%month  ==  PSMILe_undef ) delta_time%month  = 0
00168          if ( delta_time%day    ==  PSMILe_undef ) delta_time%day    = 0
00169          if ( delta_time%hour   ==  PSMILe_undef ) delta_time%hour   = 0
00170          if ( delta_time%minute ==  PSMILe_undef ) delta_time%minute = 0
00171          if ( delta_time%second ==  PSMILe_dundef) delta_time%second = 0
00172 
00173          if ( delta_time%year   == 0 .and. delta_time%month  == 0   .and. &
00174               delta_time%day    == 0 .and. delta_time%hour   == 0   .and. &
00175               delta_time%minute == 0 .and. delta_time%second == 0.0 ) then
00176 
00177             print *, trim(ch_id), ': psmile_create_timeaxis: output delta time == ZERO! We return.'
00178             ierror = PRISM_Error_Date
00179             return
00180          endif
00181 
00182       else
00183          print *, trim(ch_id), ': psmile_create_timeaxis: unsupported exchange out date type'
00184          ierror = PRISM_Error_Date
00185          return
00186       endif
00187 
00188       allocate (Fields(var_id)%Taskout(ii)%Judate_Axis(ndim), STAT=ierror )
00189       if (ierror > 0) then
00190          ierrp (1) = ierror
00191          ierrp (2) = ndim
00192          ierror    = PRISM_Error_Alloc
00193 
00194          call psmile_error ( ierror, 'Judate_Axis', &
00195               ierrp, 2, __FILE__, __LINE__ )
00196          return
00197       endif
00198 
00199       i    = 1
00200       iold = 1
00201       inew = 2
00202 
00203       tmp_date(iold) = PRISM_Jobstart_date
00204       tmp_date(inew) = PRISM_Jobstart_date
00205 
00206       Fields(var_id)%Taskout(ii)%delta_time = delta_time
00207 
00208       Fields(var_id)%Taskout(ii)%Judate_Start%days = jd_start
00209       Fields(var_id)%Taskout(ii)%Judate_Start%secs = js_start
00210 
00211       Fields(var_id)%Taskout(ii)%Judate_Stop%days = jd_end
00212       Fields(var_id)%Taskout(ii)%Judate_Stop%secs = js_end
00213 
00214       Fields(var_id)%Taskout(ii)%Judate_Event%days = jd_start
00215       Fields(var_id)%Taskout(ii)%Judate_Event%secs = js_start
00216 
00217       Fields(var_id)%Taskout(ii)%Judate_Axis(i)%days = jd_start
00218       Fields(var_id)%Taskout(ii)%Judate_Axis(i)%secs = js_start
00219 #ifdef DEBUGX
00220          write ( *, '(a27,i4)') ' List of events for var id ', var_id
00221          write ( *, '(5x,a5,4a3,a4)') ' year', '  m', '  d', ' hh', ':mm', ':sec'
00222 
00223          write ( *, '(i4,a1,i5,4i3, f6.3)' ) iold, ':', tmp_date(iold)%year,   &
00224                                                         tmp_date(iold)%month,  &
00225                                                         tmp_date(iold)%day,    &
00226                                                         tmp_date(iold)%hour,   &
00227                                                         tmp_date(iold)%minute, &
00228                                                         tmp_date(iold)%second
00229 #endif
00230       do
00231 
00232          i = i+1
00233 
00234          !--------------------------------------------------------
00235          ! a) Updates years and months first
00236          !--------------------------------------------------------
00237 
00238          tmp_date(inew)%year  = tmp_date(iold)%year  + delta_time%year
00239          tmp_date(inew)%month = tmp_date(iold)%month + delta_time%month
00240 
00241          if ( tmp_date(inew)%month > 12 ) then
00242             tmp_date(inew)%month = tmp_date(inew)%month - 12
00243             tmp_date(inew)%year  = tmp_date(inew)%year  +  1
00244          endif
00245 
00246          tmp_date(inew)%day    = tmp_date(iold)%day
00247          tmp_date(inew)%hour   = tmp_date(iold)%hour
00248          tmp_date(inew)%minute = tmp_date(iold)%minute
00249          tmp_date(inew)%second = tmp_date(iold)%second
00250 
00251          !---------------------------------------------------------
00252          ! b) Calculate intermediate julian date
00253          !---------------------------------------------------------
00254 
00255          call psmile_date2ju ( tmp_date(inew), temp_days, temp_secs )
00256 
00257          !---------------------------------------------------------
00258          ! c) Now add days and seconds to intermediate julian date
00259          !---------------------------------------------------------
00260 
00261          secs = delta_time%hour*3600.0 + delta_time%minute*60.0 &
00262               + delta_time%second      + temp_secs
00263 
00264          add_days = int(secs/86400.0)
00265 
00266          temp_days = temp_days + delta_time%day + add_days
00267          temp_secs = secs - (float(add_days) * 86400.0)
00268 
00269          Fields(var_id)%Taskout(ii)%Judate_Axis(i)%days = temp_days
00270          Fields(var_id)%Taskout(ii)%Judate_Axis(i)%secs = temp_secs
00271 
00272          call psmile_ju2date( tmp_date(inew), temp_days, temp_secs )
00273 #ifdef DEBUGX
00274          write ( *, '(i4,a1,i5,4i3, f6.3)' ) i, ':', tmp_date(inew)%year,   &
00275                                                      tmp_date(inew)%month,  &
00276                                                      tmp_date(inew)%day,    &
00277                                                      tmp_date(inew)%hour,   &
00278                                                      tmp_date(inew)%minute, &
00279                                                      tmp_date(inew)%second
00280 #endif
00281          !------------------------------------------------------
00282          ! e) Exit loop when completed
00283          !------------------------------------------------------
00284 
00285          if ( temp_days  == jd_end .and. temp_secs >= js_end ) exit  
00286          if ( temp_days   > jd_end ) exit
00287 
00288          iold = mod(i-1,2)+1
00289          inew = mod(i  ,2)+1
00290 
00291          !------------------------------------------------------
00292          ! f) Allocate more memory for the next round if needed
00293          !------------------------------------------------------
00294 
00295          if ( i == ndim ) then
00296 
00297             Allocate ( New_judateaxis (ndim+128), STAT = ierror )
00298             if (ierror > 0) then
00299                ierrp (1) = ierror
00300                ierrp (2) = ndim+128
00301                ierror    = PRISM_Error_Alloc
00302 
00303                call psmile_error ( ierror, 'New_judateaxis', &
00304                     ierrp, 2, __FILE__, __LINE__ )
00305                return
00306             endif
00307 
00308             New_judateaxis(1:ndim)%days = Fields(var_id)%Taskout(ii)%Judate_Axis(1:ndim)%days
00309             New_judateaxis(1:ndim)%secs = Fields(var_id)%Taskout(ii)%Judate_Axis(1:ndim)%secs
00310 
00311             Deallocate ( Fields(var_id)%Taskout(ii)%Judate_Axis, STAT = ierror )
00312             if (ierror > 0) then
00313                ierrp (1) = ierror
00314                ierror = PRISM_Error_Dealloc
00315 
00316                call psmile_error ( ierror, 'Judate_Axis', &
00317                     ierrp, 1, __FILE__, __LINE__ )
00318                return
00319             endif
00320 
00321             Fields(var_id)%Taskout(ii)%Judate_Axis => New_judateaxis
00322 
00323             ndim = ndim + 128
00324 
00325          endif
00326 
00327       enddo
00328 
00329 !     Fields(var_id)%Taskout(ii)%Time_length = i - 1
00330       Fields(var_id)%Taskout(ii)%Time_length = i
00331 
00332     ENDDO
00333 
00334 !-----------------------------------------------------------------------
00335 !  3rd Work on transient in
00336 !-----------------------------------------------------------------------
00337 
00338    ndim = 128
00339 
00340    IF (sga_smioc_transi(Fields(var_id)%smioc_loc)%sg_transi_in%ig_nb_in_orig > 0) THEN
00341        
00342 
00343    if ( sga_smioc_transi(Fields(var_id)%smioc_loc)%sg_transi_in%ig_exch_date_type == PSMILe_period ) then
00344       delta_time = sga_smioc_transi(Fields(var_id)%smioc_loc)%sg_transi_in%sg_exch_date%sg_period
00345    else
00346       print *, trim(ch_id), ': psmile_create_timeaxis: unsupported exchange in date type'
00347       ierror = PRISM_Error_Date
00348       return
00349    endif
00350 
00351    if ( delta_time%year   ==  PSMILe_undef ) delta_time%year   = 0
00352    if ( delta_time%month  ==  PSMILe_undef ) delta_time%month  = 0
00353    if ( delta_time%day    ==  PSMILe_undef ) delta_time%day    = 0
00354    if ( delta_time%hour   ==  PSMILe_undef ) delta_time%hour   = 0
00355    if ( delta_time%minute ==  PSMILe_undef ) delta_time%minute = 0
00356    if ( delta_time%second ==  PSMILe_dundef) delta_time%second = 0.0
00357 
00358    if ( delta_time%year   == 0 .and. delta_time%month  == 0   .and. &
00359         delta_time%day    == 0 .and. delta_time%hour   == 0   .and. &
00360         delta_time%minute == 0 .and. delta_time%second == 0.0 ) then
00361 
00362      print *, trim(ch_id), ': psmile_create_timeaxis: input delta time == ZERO! We return.'
00363      ierror = PRISM_Error_Date
00364      return
00365 
00366    endif
00367 
00368 #ifdef DEBUG
00369    print *, trim(ch_id), ': psmile_create_timeaxis: Delta time used is:'
00370    print *, trim(ch_id), ': psmile_create_timeaxis: yr ', delta_time%year
00371    print *, trim(ch_id), ': psmile_create_timeaxis: mo ', delta_time%month
00372    print *, trim(ch_id), ': psmile_create_timeaxis: d  ', delta_time%day
00373    print *, trim(ch_id), ': psmile_create_timeaxis: hr ', delta_time%hour
00374    print *, trim(ch_id), ': psmile_create_timeaxis: mi ', delta_time%minute
00375    print *, trim(ch_id), ': psmile_create_timeaxis: s  ', delta_time%second
00376 #endif
00377 
00378    allocate (Fields(var_id)%Taskin%Judate_Axis(ndim), STAT=ierror )
00379    if (ierror > 0) then
00380       ierrp (1) = ierror
00381       ierrp (2) = ndim
00382       ierror    = PRISM_Error_Alloc
00383 
00384       call psmile_error ( ierror, 'Judate_Axis', &
00385            ierrp, 2, __FILE__, __LINE__ )
00386       return
00387    endif
00388 
00389    i    = 1
00390    iold = 1
00391    inew = 2
00392 
00393    tmp_date(iold) = PRISM_Jobstart_date
00394    tmp_date(inew) = PRISM_Jobstart_date
00395 
00396    Fields(var_id)%Taskin%delta_time = delta_time
00397 
00398    Fields(var_id)%Taskin%Judate_Start%days = jd_start
00399    Fields(var_id)%Taskin%Judate_Start%secs = js_start
00400 
00401    Fields(var_id)%Taskin%Judate_Stop%days = jd_end
00402    Fields(var_id)%Taskin%Judate_Stop%secs = js_end
00403 
00404    Fields(var_id)%Taskin%Judate_Event%days = jd_start
00405    Fields(var_id)%Taskin%Judate_Event%secs = js_start
00406 
00407    Fields(var_id)%Taskin%Judate_Axis(i)%days = jd_start
00408    Fields(var_id)%Taskin%Judate_Axis(i)%secs = js_start
00409 
00410    DO 
00411 
00412       i = i+1
00413 
00414       !--------------------------------------------------------
00415       ! a) Updates years and months first
00416       !--------------------------------------------------------
00417 
00418       tmp_date(inew)%year  = tmp_date(iold)%year  + delta_time%year
00419       tmp_date(inew)%month = tmp_date(iold)%month + delta_time%month
00420 
00421       if ( tmp_date(inew)%month > 12 ) then
00422          tmp_date(inew)%month = tmp_date(inew)%month - 12
00423          tmp_date(inew)%year  = tmp_date(inew)%year  +  1
00424       endif
00425 
00426       tmp_date(inew)%day    = tmp_date(iold)%day
00427       tmp_date(inew)%hour   = tmp_date(iold)%hour
00428       tmp_date(inew)%minute = tmp_date(iold)%minute
00429       tmp_date(inew)%second = tmp_date(iold)%second
00430 
00431       !---------------------------------------------------------
00432       ! b) Calculate intermediate julian date
00433       !---------------------------------------------------------
00434 
00435       call psmile_date2ju ( tmp_date(inew), temp_days, temp_secs )
00436 
00437       !---------------------------------------------------------
00438       ! c) Now add days and seconds to intermediate julian date
00439       !---------------------------------------------------------
00440 
00441       secs = delta_time%hour*3600.0 + delta_time%minute*60.0 &
00442            + delta_time%second      + temp_secs
00443 
00444       add_days = int(secs/86400.0)
00445 
00446       temp_days = temp_days + delta_time%day + add_days
00447       temp_secs = secs - (float(add_days) * 86400.0)
00448 
00449       Fields(var_id)%Taskin%Judate_Axis(i)%days = temp_days
00450       Fields(var_id)%Taskin%Judate_Axis(i)%secs = temp_secs
00451 
00452       call psmile_ju2date( tmp_date(inew), temp_days, temp_secs )
00453 
00454       !------------------------------------------------------
00455       ! e) Exit loop when completed
00456       !------------------------------------------------------
00457 
00458       if ( temp_days  == jd_end .and. temp_secs >= js_end ) exit  
00459       if ( temp_days  >  jd_end ) exit
00460 
00461       iold = mod(i-1,2)+1
00462       inew = mod(i  ,2)+1
00463 
00464       !------------------------------------------------------
00465       ! f) Allocate more memory for the next round if needed
00466       !------------------------------------------------------
00467 
00468       if ( i == ndim ) then
00469 
00470          Allocate ( New_judateaxis (ndim+128), STAT = ierror )
00471          if (ierror > 0) then
00472             ierrp (1) = ierror
00473             ierrp (2) = ndim+128
00474             ierror    = PRISM_Error_Alloc
00475 
00476             call psmile_error ( ierror, 'New_judateaxis', &
00477                  ierrp, 2, __FILE__, __LINE__ )
00478             return
00479          endif
00480 
00481          New_judateaxis(1:ndim)%days = Fields(var_id)%Taskin%Judate_Axis(1:ndim)%days
00482          New_judateaxis(1:ndim)%secs = Fields(var_id)%Taskin%Judate_Axis(1:ndim)%secs
00483 
00484          Deallocate ( Fields(var_id)%Taskin%Judate_Axis, STAT = ierror )
00485          if (ierror > 0) then
00486             ierrp (1) = ierror
00487             ierror = PRISM_Error_Dealloc
00488 
00489             call psmile_error ( ierror, 'Judateaxis_in', &
00490                  ierrp, 1, __FILE__, __LINE__ )
00491             return
00492          endif
00493 
00494          Fields(var_id)%Taskin%Judate_Axis => New_judateaxis
00495 
00496          ndim = ndim + 128
00497 
00498       endif
00499 
00500     ENDDO
00501 
00502 !  Fields(var_id)%Taskin%Time_length = i - 1
00503    Fields(var_id)%Taskin%Time_length = i
00504 
00505    ENDIF
00506 #ifdef VERBOSE
00507       print *, trim(ch_id), ': psmile_create_timeaxis: eof ierror ', ierror
00508 
00509       call psmile_flushstd
00510 #endif /* VERBOSE */
00511 !
00512    end subroutine psmile_create_timeaxis
00513