SUBROUTINE U_MODEL( 1,109@DYALLOC.3577
& NFT,NFTU, GSS2F401.492
*CALL ARGSZSP 
@DYALLOC.3578
*CALL ARGSZSPA @DYALLOC.3579
*CALL ARGSZSPO @DYALLOC.3580
*CALL ARGSZSPW WRB1F401.1134
*CALL ARGSZSPC @DYALLOC.3581
*CALL ARGSIZE @DYALLOC.3582
& P_FIELDDA_CONV,Q_LEVELSDA, RB300993.134
*IF DEF,FRADIO GGH3F401.39
& P_FIELDDA,P_LEVELSDA, @DYALLOC.3584
*ENDIF @DYALLOC.3585
& ppxRecs,ICODE,CMESSAGE) GSS1F400.988
@DYALLOC.3587
IMPLICIT NONE @DYALLOC.3588
@DYALLOC.3589
C*L Interface and arguments: ------------------------------------------ U_MODEL1.25
CL Sizes of super arrays @DYALLOC.3590
*CALL TYPSZSP @DYALLOC.3591
*CALL TYPSZSPA @DYALLOC.3592
*CALL TYPSZSPO @DYALLOC.3593
*CALL TYPSZSPW WRB1F401.1135
*CALL TYPSZSPC @DYALLOC.3594
CL @DYALLOC.3595
CL Model sizes @DYALLOC.3596
*CALL TYPSIZE @DYALLOC.3597
CL @DYALLOC.3598
INTEGER RB300993.135
& P_FIELDDA_CONV !copy of P_FIELD_CONV for portability of dyn.alloc RB300993.136
&,Q_LEVELSDA ! copy of Q_LEVELS for portability of dynamic allocn. RB300993.137
*IF DEF,FRADIO GGH3F401.40
&,P_FIELDDA ! copy of P_FIELD for portability of dynamic allocn. RB300993.138
&,P_LEVELSDA ! copy of P_LEVELS for portability of dynamic allocn. RB300993.139
*ENDIF @DYALLOC.3603
CL Addresses of component arrays within super arrays @DYALLOC.3604
*CALL SPINDEX @DYALLOC.3605
CL @DYALLOC.3606
CHARACTER*80 CMESSAGE ! OUT - Error message WRB1F401.1136
INTEGER ICODE ! OUT - Return code @DYALLOC.3608
C*---------------------------------------------------------------------- U_MODEL1.29
C U_MODEL1.31
C Common blocks U_MODEL1.32
C U_MODEL1.33
*CALL CMAXSIZE GDR3F405.30
*CALL CSUBMODL GRR2F305.610
*CALL CHSUNITS GDR3F305.186
*CALL CHISTORY RS030293.240
*CALL CCONTROL U_MODEL1.34
*CALL CTIME GDR3F405.31
*CALL CINTFA GDR3F405.32
*CALL C_GLOBAL GSS1F304.720
*CALL PARVARS ARB1F402.789
CL GSS1F304.721
! Dynamic allocation of ppxref look-up arrays and declaration of GSS1F305.900
! ppxref pointer array. GSS1F305.901
*CALL CPPXREF GSS1F305.902
*CALL PPXLOOK GSS1F305.903
*CALL DECOMPTP GRR0F402.26
*CALL DECOMPDB GRR0F402.27
C U_MODEL1.38
C Subroutines called U_MODEL1.39
C U_MODEL1.40
EXTERNAL INITIAL,EXITCHEK,SETGRCTL,SETTSCTL, U_MODEL1.41
& INCRTIME,DUMPCTL,PRINTCTL,GEN_INTF,MEANCTL,TEMPHIST, U_MODEL1.42
& UP_ANCIL,UP_BOUND,GETPPX_PART, GSS1F305.904
& EXITPROC,EREPORT,ABORT, U_MODEL1.44
& TIMER,PPCTL,JOBCTL,SET_HISTORY_VALUES U_MODEL1.45
*IF DEF,ATMOS U_MODEL1.46
* ,ATM_STEP,RESETATM U_MODEL1.47
*ENDIF U_MODEL1.48
*IF DEF,OCEAN U_MODEL1.49
* ,OCN_STEP,RESETOCN TJ230793.3
*ENDIF U_MODEL1.51
*IF DEF,SLAB U_MODEL1.52
* ,SLABSTEP U_MODEL1.53
*ENDIF U_MODEL1.54
*IF DEF,WAVE WRB1F401.1137
* ,WAV_STEP WRB1F401.1138
*ENDIF WRB1F401.1139
*IF DEF,ATMOS,AND,DEF,OCEAN U_MODEL1.55
* ,SWAP_A2O,SWAP_O2A U_MODEL1.56
*ENDIF U_MODEL1.57
CL @DYALLOC.3609
CL DYNAMIC ALLOCATION OF SUPER ARRAYS: @DYALLOC.3610
CL @DYALLOC.3611
CL Main D1 data array @DYALLOC.3612
*CALL TYPSPD1 @DYALLOC.3613
cdir$ cache_align spd1 GBC6F404.320
CL @DYALLOC.3614
CL STASH related arrays @DYALLOC.3615
*CALL TYPSPST @DYALLOC.3616
CL @DYALLOC.3617
CL Dump headers and lookups @DYALLOC.3618
*CALL TYPSPDUA @DYALLOC.3619
*CALL TYPSPDUO @DYALLOC.3620
*CALL TYPSPDUW WRB1F401.1140
CL @DYALLOC.3621
CL Pointers (addresses) of model variables and constants @DYALLOC.3622
*CALL TYPSPPTA @DYALLOC.3623
*CALL TYPSPPTO @DYALLOC.3624
*CALL TYPSPPTW WRB1F401.1141
CL Maximum sizes of fields limited by User Interface GDR3F305.187
CL CMAXSIZE now included earlier in routine GDR3F305.188
CL @DYALLOC.3628
CL Model derived constants arrays @DYALLOC.3629
*CALL TYPSPCOA @DYALLOC.3630
*CALL TYPSPCOO @DYALLOC.3631
*CALL TYPSPCOW WRB1F401.1142
CL @DYALLOC.3632
CL Generation of output interface fields @DYALLOC.3633
*CALL TYPSPINA @DYALLOC.3634
*CALL TYPSPINO @DYALLOC.3635
*CALL TYPSPINW WRB1F401.1143
CL @DYALLOC.3636
CL Updating of model from ancillary files @DYALLOC.3637
*CALL TYPSPANA @DYALLOC.3638
*CALL TYPSPANO @DYALLOC.3639
*CALL TYPSPANW WRB1F401.1144
CL @DYALLOC.3640
CL Boundary updating for Limited Area Models @DYALLOC.3641
*CALL TYPSPBO @DYALLOC.3642
*CALL TYPSPBOA @DYALLOC.3643
*CALL TYPSPBOO @DYALLOC.3644
*CALL TYPSPBOW WRB1F401.1145
CL @DYALLOC.3645
CL Coupled model arrays (atmosphere-ocean) @DYALLOC.3646
*CALL TYPSPCPL @DYALLOC.3647
CL @DYALLOC.3648
CL Convection increments arrays RB300993.140
CL Only used when convection scheme not called every timestep, RB300993.141
CL otherwise first dimension set to 1. RB300993.142
C Same as *CALL TYPCNVI but 'DA' sizes for portability of dyn.allocn. RB300993.143
REAL RB300993.144
& CNVINCS(P_FIELDDA_CONV,Q_LEVELSDA,2) ! Conv.increments, TH & Q RB300993.145
&,CNV_RAIN(P_FIELDDA_CONV) ! Conv.rain amount RB300993.146
&,CNV_SNOW(P_FIELDDA_CONV) ! Conv.snow amount RB300993.147
&,CNV_CCW(P_FIELDDA_CONV,Q_LEVELSDA) ! Conv.cloud water amount RB300993.148
&,CNV_LA(P_FIELDDA_CONV) !INOUT Lowest conv.cloud amount ARN2F304.107
&,CNV_LP(P_FIELDDA_CONV) !INOUT Lowest conv.cloud liq.water path ARN2F304.108
INTEGER ARN2F304.109
& CNV_LB(P_FIELDDA_CONV) !INOUT Lowest conv.cloud base level ARN2F304.110
&,CNV_LT(P_FIELDDA_CONV) !INOUT Lowest conv.cloud top level ARN2F304.111
*IF DEF,FRADIO GGH3F401.41
CL RB300993.149
CL Radiation increments array (*IF DEF,FRADIO) GGH3F401.42
C same as *CALL CRADINCS but with copies for portability of dyn.allocn. @DYALLOC.3651
CL The dimension of radincrs kept as for -*DEF,FRADIO which requires 512 GGH3F401.43
CL word blocking. @DYALLOC.3653
REAL ! RADIATION INCRS (SW+LW) @DYALLOC.3654
& RADINCS ( (P_FIELDDA*(P_LEVELSDA+3)+511)/512*512*2 ) ARE2F404.530
*ENDIF @DYALLOC.3656
C U_MODEL1.58
C Local variables U_MODEL1.59
C U_MODEL1.60
INTEGER internal_model ! Work - Internal model identifier GRR2F305.611
INTEGER internal_model_prev!Work - Previous internal model ident GRR2F305.612
INTEGER submodel ! Work - Submodel id for dump partition GRR2F305.613
INTEGER submodel_prev ! Work - Previous submodel dump id GRR2F305.614
INTEGER NGROUP ! Work - Number of steps in "group" U_MODEL1.62
INTEGER MEANLEV ! Work - Mean level indicator U_MODEL1.63
INTEGER IABORT ! Work - Internal return code @DYALLOC.3657
INTEGER I_STEP ! Work - Loop counter over timesteps U_MODEL1.65
INTEGER G_P_FIELD ! Sizes for MPP dynamic allocation GRR0F402.28
& ,G_IMTJMT ! in A-O coupling routines GRR0F402.29
LOGICAL LEXITNOW ! Work - Immediate exit indicator U_MODEL1.67
CHARACTER*14 PPNAME ! Work - Dummy PP filename U_MODEL1.68
INTEGER NFT ! Unit no. for standard STASHmaster files GSS2F401.493
INTEGER NFTU ! Do. user STASH files (for GET_FILE) GSS2F401.494
INTEGER RowNumber ! Row no. counter for PPXI, PPXC arrays GSS2F401.495
INTEGER I,J,K ! Loop counters GSS2F401.496
INTEGER CO2_DIMA, ! CO2 array dimensions CCN1F405.87
& CO2_DIMO, CCN1F405.88
& CO2_DIMO2 CCN1F405.89
*IF DEF,MPP ARB1F402.790
Integer info ! Return code from GCom routines ARB1F402.791
*ENDIF ARB1F402.792
C U_MODEL1.69
GDR3F405.33
integer len_runid ! No of chars in RUNID GDR3F405.34
integer um_lbc_coup ! LBC Coupling Switch : 1/0 is on/off GDR3F405.35
GDR3F405.36
character*80 filename ! Filename of communication file. GDR3F405.37
character*8 c_lbc_coup ! Character variable to read env var GDR3F405.38
character*8 ch_date2 ! Date returned from date_and_time GDR3F405.39
character*10 ch_time2 ! Time returned from date_and_time GDR3F405.40
character*5 runid_char ! RUNID for job GDR3F405.41
character*4 runtype_char ! Run Type (ie. NRUN, CRUN) GDR3F405.42
integer get_char_len ! Function to get no of char in string GDR3F405.43
integer lbc_ntimes ! No of BCs in communication file. GDR3F405.44
integer ms_ntimes ! No of BCs required in mesoscale. GDR3F405.45
integer len_wait_tot ! Total wait for availability of BCs GDR3F405.46
*IF DEF,MPP GDR3F405.47
integer iostatus ! Error code GDR3F405.48
*ENDIF GDR3F405.49
integer*8 isleep ! Return value from SLEEP GDR3F405.50
integer*8 sleep ! SLEEP function to make job wait GDR3F405.51
GDR3F405.52
logical l_exist ! T : Communication File exists GDR3F405.53
logical l_active ! T : Output stream active for LBCs. GDR3F405.54
GDR3F405.55
*CALL LBC_COUP GDR3F405.56
GDR3F405.57
CL---------------------------------------------------------------------- U_MODEL1.70
CL 0. Start Timer call for U_MODEL (NB: not conditional on LTIMER) @DYALLOC.3658
CL U_MODEL1.72
IF (LTIMER) THEN GSM1F401.26
CALL TIMER('U_MODEL ',3) GSM1F401.27
END IF GSM1F401.28
GDR3F405.58
! Find out if LBC Coupling has been switched on this run GDR3F405.59
! from the env. variable UM_LBC_COUP. GDR3F405.60
GDR3F405.61
call fort_get_env('UM_LBC_COUP',11,c_lbc_coup,8,icode) GDR3F405.62
if (icode.ne.0) then GDR3F405.63
um_lbc_coup = 0 ! No coupling GDR3F405.64
write (6,*) ' Env Var UM_LBC_COUP not set.' GDR3F405.65
write (6,*) ' Setting UM_LBC_COUP to ',um_lbc_coup GDR3F405.66
else GDR3F405.67
read(c_lbc_coup,'(i8)') um_lbc_coup GDR3F405.68
write (6,*) ' UM_LBC_COUP is set to ',UM_LBC_COUP GDR3F405.69
endif GDR3F405.70
if (um_lbc_coup.eq.0 .or. um_lbc_coup.eq.1) then GDR3F405.71
l_lbc_coup = um_lbc_coup.eq.1 GDR3F405.72
else GDR3F405.73
write (6,*) ' Invalid value given to UM_LBC_COUP ', GDR3F405.74
& UM_LBC_COUP GDR3F405.75
write (6,*) ' Valid values are 0 or 1' GDR3F405.76
write (6,*) ' L_LBC_COUP set to F. No LBC Coupling ', GDR3F405.77
& 'in this run.' GDR3F405.78
cmessage = 'U_MODEL : Invalid value given to UM_LBC_COUP' GDR3F405.79
icode = 100 GDR3F405.80
go to 999 ! Return GDR3F405.81
endif GDR3F405.82
GDR3F405.83
if (l_lbc_coup) then GDR3F405.84
write (6,*) ' LBC COUPLING switched on in this run.' GDR3F405.85
else GDR3F405.86
write (6,*) ' LBC COUPLING switched off in this run.' GDR3F405.87
endif GDR3F405.88
GDR3F405.89
if (l_lbc_coup) then GDR3F405.90
GDR3F405.91
*IF DEF,ATMOS,AND,DEF,GLOBAL GDR3F405.92
GDR3F405.93
! Find out which LBC output stream is providing the data GDR3F405.94
! from the env. variable UM_LBC_STREAM. GDR3F405.95
GDR3F405.96
call fort_get_env('UM_LBC_STREAM',13,c_lbc_coup,8,icode) GDR3F405.97
if (icode.ne.0) then GDR3F405.98
um_lbc_stream = 0 ! No coupling GDR3F405.99
write (6,*) ' gl : Env Var UM_LBC_STREAM not set.' GDR3F405.100
write (6,*) ' gl : Setting UM_LBC_STREAM to ',um_lbc_stream GDR3F405.101
else GDR3F405.102
read(c_lbc_coup,'(i8)') um_lbc_stream GDR3F405.103
write (6,*) ' gl : UM_LBC_STREAM is set to ',UM_LBC_STREAM GDR3F405.104
endif GDR3F405.105
GDR3F405.106
! Check validity of UM_LBC_STREAM GDR3F405.107
GDR3F405.108
if (um_lbc_stream.lt.1.or.um_lbc_stream.gt.max_n_intf_a) then GDR3F405.109
write (6,*) ' gl : UM_LBC_STREAM = ',UM_LBC_STREAM, GDR3F405.110
& ' is an invalid value.' GDR3F405.111
write (6,*) ' gl : Valid values are 1-',MAX_N_INTF_A GDR3F405.112
cmessage = 'U_MODEL : Invalid value given to UM_LBC_STREAM' GDR3F405.113
icode = 101 GDR3F405.114
go to 999 ! Return GDR3F405.115
endif GDR3F405.116
GDR3F405.117
! Check if this output stream is active. GDR3F405.118
l_active = .false. GDR3F405.119
do j=1,n_intf_a GDR3F405.120
l_active = l_active .or. um_lbc_stream.eq.lbc_stream_a(j) GDR3F405.121
enddo GDR3F405.122
if (.not.l_active) then GDR3F405.123
write (6,*) ' gl : Output LBC stream ',UM_LBC_STREAM, GDR3F405.124
& ' is inactive. Check UM_LBC_STREAM.' GDR3F405.125
write (6,*) ' gl : Active LBC streams are ', GDR3F405.126
& (LBC_STREAM_A(j),j=1,n_intf_a) GDR3F405.127
cmessage = 'U_MODEL : Output LBC stream is inactive.' GDR3F405.128
icode = 101 GDR3F405.129
go to 999 ! Return GDR3F405.130
endif GDR3F405.131
GDR3F405.132
GDR3F405.133
*ENDIF GDR3F405.134
*IF DEF,ATMOS,AND,-DEF,GLOBAL GDR3F405.135
GDR3F405.136
! Find out how long the mesoscale is to wait if there GDR3F405.137
! are insufficient boundary conditions to proceed. GDR3F405.138
GDR3F405.139
call fort_get_env('UM_LBC_WAIT',11,c_lbc_coup,8,icode) GDR3F405.140
if (icode.ne.0) then GDR3F405.141
um_lbc_wait = 0 ! No waiting GDR3F405.142
write (6,*) ' ms : Env Var UM_LBC_WAIT not set.' GDR3F405.143
write (6,*) ' ms : Setting UM_LBC_WAIT to ',um_lbc_wait GDR3F405.144
else GDR3F405.145
read(c_lbc_coup,'(i8)') um_lbc_wait GDR3F405.146
write (6,*) ' ms : UM_LBC_WAIT is set to ',um_lbc_wait GDR3F405.147
endif GDR3F405.148
GDR3F405.149
! Find out maximum wait if there are insufficient GDR3F405.150
! boundary conditions to proceed. GDR3F405.151
GDR3F405.152
call fort_get_env('UM_LBC_WAIT_MAX',15,c_lbc_coup,8,icode) GDR3F405.153
if (icode.ne.0) then GDR3F405.154
um_lbc_wait_max = 0 ! No waiting GDR3F405.155
write (6,*) ' ms : Env Var UM_LBC_WAIT_MAX not set.' GDR3F405.156
write (6,*) ' ms : Setting UM_LBC_WAIT_MAX to ', GDR3F405.157
& um_lbc_wait_max GDR3F405.158
else GDR3F405.159
read(c_lbc_coup,'(i8)') um_lbc_wait_max GDR3F405.160
write (6,*) ' ms : UM_LBC_WAIT_MAX is set to ',UM_LBC_WAIT_MAX GDR3F405.161
endif GDR3F405.162
*ENDIF GDR3F405.163
GDR3F405.164
endif ! if l_lbc_coup GDR3F405.165
GDR3F405.166
*IF DEF,ATMOS,AND,DEF,GLOBAL GDR3F405.167
GDR3F405.168
if (l_lbc_coup) then GDR3F405.169
GDR3F405.170
*IF DEF,MPP GDR3F405.171
if (mype.eq.0) then GDR3F405.172
*ENDIF GDR3F405.173
GDR3F405.174
! Get filename attached to Unit 190 GDR3F405.175
CALL GET_FILE(190,filename,80,ICODE) GDR3F405.176
GDR3F405.177
if (icode.ne.0) then GDR3F405.178
write (6,*) ' gl : Problem with GET_FILE', GDR3F405.179
& ' for Unit No 190.' GDR3F405.180
write (6,*) ' gl : Return code from GET_FILE ',icode GDR3F405.181
write (cmessage,*) GDR3F405.182
& 'U_MODEL : Error in GET_FILE for Unit No 190.' GDR3F405.183
icode = 102 GDR3F405.184
go to 123 GDR3F405.185
endif GDR3F405.186
GDR3F405.187
write (6,*) ' gl : Filename for unit no 190 ',FILENAME GDR3F405.188
GDR3F405.189
! Open the file with WRITE permission. GDR3F405.190
OPEN(unit=190,FILE=filename,action="write",iostat=icode) GDR3F405.191
GDR3F405.192
if (icode.ne.0) then GDR3F405.193
write (6,*) ' gl : Problem with OPEN for Unit 190.' GDR3F405.194
write (6,*) ' gl : Return code from OPEN ',icode GDR3F405.195
write (cmessage,*) GDR3F405.196
& 'U_MODEL : Problem with OPEN for Unit No 190.' GDR3F405.197
icode = 103 GDR3F405.198
go to 123 GDR3F405.199
endif GDR3F405.200
GDR3F405.201
write (6,*) ' gl : File(unit 190) has been opened.' GDR3F405.202
GDR3F405.203
! Send info to meso that L_LBC_COUP=T in Global. GDR3F405.204
GDR3F405.205
lbc_ntimes = 1000 + um_lbc_stream GDR3F405.206
write (190,*) lbc_ntimes GDR3F405.207
GDR3F405.208
call flush (190,icode) GDR3F405.209
GDR3F405.210
if (icode.ne.0) then GDR3F405.211
write (6,*) 'Return Code from FLUSH ',icode GDR3F405.212
icode = 104 GDR3F405.213
write (cmessage,*) 'U_MODEL : Error flushing out '// GDR3F405.214
& 'contents for Unit 190.' GDR3F405.215
go to 123 GDR3F405.216
endif GDR3F405.217
GDR3F405.218
write (6,*) ' gl : lbc_ntimes ', lbc_ntimes, GDR3F405.219
& ' sent to LBC_FILE.' GDR3F405.220
GDR3F405.221
! Unit 191 : File with information for operators to GDR3F405.222
! monitor progress with Boundary Conditions generated. GDR3F405.223
GDR3F405.224
! Get filename attached to Unit 191 GDR3F405.225
CALL GET_FILE(191,filename,80,ICODE) GDR3F405.226
GDR3F405.227
if (icode.ne.0) then GDR3F405.228
write (6,*) ' gl : Problem with GET_FILE for Unit 191.' GDR3F405.229
write (6,*) ' gl : Return code from GET_FILE ',icode GDR3F405.230
write (cmessage,*) GDR3F405.231
& 'U_MODEL : Error in GET_FILE for Unit No 191.' GDR3F405.232
icode = 105 GDR3F405.233
go to 123 GDR3F405.234
endif GDR3F405.235
GDR3F405.236
write (6,*) ' gl : Filename for unit no 191 ',FILENAME GDR3F405.237
GDR3F405.238
! Open the file with WRITE permission only. GDR3F405.239
OPEN(unit=191,FILE=filename,action="write",iostat=icode) GDR3F405.240
GDR3F405.241
if (icode.ne.0) then GDR3F405.242
write (6,*) ' gl : Problem with OPEN for Unit 191.' GDR3F405.243
write (6,*) ' gl : Return code from OPEN ',icode GDR3F405.244
write (cmessage,*) GDR3F405.245
& 'U_MODEL : Problem with OPEN for Unit No 191.' GDR3F405.246
icode = 106 GDR3F405.247
go to 123 GDR3F405.248
endif GDR3F405.249
GDR3F405.250
write (6,*) ' gl : File opened on unit 191.' GDR3F405.251
GDR3F405.252
! Send RUNID and date to file on unit 191 GDR3F405.253
call fort_get_env('RUNID',5,runid_char,5,icode) GDR3F405.254
if (icode.ne.0) then GDR3F405.255
write (6,*) ' Problem with FORT_GET_ENV for RUNID.' GDR3F405.256
write (cmessage,*) GDR3F405.257
& 'U_MODEL : Problem with FORT_GET_ENV for RUNID.' GDR3F405.258
icode = 107 GDR3F405.259
go to 123 GDR3F405.260
endif GDR3F405.261
GDR3F405.262
call fort_get_env('TYPE',4,runtype_char,5,icode) GDR3F405.263
if (icode.ne.0) then GDR3F405.264
write (6,*) ' Problem with FORT_GET_ENV for TYPE.' GDR3F405.265
write (cmessage,*) GDR3F405.266
& 'U_MODEL : Problem with FORT_GET_ENV for TYPE.' GDR3F405.267
icode = 108 GDR3F405.268
go to 123 GDR3F405.269
endif GDR3F405.270
GDR3F405.271
len_runid=GET_CHAR_LEN(runid_char) GDR3F405.272
call date_and_time(ch_date2, ch_time2) GDR3F405.273
write (191,*) ' RUNID : ',runid_char(1:len_runid), GDR3F405.274
& ' RUN TYPE : ',runtype_char(1:get_char_len(runtype_char)), GDR3F405.275
& ' on ',ch_date2(7:8),'/',ch_date2(5:6),'/',ch_date2(1:4) GDR3F405.276
GDR3F405.277
call flush (191,icode) GDR3F405.278
GDR3F405.279
if (icode.ne.0) then GDR3F405.280
write (6,*) 'Return Code from FLUSH ',icode GDR3F405.281
icode = 109 GDR3F405.282
write (cmessage,*) 'U_MODEL : Error flushing out '// GDR3F405.283
& 'contents for Unit 191.' GDR3F405.284
go to 123 GDR3F405.285
endif GDR3F405.286
GDR3F405.287
*IF DEF,MPP GDR3F405.288
endif ! if mype=0 GDR3F405.289
*ENDIF GDR3F405.290
123 continue GDR3F405.291
GDR3F405.292
*IF DEF,MPP GDR3F405.293
! Broadcast icode to all PEs GDR3F405.294
iostatus = icode GDR3F405.295
call gc_ibcast (458,1,0,nproc,info,iostatus) GDR3F405.296
icode = iostatus GDR3F405.297
*ENDIF GDR3F405.298
GDR3F405.299
! Check ICODE before proceeding. GDR3F405.300
if (icode.ne.0) then GDR3F405.301
write (6,*) ' U_MODEL - Error detected' GDR3F405.302
write (6,*) ' ICODE : ',ICODE GDR3F405.303
write (6,*) ' CMESSAGE : ',CMESSAGE GDR3F405.304
go to 999 ! Return GDR3F405.305
endif GDR3F405.306
GDR3F405.307
endif ! if l_lbc_coup GDR3F405.308
GDR3F405.309
*ENDIF GDR3F405.310
*IF DEF,ATMOS,AND,-DEF,GLOBAL GDR3F405.311
GDR3F405.312
if (l_lbc_coup) then GDR3F405.313
GDR3F405.314
*IF DEF,MPP GDR3F405.315
if (mype.eq.0) then GDR3F405.316
*ENDIF GDR3F405.317
GDR3F405.318
! Get filename attached to Unit 190 GDR3F405.319
CALL GET_FILE(190,lbc_filename,80,ICODE) GDR3F405.320
write (6,*) ' ms : Filename from GET_FILE ',lbc_filename GDR3F405.321
GDR3F405.322
if (icode.ne.0) then GDR3F405.323
write (6,*) ' Return code from GET_FILE ',icode GDR3F405.324
icode = 600 GDR3F405.325
write (cmessage,*) 'U_MODEL : Problem with GET_FILE '// GDR3F405.326
& 'for Unit No 190.' GDR3F405.327
go to 147 GDR3F405.328
endif GDR3F405.329
GDR3F405.330
call date_and_time(ch_date2, ch_time2) GDR3F405.331
GDR3F405.332
write(6,*) 'LBC_COUP: ', GDR3F405.333
& ch_time2(1:2),':',ch_time2(3:4),':',ch_time2(5:6),' on ', GDR3F405.334
& ch_date2(7:8),'/',ch_date2(5:6),'/',ch_date2(1:4), GDR3F405.335
& ' Wait to see if file exists.' GDR3F405.336
GDR3F405.337
len_wait_tot = 0 GDR3F405.338
149 continue GDR3F405.339
GDR3F405.340
! Check that the file exists. GDR3F405.341
INQUIRE (file=lbc_filename,exist=l_exist,iostat=icode) GDR3F405.342
GDR3F405.343
if (l_exist) then ! file exists GDR3F405.344
GDR3F405.345
call date_and_time(ch_date2, ch_time2) GDR3F405.346
write(6,*) 'LBC_COUP: ', GDR3F405.347
& ch_time2(1:2),':',ch_time2(3:4),':',ch_time2(5:6),' on ', GDR3F405.348
& ch_date2(7:8),'/',ch_date2(5:6),'/',ch_date2(1:4), GDR3F405.349
& ' File exists - Proceed to open file.' GDR3F405.350
GDR3F405.351
! Open the file with READ ONLY permission. GDR3F405.352
OPEN (unit=190,file=lbc_filename,action="read", GDR3F405.353
& iostat=icode) GDR3F405.354
GDR3F405.355
! Check return code from OPEN. GDR3F405.356
if (icode.ne.0) then GDR3F405.357
write (6,*) ' Return code from OPEN ',icode GDR3F405.358
icode = 601 GDR3F405.359
write (cmessage,*) 'U_MODEL : Problem with OPEN '// GDR3F405.360
& 'for Unit No 190.' GDR3F405.361
go to 147 GDR3F405.362
endif GDR3F405.363
GDR3F405.364
else ! file does not exist GDR3F405.365
GDR3F405.366
if (len_wait_tot.ge.um_lbc_wait_max) then GDR3F405.367
GDR3F405.368
! Maximum wait time has been reached/exceeded. GDR3F405.369
GDR3F405.370
write (6,*) ' ms : lbc_file does not exist.' GDR3F405.371
write (6,*) ' ms : Maximum wait time reached', GDR3F405.372
& ' after ',um_lbc_wait_max,' seconds.' GDR3F405.373
icode = 602 GDR3F405.374
cmessage = 'U_MODEL : LBC_FILE does not exist.' GDR3F405.375
go to 147 GDR3F405.376
GDR3F405.377
else GDR3F405.378
GDR3F405.379
! Wait for um_lbc_wait seconds before another attempt GDR3F405.380
! to see if file exists. GDR3F405.381
GDR3F405.382
write (6,*) ' ms : lbc_file does not exist yet.' GDR3F405.383
write (6,*) ' ms : wait for ',um_lbc_wait, GDR3F405.384
& ' seconds and retry.' GDR3F405.385
isleep = sleep(um_lbc_wait) GDR3F405.386
len_wait_tot = len_wait_tot+um_lbc_wait GDR3F405.387
write (6,*) ' ms : Total Wait so far ',len_wait_tot, GDR3F405.388
& ' seconds.' GDR3F405.389
go to 149 ! Retry to see if LBC_FILE exists GDR3F405.390
GDR3F405.391
endif GDR3F405.392
GDR3F405.393
endif ! if l_exist GDR3F405.394
GDR3F405.395
*IF DEF,MPP GDR3F405.396
endif ! if mype=0 GDR3F405.397
*ENDIF GDR3F405.398
GDR3F405.399
147 continue GDR3F405.400
GDR3F405.401
*IF DEF,MPP GDR3F405.402
! Broadcast ICODE to all PEs GDR3F405.403
iostatus = icode GDR3F405.404
call gc_ibcast (458,1,0,nproc,info,iostatus) GDR3F405.405
icode = iostatus GDR3F405.406
*ENDIF GDR3F405.407
GDR3F405.408
! Check on ICODE before proceeding. GDR3F405.409
if (icode.ne.0) then GDR3F405.410
write (6,*) ' U_MODEL - Error detected.' GDR3F405.411
write (6,*) ' ICODE : ',ICODE GDR3F405.412
write (6,*) ' CMESSAGE : ',CMESSAGE GDR3F405.413
go to 999 ! Return GDR3F405.414
endif GDR3F405.415
GDR3F405.416
! Check that LBC_COUPLING has been switched on in Global. GDR3F405.417
*IF DEF,MPP GDR3F405.418
if (mype.eq.0) then GDR3F405.419
*ENDIF GDR3F405.420
GDR3F405.421
len_wait_tot = 0 GDR3F405.422
150 continue GDR3F405.423
GDR3F405.424
! Close the communication file and re-open GDR3F405.425
close(190) GDR3F405.426
open (190,file=lbc_filename,action="read",iostat=icode) GDR3F405.427
GDR3F405.428
! Check retrun code from OPEN GDR3F405.429
if (icode.ne.0) then GDR3F405.430
write (6,*) ' Return code from OPEN ',icode GDR3F405.431
icode = 603 GDR3F405.432
write (cmessage,*) 'U_MODEL : Problem with OPEN '// GDR3F405.433
& 'for Unit No 190.' GDR3F405.434
go to 148 GDR3F405.435
endif GDR3F405.436
GDR3F405.437
! Read in the first value GDR3F405.438
read (190,*,iostat=icode) lbc_ntimes GDR3F405.439
GDR3F405.440
! Check return code from READ GDR3F405.441
if (icode.ne.0) then GDR3F405.442
GDR3F405.443
write (6,*) ' ms : Return code from READ ',icode GDR3F405.444
GDR3F405.445
if (len_wait_tot.ge.um_lbc_wait_max) then GDR3F405.446
GDR3F405.447
! Maximum wait time has been reached or exceeded. GDR3F405.448
! Give up waiting and abort. GDR3F405.449
GDR3F405.450
write (6,*) ' ms : Required LBC_NTIMES not read in', GDR3F405.451
& ' after ',um_lbc_wait_max,' seconds.' GDR3F405.452
icode = 604 GDR3F405.453
cmessage = 'U_MODEL : Required LBC_NTIMES '// GDR3F405.454
& 'not found in LBC_FILE.' GDR3F405.455
go to 148 GDR3F405.456
GDR3F405.457
else GDR3F405.458
GDR3F405.459
! Wait for um_lbc_wait seconds abefore another attempt GDR3F405.460
! to read a value. GDR3F405.461
GDR3F405.462
write (6,*) ' ms : wait for ',um_lbc_wait, GDR3F405.463
& ' seconds and retry.' GDR3F405.464
isleep = sleep(um_lbc_wait) GDR3F405.465
len_wait_tot = len_wait_tot+um_lbc_wait GDR3F405.466
write (6,*) ' ms : Total Wait so far ',len_wait_tot, GDR3F405.467
& ' seconds.' GDR3F405.468
go to 150 ! Retry to see if required LBC_NTIMES exists GDR3F405.469
GDR3F405.470
endif GDR3F405.471
GDR3F405.472
endif ! if icode.ne.0 GDR3F405.473
GDR3F405.474
! The first value in the file is >1000. GDR3F405.475
if (lbc_ntimes.gt.1000) then GDR3F405.476
write (6,*) ' ms : l_lbc_coup = T in Global' GDR3F405.477
um_lbc_stream = lbc_ntimes - 1000 GDR3F405.478
write (6,*) ' ms : global output stream is ',um_lbc_stream GDR3F405.479
endif ! if l_lbc_ntimes GDR3F405.480
GDR3F405.481
*IF DEF,MPP GDR3F405.482
endif ! if mype=0 GDR3F405.483
*ENDIF GDR3F405.484
GDR3F405.485
148 continue GDR3F405.486
GDR3F405.487
*IF DEF,MPP GDR3F405.488
! Broadcast ICODE to all PEs GDR3F405.489
iostatus = icode GDR3F405.490
call gc_ibcast (458,1,0,nproc,info,iostatus) GDR3F405.491
icode = iostatus GDR3F405.492
*ENDIF GDR3F405.493
GDR3F405.494
! Check ICODE before proceeding. GDR3F405.495
if (icode.ne.0) then GDR3F405.496
write (6,*) ' U_MODEL - Error detected.' GDR3F405.497
write (6,*) ' ICODE : ',ICODE GDR3F405.498
write (6,*) ' CMESSAGE : ',CMESSAGE GDR3F405.499
go to 999 ! Return GDR3F405.500
endif GDR3F405.501
GDR3F405.502
endif ! if l_lbc_coup GDR3F405.503
GDR3F405.504
*ENDIF GDR3F405.505
GDR3F405.506
*IF DEF,T3E GBC6F404.321
c GBC6F404.322
c--find the start address of spd1 GBC6F404.323
i=loc(spd1(ixd1(2))) GBC6F404.324
c--find the offset to the nearest SCACHE line boundary upwards GBC6F404.325
j=((i+63)/64)*64-i GBC6F404.326
c--compute the offset to be added to the index values GBC6F404.327
j=j/8 GBC6F404.328
c GBC6F404.329
c--add this offset on to the current addresses GBC6F404.330
do k=1, ixd1_len GBC6F404.331
ixd1(k)=ixd1(k)+j GBC6F404.332
end do GBC6F404.333
c GBC6F404.334
*IF DEF,DIAG92 GBC6F404.335
*IF DEF,MPP GBC6F404.336
if(mype.eq.0) then GBC6F404.337
*ENDIF GBC6F404.338
write(0,'(4z17)') (loc(spd1(ixd1(i))), i=1,4) GBC6F404.339
*IF DEF,MPP GBC6F404.340
endif GBC6F404.341
*ENDIF GBC6F404.342
*ENDIF GBC6F404.343
*ENDIF GBC6F404.344
GSS1F305.907
! Routine GETPPX_PART reads those ppxref records which correspond to GSS1F305.908
! entries in the stash list into the ppx look-up arrays PPXI, PPXC. GSS1F305.909
! It also sets the ppx pointer array PPXPTR. The lengths of PPXI, PPXC GSS1F305.910
! have been dynamically allocated to the value of ppxRecs. GSS1F305.911
GSS1F305.912
! Initialise row number in PPXI, PPXC arrays GSS2F401.497
RowNumber = 1 GSS2F401.498
GSS2F401.499
! Initialise lookup and pointer array GSS2F401.500
DO I=1,ppxRecs GSS2F401.501
DO J=1,PPXREF_CODELEN GSS2F401.502
PPXI(I,J)=0 GSS2F401.503
END DO GSS2F401.504
DO J=1,PPXREF_CHARLEN GSS2F401.505
PPXC(I,J) = ' ' GSS2F401.506
END DO GSS2F401.507
END DO GSS2F401.508
*IF DEF,RECON GSS2F401.509
DO I = 1,N_INTERNAL_MODEL_MAX GSS2F401.510
*ELSE GSS2F401.511
DO I = 1,N_INTERNAL_MODEL GSS2F401.512
*ENDIF GSS2F401.513
DO J = 0,PPXREF_SECTIONS GSS2F401.514
DO K = 1,PPXREF_ITEMS GSS2F401.515
PPXPTR(I,J,K)=0 GSS2F401.516
END DO GSS2F401.517
END DO GSS2F401.518
END DO GSS2F401.519
GSS2F401.520
! Read in STASHmaster records GSS2F401.521
IF (INTERNAL_MODEL_INDEX(A_IM).GT.0) THEN GSS2F401.522
CALL GETPPX_PART(NFT,NFTU,'STASHmaster_A',A_IM,RowNumber, GSS2F401.523
*CALL ARGPPX GSS1F305.914
& ICODE,CMESSAGE) GSS1F305.915
END IF GSS2F401.524
IF (INTERNAL_MODEL_INDEX(O_IM).GT.0) THEN GSS2F401.525
CALL GETPPX_PART(NFT,NFTU,'STASHmaster_O',O_IM,RowNumber, GSS2F401.526
*CALL ARGPPX GSS2F401.527
& ICODE,CMESSAGE) GSS2F401.528
END IF GSS2F401.529
IF (INTERNAL_MODEL_INDEX(S_IM).GT.0) THEN GSS2F401.530
CALL GETPPX_PART(NFT,NFTU,'STASHmaster_S',S_IM,RowNumber, GSS2F401.531
*CALL ARGPPX GSS2F401.532
& ICODE,CMESSAGE) GSS2F401.533
END IF GSS2F401.534
IF (INTERNAL_MODEL_INDEX(W_IM).GT.0) THEN GSS2F401.535
CALL GETPPX_PART(NFT,NFTU,'STASHmaster_W',W_IM,RowNumber, GSS2F401.536
*CALL ARGPPX GSS2F401.537
& ICODE,CMESSAGE) GSS2F401.538
END IF GSS2F401.539
GSS2F401.540
GSS2F401.541
IF (ICODE.GT.0) GOTO 999 GSS1F400.989
GSS1F305.916
CL---------------------------------------------------------------------- U_MODEL1.74
CL 1. General initialisation of control and physical data blocks U_MODEL1.75
CL U_MODEL1.76
ICODE=0 U_MODEL1.77
CALL INITIAL( @DYALLOC.3660
*CALL ARGPPX GSS1F305.917
*CALL ARGSZSP @DYALLOC.3661
*CALL ARGSZSPA @DYALLOC.3662
*CALL ARGSZSPO @DYALLOC.3663
*CALL ARGSZSPW WRB1F401.1146
*CALL ARGSZSPC @DYALLOC.3664
*CALL ARGSP @DYALLOC.3665
*CALL ARGSPA @DYALLOC.3666
*CALL ARGSPO @DYALLOC.3667
*CALL ARGSPW WRB1F401.1147
*CALL ARGSPC @DYALLOC.3668
*CALL ARGSIZE @DYALLOC.3669
* internal_model,submodel,NGROUP,MEANLEV, GRR2F305.615
* ICODE,CMESSAGE) GRR2F305.616
IF (ICODE.GT.0) GOTO 999 U_MODEL1.79
CL---------------------------------------------------------------------- U_MODEL1.80
CL 2. Check for nothing-to-do U_MODEL1.81
CL U_MODEL1.82
IF (LTIMER) CALL TIMER('EXITCHEK',3) U_MODEL1.83
CALL EXITCHEK( internal_model, LEXITNOW) GKR7F403.13
IF (LTIMER) CALL TIMER('EXITCHEK',4) U_MODEL1.85
IF (LEXITNOW) GOTO 999 U_MODEL1.86
CL---------------------------------------------------------------------- U_MODEL1.87
CL 3. Start group of timesteps U_MODEL1.88
CL U_MODEL1.89
1 CONTINUE U_MODEL1.90
CL---------------------------------------------------------------------- U_MODEL1.91
CL 3.1. Start main timestep loop U_MODEL1.92
CL U_MODEL1.93
*IF DEF,ATMOS U_MODEL1.94
*IF DEF,OCEAN,OR,DEF,SLAB U_MODEL1.95
DO I_STEP=1,NGROUP U_MODEL1.96
*ENDIF U_MODEL1.97
*ENDIF U_MODEL1.98
CL 3.1.1 Increment model time .. U_MODEL1.99
IF (LTIMER) CALL TIMER('INCRTIME',3) U_MODEL1.100
CALL INCRTIME ( @DYALLOC.3671
*CALL ARGSIZE @DYALLOC.3672
*CALL ARTDUMA @DYALLOC.3673
*CALL ARTDUMO @DYALLOC.3674
*CALL ARTDUMW WRB1F401.1148
& internal_model,ICODE,CMESSAGE) GRR2F305.617
IF (LTIMER) CALL TIMER('INCRTIME',4) U_MODEL1.102
CL 3.1.2 .. set timestep control switches U_MODEL1.103
IF (LTIMER) CALL TIMER('SETTSCTL',3) U_MODEL1.104
CALL SETTSCTL ( @DYALLOC.3676
*CALL ARGSIZE @DYALLOC.3677
*CALL ARTDUMA @DYALLOC.3678
*CALL ARTDUMO @DYALLOC.3679
*CALL ARTDUMW WRB1F401.1149
*CALL ARTSTS @DYALLOC.3680
*CALL ARTINFA @DYALLOC.3681
*CALL ARTINFO @DYALLOC.3682
*CALL ARTINFW WRB1F401.1150
& internal_model,.FALSE.,MEANLEV,ICODE,CMESSAGE) GRR2F305.618
IF (LTIMER) CALL TIMER('SETTSCTL',4) U_MODEL1.106
IF (ICODE.GT.0) GOTO 999 U_MODEL1.107
CL 3.1.3 If PPfile initialisation time call PP control routine U_MODEL1.108
CL for instantaneous data (MEANLEV=0) U_MODEL1.109
IF (LPP) THEN U_MODEL1.110
IF (LTIMER) CALL TIMER('PPCTL ',3) U_MODEL1.111
MEANLEV=0 U_MODEL1.112
CALL PPCTL( @DYALLOC.3684
*CALL ARGSIZE @DYALLOC.3685
*CALL ARTD1 @DYALLOC.3686
*CALL ARTDUMA @DYALLOC.3687
*CALL ARTDUMO @DYALLOC.3688
*CALL ARTDUMW WRB1F401.1151
*CALL ARTINFA @DYALLOC.3689
*CALL ARTINFO GMB1F405.415
*CALL ARGPPX GMB1F405.416
& internal_model,MEANLEV,.FALSE.,PPNAME,ICODE,CMESSAGE) GRR2F305.619
IF (LTIMER) CALL TIMER('PPCTL ',4) U_MODEL1.114
IF (ICODE.GT.0) GOTO 999 U_MODEL1.115
ENDIF U_MODEL1.116
CJC1F404.1
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! CJC1F404.2
! call the oasis coupler before the dump. CJC1F404.3
*IF DEF,OASIS CJC1F404.4
*IF DEF,MPP CJC1F404.5
! Synchronize before the timestep starts CJC1F404.6
CALL GC_GSYNC(nproc,info) CJC1F404.7
*ENDIF CJC1F404.8
*IF DEF,MPP CJC1F404.9
! Get 'global' atmos and ocean horizontal domain sizes from database CJC1F404.10
! in DECOMPDB to set dynamic allocation in SWAP_A2O,SWAP_O2A. CJC1F404.11
*IF DEF,ATMOS CJC1F404.12
G_P_FIELD= decomp_db_glsize(1,decomp_standard_atmos) * CJC1F404.13
& decomp_db_glsize(2,decomp_standard_atmos) CJC1F404.14
*ENDIF CJC1F404.15
*IF DEF,OCEAN CJC1F404.16
CC G_IMTJMT = decomp_db_glsize(1,decomp_standard_ocean) * CJC1F404.17
CC & (decomp_db_glsize(2,decomp_standard_ocean)+1) CJC1F404.18
G_IMTJMT = decomp_db_glsize(1,decomp_standard_ocean) * CJC1F404.19
& (decomp_db_glsize(2,decomp_standard_ocean)) CJC1F404.20
*ENDIF CJC1F404.21
*ELSE CJC1F404.22
! Sizes not used for non-MPP: dummy values only CJC1F404.23
*IF DEF,ATMOS CJC1F404.24
G_P_FIELD= P_FIELD CJC1F404.25
*ENDIF CJC1F404.26
*IF DEF,OCEAN CJC1F404.27
G_IMTJMT = IMT*JMT CJC1F404.28
*ENDIF CJC1F404.29
*ENDIF CJC1F404.30
ICODE=0 CJC1F404.31
CALL OASIS_STEP( CJC1F404.32
*IF DEF,ATMOS CJC1F404.33
& G_P_FIELD, CJC1F404.34
*ENDIF CJC1F404.35
*IF DEF,OCEAN CJC1F404.36
& G_IMTJMT, CJC1F404.37
*ENDIF CJC1F404.38
*CALL ARGSIZE CJC1F404.39
*CALL ARTD1 CJC1F404.40
*CALL ARTSTS CJC1F404.41
*CALL ARTDUMA CJC1F404.42
*CALL ARTDUMO CJC1F404.43
*CALL ARTPTRA CJC1F404.44
*CALL ARTPTRO CJC1F404.45
*CALL ARTCONA CJC1F404.46
*CALL ARTCONO CJC1F404.47
& internal_model, CJC1F404.48
& ICODE,CMESSAGE) CJC1F404.49
IF (ICODE.GT.0) GOTO 999 CJC1F404.50
*ENDIF CJC1F404.51
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! CJC1F404.52
CL Integrate atmosphere or ocean by 1 timestep U_MODEL1.117
*IF DEF,ATMOS U_MODEL1.118
IF (internal_model.EQ.atmos_im) THEN GRR2F305.620
IF (LTIMER) CALL TIMER('ATM_STEP',3) U_MODEL1.120
CC (DYNAMIC ALLOCATION) OCEAN COMDECKS NEEDED BECAUSE OF STASH STRUCTURE @DYALLOC.3691
CJC1F404.53
GPB5F403.90
*IF DEF,MPP GPB5F403.91
! Synchronize before the timestep starts GPB5F403.92
CALL GC_GSYNC(nproc,info) GPB1F404.90
*ENDIF GPB5F403.94
GPB5F403.95
CALL ATM_STEP ( @DYALLOC.3692
*CALL ARGSZSP @DYALLOC.3693
*CALL ARGSZSPA @DYALLOC.3694
*CALL ARGSZSPO @DYALLOC.3695
*CALL ARGSP @DYALLOC.3696
*CALL ARGSPA @DYALLOC.3697
*CALL ARGSPO @DYALLOC.3698
*CALL ARGSIZE @DYALLOC.3699
*CALL ARGCNVI RB300993.150
*CALL ARGPPX GSS1F305.918
*IF DEF,FRADIO GGH3F401.44
& RADINCS, @DYALLOC.3701
*ENDIF @DYALLOC.3702
& P_FIELD, ! for dynamic array NF171193.10
& ICODE,CMESSAGE) @DYALLOC.3703
IF (LTIMER) CALL TIMER('ATM_STEP',4) U_MODEL1.122
ENDIF U_MODEL1.123
*ENDIF U_MODEL1.124
*IF DEF,OCEAN U_MODEL1.127
IF (internal_model.EQ.ocean_im) THEN GRR2F305.621
IF (LTIMER) CALL TIMER('OCN_STEP',3) U_MODEL1.128
CL (DYNAMIC ALLOCATION) ATMOS COMDECKs needed because of STASH structure @DYALLOC.3704
CL @DYALLOC.3705
GPB5F403.96
*IF DEF,MPP GPB5F403.97
! Synchronize before the timestep starts GPB5F403.98
CALL GC_GSYNC(nproc,info) GPB1F404.91
*ENDIF GPB5F403.100
CALL OCN_STEP( @DYALLOC.3706
*CALL ARGSIZE @DYALLOC.3707
*CALL ARTDUMA @DYALLOC.3708
*CALL ARTDUMO @DYALLOC.3709
*CALL ARTDUMW GKR1F401.280
*CALL ARTD1 @DYALLOC.3710
*CALL ARTPTRA @DYALLOC.3711
*CALL ARTPTRO @DYALLOC.3712
*CALL ARTSTS @DYALLOC.3713
*CALL ARTCONA @DYALLOC.3714
*CALL ARTCONO @DYALLOC.3715
*CALL ARTBND SI180893.27
*CALL ARGPPX GKR0F305.1008
& ICODE,CMESSAGE) @DYALLOC.3716
IF (LTIMER) CALL TIMER('OCN_STEP',4) U_MODEL1.130
ENDIF TJ061293.11
*ENDIF U_MODEL1.131
*IF DEF,SLAB U_MODEL1.132
IF (internal_model.EQ.slab_im) THEN GRR2F305.622
IF (LTIMER) CALL TIMER('SLABSTEP',3) U_MODEL1.133
CL (DYNAMIC ALLOCATION) ????? COMDECKs needed because of STASH structure SCH0F405.28
CL SCH0F405.29
SCH0F405.30
*IF DEF,MPP SCH0F405.31
! Synchronize before the timestep starts SCH0F405.32
CALL GC_GSYNC(nproc,info) SCH0F405.33
*ENDIF SCH0F405.34
CALL SLABSTEP( @DYALLOC.3717
*CALL ARGSIZE @DYALLOC.3718
*CALL ARTD1 @DYALLOC.3719
*CALL ARTDUMA TJ061293.13
*CALL ARTDUMO TJ061293.14
*CALL ARTDUMW GKR1F401.281
*CALL ARTSTS TJ061293.15
*CALL ARTPTRA @DYALLOC.3720
*CALL ARTPTRO TJ061293.16
*CALL ARTCONA @DYALLOC.3722
*CALL ARGPPX GKR0F305.1009
* ICODE,CMESSAGE) @DYALLOC.3723
IF (LTIMER) CALL TIMER('SLABSTEP',4) U_MODEL1.135
ENDIF U_MODEL1.137
*ENDIF U_MODEL1.138
*IF DEF,WAVE WRB1F401.1152
IF (internal_model.EQ.wave_im) THEN WRB1F401.1153
IF (LTIMER) CALL TIMER('WAV_STEP',3) WRB1F401.1154
CALL WAV_STEP( WRB1F401.1155
*CALL ARGSIZE WRB1F401.1156
*CALL ARTD1 WRB1F401.1157
*CALL ARTDUMW WRB1F401.1158
*CALL ARTSTS WRB1F401.1159
*CALL ARTPTRW WRB1F401.1160
*CALL ARTCONW WRB1F401.1161
*CALL ARGPPX WRB1F401.1162
* ICODE,CMESSAGE) WRB1F401.1163
IF (LTIMER) CALL TIMER('WAV_STEP',4) WRB1F401.1164
ENDIF WRB1F401.1165
*ENDIF WRB1F401.1166
IF (ICODE.GT.0) GOTO 999 U_MODEL1.139
CL 3.1.4 If dump time, call dump control routine U_MODEL1.140
IF (LDUMP) THEN U_MODEL1.141
IF (LTIMER) THEN GPB1F401.35
CALL TIMER('DUMPCTL',5) GPB1F401.36
CALL TIMER('DUMPCTL ',3) GPB1F401.37
ENDIF GPB1F401.38
CALL DUMPCTL ( @DYALLOC.3725
*CALL ARGSIZE @DYALLOC.3726
*CALL ARTD1 @DYALLOC.3727
*CALL ARTDUMA @DYALLOC.3728
*CALL ARTDUMO @DYALLOC.3729
*CALL ARTDUMW WRB1F401.1167
*CALL ARTCONA @DYALLOC.3730
*CALL ARTPTRA @DYALLOC.3731
*CALL ARTSTS @DYALLOC.3732
*CALL ARGPPX GDG0F401.1475
& submodel,MEANLEV,.false.,' ',0, GKR4F403.32
& ICODE,CMESSAGE) GKR4F403.33
GKR4F403.34
IF (LTIMER) THEN GPB1F401.39
CALL TIMER('DUMPCTL',4) GPB1F401.40
CALL TIMER('DUMPCTL ',6) GPB1F401.41
ENDIF GPB1F401.42
IF (ICODE.GT.0) GOTO 999 U_MODEL1.145
CL 3.1.4.1 Update interim history file unless means are to follow U_MODEL1.146
IF (LTIMER) CALL TIMER('TEMPHIST',3) U_MODEL1.147
IF (.NOT.LMEAN) THEN U_MODEL1.148
IF (.NOT. (N_SUBMODEL_PARTITION .GT.1 .AND. submodel GKR2F405.15
& .ne. SUBMODEL_PARTITION_LIST(N_SUBMODEL_PARTITION) .AND. GKR2F405.16
& steps_per_periodim(submodel) .NE. GKR2F405.17
& dumpfreqim(submodel) )) THEN GKR2F405.18
CALL SET_HISTORY_VALUES GRR2F305.626
*IF DEF,MPP ARB1F402.793
CALL GC_SSYNC(nproc,info) ARB1F402.794
IF (MYPE .eq. 0) THEN ARB1F402.795
*ENDIF ARB1F402.796
CALL TEMPHIST(PHIST_UNIT,ICODE,CMESSAGE) U_MODEL1.150
*IF DEF,MPP ARB1F402.797
ENDIF U_MODEL1.151
*ENDIF ARB1F402.798
ENDIF GJC0F405.39
ENDIF ARB1F402.799
IF (LTIMER) CALL TIMER('TEMPHIST',4) U_MODEL1.152
IF (ICODE.GT.0) GOTO 999 U_MODEL1.153
*IF DEF,ATMOS U_MODEL1.154
CL 3.1.4.2 If atmosphere timestep recalculate prognostic data and U_MODEL1.155
CL wrap-around fields using rounded off values U_MODEL1.156
IF (submodel.EQ.atmos_sm) THEN GRR2F305.624
IF (LTIMER) CALL TIMER('RESETATM',3) U_MODEL1.158
CALL RESETATM ( @DYALLOC.3734
*CALL ARGSZSP @DYALLOC.3735
*CALL ARGSZSPA @DYALLOC.3736
*CALL ARGSP @DYALLOC.3737
*CALL ARGSPA @DYALLOC.3738
*CALL ARGSIZE @DYALLOC.3739
& ICODE,CMESSAGE) @DYALLOC.3740
IF (LTIMER) CALL TIMER('RESETATM',4) U_MODEL1.160
IF (ICODE.GT.0) GOTO 999 TJ230793.4
ENDIF TJ230793.5
*ENDIF TJ230793.6
*IF DEF,OCEAN TJ230793.7
CL 3.1.4.3 If ocean timestep copy second timelevel prognostic data TJ230793.8
CL from rounded off values TJ230793.9
IF (internal_model.EQ.ocean_im) THEN GRR2F305.625
IF (LTIMER) CALL TIMER('RESETOCN',3) TJ230793.11
CALL RESETOCN( TJ230793.12
*CALL ARGSIZE TJ230793.13
*CALL ARTD1 TJ230793.14
*CALL ARTPTRO TJ230793.15
& ICODE,CMESSAGE) TJ230793.16
IF (LTIMER) CALL TIMER('RESETOCN',4) TJ230793.17
IF (ICODE.GT.0) GOTO 999 U_MODEL1.161
ENDIF U_MODEL1.162
*ENDIF U_MODEL1.163
ENDIF U_MODEL1.164
CL 3.1.5 If printed output time, call print control routine U_MODEL1.165
IF (LPRINT) THEN U_MODEL1.166
IF (LTIMER) CALL TIMER('PRINTCTL',3) U_MODEL1.167
CALL PRINTCTL( GRR2F305.627
*CALL ARGSIZE GRR2F305.628
*CALL ARTD1 GRR2F305.629
*CALL ARTDUMA GRR2F305.630
*CALL ARTPTRA GRR2F305.631
*CALL ARTCONA GRR2F305.632
& submodel,MEANLEV,ICODE,CMESSAGE) GRR2F305.633
IF (LTIMER) CALL TIMER('PRINTCTL',4) U_MODEL1.169
IF (ICODE.GT.0) GOTO 999 U_MODEL1.170
ENDIF U_MODEL1.171
CL 3.1.6 If interface generation time, generate interface fields U_MODEL1.172
IF (internal_model.EQ.ocean_im) THEN GRR2F305.634
U_MODEL1.174
IF (LINTERFACE) THEN U_MODEL1.175
IF (LTIMER) CALL TIMER('GEN_INTF',3) U_MODEL1.176
CALL GEN_INTF ( @DYALLOC.3741
*CALL ARGSIZE @DYALLOC.3742
*CALL ARTD1 @DYALLOC.3743
*CALL ARTDUMA @DYALLOC.3744
*CALL ARTSTS @DYALLOC.3745
*CALL ARTPTRA @DYALLOC.3746
*CALL ARTCONA @DYALLOC.3747
*CALL ARTINFA @DYALLOC.3748
*CALL ARTPTRO GMB1F405.417
*CALL ARTCONO GMB1F405.418
*CALL ARTDUMO GMB1F405.419
*CALL ARTINFO GMB1F405.420
*CALL ARGPPX GMB1F405.421
& submodel,ICODE,CMESSAGE) GRR2F305.635
IF (LTIMER) CALL TIMER('GEN_INTF',4) U_MODEL1.178
IF (ICODE.GT.0) GOTO 999 U_MODEL1.179
ENDIF U_MODEL1.180
U_MODEL1.181
END IF U_MODEL1.182
CL 3.1.6.1 Release job to process output created so far, if selected U_MODEL1.183
IF (LJOBRELEASE) THEN U_MODEL1.184
IF (LTIMER) CALL TIMER('JOBCTL ',3) U_MODEL1.185
CALL JOBCTL(internal_model,ICODE,CMESSAGE) GRR2F305.636
IF (LTIMER) CALL TIMER('JOBCTL ',4) U_MODEL1.187
IF (ICODE.GT.0) GOTO 999 U_MODEL1.188
ENDIF U_MODEL1.189
CL 3.1.7 If partial sum/mean creation time, call means control routine U_MODEL1.190
CL (calls mean PPfield and diagnostic print routines internally) U_MODEL1.191
IF (LMEAN) THEN U_MODEL1.192
IF (LTIMER) CALL TIMER('MEANCTL ',3) U_MODEL1.193
CALL MEANCTL ( @DYALLOC.3750
*CALL ARGSIZE @DYALLOC.3751
*CALL ARTD1 @DYALLOC.3752
*CALL ARTDUMA @DYALLOC.3753
*CALL ARTDUMO @DYALLOC.3754
*CALL ARTDUMW GKR1F401.282
*CALL ARTPTRA @DYALLOC.3755
*CALL ARTPTRO @DYALLOC.3756
*CALL ARTSTS @DYALLOC.3757
*CALL ARTCONA @DYALLOC.3758
*CALL ARTINFA @DYALLOC.3759
*CALL ARTINFO GMB1F405.422
*CALL ARGPPX GKR0F305.1010
& submodel,MEANLEV,ICODE,CMESSAGE) GRR2F305.637
IF (LTIMER) CALL TIMER('MEANCTL ',4) U_MODEL1.195
IF (ICODE.GT.0) THEN U_MODEL1.196
CALL DEL_HIST(PHIST_UNIT) U_MODEL1.197
WRITE(6,*)'U_MODEL: interim history file deleted due to failu GIE0F403.666
&re writing partial sum files' U_MODEL1.199
GOTO 999 U_MODEL1.200
ENDIF U_MODEL1.201
CL 3.1.7.1 On successful completion, update interim history file U_MODEL1.202
IF (LTIMER) CALL TIMER('TEMPHIST',3) U_MODEL1.203
GKR1F404.267
IF (.NOT. (N_SUBMODEL_PARTITION .GT.1 .AND. submodel GKR2F405.19
& .ne. SUBMODEL_PARTITION_LIST(N_SUBMODEL_PARTITION) .AND. GKR2F405.20
& steps_per_periodim(submodel) .NE. GKR2F405.21
& dumpfreqim(submodel) )) THEN GKR2F405.22
GKR1F404.271
CALL SET_HISTORY_VALUES GRR2F305.638
*IF DEF,MPP ARB1F402.800
CALL GC_SSYNC(nproc,info) ARB1F402.801
IF (MYPE .eq. 0) THEN ARB1F402.802
*ENDIF ARB1F402.803
CALL TEMPHIST(PHIST_UNIT,ICODE,CMESSAGE) U_MODEL1.205
*IF DEF,MPP ARB1F402.804
ENDIF ARB1F402.805
*ENDIF ARB1F402.806
IF (ICODE.GT.0) GOTO 999 U_MODEL1.207
ENDIF GJC0F405.40
IF (LTIMER) CALL TIMER('TEMPHIST',4) GRH0F405.1
ENDIF U_MODEL1.208
CL 3.1.8 Update temporary history file if at a 'safe' restart point U_MODEL1.209
IF (LTIMER) CALL TIMER('TEMPHIST',3) U_MODEL1.210
IF (LHISTORY) THEN U_MODEL1.211
! In coupled model do not update history file until both GKR1F404.273
! submodels have reached the safe restart point GKR1F404.274
GKR1F404.275
IF (.NOT. (N_SUBMODEL_PARTITION .GT.1 .AND. submodel GKR2F405.23
& .ne. SUBMODEL_PARTITION_LIST(N_SUBMODEL_PARTITION) .AND. GKR2F405.24
& steps_per_periodim(submodel) .NE. GKR2F405.25
& dumpfreqim(submodel) )) THEN GKR2F405.26
CALL SET_HISTORY_VALUES GRR2F305.639
*IF DEF,MPP ARB1F402.807
CALL GC_SSYNC(nproc,info) ARB1F402.808
IF (MYPE .eq. 0) THEN ARB1F402.809
*ENDIF ARB1F402.810
CALL TEMPHIST(THIST_UNIT,ICODE,CMESSAGE) U_MODEL1.213
*IF DEF,MPP ARB1F402.811
ENDIF U_MODEL1.214
*ENDIF ARB1F402.812
ENDIF GJC0F405.41
ENDIF ARB1F402.813
IF (LTIMER) CALL TIMER('TEMPHIST',4) U_MODEL1.215
IF (ICODE.GT.0) GOTO 999 U_MODEL1.216
CL 3.1.9 If exit check time, check for immediate exit U_MODEL1.217
IF (LEXIT) THEN U_MODEL1.218
IF (LTIMER) CALL TIMER('EXITCHEK',3) U_MODEL1.219
CALL EXITCHEK(internal_model, LEXITNOW) GKR7F403.14
IF (LTIMER) CALL TIMER('EXITCHEK',4) U_MODEL1.221
IF (LEXITNOW) THEN GGH5F401.1
IF (.NOT.LDUMP) THEN GGH5F401.2
GKR1F404.280
IF (.NOT. (N_SUBMODEL_PARTITION .GT.1 .AND. submodel GKR2F405.27
& .ne. SUBMODEL_PARTITION_LIST(N_SUBMODEL_PARTITION).AND. GKR2F405.28
& steps_per_periodim(submodel) .NE. GKR2F405.29
& dumpfreqim(submodel) )) THEN GKR2F405.30
GKR1F404.284
CALL SET_HISTORY_VALUES GGH5F401.3
*IF DEF,MPP ARB1F402.814
CALL GC_SSYNC(nproc,info) ARB1F402.815
IF (MYPE .eq. 0) THEN ARB1F402.816
*ENDIF ARB1F402.817
CALL TEMPHIST(PHIST_UNIT,ICODE,CMESSAGE) GGH5F401.4
*IF DEF,MPP ARB1F402.818
ENDIF ARB1F402.819
*ENDIF ARB1F402.820
! Exit model so no need to set ppflush GKR1F404.285
END IF GJC0F405.42
END IF GGH5F401.5
GOTO 999 GGH5F401.6
END IF GJC0F405.43
ENDIF U_MODEL1.223
CL 3.1.10 Update ancillary fields if necessary U_MODEL1.224
IF (LANCILLARY) THEN U_MODEL1.225
IF (LTIMER) CALL TIMER('UP_ANCIL',3) U_MODEL1.226
CALL UP_ANCIL ( @DYALLOC.3761
*CALL ARGSIZE @DYALLOC.3762
*CALL ARTD1 @DYALLOC.3763
*CALL ARTDUMA @DYALLOC.3764
*CALL ARTDUMO @DYALLOC.3765
*CALL ARTDUMW WRB1F401.1168
*CALL ARTPTRA @DYALLOC.3766
*CALL ARTPTRO @DYALLOC.3767
*CALL ARTPTRW WRB1F401.1169
*CALL ARTANC @DYALLOC.3768
& submodel, GDG0F401.1476
*CALL ARGPPX GDG0F401.1477
& ICODE,CMESSAGE) GDG0F401.1478
IF (LTIMER) CALL TIMER('UP_ANCIL',4) U_MODEL1.228
IF (ICODE.GT.0) GOTO 999 U_MODEL1.229
ENDIF U_MODEL1.230
CL 3.1.11 Update boundary fields if necessary U_MODEL1.231
IF (LBOUNDARY) THEN U_MODEL1.232
GDR3F405.507
if (l_lbc_coup) then GDR3F405.508
GDR3F405.509
! The boundary conditions (BCs) are updated every N hours. GDR3F405.510
! The BCs required to proceed N hours are read in. If the GDR3F405.511
! model has run M hours, then BCs must be available at GDR3F405.512
! least M+N hours. GDR3F405.513
GDR3F405.514
call date_and_time(ch_date2, ch_time2) GDR3F405.515
GDR3F405.516
write(6,*) 'LBC_COUP: ', GDR3F405.517
& ch_time2(1:2),':',ch_time2(3:4),':',ch_time2(5:6),' on ', GDR3F405.518
& ch_date2(7:8),'/',ch_date2(5:6),'/',ch_date2(1:4), GDR3F405.519
& ' Wait to call INBOUND/UPBOUND in U_MODEL.' GDR3F405.520
GDR3F405.521
! Determine which boundary data is required to proceed GDR3F405.522
! the next period. GDR3F405.523
ms_ntimes = 2 + (stepim(a_im)/boundary_stepsim(a_im)) GDR3F405.524
GDR3F405.525
*IF DEF,MPP GDR3F405.526
if (mype.eq.0) then GDR3F405.527
*ENDIF GDR3F405.528
GDR3F405.529
len_wait_tot = 0 GDR3F405.530
160 continue GDR3F405.531
GDR3F405.532
! Close the communication file and re-open. GDR3F405.533
close(190) GDR3F405.534
open (190,file=lbc_filename,action="read",iostat=icode) GDR3F405.535
GDR3F405.536
! Check return code from OPEN. GDR3F405.537
if (icode.ne.0) then GDR3F405.538
write (6,*) ' Return code from OPEN ',icode GDR3F405.539
icode = 701 GDR3F405.540
write (cmessage,*) 'U_MODEL : Problem with OPEN '// GDR3F405.541
& 'for Unit No 190.' GDR3F405.542
go to 162 GDR3F405.543
endif GDR3F405.544
GDR3F405.545
161 continue GDR3F405.546
GDR3F405.547
! Read next value. GDR3F405.548
read (190,*,iostat=icode) lbc_ntimes GDR3F405.549
GDR3F405.550
! Check return code from READ. GDR3F405.551
if (icode.ne.0) then GDR3F405.552
GDR3F405.553
write (6,*) ' ms : Return code from READ ',icode GDR3F405.554
GDR3F405.555
if (len_wait_tot.ge.um_lbc_wait_max) then GDR3F405.556
! Maximum wait time has been reached or exceeded. GDR3F405.557
write (6,*) ' ms : Maximum wait time reached'// GDR3F405.558
& ' after ',um_lbc_wait_max,' seconds.' GDR3F405.559
icode = 702 GDR3F405.560
write (cmessage,*) 'U_MODEL : Maximum wait time '// GDR3F405.561
& 'reached while reading from LBC_FILE.' GDR3F405.562
go to 162 GDR3F405.563
endif GDR3F405.564
GDR3F405.565
! Wait for um_lbc_wait seconds before re-trying. GDR3F405.566
GDR3F405.567
write (6,*) ' ms : Wait for ',um_lbc_wait, GDR3F405.568
& ' seconds and retry.' GDR3F405.569
isleep = sleep(um_lbc_wait) GDR3F405.570
len_wait_tot = len_wait_tot+um_lbc_wait GDR3F405.571
write (6,*) ' ms : Total Wait so far ',len_wait_tot, GDR3F405.572
& ' seconds.' GDR3F405.573
GDR3F405.574
go to 160 ! Retry finding required lbc_ntimes GDR3F405.575
GDR3F405.576
endif ! if icode.ne.0 GDR3F405.577
GDR3F405.578
! See if required lbc_ntimes has been read in. GDR3F405.579
if (lbc_ntimes.ge.1000) then GDR3F405.580
GDR3F405.581
! First value in file is always >1000. Read next value. GDR3F405.582
go to 161 GDR3F405.583
GDR3F405.584
elseif (lbc_ntimes.lt.ms_ntimes) then GDR3F405.585
GDR3F405.586
write (6,*) ' ms : gl_ntimes = ',lbc_ntimes, GDR3F405.587
& ' read in. gl_ntimes >= ',ms_ntimes, GDR3F405.588
& ' is required. Read next value.' GDR3F405.589
go to 161 GDR3F405.590
GDR3F405.591
elseif (lbc_ntimes.ge.ms_ntimes) then GDR3F405.592
GDR3F405.593
write (6,*) ' ms : gl_ntimes = ',lbc_ntimes, GDR3F405.594
& ' read in. gl_ntimes >= ',ms_ntimes,' is required.', GDR3F405.595
& ' Proceed.' GDR3F405.596
GDR3F405.597
call date_and_time (ch_date2, ch_time2) GDR3F405.598
write(6,*) 'LBC_COUP: ', GDR3F405.599
& ch_time2(1:2),':',ch_time2(3:4),':',ch_time2(5:6), GDR3F405.600
& ' on ', GDR3F405.601
& ch_date2(7:8),'/',ch_date2(5:6),'/',ch_date2(1:4), GDR3F405.602
& ' Proceed to call INBOUND in U_MODEL.' GDR3F405.603
GDR3F405.604
endif ! if lbc_ntimes GDR3F405.605
GDR3F405.606
*IF DEF,MPP GDR3F405.607
endif ! if mype=0 GDR3F405.608
*ENDIF GDR3F405.609
GDR3F405.610
162 continue GDR3F405.611
GDR3F405.612
*IF DEF,MPP GDR3F405.613
! Broadcast ICODE to all PEs GDR3F405.614
iostatus = icode GDR3F405.615
call gc_ibcast (458,1,0,nproc,info,iostatus) GDR3F405.616
icode = iostatus GDR3F405.617
*ENDIF GDR3F405.618
GDR3F405.619
! Check on ICODE before proceeding. GDR3F405.620
if (icode.ne.0) then GDR3F405.621
write (6,*) ' U_MODEL - Error detected.' GDR3F405.622
write (6,*) ' ICODE : ',ICODE GDR3F405.623
write (6,*) ' CMESSAGE : ',CMESSAGE GDR3F405.624
go to 999 ! Return GDR3F405.625
endif GDR3F405.626
GDR3F405.627
! Call IN_BOUND to update the headers/lookup-table GDR3F405.628
GDR3F405.629
IF (LTIMER) CALL TIMER('IN_BOUND',3) GDR3F405.630
GDR3F405.631
CALL IN_BOUND( GDR3F405.632
*CALL ARGSIZE GDR3F405.633
*CALL ARTDUMA GDR3F405.634
*CALL ARTDUMO GDR3F405.635
*CALL ARTDUMW GDR3F405.636
*CALL ARTSTS GDR3F405.637
*CALL ARTPTRA GDR3F405.638
*CALL ARTPTRO GDR3F405.639
*CALL ARTPTRW GDR3F405.640
*CALL ARTBND GDR3F405.641
*IF DEF,ATMOS GDR3F405.642
& A_LEN1_LEVDEPC,A_LEN2_LEVDEPC, ! for dynamic array GDR3F405.643
*ENDIF GDR3F405.644
*IF DEF,OCEAN GDR3F405.645
& O_LEN1_LEVDEPC,O_LEN2_LEVDEPC, ! for dynamic array GDR3F405.646
*ENDIF GDR3F405.647
*IF DEF,WAVE GDR3F405.648
& W_LEN1_LEVDEPC,W_LEN2_LEVDEPC, ! for dynamic array GDR3F405.649
*ENDIF GDR3F405.650
*CALL ARGPPX GDR3F405.651
& ICODE,CMESSAGE) GDR3F405.652
GDR3F405.653
IF (LTIMER) CALL TIMER('IN_BOUND',4) GDR3F405.654
GDR3F405.655
IF (ICODE.GT.0) GO TO 999 ! Return GDR3F405.656
GDR3F405.657
call date_and_time(ch_date2, ch_time2) GDR3F405.658
GDR3F405.659
write(6,*) 'LBC_COUP: ', GDR3F405.660
& ch_time2(1:2),':',ch_time2(3:4),':',ch_time2(5:6),' on ', GDR3F405.661
& ch_date2(7:8),'/',ch_date2(5:6),'/',ch_date2(1:4), GDR3F405.662
& ' Proceed to call UPBOUND in U_MODEL.' GDR3F405.663
GDR3F405.664
endif ! if l_lbc_coup GDR3F405.665
GDR3F405.666
IF (LTIMER) CALL TIMER('UP_BOUND',3) U_MODEL1.233
CALL UP_BOUND(submodel, GRR2F305.641
*CALL ARGSIZE @DYALLOC.3771
*CALL ARTD1 @DYALLOC.3772
*CALL ARTDUMA @DYALLOC.3773
*CALL ARTDUMO @DYALLOC.3774
*CALL ARTDUMW WRB1F401.1170
*CALL ARTPTRA @DYALLOC.3775
*CALL ARTPTRO @DYALLOC.3776
*CALL ARTPTRW WRB1F401.1171
*CALL ARTBND @DYALLOC.3777
*CALL ARGPPX GDG0F401.1479
& ICODE,CMESSAGE) GDG0F401.1480
IF (LTIMER) CALL TIMER('UP_BOUND',4) U_MODEL1.235
IF (ICODE.GT.0) GOTO 999 U_MODEL1.236
ENDIF U_MODEL1.237
*IF DEF,T3E GPB0F405.15
! Flush any output from this timestep to unit6 output file GPB0F405.16
CALL flush(6) GPB0F405.17
*ENDIF GPB0F405.18
CL U_MODEL1.238
CL End main timestep loop U_MODEL1.239
CL---------------------------------------------------------------------- U_MODEL1.240
*IF DEF,ATMOS U_MODEL1.241
*IF DEF,OCEAN,OR,DEF,SLAB U_MODEL1.242
U_MODEL1.243
ENDDO U_MODEL1.244
CL U_MODEL1.245
CL 3.2 If coupled, set timestep group control switches for next group U_MODEL1.246
CL U_MODEL1.247
internal_model_prev=internal_model GRR2F305.642
submodel_prev =submodel GRR2F305.643
GRR2F305.644
IF (LTIMER) CALL TIMER('SETGRCTL',3) U_MODEL1.248
CALL SETGRCTL(internal_model,submodel,NGROUP, GRR2F305.645
* ICODE,CMESSAGE) GRR2F305.646
IF (LTIMER) CALL TIMER('SETGRCTL',4) U_MODEL1.250
IF (ICODE.GT.0) GOTO 999 U_MODEL1.251
U_MODEL1.252
CL 3.3 If coupled model, swap atmosphere/ocean data from disk to memory U_MODEL1.253
CL and perform the data transfer (full coupled model), U_MODEL1.254
CL No action required for slab model. U_MODEL1.255
*IF DEF,OCEAN U_MODEL1.256
*IF DEF,MPP GRR0F402.30
! Get 'global' atmos and ocean horizontal domain sizes from database GRR0F402.31
! in DECOMPDB to set dynamic allocation in SWAP_A2O,SWAP_O2A. GRR0F402.32
G_P_FIELD= decomp_db_glsize(1,decomp_standard_atmos) * GRR0F402.33
& decomp_db_glsize(2,decomp_standard_atmos) GRR0F402.34
GRR0F402.35
G_IMTJMT = decomp_db_glsize(1,decomp_standard_ocean) * GRR0F402.36
& decomp_db_glsize(2,decomp_standard_ocean) GRR0F402.37
*ELSE GRR0F402.38
! Sizes not used for non-MPP: dummy values only GRR0F402.39
G_P_FIELD= P_FIELD GRR0F402.40
G_IMTJMT = IMT*JMT GRR0F402.41
*ENDIF GRR0F402.42
IF(new_sm) THEN ! New submodel partition GRR2F305.647
GRR2F305.648
IF (L_CO2_INTERACTIVE) THEN CCN1F405.90
CO2_DIMA = G_P_FIELD CCN1F405.91
CO2_DIMO = G_IMTJMT CCN1F405.92
*IF DEF,MPP CCN1F405.93
CO2_DIMO2 = (decomp_db_glsize(1,decomp_standard_ocean)-2) * CCN1F405.94
& decomp_db_glsize(2,decomp_standard_ocean) CCN1F405.95
*ELSE CCN1F405.96
CO2_DIMO2 = (IMT-2)*JMT CCN1F405.97
*ENDIF CCN1F405.98
ELSE CCN1F405.99
CO2_DIMA = 1 CCN1F405.100
CO2_DIMO = 1 CCN1F405.101
CO2_DIMO2 = 1 CCN1F405.102
ENDIF CCN1F405.103
IF(submodel.EQ.ocean_sm.AND. GRR2F305.649
* submodel_prev.EQ.atmos_sm) THEN ! Atmos -> Ocean GRR2F305.650
GRR2F305.651
IF (LTIMER) CALL TIMER('SWAP_A2O',3) U_MODEL1.258
CALL SWAP_A2O(G_P_FIELD,G_IMTJMT,CO2_DIMA,CO2_DIMO, CCN1F405.104
*CALL ARGSIZE @DYALLOC.3780
*CALL ARTD1 @DYALLOC.3781
*CALL ARTDUMO @DYALLOC.3782
*CALL ARTPTRA @DYALLOC.3783
*CALL ARTPTRO @DYALLOC.3784
*CALL ARTCONA @DYALLOC.3785
*CALL ARTCONO CJG6F401.1
*CALL ARTAOCPL @DYALLOC.3786
* ICODE,CMESSAGE) @DYALLOC.3787
IF (LTIMER) CALL TIMER('SWAP_A2O',4) U_MODEL1.260
GRR2F305.653
ELSEIF(submodel.EQ.atmos_sm.AND. GRR2F305.654
* submodel_prev.EQ.ocean_sm) THEN ! Ocean -> Atmos GRR2F305.655
GRR2F305.656
IF (LTIMER) CALL TIMER('SWAP_O2A',3) U_MODEL1.262
CALL SWAP_O2A(G_P_FIELD,G_IMTJMT,CO2_DIMA,CO2_DIMO,CO2_DIMO2, CCN1F405.105
*CALL ARGSIZE @DYALLOC.3789
*CALL ARTD1 @DYALLOC.3790
*CALL ARTDUMO @DYALLOC.3791
*CALL ARTPTRA @DYALLOC.3792
*CALL ARTPTRO @DYALLOC.3793
*CALL ARTCONO CJG6F401.2
*CALL ARTAOCPL @DYALLOC.3794
* ICODE,CMESSAGE) @DYALLOC.3795
IF (LTIMER) CALL TIMER('SWAP_O2A',4) U_MODEL1.264
GRR2F305.658
ELSE ! No other submodel -> submodel coupling allowed yet GRR2F305.659
ICODE=1 GRR2F305.660
CMESSAGE='U_MODEL: Illegal combination of submodels' GRR2F305.661
write(6,*) CMESSAGE GRR2F305.662
write(6,*) 'Previous submodel id =',submodel_prev, GRR2F305.663
* 'Current submodel id =',submodel GRR2F305.664
GRR2F305.665
ENDIF ! End tests on coupled submodels' identity GRR2F305.666
GRR2F305.667
ENDIF ! End test on new submodel GRR2F305.668
IF (ICODE.GT.0) GOTO 999 U_MODEL1.266
*ENDIF U_MODEL1.267
CL U_MODEL1.268
CL End group of timesteps U_MODEL1.269
CL---------------------------------------------------------------------- U_MODEL1.270
*ENDIF U_MODEL1.271
*ENDIF U_MODEL1.272
GOTO 1 U_MODEL1.273
C U_MODEL1.274
999 CONTINUE U_MODEL1.275
CL---------------------------------------------------------------------- U_MODEL1.276
CL 4. Exit processing: Output error messages and perform tidy-up U_MODEL1.277
CL U_MODEL1.278
CL 4.1 Exit processing: If abnormal completion, output error message U_MODEL1.279
IABORT=ICODE U_MODEL1.280
IF (ICODE.NE.0) THEN U_MODEL1.281
IF (LTIMER) CALL TIMER('EREPORT ',3) U_MODEL1.282
CALL EREPORT(ICODE,CMESSAGE) U_MODEL1.283
IF (LTIMER) CALL TIMER('EREPORT ',4) U_MODEL1.284
ENDIF U_MODEL1.285
CL 4.2 Exit processing: Perform tidy-up U_MODEL1.286
IF (LTIMER) CALL TIMER('EXITPROC',3) U_MODEL1.287
CALL EXITPROC(ICODE,CMESSAGE) U_MODEL1.288
IF (LTIMER) CALL TIMER('EXITPROC',4) U_MODEL1.289
CL 4.3 Exit processing: If error in exit processing, output error mess U_MODEL1.290
IF (ICODE.NE.0) THEN U_MODEL1.291
IF (LTIMER) CALL TIMER('EREPORT ',3) U_MODEL1.292
CALL EREPORT(ICODE,CMESSAGE) U_MODEL1.293
IF (LTIMER) CALL TIMER('EREPORT ',4) U_MODEL1.294
ENDIF U_MODEL1.295
CL---------------------------------------------------------------------- U_MODEL1.296
CL 5. Complete Timer call and return @DYALLOC.3796
CL U_MODEL1.298
ICODE=IABORT @DYALLOC.3797
IF (LTIMER) THEN GSM1F401.29
CALL TIMER('U_MODEL ',4) GSM1F401.30
END IF GSM1F401.31
RETURN @DYALLOC.3799
END U_MODEL1.302
*ENDIF U_MODEL1.303