SUBROUTINE INITIAL( 1,136@DYALLOC.1695
*CALL ARGPPX 
GSS1F305.532
*CALL ARGSZSP @DYALLOC.1696
*CALL ARGSZSPA @DYALLOC.1697
*CALL ARGSZSPO @DYALLOC.1698
*CALL ARGSZSPW WRB1F401.481
*CALL ARGSZSPC @DYALLOC.1699
*CALL ARGSP @DYALLOC.1700
*CALL ARGSPA @DYALLOC.1701
*CALL ARGSPO @DYALLOC.1702
*CALL ARGSPW WRB1F401.482
*CALL ARGSPC @DYALLOC.1703
*CALL ARGSIZE @DYALLOC.1704
& internal_model,submodel,NGROUP,MEANLEV, GRR2F305.308
& ICODE,CMESSAGE ) GRR2F305.309
C INITIAL1.37
IMPLICIT NONE INITIAL1.38
INTEGER internal_model ! OUT internal model identifier: GRR2F305.310
! ! 1:Atmos; 2:Ocean; 3:Slab ; etc GRR2F305.311
INTEGER submodel ! OUT submodel partition (dump) identifier: GRR2F305.312
! ! 1:Atmos; 2:Ocean; etc GRR2F305.313
INTEGER NGROUP ! OUT - No of steps in "group"n GRR2F305.314
INTEGER MEANLEV ! OUT - Mean level indicator GRR2F305.315
*CALL CMAXSIZE @DYALLOC.1706
*CL Super array lengths @DYALLOC.1707
*CALL TYPSZSP @DYALLOC.1708
*CALL TYPSZSPA @DYALLOC.1709
*CALL TYPSZSPO @DYALLOC.1710
*CALL TYPSZSPW WRB1F401.483
*CALL TYPSZSPC @DYALLOC.1711
*CL Super arrays @DYALLOC.1712
*CALL TYPSPD1 @DYALLOC.1713
*CALL TYPSPDUA @DYALLOC.1714
*CALL TYPSPDUO @DYALLOC.1715
*CALL TYPSPDUW WRB1F401.484
*CALL TYPSPST @DYALLOC.1716
*CALL TYPSPPTA @DYALLOC.1717
*CALL TYPSPPTO @DYALLOC.1718
*CALL TYPSPPTW WRB1F401.485
*CALL TYPSPCOA @DYALLOC.1719
*CALL TYPSPCOO @DYALLOC.1720
*CALL TYPSPCOW WRB1F401.486
*CALL TYPSPINA @DYALLOC.1721
*CALL TYPSPINO @DYALLOC.1722
*CALL TYPSPINW WRB1F401.487
*CALL TYPSPANA @DYALLOC.1723
*CALL TYPSPANO @DYALLOC.1724
*CALL TYPSPANW WRB1F401.488
*CALL TYPSPBO @DYALLOC.1725
*CALL TYPSPBOA @DYALLOC.1726
*CALL TYPSPBOO @DYALLOC.1727
*CALL TYPSPBOW WRB1F401.489
*CALL TYPSPCPL @DYALLOC.1728
CL Model sizes @DYALLOC.1729
*CALL TYPSIZE @DYALLOC.1730
CL Addresses of arrays within super arrays @DYALLOC.1731
*CALL SPINDEX @DYALLOC.1732
*CALL TYPOCDPT @DYALLOC.1733
*CALL TYPWVDPT WRB1F401.490
CL @DYALLOC.1734
INTEGER ICODE ! Out - Return code from routine INITIAL1.42
CHARACTER*80 CMESSAGE TS150793.86
C INITIAL1.44
C*---------------------------------------------------------------------- INITIAL1.45
C Common blocks INITIAL1.46
C INITIAL1.47
*CALL CSUBMODL GRR2F305.316
! Rick's mods have *CALL CSUBMODL here GSS1F305.533
*CALL CPPXREF GSS1F305.534
*CALL PPXLOOK GSS1F305.535
GSS1F305.536
*CALL CHSUNITS GRB1F305.131
*CALL CHISTORY RS030293.147
*CALL CCONTROL INITIAL1.48
*CALL CTIME INITIAL1.50
*CALL CPPRINT INITIAL1.53
*CALL CENVIR INITIAL1.54
*CALL C_GLOBAL GSS1F304.996
*CALL C_WRITD GSS1F304.997
*CALL PARVARS ARB1F402.264
*CALL DECOMPTP GRR0F402.4
*CALL DECOMPDB GRR0F402.5
C INITIAL1.59
C Subroutines called INITIAL1.60
C INITIAL1.61
EXTERNAL INITDUMP,INITHDRS,PPCTL,DUMPCTL, GKR4F403.262
& INITTIME,INTF_CTL, INITIAL1.63
& INANCCTL,IN_ACCTL,IN_BOUND,INITCTL,INIT_HYD, @DYALLOC.1736
& INIT_VEG, ABX1F404.219
& SETGRCTL,SETTSCTL,INITMEAN,TEMPHIST, INITIAL1.65
& UP_BOUND,UP_ANCIL,GEN_INTF,PRINTCTL, INITIAL1.66
& GET_FILE,TIMER,READWRITD,EXPPXI GRB1F400.25
& ,Oper_Emergency GRR2F405.5
*IF DEF,MPP GRR2F405.6
& ,OperatorMessage GRR2F405.7
*ENDIF GRR2F405.8
*IF DEF,ATMOS INITIAL1.68
* ,INITPHYS,INITDIAG,INITZONM,INITMOS,INIT_CNV RB250294.1
*ENDIF INITIAL1.70
*IF DEF,OCEAN ORH9F404.3
& ,INITDIAGO ORH9F404.4
*ENDIF ORH9F404.5
* ,INIT_EMCORR GSS1F304.999
*IF DEF,ATMOS INITIAL1.74
*IF DEF,OCEAN INITIAL1.75
* ,TRANSOUT,TRANSIN,INIT_A2O,SWAP_A2O,SWAP_O2A INITIAL1.76
*ENDIF INITIAL1.77
*IF DEF,SLAB INITIAL1.78
* ,INIT_A2S INITIAL1.79
*ENDIF INITIAL1.80
*ENDIF INITIAL1.81
*IF -DEF,FRADIO GGH3F401.21
* ,SETPOS,BUFFOUT @DYALLOC.1739
*ENDIF @DYALLOC.1740
*IF DEF,MACRO AAD1F304.14
& ,getenv AAD1F304.15
*ENDIF AAD1F304.16
C INITIAL1.82
C Local variables INITIAL1.83
C INITIAL1.84
INTEGER IMEAN ! Loop index over mean periods INITIAL1.85
INTEGER I ! Loop index INITIAL1.86
INTEGER ISM ! Loop index over submodels GRR2F305.317
INTEGER submodel_next ! Submodel identifier GRR2F305.318
INTEGER NFTASWAP,NFTOSWAP ! Fortran units for coupling swapfiles INITIAL1.87
INTEGER NFTSWAP ! General Fortran unit for coupling swapfiles GRR2F305.319
INTEGER FTN_UNIT ! Fortran unit for pp files INITIAL1.88
INTEGER TRANSALEN,TRANSOLEN !data length for TRANSOUT/IN GRR2F305.320
INTEGER TRANS_LEN ! General data length for TRANSOUT/IN GRR2F305.321
INTEGER NDEV ! Unit no. ARR1F402.126
INTEGER LL ! Counter ARR1F402.127
INTEGER LEN_FILENAME ! Length of FILENAME array ARR1F402.128
INTEGER G_P_FIELD ! Sizes for MPP dynamic allocation GRR0F402.6
& ,G_IMTJMT ! in A-O coupling routines GRR0F402.7
INTEGER CO2_DIMA, ! CO2 array dimensions CCN1F405.106
& CO2_DIMO, CCN1F405.107
& CO2_DIMO2 CCN1F405.108
CHARACTER*14 PPNAME ! Dummy PP file name returned by PPCTL INITIAL1.93
CHARACTER*80 FILENAME AD050293.216
*IF -DEF,FRADIO GGH3F401.22
REAL DUMMY_WRITE, ! Dummy variable for rad incs write @DYALLOC.1742
* A_IO ! BUFFOUT return code @DYALLOC.1743
INTEGER LEN_IO ! BUFFOUT return length @DYALLOC.1744
*ENDIF @DYALLOC.1745
*IF DEF,MACRO AAD1F304.17
INTEGER II,getenv AAD1F304.18
CHARACTER*2 ENVALUE AAD1F304.19
*ENDIF AAD1F304.20
C INITIAL1.94
*CALL LBC_COUP GDR3F405.850
integer len_wait_tot ! Total wait time for boundary data GDR3F405.851
integer iostatus ! Return code GDR3F405.852
character*8 ch_date2 ! Date from date_and_time GDR3F405.853
character*10 ch_time2 ! Time from date_and_time GDR3F405.854
integer*8 sleep ! SLEEP Function to make UM wait GDR3F405.855
integer*8 ISLEEP ! SLEEP Function to make UM wait GDR3F405.856
*IF DEF,ATMOS,AND,-DEF,GLOBAL,AND,DEF,MPP GDR3F405.857
integer info ! Return Code from GCOM routine. GDR3F405.858
*ENDIF GDR3F405.859
integer lbc_ntimes ! No of BC's in communication file GDR3F405.860
integer ms_ntimes ! No of BC's required in mesoscale GDR3F405.861
integer gl_ntimes ! No of BC's generated in global GDR3F405.862
GDR3F405.863
CL---------------------------------------------------------------------- INITIAL1.101
C GSS1F304.1005
IF (LTIMER) CALL TIMER('INITIAL ',3) INITIAL1.118
CL INITIAL1.119
CL---------------------------------------------------------------------- GSS1F304.1006
CL GSS1F304.1007
CL 1.2 Set FT units as inactive on first step of the integration INITIAL1.120
CL and set last field written/read to zero for each unit INITIAL1.121
CL INITIAL1.122
IF (H_STEPim(a_im).EQ.0.AND.H_STEPim(o_im).EQ.0 WRB1F401.491
& .and. H_STEPim(w_im).eq.0) THEN WRB1F401.492
DO I=20,NUNITS RS030293.148
FT_ACTIVE(I)='N' INITIAL1.125
FT_LASTFIELD(I)=0 INITIAL1.126
ENDDO INITIAL1.127
ENDIF INITIAL1.128
CL INITIAL1.129
CL 1.3 Open file for RADINCS array spooling in RAD_CTL INITIAL1.130
CL INITIAL1.131
*IF DEF,FRADIO GGH3F401.23
WRITE(6,*) 'Fast i/o of radincs directly to core memory' INITIAL1.133
*ELSE INITIAL1.134
CL Open unit 16 for CACHE2 file INITIAL1.135
CL Open radiation increments file for portable i/o INITIAL1.136
CALL FILE_OPEN(16,FT_ENVIRON(16),LEN_FT_ENVIR(16),1,0,ICODE) GPB1F305.55
IF(ICODE.NE.0) CMESSAGE='INITPHY1: Error opening rad incs file' INITIAL1.138
CLL @DYALLOC.1746
CLL Extra dummy write of radiation increments to stop heap fragmentation @DYALLOC.1747
CLL (caused by CRAY I/O bug) @DYALLOC.1748
CLL @DYALLOC.1749
CALL SETPOS(16,0,ICODE) GTD0F400.90
DUMMY_WRITE=0.0 @DYALLOC.1751
CALL BUFFOUT(16,DUMMY_WRITE,1,LEN_IO,A_IO) @DYALLOC.1752
IF(A_IO.NE.-1.0.OR.LEN_IO.NE.1) THEN @DYALLOC.1753
CMESSAGE=' INITIAL :Paging IO error radn incrs' @DYALLOC.1754
ICODE=1 @DYALLOC.1755
ENDIF @DYALLOC.1756
CALL SETPOS(16,0,ICODE) GTD0F400.91
*ENDIF INITIAL1.139
CL AAD1F304.21
CL 1.4 Get number of CPUs attached to program (NCPU). This is AAD1F304.22
CL used by macrotasked physics code. AAD1F304.23
CL If DEF MACRO is not selected, NCPU defaults to 1. AAD1F304.24
CL AAD1F304.25
*IF DEF,MACRO AAD1F304.26
II=getenv('NCPUS',ENVALUE) WRB1F401.493
IF(ENVALUE.eq.' ')THEN AAD1F304.28
NCPU=1 AAD1F304.29
ELSE AAD1F304.30
READ(ENVALUE,'(I2)')NCPU AAD1F304.31
ENDIF AAD1F304.32
*ELSE AAD1F304.33
NCPU=1 AAD1F304.34
*ENDIF AAD1F304.35
C DEF,ATMOS needed for OCEAN only compilation, AAD1F304.36
C because MAX_NO_OF_SEGS is under DEF,ATMOS in CMAXSIZE. AAD1F304.37
*IF DEF,ATMOS AAD1F304.38
IF (MAX(A_SW_SEGMENTS*NCPU, A_LW_SEGMENTS*NCPU, AAD1F304.39
& A_CONVECT_SEGMENTS*NCPU) .GT. MAX_NO_OF_SEGS) THEN AAD1F304.40
ICODE=1000 AAD1F304.41
CMESSAGE='INITIAL: MAX_NO_OF_SEGS (in CMAXSIZE) not large enough' AAD1F304.42
GOTO 999 AAD1F304.43
ENDIF AAD1F304.44
*ENDIF AAD1F304.45
CL INITIAL1.140
CL--------------------------------------------------------------------- INITIAL1.141
CL 2. Initialise STASH control arrays from STASH control file. INITIAL1.142
CL--------------------------------------------------------------------- INITIAL1.143
INITIAL1.144
IF(LTIMER) THEN INITIAL1.145
CALL TIMER('INITCTL ',3) INITIAL1.146
END IF INITIAL1.147
INITIAL1.148
! Note that NSECTS=NSECTP, NITEMS=NITEMP : set in WSTLST GSS1F305.539
GSS1F305.540
CALL INITCTL( @DYALLOC.1758
& NUM_STASH_LEVELS,NUM_LEVEL_LISTS, @DYALLOC.1759
& NITEMS,NSECTS,N_INTERNAL_MODEL_MAX, GSS1F305.541
*CALL ARGSIZE @DYALLOC.1760
*CALL ARTSTS @DYALLOC.1761
*CALL ARGPPX GSS1F305.542
*CALL ARTD1 GSM2F403.233
& ICODE,CMESSAGE ) @DYALLOC.1762
INITIAL1.150
IF(LTIMER) THEN INITIAL1.151
CALL TIMER('INITCTL ',4) INITIAL1.152
END IF INITIAL1.153
INITIAL1.154
IF(ICODE.GT.0) RETURN INITIAL1.155
INITIAL1.156
INITIAL1.157
CL INITIAL1.158
CL---------------------------------------------------------------------- INITIAL1.159
CL 3. Read appropriate submodel partition dump to memory. If coupled, GRR2F305.322
CL page out the D1 part of each dump to its 'swap' file and read the GRR2F305.323
CL other dump(s) into memory. Write temporary history file if dumps GRR2F305.324
CL read successfully on timestep 0. TJ040293.6
CL INITIAL1.163
CL Check if coupling across submodel partitions required and assign GRR2F305.325
CL fotran unit nos. { This could be generalised. Only atmos and ocean GRR2F305.326
CL dumps catered for here.} GRR2F305.327
GRR2F305.328
C *if def,atmos required for TRANSALEN as p_field GRR2F305.329
C under *if def,atmos in TYPSIZE prevents warning & compile errors if GRR2F305.330
C ocean only being compiled ; to be sorted out in next version (4.1) GRR2F305.331
IF (N_SUBMODEL_PARTITION.GT.1) THEN GRR2F305.332
NFTASWAP=18 GRR2F305.333
NFTOSWAP=19 GRR2F305.334
*IF DEF,ATMOS GRR2F305.335
TRANSALEN= A_LEN_DATA+(P_LEVELS+1+2*Q_LEVELS)*P_FIELD GRR2F305.336
*ELSE GRR2F305.337
TRANSALEN= 1 GRR2F305.338
*ENDIF GRR2F305.339
TRANSOLEN= O_LEN_DATA+O_LEN_DUALDATA GSI0F402.27
ENDIF GRR2F305.341
GRR2F305.342
CL GRR2F305.343
CL 3.1 Loop over submodel partition dumps GRR2F305.344
CL GRR2F305.345
DO ISM=1,N_SUBMODEL_PARTITION GRR2F305.346
GRR2F305.347
submodel=SUBMODEL_PARTITION_LIST(ISM) GRR2F305.348
IF (LTIMER) THEN GPB1F401.27
CALL TIMER('INITDUMP',5) GPB1F401.28
CALL TIMER('INITDUMP',3) GPB1F401.29
ENDIF GPB1F401.30
CALL INITDUMP( GRR2F305.349
*CALL ARGSIZE @DYALLOC.1764
*CALL ARTD1 @DYALLOC.1765
*CALL ARTDUMA @DYALLOC.1766
*CALL ARTDUMO @DYALLOC.1767
*CALL ARTDUMW WRB1F401.494
*CALL ARTSTS @DYALLOC.1768
*CALL ARTPTRA @DYALLOC.1769
*CALL ARTPTRO @DYALLOC.1770
*CALL ARTPTRW WRB1F401.495
*CALL ARTCONA @DYALLOC.1771
*CALL ARTCONO @DYALLOC.1772
*CALL ARTCONW WRB1F401.496
*CALL ARGPPX GSS1F305.543
& submodel,ICODE,CMESSAGE) GRR2F305.350
IF (LTIMER) THEN GPB1F401.31
CALL TIMER('INITDUMP',4) GPB1F401.32
CALL TIMER('INITDUMP',6) GPB1F401.33
ENDIF GPB1F401.34
IF (ICODE.GT.0) GOTO 999 GRR2F305.351
GRR2F305.352
IF(N_SUBMODEL_PARTITION.GT.1) THEN ! coupling across dumps GRR2F305.353
GRR2F305.354
IF(submodel.eq.atmos_sm) then ! atmosphere GRR2F305.355
NFTSWAP=NFTASWAP GRR2F305.356
TRANS_LEN= TRANSALEN GRR2F305.357
ELSEIF(submodel.eq.ocean_sm) then ! ocean GRR2F305.358
NFTSWAP=NFTOSWAP GRR2F305.359
TRANS_LEN= TRANSOLEN GRR2F305.360
ELSE GRR2F305.361
CMESSAGE='INITIAL: submodel ident not valid' GRR2F305.362
write(6,*) CMESSAGE GRR2F305.363
write(6,*) 'Non valid submodel identifier=',submodel GRR2F305.364
ICODE=1 GRR2F305.365
ENDIF GRR2F305.366
IF (ICODE.GT.0) GOTO 999 GRR2F305.367
GRR2F305.368
CL Copy data from one start dump to "swap" file, read the other INITIAL1.185
CL start dump to memory, and write it out to its "swap" file INITIAL1.186
IF (LTIMER) CALL TIMER('TRANSOUT',3) GRR2F305.369
CALL TRANSOUT( GRR2F305.370
*CALL ARTD1 GRR2F305.371
& TRANS_LEN,NFTSWAP,submodel,ICODE,CMESSAGE) GRR1F402.295
IF (LTIMER) CALL TIMER('TRANSOUT',4) GRR2F305.373
GRR2F305.374
IF (ICODE.GT.0) GOTO 999 GRR2F305.375
GRR2F305.376
ENDIF ! end of test for coupling acroos dumps GRR2F305.377
GRR2F305.378
ENDDO ! ISM over submodel partitions GRR2F305.379
CL INITIAL1.187
! GRR2F405.9
! 3.2 Allow Override of namelist input in operational environment GRR2F405.10
! GRR2F405.11
IF(MODEL_STATUS .EQ. 'Operational') Call Oper_Emergency GRR2F405.12
! GRR2F405.13
CL GRR2F305.380
*IF DEF,ATMOS INITIAL1.221
CL INITIAL1.222
CL Set RUN indicator in atmosphere dump header INITIAL1.223
CL INITIAL1.224
CALL SET_RUN_INDIC_OP( @DYALLOC.1797
*CALL ARGSIZE @DYALLOC.1798
*CALL ARTDUMA @DYALLOC.1799
& ICODE,CMESSAGE) @DYALLOC.1800
*ENDIF INITIAL1.226
CL @DYALLOC.1801
CL 3.3 On NRUN initialise dump LOOKUP headers associated with @DYALLOC.1802
CL diagnostic fields with the bare essentials needed to read and @DYALLOC.1803
CL write dumps - the rest to be filled in by STASH during the run. @DYALLOC.1804
CL @DYALLOC.1805
IF (H_STEPim(a_im).EQ.0.AND.H_STEPim(o_im).EQ.0 WRB1F401.497
& .and. H_STEPim(w_im).eq.0) THEN WRB1F401.498
CALL INITHDRS( @DYALLOC.1807
*CALL ARGSIZE @DYALLOC.1808
*CALL ARTDUMA @DYALLOC.1809
*CALL ARTDUMO @DYALLOC.1810
*CALL ARTDUMW WRB1F401.499
*CALL ARTSTS @DYALLOC.1811
*CALL ARGPPX GSS1F305.544
& ICODE,CMESSAGE) @DYALLOC.1812
IF (ICODE.GT.0) GOTO 999 @DYALLOC.1813
GRR2F305.381
ENDIF ! End test for NRUN GRR2F305.382
GKR4F403.263
!L GKR4F403.264
!L 3.4 Write out temporary copy of D1 for current submodel GKR4F403.265
!L GKR4F403.266
GKR4F403.267
IF (L_WRIT_INIT) THEN GKR4F403.268
GKR4F403.269
if (submodel .eq. atmos_sm) then GKR4F403.270
CALL DUMPCTL ( GKR4F403.271
*CALL ARGSIZE GKR4F403.272
*CALL ARTD1 GKR4F403.273
*CALL ARTDUMA GKR4F403.274
*CALL ARTDUMO GKR4F403.275
*CALL ARTDUMW GKR4F403.276
*CALL ARTCONA GKR4F403.277
*CALL ARTPTRA GKR4F403.278
*CALL ARTSTS GKR4F403.279
*CALL ARGPPX GKR4F403.280
& atmos_sm,0,.TRUE.,'atminitial',0, GIE1F405.17
& ICODE,CMESSAGE) GKR4F403.282
GKR4F403.283
elseif (submodel .eq. ocean_sm) then GKR4F403.284
CALL DUMPCTL ( GKR4F403.285
*CALL ARGSIZE GKR4F403.286
*CALL ARTD1 GKR4F403.287
*CALL ARTDUMA GKR4F403.288
*CALL ARTDUMO GKR4F403.289
*CALL ARTDUMW GKR4F403.290
*CALL ARTCONA GKR4F403.291
*CALL ARTPTRA GKR4F403.292
*CALL ARTSTS GKR4F403.293
*CALL ARGPPX GKR4F403.294
& ocean_sm,0,.TRUE.,'ocninitial',0, GIE1F405.18
& ICODE,CMESSAGE) GKR4F403.296
GKR4F403.297
elseif (submodel .eq. wave_sm) then GKR4F403.298
CALL DUMPCTL ( GKR4F403.299
*CALL ARGSIZE GKR4F403.300
*CALL ARTD1 GKR4F403.301
*CALL ARTDUMA GKR4F403.302
*CALL ARTDUMO GKR4F403.303
*CALL ARTDUMW GKR4F403.304
*CALL ARTCONA GKR4F403.305
*CALL ARTPTRA GKR4F403.306
*CALL ARTSTS GKR4F403.307
*CALL ARGPPX GKR4F403.308
& wave_sm,0,.TRUE.,'wavinitial',0, GIE1F405.19
& ICODE,CMESSAGE) GKR4F403.310
endif GKR4F403.311
GKR4F403.312
END IF GKR4F403.313
GRR2F305.383
CL---------------------------------------------------------------------- INITIAL1.227
CL 6. Initialise means program control block GSM6F403.3
CL GSM6F403.4
DO ISM=1,N_SUBMODEL_PARTITION GSM6F403.5
GSM6F403.6
submodel=SUBMODEL_PARTITION_LIST(ISM) GSM6F403.7
IF (LTIMER) CALL TIMER('INITMEAN',3) GSM6F403.8
CALL INITMEAN( GSM6F403.9
*CALL ARGSIZE GSM6F403.10
*CALL ARTDUMA GSM6F403.11
*CALL ARTDUMO GSM6F403.12
*CALL ARTDUMW GSM6F403.13
& submodel,ICODE,CMESSAGE) GSM6F403.14
IF (LTIMER) CALL TIMER('INITMEAN',4) GSM6F403.15
IF (ICODE.GT.0) GOTO 999 GSM6F403.16
GSM6F403.17
ENDDO ! ISM over submodel partition dumps GSM6F403.18
CL---------------------------------------------------------------------- GSM6F403.19
CL 4. Set up other control blocks and physical constants INITIAL1.228
CL INITIAL1.229
CL 4.1 Initialise the model time and check that history file data time INITIAL1.230
CL matches dump(s); set derived time/step information INITIAL1.231
CL INITIAL1.232
IF (LTIMER) CALL TIMER('INITTIME',3) INITIAL1.233
CALL INITTIME( @DYALLOC.1815
*CALL ARGSIZE @DYALLOC.1816
*CALL ARTDUMA @DYALLOC.1817
*CALL ARTDUMO @DYALLOC.1818
*CALL ARTDUMW WRB1F401.500
& submodel,ICODE,CMESSAGE) GRR2F305.384
IF (LTIMER) CALL TIMER('INITTIME',4) INITIAL1.235
IF (ICODE.GT.0) GOTO 999 INITIAL1.236
CL GRB1F400.12
CL 4.2 Write up temporary history file after successfully reading GRB1F400.13
CL initial dumps on timestep 0 and setting model_data_time if GRB1F400.14
CL assimilation run, to allow CRUN from initial dumps. GRB1F400.15
CL GRB1F400.16
*IF DEF,MPP ARB1F402.265
IF (mype .eq. 0) THEN ARB1F402.266
*ENDIF ARB1F402.267
IF (H_STEPim(a_im).EQ.0.AND.H_STEPim(o_im).EQ.0 WRB1F401.501
& .and. H_STEPim(w_im).eq.0) THEN WRB1F401.502
CALL TEMPHIST(THIST_UNIT,ICODE,CMESSAGE) GRB1F400.18
IF (ICODE.GT.0) GOTO 999 GRB1F400.19
END IF GRB1F400.20
*IF DEF,MPP ARB1F402.268
ENDIF ARB1F402.269
*ENDIF ARB1F402.270
CL INITIAL1.237
CL 4.3 Set up control block for updating ancillary fields INITIAL1.238
CL INITIAL1.239
IF (LTIMER) CALL TIMER('INANCCTL',3) INITIAL1.240
CALL INANCCTL( @DYALLOC.1820
*CALL ARGSIZE @DYALLOC.1821
*CALL ARTDUMA @DYALLOC.1822
*CALL ARTDUMO @DYALLOC.1823
*CALL ARTDUMW WRB1F401.503
*CALL ARTSTS @DYALLOC.1824
*CALL ARTPTRA @DYALLOC.1825
*CALL ARTPTRO @DYALLOC.1826
*CALL ARTPTRW WRB1F401.504
*CALL ARTANC @DYALLOC.1827
*CALL ARGPPX GDG0F401.818
& ICODE,CMESSAGE) GRB1F305.135
IF (LTIMER) CALL TIMER('INANCCTL',4) INITIAL1.242
IF (ICODE.GT.0) GOTO 999 INITIAL1.243
CL INITIAL1.244
CL 4.4 Set up control block for updating boundary fields INITIAL1.245
GDR3F405.864
*IF DEF,ATMOS,AND,-DEF,GLOBAL GDR3F405.865
GDR3F405.866
if (l_lbc_coup) then GDR3F405.867
GDR3F405.868
! Set no of boundary conditions required to proceed. GDR3F405.869
! For the first hour, 2 lots of boundary conditions required. GDR3F405.870
! This value cannot be computed before the first read of GDR3F405.871
! INBOUND so it is hardwired initially. GDR3F405.872
GDR3F405.873
ms_ntimes = 2 GDR3F405.874
GDR3F405.875
endif GDR3F405.876
GDR3F405.877
! Return here if IN_BOUND has been called and there GDR3F405.878
! are insufficient BCs to proceed. This is possible GDR3F405.879
! in CRUNs. GDR3F405.880
GDR3F405.881
160 continue GDR3F405.882
GDR3F405.883
if (l_lbc_coup) then GDR3F405.884
GDR3F405.885
call date_and_time(ch_date2, ch_time2) GDR3F405.886
GDR3F405.887
write(6,*) 'LBC_COUP: ', GDR3F405.888
& ch_time2(1:2),':',ch_time2(3:4),':',ch_time2(5:6),' on ', GDR3F405.889
& ch_date2(7:8),'/',ch_date2(5:6),'/',ch_date2(1:4), GDR3F405.890
& ' Wait to call INBOUND in INITIAL.' GDR3F405.891
GDR3F405.892
*IF DEF,MPP GDR3F405.893
if (mype.eq.0) then GDR3F405.894
*ENDIF GDR3F405.895
GDR3F405.896
write (6,*) ' ms_ntimes in INITIAL ',ms_ntimes GDR3F405.897
GDR3F405.898
len_wait_tot = 0 GDR3F405.899
150 continue GDR3F405.900
GDR3F405.901
! Close the communication file and re-open. GDR3F405.902
close(190) GDR3F405.903
open (190,file=lbc_filename,action="read",iostat=icode) GDR3F405.904
GDR3F405.905
! Check error code from OPEN GDR3F405.906
if (icode.ne.0) then GDR3F405.907
write (6,*) ' Return code from OPEN ',icode GDR3F405.908
icode = 401 GDR3F405.909
write (cmessage,*) 'INITIAL : Problem with OPEN '// GDR3F405.910
& 'for Unit No 190.' GDR3F405.911
go to 151 GDR3F405.912
endif GDR3F405.913
GDR3F405.914
! Return here to read next value from Unit 190 GDR3F405.915
456 continue GDR3F405.916
GDR3F405.917
! Read in the next value of lbc_ntimes GDR3F405.918
read (190,*,iostat=icode) lbc_ntimes GDR3F405.919
GDR3F405.920
! Check error code from READ GDR3F405.921
if (icode.ne.0) then ! Non-zero return code from READ. GDR3F405.922
GDR3F405.923
write (6,*) ' ms : Return code from READ ',icode GDR3F405.924
GDR3F405.925
! Check if maximum wait time has been exceeded to read GDR3F405.926
! required value of lbc_ntimes. GDR3F405.927
if (len_wait_tot.ge.um_lbc_wait_max) then GDR3F405.928
GDR3F405.929
! Maximum wait time has been exceeded. GDR3F405.930
! Insufficient Boundary Conditions to proceed. GDR3F405.931
! Likely cause is delay in job generating the BC's. GDR3F405.932
GDR3F405.933
write (6,*) ' ms : Maximum wait time reached'// GDR3F405.934
& ' after ',um_lbc_wait_max,' seconds.' GDR3F405.935
icode = 402 GDR3F405.936
write (cmessage,*) GDR3F405.937
& 'INITIAL : Failed to find required value in LBC_FILE.' GDR3F405.938
icode = 402 GDR3F405.939
go to 151 GDR3F405.940
GDR3F405.941
endif ! if len_wait_tot GDR3F405.942
GDR3F405.943
! Insufficient BC's to proceed ; Wait for um_lbc_wait GDR3F405.944
! seconds before another attempt to proceed. GDR3F405.945
GDR3F405.946
write (6,*) ' ms : Wait for ',um_lbc_wait, GDR3F405.947
& ' seconds and retry.' GDR3F405.948
isleep = sleep(um_lbc_wait) GDR3F405.949
len_wait_tot = len_wait_tot+um_lbc_wait GDR3F405.950
write (6,*) ' ms : Total Wait so far ',len_wait_tot, GDR3F405.951
& ' seconds.' GDR3F405.952
GDR3F405.953
go to 150 ! Retry to find required lbc_ntimes. GDR3F405.954
GDR3F405.955
endif ! if icode.ne.0 GDR3F405.956
GDR3F405.957
if (lbc_ntimes.gt.1000) then GDR3F405.958
GDR3F405.959
! First value in the file is always >1000. Read next value. GDR3F405.960
go to 456 GDR3F405.961
GDR3F405.962
elseif (lbc_ntimes.lt.ms_ntimes) then GDR3F405.963
GDR3F405.964
! Value is not required. Proceed to read next value. GDR3F405.965
write (6,*) ' ms : gl_ntimes = ',lbc_ntimes,' read in.'// GDR3F405.966
& ' gl_ntimes >= ',ms_ntimes,' is required. Read next value.' GDR3F405.967
go to 456 GDR3F405.968
GDR3F405.969
elseif (lbc_ntimes.ge.ms_ntimes) then GDR3F405.970
GDR3F405.971
! Required value read in. Sufficient BC's to proceed. GDR3F405.972
write (6,*) ' ms : gl_ntimes = ',lbc_ntimes,' read in.'// GDR3F405.973
& ' gl_ntimes >= ',ms_ntimes,' is required. Proceed.' GDR3F405.974
GDR3F405.975
call date_and_time (ch_date2, ch_time2) GDR3F405.976
GDR3F405.977
write(6,*) 'LBC_COUP: ', GDR3F405.978
& ch_time2(1:2),':',ch_time2(3:4),':',ch_time2(5:6),' on ', GDR3F405.979
& ch_date2(7:8),'/',ch_date2(5:6),'/',ch_date2(1:4), GDR3F405.980
& ' Proceed to call INBOUND in INITIAL.' GDR3F405.981
GDR3F405.982
gl_ntimes = lbc_ntimes GDR3F405.983
GDR3F405.984
endif ! if lbc_ntimes GDR3F405.985
GDR3F405.986
*IF DEF,MPP GDR3F405.987
endif ! if mype=0 GDR3F405.988
*ENDIF GDR3F405.989
GDR3F405.990
151 continue GDR3F405.991
GDR3F405.992
*IF DEF,MPP GDR3F405.993
! Broadcast ICODE to all PEs GDR3F405.994
iostatus = icode GDR3F405.995
call gc_ibcast (458,1,0,nproc,info,iostatus) GDR3F405.996
icode = iostatus GDR3F405.997
*ENDIF GDR3F405.998
GDR3F405.999
! Check on ICODE before proceeding. GDR3F405.1000
if (icode.ne.0) then GDR3F405.1001
write (6,*) ' U_MODEL - Error detected.' GDR3F405.1002
write (6,*) ' ICODE : ',ICODE GDR3F405.1003
write (6,*) ' CMESSAGE : ',CMESSAGE GDR3F405.1004
go to 999 ! Return GDR3F405.1005
endif GDR3F405.1006
GDR3F405.1007
*IF DEF,MPP GDR3F405.1008
! Broadcast gl_ntimes to all PEs GDR3F405.1009
call gc_ibcast (458,1,0,nproc,info,gl_ntimes) GDR3F405.1010
*ENDIF GDR3F405.1011
lbc_ntimes = gl_ntimes GDR3F405.1012
GDR3F405.1013
endif ! if l_lbc_coup GDR3F405.1014
GDR3F405.1015
*ENDIF GDR3F405.1016
GDR3F405.1017
CL INITIAL1.246
IF (LTIMER) CALL TIMER('IN_BOUND',3) INITIAL1.247
CALL IN_BOUND( @DYALLOC.1829
*CALL ARGSIZE @DYALLOC.1830
*CALL ARTDUMA @DYALLOC.1831
*CALL ARTDUMO @DYALLOC.1832
*CALL ARTDUMW WRB1F401.505
*CALL ARTSTS ARB1F404.369
*CALL ARTPTRA @DYALLOC.1833
*CALL ARTPTRO @DYALLOC.1834
*CALL ARTPTRW WRB1F401.506
*CALL ARTBND @DYALLOC.1835
*IF DEF,ATMOS NF171193.16
& A_LEN1_LEVDEPC,A_LEN2_LEVDEPC, ! for dynamic array NF171193.17
*ENDIF NF171193.18
*IF DEF,OCEAN NF171193.19
& O_LEN1_LEVDEPC,O_LEN2_LEVDEPC, ! for dynamic array NF171193.20
*ENDIF NF171193.21
*IF DEF,WAVE WRB1F401.507
& W_LEN1_LEVDEPC,W_LEN2_LEVDEPC, ! for dynamic array WRB1F401.508
*ENDIF WRB1F401.509
*CALL ARGPPX GDG0F401.819
& ICODE,CMESSAGE) GRB1F305.136
IF (LTIMER) CALL TIMER('IN_BOUND',4) INITIAL1.249
IF (ICODE.GT.0) GOTO 999 INITIAL1.250
GDR3F405.1018
*IF DEF,ATMOS,AND,-DEF,GLOBAL GDR3F405.1019
GDR3F405.1020
if (l_lbc_coup) then GDR3F405.1021
GDR3F405.1022
! Now that IN_BOUND has been called for the first time GDR3F405.1023
! double check that there are sufficient BCs to proceed. GDR3F405.1024
! GDR3F405.1025
! Determine which boundary data is required to proceed GDR3F405.1026
! the next period. GDR3F405.1027
if (boundary_stepsim(a_im).gt.0) then GDR3F405.1028
ms_ntimes = 2 + (stepim(a_im)/boundary_stepsim(a_im)) GDR3F405.1029
endif GDR3F405.1030
GDR3F405.1031
if (lbc_ntimes.lt.ms_ntimes) then GDR3F405.1032
GDR3F405.1033
! There are insufficient BCs to proceed. Go back and wait GDR3F405.1034
! for sufficient BCs to proceed. GDR3F405.1035
write (6,*) ' ms : gl_ntimes = ',lbc_ntimes, GDR3F405.1036
& ' gl_ntimes >= ',ms_ntimes,' is required. '// GDR3F405.1037
& ' Insufficient BCs to proceed. Wait.' GDR3F405.1038
go to 160 GDR3F405.1039
GDR3F405.1040
endif GDR3F405.1041
GDR3F405.1042
endif ! if l_lbc_coup GDR3F405.1043
GDR3F405.1044
*ENDIF GDR3F405.1045
GDR3F405.1046
CL INITIAL1.251
CL 4.5 Set up control block for writing interface fields. INITIAL1.252
CL INITIAL1.253
IF (LTIMER) CALL TIMER('INTF_CTL',3) INITIAL1.254
CALL INTF_CTL ( @DYALLOC.1837
*CALL ARGSIZE @DYALLOC.1838
*CALL ARTINFA GDR2F405.55
& ICODE,CMESSAGE) GRB1F305.137
IF (LTIMER) CALL TIMER('INTF_CTL',4) INITIAL1.256
IF (ICODE.GT.0) GOTO 999 INITIAL1.257
CL INITIAL1.258
*IF DEF,ATMOS INITIAL1.259
CL INITIAL1.260
CL 4.6 Initialise physical constants used in main physics INITIAL1.261
CL packages - includes radiation lookup tables, and QSAT INITIAL1.262
CL lookup table INITIAL1.263
CL INITIAL1.264
GRR2F305.385
C First read the atmosphere data to memory if coupled INITIAL1.266
IF(submodel.NE.atmos_sm) THEN GRR2F305.386
GRR2F305.387
TRANS_LEN=TRANSALEN GRR2F305.388
NFTSWAP =NFTASWAP GRR2F305.389
submodel=atmos_sm ! new submodel will be atmosphere GRR1F402.296
IF (LTIMER) CALL TIMER('TRANSIN ',3) INITIAL1.267
CALL TRANSIN( GRR2F305.390
*CALL ARTD1 @DYALLOC.1841
& TRANS_LEN,NFTSWAP,submodel,ICODE,CMESSAGE) GRR1F402.297
IF (LTIMER) CALL TIMER('TRANSIN ',4) INITIAL1.270
ENDIF ! End check on submodel GRR2F305.393
GRR2F305.394
IF (LTIMER) CALL TIMER('INITPHYS',3) INITIAL1.272
CALL INITPHYS(ICODE,CMESSAGE) INITIAL1.273
IF (LTIMER) CALL TIMER('INITPHYS',4) INITIAL1.274
IF (ICODE.GT.0) GOTO 999 INITIAL1.275
LADD_RADINCS=(A_SW_RADSTEP.EQ.A_LW_RADSTEP) INITIAL1.276
GSS1F304.1011
IF (LEMCORR) THEN GSS1F304.1012
CL INITIAL1.278
CL 4.7 Initialise total atmospheric energy INITIAL1.279
CL INITIAL1.280
IF (STEPim(a_im).EQ.0 ) THEN GDR5F305.63
C INITIAL1.286
IF (LTIMER) CALL TIMER('INEMCORR',3) INITIAL1.287
C INITIAL1.288
CALL INIT_EMCORR( @DYALLOC.1844
*CALL ARGSIZE @DYALLOC.1845
*CALL ARTD1 @DYALLOC.1846
*CALL ARTDUMA @DYALLOC.1847
*CALL ARTPTRA @DYALLOC.1848
*CALL ARTCONA @DYALLOC.1849
& ICODE,CMESSAGE,LLINTS,LWHITBROM) GSS1F304.1013
C INITIAL1.299
IF (LTIMER) CALL TIMER('INEMCORR',4) INITIAL1.300
C INITIAL1.301
C INITIAL1.302
END IF INITIAL1.303
C INITIAL1.304
END IF ! LEMCORR GSS1F304.1014
CL INITIAL1.306
CL 4.8 Initialise MOS grid information INITIAL1.307
CL INITIAL1.308
IF (LTIMER) CALL TIMER('INITMOS ',3) INITIAL1.309
CALL INITMOS( @DYALLOC.1851
*CALL ARGSIZE @DYALLOC.1852
*CALL ARTDUMA @DYALLOC.1853
*CALL ARTSTS @DYALLOC.1854
*CALL ARTCONA @DYALLOC.1855
& ICODE,CMESSAGE) @DYALLOC.1856
IF (LTIMER) CALL TIMER('INITMOS ',4) INITIAL1.311
IF (ICODE.GT.0) GOTO 999 INITIAL1.312
*ENDIF INITIAL1.313
CL---------------------------------------------------------------------- INITIAL1.314
CL 5. Set timestep group control switches for initial step INITIAL1.315
CL INITIAL1.316
IF (LTIMER) CALL TIMER('SETGRCTL',3) INITIAL1.317
CALL SETGRCTL(internal_model,submodel,NGROUP, GRR2F305.395
* ICODE,CMESSAGE) GRR2F305.396
IF (LTIMER) CALL TIMER('SETGRCTL',4) INITIAL1.319
submodel_next=submodel ! Next submodel group of timesteps. GRR2F305.397
GRR2F305.398
IF (ICODE.GT.0) GOTO 999 INITIAL1.320
CL INITIAL1.321
CL 5.1 Set timestep control switches for initial step INITIAL1.322
CL INITIAL1.323
IF (LTIMER) CALL TIMER('SETTSCTL',3) INITIAL1.324
CALL SETTSCTL ( @DYALLOC.1857
*CALL ARGSIZE @DYALLOC.1858
*CALL ARTDUMA @DYALLOC.1859
*CALL ARTDUMO @DYALLOC.1860
*CALL ARTDUMW WRB1F401.510
*CALL ARTSTS @DYALLOC.1861
*CALL ARTINFA @DYALLOC.1862
*CALL ARTINFO @DYALLOC.1863
*CALL ARTINFW WRB1F401.511
& internal_model,.TRUE.,MEANLEV,ICODE,CMESSAGE) GRR2F305.399
IF (LTIMER) CALL TIMER('SETTSCTL',4) INITIAL1.326
IF (ICODE.GT.0) GOTO 999 INITIAL1.327
CL INITIAL1.328
CL 5.2 Initialise PP files at step 0 INITIAL1.329
CL INITIAL1.330
IF (LTIMER) CALL TIMER('PPCTL ',3) INITIAL1.331
MEANLEV=0 INITIAL1.332
CALL PPCTL( @DYALLOC.1865
*CALL ARGSIZE @DYALLOC.1866
*CALL ARTD1 @DYALLOC.1867
*CALL ARTDUMA @DYALLOC.1868
*CALL ARTDUMO @DYALLOC.1869
*CALL ARTDUMW WRB1F401.512
*CALL ARTINFA @DYALLOC.1870
*CALL ARTINFO GMB1F405.380
*CALL ARGPPX GMB1F405.381
& submodel,MEANLEV,.TRUE.,PPNAME,ICODE,CMESSAGE) GRR2F305.400
IF (LTIMER) CALL TIMER('PPCTL ',4) INITIAL1.334
IF (ICODE.GT.0) GOTO 999 INITIAL1.335
CL INITIAL1.336
CL 5.3 Initialise assimilation package (not if assimilation completed) INITIAL1.337
CL INITIAL1.338
*IF DEF,ATMOS,OR,DEF,OCNASSM ORH6F401.1
IF ( (ASSIM_STEPSim(a_im)+ASSIM_EXTRASTEPSim(a_im).GT.0 .AND. GDR5F305.64
* (MODEL_ASSIM_MODE.EQ."Atmosphere" .OR. INITIAL1.340
* MODEL_ASSIM_MODE.EQ."Coupled ") .AND. INITIAL1.341
* (RUN_ASSIM_MODE .EQ."Atmosphere" .OR. INITIAL1.342
* RUN_ASSIM_MODE .EQ."Coupled ") .AND. INITIAL1.343
* STEPim(a_im) .LT. ASSIM_FIRSTSTEPim(a_im) + GDR5F305.65
* ASSIM_STEPSim(a_im) + ASSIM_EXTRASTEPSim(a_im)) GDR5F305.66
* .OR. (ASSIM_STEPSim(o_im)+ASSIM_EXTRASTEPSim(o_im).GT.0 .AND. GDR5F305.67
* (MODEL_ASSIM_MODE.EQ."Ocean " .OR. INITIAL1.346
* MODEL_ASSIM_MODE.EQ."Coupled ") .AND. INITIAL1.347
* (RUN_ASSIM_MODE .EQ."Ocean " .OR. INITIAL1.348
* RUN_ASSIM_MODE .EQ."Coupled ") .AND. INITIAL1.349
* STEPim(o_im) .LT. ASSIM_FIRSTSTEPim(o_im) + GDR5F305.68
* ASSIM_STEPSim(o_im) + ASSIM_EXTRASTEPSim(o_im)) GDR5F305.69
* .OR. (ASSIM_STEPSim(w_im)+ASSIM_EXTRASTEPSim(w_im).GT.0 .AND. WRB1F401.513
* (MODEL_ASSIM_MODE.EQ."Wave " .OR. WRB1F401.514
* MODEL_ASSIM_MODE.EQ."Coupled ") .AND. WRB1F401.515
* (RUN_ASSIM_MODE .EQ."Wave " .OR. WRB1F401.516
* RUN_ASSIM_MODE .EQ."Coupled ") .AND. WRB1F401.517
* STEPim(w_im) .LT. ASSIM_FIRSTSTEPim(w_im) + WRB1F401.518
* ASSIM_STEPSim(w_im) + ASSIM_EXTRASTEPSim(w_im)) WRB1F401.519
* .OR. (L_3DVAR.OR.L_4DVAR) ) VSB1F304.137
* THEN INITIAL1.351
IF (LTIMER) CALL TIMER('IN_ACCTL',3) INITIAL1.352
CALL IN_ACCTL( @DYALLOC.1872
*CALL ARGSIZE @DYALLOC.1873
*CALL ARTDUMA @DYALLOC.1874
*CALL ARTDUMO @DYALLOC.1875
*CALL ARTDUMW WRB1F401.520
*CALL ARTPTRA @DYALLOC.1876
*CALL ARTPTRO @DYALLOC.1877
*CALL ARTPTRW WRB1F401.521
*CALL ARGOCTOP @DYALLOC.1878
*CALL ARGPPX GDG0F401.820
& ICODE,CMESSAGE) @DYALLOC.1879
IF (LTIMER) CALL TIMER('IN_ACCTL',4) INITIAL1.354
IF (ICODE.GT.0) GOTO 999 INITIAL1.355
ENDIF INITIAL1.356
*ENDIF ORH6F401.2
CL INITIAL1.357
CL 5.4 Open unit for model increments diagnostics if requested INITIAL1.358
CL INITIAL1.359
*IF DEF,ATMOS INITIAL1.360
IF(LPRFLD)THEN AD050293.220
LEN_FILENAME=LEN(FILENAME) ARR0F404.30
*IF DEF,MPP ARR0F404.31
CALL FORT_GET_ENV(FT_ENVIRON(NDEV_FLD),LEN_FT_ENVIR(NDEV_FLD), ARR0F404.32
& FILENAME,LEN_FILENAME,ICODE) ARR0F404.33
ARR1F402.133
C Search for end of filename ARR1F402.134
LL=0 ARR1F402.135
DO I=1,LEN_FILENAME ARR1F402.136
IF(FILENAME(I:I).ne.' ') THEN ARR1F402.137
LL=LL+1 ARR1F402.138
ENDIF ARR1F402.139
ENDDO ! I over characters ARR1F402.140
ARR1F402.141
C Construct filename with PE no. appended ARR1F402.142
FILENAME(LL+1:LL+1)='.' ARR1F402.143
WRITE(FILENAME(LL+2:LL+5),'(i4.4)') mype ARR1F402.144
*ENDIF ARR1F402.145
ARR1F402.146
*IF DEF,MPP ARR0F404.34
LEN_FLD_FILENAME=LL+5 ARR0F404.35
FLD_FILENAME=FILENAME ARR0F404.36
CALL OPEN_SINGLE(NDEV_FLD,FLD_FILENAME, ARR0F404.37
& LEN_FLD_FILENAME,1,1,ICODE) ARR0F404.38
*ELSE ARR0F404.39
CALL FILE_OPEN(NDEV_FLD,FT_ENVIRON(NDEV_FLD), ARR0F404.40
& LEN_FT_ENVIR(NDEV_FLD),1,0,ICODE) ARR0F404.41
*ENDIF ARR0F404.42
IF(ICODE.NE.0) THEN ARR0F404.43
WRITE(6,*) 'INITIAL: Error opening cached file on unit ', ARR0F404.44
& NDEV_FLD ARR0F404.45
GO TO 999 ARR0F404.46
ENDIF ARR0F404.47
ENDIF AD050293.223
*ENDIF INITIAL1.362
GRR2F305.409
CL---------------------------------------------------------------------- INITIAL1.376
WRB1F401.523
!!! WAVE MODS INCOMPLETE BEYOND HERE - DUPLICAT OR GENERIFY ??? WRB1F401.524
WRB1F401.525
CL 7. Get derived diagnostics from, and update ancillary and boundary INITIAL1.377
CL fields in, initial data. Generate T+0 interface fields. INITIAL1.378
CL INITIAL1.379
*IF DEF,ATMOS INITIAL1.380
C First read the atmosphere data to memory if coupled INITIAL1.382
IF(submodel.NE.atmos_sm) THEN GRR2F305.410
GRR2F305.411
TRANS_LEN=TRANSALEN GRR2F305.412
NFTSWAP =NFTASWAP GRR2F305.413
submodel=atmos_sm ! new submodel will be atmosphere GRR1F402.298
IF (LTIMER) CALL TIMER('TRANSIN ',3) INITIAL1.383
CALL TRANSIN( GRR2F305.414
*CALL ARTD1 @DYALLOC.1891
& TRANS_LEN,NFTSWAP,submodel,ICODE,CMESSAGE) GRR1F402.299
IF (LTIMER) CALL TIMER('TRANSIN ',4) INITIAL1.386
ENDIF ! End check on submodel GRR2F305.417
CL INITIAL1.388
CL 7.1 Get derived diagnostics from start fields (atmosphere) INITIAL1.389
CL INITIAL1.390
IF (STEPim(a_im).EQ.0) THEN GDR5F305.70
IF (LTIMER) CALL TIMER('INITDIAG',3) INITIAL1.392
CALL INITDIAG( @DYALLOC.1893
*CALL ARGSIZE @DYALLOC.1894
*CALL ARTD1 @DYALLOC.1895
*CALL ARTDUMA @DYALLOC.1896
*CALL ARTDUMO @DYALLOC.1897
*CALL ARTDUMW GKR1F401.218
*CALL ARTSTS @DYALLOC.1898
*CALL ARTPTRA @DYALLOC.1899
*CALL ARTPTRO @DYALLOC.1900
*CALL ARTCONA @DYALLOC.1901
*CALL ARGPPX GKR0F305.945
& P_FIELD, ! for dynamic array NF171193.41
& ICODE,CMESSAGE) @DYALLOC.1902
IF (LTIMER) CALL TIMER('INITDIAG',4) INITIAL1.394
IF (ICODE.GT.0) GOTO 999 INITIAL1.395
ENDIF INITIAL1.396
CL INITIAL1.397
CL 7.2 Update boundary fields at step zero if required INITIAL1.398
CL or if LBOUNDARY=T (continuation run) INITIAL1.399
CL INITIAL1.400
IF (STEPim(a_im).EQ.0.OR.LBOUNDARY) THEN GDR5F305.71
IF (BOUNDARY_STEPSim(a_im).NE.0) THEN GDR5F305.72
GDR3F405.1047
if (l_lbc_coup) then GDR3F405.1048
GDR3F405.1049
call date_and_time(ch_date2, ch_time2) GDR3F405.1050
GDR3F405.1051
write(6,*) 'LBC_COUP: ', GDR3F405.1052
& ch_time2(1:2),':',ch_time2(3:4),':',ch_time2(5:6),' on ', GDR3F405.1053
& ch_date2(7:8),'/',ch_date2(5:6),'/',ch_date2(1:4), GDR3F405.1054
& ' Proceed to call UPBOUND in INITIAL.' GDR3F405.1055
GDR3F405.1056
endif ! If l_lbc_coup GDR3F405.1057
GDR3F405.1058
IF (LTIMER) CALL TIMER('UP_BOUND',3) INITIAL1.403
CALL UP_BOUND(submodel, GRR2F305.418
*CALL ARGSIZE @DYALLOC.1904
*CALL ARTD1 @DYALLOC.1905
*CALL ARTDUMA @DYALLOC.1906
*CALL ARTDUMO @DYALLOC.1907
*CALL ARTDUMW GKR1F401.219
*CALL ARTPTRA @DYALLOC.1908
*CALL ARTPTRO @DYALLOC.1909
*CALL ARTBND @DYALLOC.1910
*CALL ARGPPX GDG0F401.821
& ICODE,CMESSAGE) GDG0F401.822
IF (LTIMER) CALL TIMER('UP_BOUND',4) INITIAL1.405
IF (ICODE.GT.0) GOTO 999 INITIAL1.406
ENDIF INITIAL1.407
ENDIF INITIAL1.408
CL INITIAL1.409
CL 7.3 Update ancillary fields in dump if start time corresponds to INITIAL1.410
CL an ancillary field update time. Also done at T+0 with values GRB1F304.29
CL updated to half a period back from first standard update time GRB1F304.30
CL to ensure reproducibility between long runs and new runs GRB1F304.31
CL started from dump at any time. GRB1F304.32
CL INITIAL1.412
IF (LTIMER) CALL TIMER('UP_ANCIL',3) INITIAL1.413
IF (ANCILLARY_STEPSim(a_im).GT.0) THEN GDR5F305.73
IF (STEPim(a_im).EQ.0 .OR. GRB1F400.21
& MOD(STEPim(a_im),ANCILLARY_STEPSim(a_im)).EQ.0) GRB1F400.22
& CALL UP_ANCIL ( @DYALLOC.1912
*CALL ARGSIZE @DYALLOC.1913
*CALL ARTD1 @DYALLOC.1914
*CALL ARTDUMA @DYALLOC.1915
*CALL ARTDUMO @DYALLOC.1916
*CALL ARTDUMW GKR1F401.220
*CALL ARTPTRA @DYALLOC.1917
*CALL ARTPTRO @DYALLOC.1918
*CALL ARTANC @DYALLOC.1919
& submodel, GDG0F401.823
*CALL ARGPPX GDG0F401.824
& ICODE,CMESSAGE) GDG0F401.825
ENDIF INITIAL1.417
IF (LTIMER) CALL TIMER('UP_ANCIL',4) INITIAL1.418
IF (ICODE.GT.0) GOTO 999 INITIAL1.419
CL INITIAL1.420
CL ABX1F404.220
CL 7.3.1 Initialize tiled prognostics, gridbox mean vegetation ABX1F404.221
CL parameters and TRIFFID accumulation prognostics. ABX1F404.222
CL ABX1F404.223
IF (L_VEG_FRACS) THEN ABX1F404.224
IF(LTIMER) CALL TIMER('INIT_VEG',3) ABX1F404.225
*IF DEF,MPP ABX1F404.226
! Skip INIT_VEG if LAND_FIELD=0 for this PE. ABX1F404.227
IF (LAND_FIELD .gt. 0) THEN ABX1F404.228
*ENDIF ABX1F404.229
CALL INIT_VEG(STEPim(a_im), ABX1F404.230
*CALL ARGSIZE ABX1F404.231
*CALL ARTD1 ABX1F404.232
*CALL ARTDUMA ABX1F404.233
*CALL ARTPTRA ABX1F404.234
*CALL ARTCONA ABX1F404.235
& ICODE,CMESSAGE) ABX1F404.236
*IF DEF,MPP ABX1F404.237
ELSE ABX1F404.238
WRITE(6,*)'INITIAL; skip INIT_VEG, LAND_FIELD=0 for this PE' ABX1F404.239
END IF ABX1F404.240
*ENDIF ABX1F404.241
IF(LTIMER) CALL TIMER('INIT_VEG',4) ABX1F404.242
END IF ABX1F404.243
CL 7.3.2 Ensure that canopy water does not exceed canopy ABX1F404.244
CL capacity at step zero (this may be a problem when INITIAL1.422
CL using interpolated fields INITIAL1.423
CL INITIAL1.424
IF (STEPim(a_im).EQ.0) THEN GDR5F305.74
IF(LTIMER) CALL TIMER('INIT_HYD',3) INITIAL1.426
IF (.NOT.L_VEG_FRACS) THEN ABX1F405.51
*IF DEF,MPP ARB2F403.76
! Skip INIT_HYD if LAND_FIELD=0 for this PE. ARB2F403.77
IF (LAND_FIELD .gt. 0) THEN ARB2F403.78
*ENDIF ARB2F403.79
CALL INIT_HYD( ABX1F405.52
*CALL ARGSIZE @DYALLOC.1922
*CALL ARTD1 @DYALLOC.1923
*CALL ARTPTRA @DYALLOC.1924
& ICODE,CMESSAGE) @DYALLOC.1925
*IF DEF,MPP ARB2F403.80
ELSE ARB2F403.81
write(6,*)' INITIAL; skip INIT_HYD, LAND_FIELD=0 for this PE' ARB2F403.82
END IF ARB2F403.83
*ENDIF ARB2F403.84
ENDIF ABX1F405.53
IF(LTIMER) CALL TIMER('INIT_HYD',4) INITIAL1.428
END IF RB250294.2
C RB250294.3
CL RB250294.4
CL 7.3.3 Ensure that convective cloud cover and liquid water path ABX1F404.246
CL are consistent with convective cloud base & top. (Corrects RB250294.6
CL for occasional problems caused by reconfiguration.) RB250294.7
CL RB250294.8
IF (STEPim(a_im).EQ.0) THEN GDR5F305.75
IF(LTIMER) CALL TIMER('INIT_CNV',3) RB250294.10
CALL INIT_CNV( RB250294.11
*CALL ARGSIZE RB250294.12
*CALL ARTD1 RB250294.13
*CALL ARTPTRA RB250294.14
& ICODE,CMESSAGE) RB250294.15
IF(LTIMER) CALL TIMER('INIT_CNV',4) RB250294.16
END IF INITIAL1.429
C INITIAL1.430
CL INITIAL1.431
CL 7.4 Generate interface fields at step zero if required INITIAL1.432
CL INITIAL1.433
IF (LINTERFACE .AND. STEPim(a_im).EQ.0) THEN GDR5F305.76
IF (LTIMER) CALL TIMER('GEN_INTF',3) INITIAL1.436
CALL GEN_INTF ( @DYALLOC.1926
*CALL ARGSIZE @DYALLOC.1927
*CALL ARTD1 @DYALLOC.1928
*CALL ARTDUMA GMB1F405.383
*CALL ARTSTS GMB1F405.384
*CALL ARTPTRA GMB1F405.385
*CALL ARTCONA GMB1F405.386
*CALL ARTINFA GMB1F405.387
*CALL ARTPTRO GMB1F405.388
*CALL ARTCONO GMB1F405.389
*CALL ARTDUMO GMB1F405.390
*CALL ARTINFO GMB1F405.391
*CALL ARGPPX APB4F401.492
& submodel,ICODE,CMESSAGE) GRR2F305.425
IF (LTIMER) CALL TIMER('GEN_INTF',4) INITIAL1.438
IF (ICODE.GT.0) GOTO 999 INITIAL1.439
ENDIF INITIAL1.440
GRR2F305.426
C Write atmosphere data back to "swap" file INITIAL1.442
IF(N_SUBMODEL_PARTITION.GT.1) THEN ! coupling across dumps GRR2F305.427
GRR2F305.428
IF(submodel.eq.atmos_sm) then ! atmosphere GRR2F305.429
NFTSWAP =NFTASWAP GRR2F305.430
TRANS_LEN=TRANSALEN GRR2F305.431
ELSE GRR2F305.432
CMESSAGE='INITIAL: submodel ident not atmosphere' GRR2F305.433
write(6,*) CMESSAGE GRR2F305.434
write(6,*) 'Non valid submodel identifier=',submodel GRR2F305.435
ICODE=1 GRR2F305.436
ENDIF ! End test on submodel identifier GRR2F305.437
IF (ICODE.GT.0) GOTO 999 GRR2F305.438
GRR2F305.439
CL Copy data from one start dump to "swap" file, read the other GRR2F305.440
CL start dump to memory, and write it out to its "swap" file GRR2F305.441
IF (LTIMER) CALL TIMER('TRANSOUT',3) INITIAL1.443
CALL TRANSOUT( GRR2F305.442
*CALL ARTD1 @DYALLOC.1936
& TRANS_LEN,NFTSWAP,submodel,ICODE,CMESSAGE) GRR1F402.300
IF (LTIMER) CALL TIMER('TRANSOUT',4) INITIAL1.446
GRR2F305.444
IF (ICODE.GT.0) GOTO 999 GRR2F305.445
GRR2F305.446
ENDIF ! end of test for coupling across dumps GRR2F305.447
*ENDIF INITIAL1.448
C INITIAL1.449
*IF DEF,OCEAN INITIAL1.450
C First read the ocean data to memory if coupled GRR2F305.448
IF(submodel.NE.ocean_sm) THEN GRR2F305.449
GRR2F305.450
NFTSWAP =NFTOSWAP GRR2F305.451
TRANS_LEN=TRANSOLEN GRR2F305.452
submodel=ocean_sm ! new submodel will be ocean GRR1F402.301
IF (LTIMER) CALL TIMER('TRANSIN ',3) INITIAL1.453
CALL TRANSIN( GRR2F305.453
*CALL ARTD1 @DYALLOC.1939
& TRANS_LEN,NFTSWAP,submodel,ICODE,CMESSAGE) GRR1F402.302
IF (LTIMER) CALL TIMER('TRANSIN ',4) INITIAL1.456
ENDIF ! End check on submodel GRR2F305.456
GRR2F305.458
CL INITIAL1.458
CL 7.5 Get derived diagnostics from start fields (ocean) INITIAL1.459
ORH9F404.6
IF (STEPim(o_im).EQ.0) THEN ORH9F404.7
ORH9F404.8
IF (LTIMER) CALL TIMER('INITDIAGO',3) ORH9F404.9
ORH9F404.10
CALL INITDIAGO( ORH9F404.11
*CALL ARGSIZE ORH9F404.12
*CALL ARTD1 ORH9F404.13
*CALL ARTDUMA ORH9F404.14
*CALL ARTDUMO ORH9F404.15
*CALL ARTDUMW ORH9F404.16
*CALL ARTSTS ORH9F404.17
*CALL ARTPTRA ORH9F404.18
*CALL ARTPTRO ORH9F404.19
*CALL ARTCONA ORH9F404.20
*CALL ARGPPX ORH9F404.21
& ICODE,CMESSAGE) ORH9F404.22
ORH9F404.23
IF (LTIMER) CALL TIMER('INITDIAGO',4) ORH9F404.24
ORH9F404.25
IF (ICODE.GT.0) GOTO 999 ORH9F404.26
ORH9F404.27
ENDIF ORH9F404.28
CL INITIAL1.461
CL INITIAL1.462
CL 7.6 Update boundary fields at step zero if required INITIAL1.463
CL or if LBOUNDARY=T (continuation run) INITIAL1.464
CL INITIAL1.465
IF (STEPim(o_im).EQ.0.OR.LBOUNDARY) THEN GDR5F305.77
IF (BOUNDARY_STEPSim(o_im).NE.0) THEN GDR5F305.78
IF (LTIMER) CALL TIMER('UP_BOUND',3) INITIAL1.468
CALL UP_BOUND(submodel, GRR2F305.459
*CALL ARGSIZE @DYALLOC.1942
*CALL ARTD1 @DYALLOC.1943
*CALL ARTDUMA @DYALLOC.1944
*CALL ARTDUMO @DYALLOC.1945
*CALL ARTDUMW GKR1F401.221
*CALL ARTPTRA @DYALLOC.1946
*CALL ARTPTRO @DYALLOC.1947
*CALL ARTBND @DYALLOC.1948
*CALL ARGPPX GDG0F401.826
& ICODE,CMESSAGE) GDG0F401.827
IF (LTIMER) CALL TIMER('UP_BOUND',4) INITIAL1.470
IF (ICODE.GT.0) GOTO 999 INITIAL1.471
ENDIF INITIAL1.472
ENDIF INITIAL1.473
CL INITIAL1.474
CL 7.7 Update ancillary fields in dump if start time corresponds to INITIAL1.475
CL an ancillary field update time. Also done at T+0 with values GRB1F304.36
CL updated to half a period back from first standard update time GRB1F304.37
CL to ensure reproducibility between long runs and new runs GRB1F304.38
CL started from dump at any time. GRB1F304.39
CL INITIAL1.477
IF (LTIMER) CALL TIMER('UP_ANCIL',3) INITIAL1.478
IF (ANCILLARY_STEPSim(o_im).GT.0) THEN GDR5F305.79
IF (STEPim(o_im).EQ.0 .OR. GRB1F400.23
& MOD(STEPim(o_im),ANCILLARY_STEPSim(o_im)).EQ.0) GRB1F400.24
& CALL UP_ANCIL ( @DYALLOC.1950
*CALL ARGSIZE @DYALLOC.1951
*CALL ARTD1 @DYALLOC.1952
*CALL ARTDUMA @DYALLOC.1953
*CALL ARTDUMO @DYALLOC.1954
*CALL ARTDUMW GKR1F401.222
*CALL ARTPTRA @DYALLOC.1955
*CALL ARTPTRO @DYALLOC.1956
*CALL ARTANC @DYALLOC.1957
& submodel, GDG0F401.828
*CALL ARGPPX GDG0F401.829
& ICODE,CMESSAGE) GDG0F401.830
ENDIF INITIAL1.482
IF (LTIMER) CALL TIMER('UP_ANCIL',4) INITIAL1.483
IF (ICODE.GT.0) GOTO 999 INITIAL1.484
CL INITIAL1.485
CL 7.8 Generate interface fields at step zero if required INITIAL1.486
CL INITIAL1.487
IF (LINTERFACE .AND. STEPim(o_im).EQ.0) THEN GMB1F405.382
IF (LTIMER) CALL TIMER('GEN_INTF',3) INITIAL1.490
CALL GEN_INTF ( @DYALLOC.1959
*CALL ARGSIZE @DYALLOC.1960
*CALL ARTD1 @DYALLOC.1961
*CALL ARTDUMA GMB1F405.392
*CALL ARTSTS GMB1F405.393
*CALL ARTPTRA GMB1F405.394
*CALL ARTCONA GMB1F405.395
*CALL ARTINFA GMB1F405.396
*CALL ARTPTRO GMB1F405.397
*CALL ARTCONO GMB1F405.398
*CALL ARTDUMO GMB1F405.399
*CALL ARTINFO GMB1F405.400
*CALL ARGPPX APB4F401.493
& submodel,ICODE,CMESSAGE) GRR2F305.461
IF (LTIMER) CALL TIMER('GEN_INTF',4) INITIAL1.492
IF (ICODE.GT.0) GOTO 999 INITIAL1.493
ENDIF INITIAL1.494
GRR2F305.462
C Write ocean data back to "swap" file GRR2F305.463
IF(N_SUBMODEL_PARTITION.GT.1) THEN ! coupling across dumps GRR2F305.464
GRR2F305.465
IF(submodel.eq.ocean_sm) then ! ocean GRR2F305.466
NFTSWAP =NFTOSWAP GRR2F305.467
TRANS_LEN=TRANSOLEN GRR2F305.468
ELSE GRR2F305.469
CMESSAGE='INITIAL: submodel ident not ocean ' GRR2F305.470
write(6,*) CMESSAGE GRR2F305.471
write(6,*) 'Non valid submodel identifier=',submodel GRR2F305.472
ICODE=1 GRR2F305.473
ENDIF ! End test on submodel identifier GRR2F305.474
IF (ICODE.GT.0) GOTO 999 GRR2F305.475
GRR2F305.476
C Write ocean data back to "swap" file INITIAL1.496
IF (LTIMER) CALL TIMER('TRANSOUT',3) INITIAL1.497
CALL TRANSOUT( GRR2F305.477
*CALL ARTD1 @DYALLOC.1969
& TRANS_LEN,NFTSWAP,submodel,ICODE,CMESSAGE) GRR1F402.303
IF (LTIMER) CALL TIMER('TRANSOUT',4) INITIAL1.500
GRR2F305.479
IF (ICODE.GT.0) GOTO 999 GRR2F305.480
GRR2F305.481
GRR2F305.482
ENDIF ! end of test for coupling across dumps GRR2F305.483
*ENDIF INITIAL1.501
GRR2F305.484
CL---------------------------------------------------------------------- INITIAL1.503
CL 8. If coupled model, initialise addresses of coupling fields, INITIAL1.504
CL and if model has restarted at the end of a coupling period INITIAL1.505
CL exchange coupling fields and swap data (full ocean model) INITIAL1.506
CL or both models are at step 0, exchange coupling fields and INITIAL1.507
CL swap data (in sense O-A at step 0). INITIAL1.508
CL INITIAL1.509
*IF DEF,ATMOS INITIAL1.510
*IF DEF,OCEAN INITIAL1.511
*IF DEF,MPP GRR0F402.8
! Get 'global' atmos and ocean horizontal domain sizes from database GRR0F402.9
! in DECOMPDB to set dynamic allocation in SWAP_A2O,SWAP_O2A. GRR0F402.10
G_P_FIELD= decomp_db_glsize(1,decomp_standard_atmos) * GRR0F402.11
& decomp_db_glsize(2,decomp_standard_atmos) GRR0F402.12
GRR0F402.13
G_IMTJMT = decomp_db_glsize(1,decomp_standard_ocean) * GRR0F402.14
& decomp_db_glsize(2,decomp_standard_ocean) GRR0F402.15
*ELSE GRR0F402.16
! Sizes not used for non-MPP: dummy values only GRR0F402.17
G_P_FIELD= P_FIELD GRR0F402.18
G_IMTJMT = IMT*JMT GRR0F402.19
*ENDIF GRR0F402.20
IF (LTIMER) CALL TIMER('INIT_A2O',3) INITIAL1.512
CALL INIT_A2O( @DYALLOC.1971
*CALL ARGSIZE @DYALLOC.1972
*CALL ARTD1 @DYALLOC.1973
*CALL ARTSTS @DYALLOC.1974
*CALL ARTDUMA @DYALLOC.1975
*CALL ARTDUMO @DYALLOC.1976
*CALL ARTPTRA @DYALLOC.1977
*CALL ARTPTRO @DYALLOC.1978
*CALL ARTAOCPL @DYALLOC.1979
* ICODE,CMESSAGE) @DYALLOC.1980
IF (LTIMER) CALL TIMER('INIT_A2O',4) INITIAL1.514
*ENDIF INITIAL1.515
*IF DEF,SLAB INITIAL1.516
IF (LTIMER) CALL TIMER('INIT_A2S',3) INITIAL1.517
CALL INIT_A2S( @DYALLOC.1981
*CALL ARGSIZE @DYALLOC.1982
*CALL ARTSTS @DYALLOC.1983
*CALL ARTPTRA @DYALLOC.1984
* ICODE,CMESSAGE) @DYALLOC.1985
IF (LTIMER) CALL TIMER('INIT_A2S',4) INITIAL1.519
*ENDIF INITIAL1.520
IF (ICODE.GT.0) GOTO 999 INITIAL1.521
C INITIAL1.522
*IF DEF,OCEAN INITIAL1.523
IF (new_sm) THEN ! Test for a new submodel next GRR2F305.485
IF (L_CO2_INTERACTIVE) THEN CCN1F405.109
CO2_DIMA = G_P_FIELD CCN1F405.110
CO2_DIMO = G_IMTJMT CCN1F405.111
*IF DEF,MPP CCN1F405.112
CO2_DIMO2 = (decomp_db_glsize(1,decomp_standard_ocean)-2) * CCN1F405.113
& decomp_db_glsize(2,decomp_standard_ocean) CCN1F405.114
*ELSE CCN1F405.115
CO2_DIMO2 = (IMT-2)*JMT CCN1F405.116
*ENDIF CCN1F405.117
ELSE CCN1F405.118
CO2_DIMA = 1 CCN1F405.119
CO2_DIMO = 1 CCN1F405.120
CO2_DIMO2 = 1 CCN1F405.121
ENDIF CCN1F405.122
IF(submodel_next.EQ.ocean_sm) THEN ! Atmos -> Ocean GRR2F305.486
GRR2F305.487
NFTSWAP =NFTASWAP GRR2F305.488
TRANS_LEN=TRANSALEN GRR2F305.489
IF (LTIMER) CALL TIMER('TRANSIN ',3) INITIAL1.526
CALL TRANSIN( GRR2F305.490
*CALL ARTD1 @DYALLOC.1987
& TRANS_LEN,NFTSWAP,atmos_sm,ICODE,CMESSAGE) GRR1F402.304
IF (LTIMER) CALL TIMER('TRANSIN ',4) INITIAL1.529
C INITIAL1.530
IF (LTIMER) CALL TIMER('SWAP_A2O',3) INITIAL1.531
CALL SWAP_A2O(G_P_FIELD,G_IMTJMT,CO2_DIMA,CO2_DIMO, CCN1F405.123
*CALL ARGSIZE @DYALLOC.1990
*CALL ARTD1 @DYALLOC.1991
*CALL ARTDUMO @DYALLOC.1992
*CALL ARTPTRA @DYALLOC.1993
*CALL ARTPTRO @DYALLOC.1994
*CALL ARTCONA @DYALLOC.1995
*CALL ARTCONO CJG6F401.3
*CALL ARTAOCPL @DYALLOC.1996
& ICODE,CMESSAGE) @DYALLOC.1997
IF (LTIMER) CALL TIMER('SWAP_A2O',4) INITIAL1.533
GRR2F305.492
ELSEIF(submodel_next.EQ.atmos_sm) THEN ! Ocean -> Atmos GRR2F305.493
GRR2F305.494
NFTSWAP =NFTOSWAP GRR2F305.495
TRANS_LEN=TRANSOLEN GRR2F305.496
IF (LTIMER) CALL TIMER('TRANSIN ',3) INITIAL1.536
CALL TRANSIN( GRR2F305.497
*CALL ARTD1 @DYALLOC.1999
& TRANS_LEN,NFTSWAP,ocean_sm,ICODE,CMESSAGE) GRR1F402.305
IF (LTIMER) CALL TIMER('TRANSIN ',4) INITIAL1.539
C INITIAL1.540
IF (LTIMER) CALL TIMER('SWAP_O2A',3) INITIAL1.541
CALL SWAP_O2A(G_P_FIELD,G_IMTJMT,CO2_DIMA,CO2_DIMO,CO2_DIMO2, CCN1F405.124
*CALL ARGSIZE @DYALLOC.2002
*CALL ARTD1 @DYALLOC.2003
*CALL ARTDUMO @DYALLOC.2004
*CALL ARTPTRA @DYALLOC.2005
*CALL ARTPTRO @DYALLOC.2006
*CALL ARTCONO CJG6F401.4
*CALL ARTAOCPL @DYALLOC.2007
& ICODE,CMESSAGE) @DYALLOC.2008
IF (LTIMER) CALL TIMER('SWAP_O2A',4) INITIAL1.543
GRR2F305.499
ELSE ! No other submodel -> submodel coupling allowed yet GRR2F305.500
ICODE=1 GRR2F305.501
CMESSAGE='INITIAL: Illegal submodel identifier for coupling' GRR2F305.502
write(6,*) CMESSAGE GRR2F305.503
write(6,*) 'Next submodel id =',submodel_next GRR2F305.504
GRR2F305.505
ENDIF ! End tests on coupled submodels' identity GRR2F305.506
IF (ICODE.GT.0) GOTO 999 INITIAL1.546
submodel=submodel_next ! From SETGRCTL calculations GRR2F305.507
GRR2F305.508
ENDIF ! End test on new submodel GRR2F305.509
*ENDIF INITIAL1.548
*ENDIF INITIAL1.549
CL---------------------------------------------------------------------- INITIAL1.550
CL 9. Print formatted diagnostics from initial dump INITIAL1.551
CL INITIAL1.552
*IF DEF,ATMOS INITIAL1.553
CL INITIAL1.554
CL 9.1 Set up address pointers for zonal mean print INITIAL1.555
CL INITIAL1.556
IF (PRINTFREQim(1,a_im).NE.0 .OR. PRINTFREQim(2,a_im).NE.0 .OR. GRB1F305.139
* PRINTFREQim(3,a_im).NE.0 .OR. PRINTFREQim(4,a_im).NE.0 .OR. GRB1F305.140
* PRINTFREQim(5,a_im).NE.0) THEN GRB1F305.141
IF (LTIMER) CALL TIMER('INITZONM',3) INITIAL1.560
CALL INITZONM ( @DYALLOC.2009
*CALL ARGSIZE @DYALLOC.2010
*CALL ARTSTS @DYALLOC.2011
*CALL ARTPTRA @DYALLOC.2012
& ICODE,CMESSAGE) @DYALLOC.2013
IF (LTIMER) CALL TIMER('INITZONM',4) INITIAL1.562
IF (ICODE.GT.0) GOTO 999 INITIAL1.563
ENDIF INITIAL1.564
CL INITIAL1.565
CL 9.2 Output zonal mean print from atmosphere start data INITIAL1.566
CL INITIAL1.567
IF (submodel.EQ.atmos_sm.AND.STEPim(a_im).EQ.0.AND. GRR2F305.510
& PRINTFREQim(1,a_im).NE.0) THEN GRB1F305.142
IF (LTIMER) CALL TIMER('PRINTCTL',3) INITIAL1.569
CALL PRINTCTL ( @DYALLOC.2014
*CALL ARGSIZE @DYALLOC.2015
*CALL ARTD1 @DYALLOC.2016
*CALL ARTDUMA @DYALLOC.2017
*CALL ARTPTRA @DYALLOC.2018
*CALL ARTCONA @DYALLOC.2019
& submodel,MEANLEV,ICODE,CMESSAGE) GRR2F305.511
IF (LTIMER) CALL TIMER('PRINTCTL',4) INITIAL1.571
IF (ICODE.GT.0) GOTO 999 INITIAL1.572
ENDIF INITIAL1.573
*ENDIF INITIAL1.574
CL---------------------------------------------------------------------- INITIAL1.575
CL 10. Initialisation complete - return to master routine INITIAL1.576
CL INITIAL1.577
! Check that operational model running on MPP has finished GRR2F405.14
! initialisation and write a message to the operator GRR2F405.15
*IF DEF,MPP GRR2F405.16
IF(mype.eq.0) THEN GRR2F405.17
IF(MODEL_STATUS .EQ. 'Operational') THEN GRR2F405.18
CALL OperatorMessage(nproc) GRR2F405.19
ENDIF GRR2F405.20
ENDIF GRR2F405.21
*ENDIF GRR2F405.22
999 CONTINUE INITIAL1.578
IF (LTIMER) CALL TIMER('INITIAL ',4) INITIAL1.579
RETURN INITIAL1.580
CL---------------------------------------------------------------------- INITIAL1.581
END INITIAL1.582
*ENDIF INITIAL1.583