SUBROUTINE ADDRES( 1,18GSS3F401.66
*CALL ARGPPX 
ADDRES1.7
& NRECS, GSM2F403.87
& ErrorStatus,CMESSAGE) GSM2F403.88
IMPLICIT NONE ADDRES1.9
! Description: ADDRES1.10
! ADDRES1.11
! Method: ADDRES1.12
! ADDRES1.13
! Current code owner: S.J.Swarbrick ADDRES1.14
! ADDRES1.15
! History: ADDRES1.16
! Version Date Comment ADDRES1.17
! ======= ==== ======= ADDRES1.18
! 3.5 Mar. 95 Original code. S.J.Swarbrick ADDRES1.19
! 4.0 Oct. 95 S.J.Swarbrick GSS1F400.808
! 4.1 Apr. 96 Generalisation GSS3F401.68
! of routine S.J.Swarbrick GSS3F401.69
! 4.2 Nov. 96 Allow for uncompresses ocean dumps in OSI0F402.143
! calculation of LPRIM_O2 OSI0F402.144
! 4.2 2/9/96 MPP code : Change to relevant decomposition GPB0F403.3019
! as each submodel is processed. P.Burton GPB0F403.3020
! 4.3 13/3/97 Further MPP changes P.Burton GPB0F403.3021
! 4.3 19/5/97 Allow for pseudo-levels. W.Ingram AWI1F403.100
! ADDRES1.20
! 4.3 18/03/97 Set up preliminary addressing of D1 GSM2F403.89
! S.D.Mullerworth GSM2F403.90
! 4.4 05/09/97 New space code 10. S.D.Mullerworth GSM4F404.1
! 4.4 Oct. 97 Added error checking on return from TOTIMP GDW1F404.231
! 4.4 26/08/97 Mixed phase precip scheme means not all ISPACE.eq.9 ARB1F404.4
! may be active. RTHBarnes. ARB1F404.5
! 4.4 11/07/97 Correction for fields not on model levels. GDG0F404.1
! D.M. Goddard GDG0F404.2
! vn4.4 Remove check preventing stash codes 4 and 10 UIE2F404.117
! (q and theta) from being included in variable NProgItems enabling UIE2F404.118
! them to be written out as prognostics. Ian Edmond UIE2F404.119
! 4.5 03/09/98 Don't set the decomposition in PARVARS for the SCH0F405.11
! slab model. Prior to this there would be an SCH0F405.12
! error message if the slab model was selected SCH0F405.13
! for mpp runs. Slab model can now be run with SCH0F405.14
! mpp selected. C. D. Hewitt SCH0F405.15
! Code description: ADDRES1.21
! FORTRAN 77 + common Fortran 90 extensions. ADDRES1.22
! Written to UM programming standards version 7. ADDRES1.23
! ADDRES1.24
! System component covered: ADDRES1.25
! System task: Sub-Models Project ADDRES1.26
! ADDRES1.27
! Global variables: ADDRES1.28
*CALL CSUBMODL ADDRES1.30
*CALL LENFIL ADDRES1.31
*CALL CPPXREF GSS3F401.70
*CALL PPXLOOK GSS3F401.71
*CALL TYPSIZE GSS3F401.72
*CALL MODEL ADDRES1.33
*CALL CSTASH GRB0F401.3
*CALL STEXTEND ADDRES1.35
*IF DEF,RECON ADDRES1.36
*CALL NRECON ADDRES1.37
*ENDIF ADDRES1.38
*CALL STPARAM ADDRES1.40
GPB1F402.196
*IF DEF,MPP GPB1F402.197
! MPP comdecks GPB1F402.198
*CALL DECOMPTP GPB1F402.199
*CALL PARVARS GPB1F402.200
*ENDIF GPB1F402.201
GSS3F401.73
ADDRES1.47
! Subroutine arguments: ADDRES1.48
! Scalar arguments with intent(in): ADDRES1.50
INTEGER NRECS GSS3F401.74
ADDRES1.55
! Scalar arguments with intent(out): ADDRES1.56
CHARACTER*80 CMESSAGE GSS9F402.165
ADDRES1.59
! ErrorStatus: ADDRES1.60
INTEGER ErrorStatus ADDRES1.61
ADDRES1.62
! Local scalars: ADDRES1.63
INTEGER TOTIMP GSS3F401.75
INTEGER Im_ident !Internal model identifier (absolute - CSMID) GSS1F400.809
INTEGER Im_index !Internal model index (expt. dependent) GSS1F400.810
INTEGER Sm_ident !Submodel identifier (absolute) GSS3F401.76
INTEGER ISEC ADDRES1.68
INTEGER IITM ADDRES1.69
INTEGER RLEVS ADDRES1.70
INTEGER RADDRESS ADDRES1.72
INTEGER PIrow ADDRES1.73
INTEGER I,J GSS3F401.77
INTEGER IFIRST ADDRES1.75
INTEGER IFREQ ADDRES1.76
INTEGER IHOURS ADDRES1.78
INTEGER ILAST ADDRES1.80
INTEGER IREC ADDRES1.82
INTEGER IH,IL,IP,IT GSS3F401.78
INTEGER LWORK_S(N_SUBMODEL_PARTITION_MAX) GSS3F401.79
*IF DEF,MPP GPB1F402.202
INTEGER ICODE ! return from CHANGE_DECOMPOSITION GPB1F402.203
*ENDIF GPB1F402.204
GSS3F401.80
! Local arrays: GSS3F401.81
! Submodel definitions array: stores list of Im_index's GSS3F401.82
! for each submodel partition GSS3F401.83
INTEGER GSS3F401.84
& SM_def(N_SUBMODEL_PARTITION_MAX,N_INTERNAL_MODEL_MAX) GSS3F401.85
ADDRES1.87
! Function and subroutine calls: ADDRES1.88
INTEGER EXPPXI ADDRES1.90
EXTERNAL PRIMARY,EXPPXI ADDRES1.91
ADDRES1.92
!- End of Header ---------------------------------------------------- ADDRES1.93
ADDRES1.94
ADDRES1.95
! 1. Set STASHIN addresses and input lengths for primary fields ADDRES1.96
ADDRES1.97
! The address loop for primary fields is performed for each ADDRES1.98
! internal model in turn. Hence, each internal model's primary ADDRES1.99
! data occupies a contiguous block in D1. The order of these blocks ADDRES1.100
! is the same as the order of the internal models given in the ADDRES1.101
! array INTERNAL_MODEL_LIST. ADDRES1.102
! User-defined prognostics are included in this primary addressing GSS1F400.811
! routine, since they are incorporated into the ppxref lookup GSS1F400.812
! arrays PPXI, PPXC in routine GETPPX. GSS1F400.813
ADDRES1.103
! Initialisation ADDRES1.104
*IF DEF,RECON ADDRES1.105
DO Im_ident= 1,N_INTERNAL_MODEL_MAX GSS3F401.86
NProgItems(Im_ident ) = 0 GSS3F401.87
PrimDataLen(Im_ident ) = 0 GSS3F401.88
DO IITM = 1,PPXREF_ITEMS GSS1F400.816
ProgItems(Im_ident,IITM) = 0 GSS3F401.89
END DO ADDRES1.110
END DO ADDRES1.111
*ENDIF ADDRES1.112
N_OBJ_D1_MAX=0 GSM2F403.91
DO I = 1,N_SUBMODEL_PARTITION GSM2F403.92
N_OBJ_D1(I)=0 GSM2F403.93
ENDDO GSM2F403.94
GSM2F403.95
DO I = 1,N_SUBMODEL_PARTITION_MAX GSS3F401.90
DO J = 1,N_INTERNAL_MODEL_MAX GSS3F401.91
SM_def(I,J) = 0 GSS3F401.92
END DO GSS3F401.93
END DO GSS3F401.94
GSS3F401.95
! Obtain submodel definitions and store in SMdef array GSS3F401.96
DO Im_index = 1,N_INTERNAL_MODEL GSS3F401.97
! Submodel ident. GSS3F401.98
Sm_ident = SUBMODEL_FOR_IM(Im_index) GSS3F401.99
! Internal model index GSS3F401.100
SM_def(Sm_ident,Im_index) = Im_index GSS3F401.101
END DO GSS3F401.102
ADDRES1.113
! Primary address loop ADDRES1.114
GSS1F400.819
! Loop over submodel partitions GSS3F401.103
DO Sm_ident = 1,N_SUBMODEL_PARTITION_MAX GSS3F401.104
GSS3F401.105
C Initialise LEXTRA GSM2F403.96
LEXTRA(Sm_ident)=0 GSM2F403.97
GSM2F403.98
! Initialise address for reconfiguration GSS3F401.106
RADDRESS = 1 GSS3F401.107
GSS3F401.108
! Loop over internal models for each SM partition GSS3F401.109
DO Im_index = 1,N_INTERNAL_MODEL GSS3F401.110
GSS3F401.111
! Test whether current SM contains this IM GSS3F401.112
IF (SM_def(Sm_ident,Im_index).GT.0) THEN GSS3F401.113
GSS3F401.114
! Obtain internal model identifier GSS3F401.115
Im_ident = INTERNAL_MODEL_LIST(Im_index) GSS1F400.820
GPB1F402.205
*IF DEF,MPP GPB1F402.206
! Set the correct decomposition in PARVARS GPB1F402.207
GPB1F402.208
ICODE=0 GPB1F402.209
GPB1F402.210
IF (Im_ident .EQ. A_IM) THEN GPB1F402.211
IF (current_decomp_type .NE. decomp_standard_atmos) GPB1F402.212
& CALL CHANGE_DECOMPOSITION(decomp_standard_atmos,ICODE) GPB1F402.213
GPB1F402.214
ELSEIF (Im_ident .EQ. O_IM) THEN GPB1F402.215
IF (current_decomp_type .NE. decomp_standard_ocean) GPB1F402.216
& CALL CHANGE_DECOMPOSITION(decomp_standard_ocean,ICODE) GPB1F402.217
GPB1F402.218
ELSEIF (Im_ident .EQ. S_IM) THEN SCH0F405.16
WRITE(6,*) 'ADDRES1 : Slab model not actually running MPP', SCH0F405.17
& ' but will run on PE0 while atmosphere runs MPP' SCH0F405.18
SCH0F405.19
ELSE ! unsupported decomposition type GPB1F402.219
WRITE(6,*) 'ADDRES1 : Error - Only atmosphere and ocean ', GPB1F402.220
& 'submodels are currently supported for MPP code.' GPB1F402.221
ErrorStatus=-1 GPB1F402.222
CMESSAGE='Unsupported submodel for MPP code' GPB1F402.223
GOTO 9999 GPB1F402.224
ENDIF GPB1F402.225
GPB1F402.226
IF (ICODE .NE. 0) THEN GPB1F402.227
WRITE(6,*) 'ADDRES1 : Error - Could not set decomposition ', GPB1F402.228
& 'for selected submodel.' GPB1F402.229
ErrorStatus=-2 GPB1F402.230
CMESSAGE='Unsupported decomposition selected for MPP code' GPB1F402.231
GOTO 9999 GPB1F402.232
ENDIF GPB1F402.233
GPB1F402.234
*ENDIF GPB1F402.235
GSS3F401.116
! Initialise primary data lengths for TYPSIZE GSS3F401.117
IF (Im_ident.EQ.A_IM) A_PROG_LEN=0 GSS3F401.118
IF (Im_ident.EQ.O_IM) O_PROG_LEN=0 GSS3F401.119
IF (Im_ident.EQ.S_IM) S_PROG_LEN=0 GSS3F401.120
IF (Im_ident.EQ.W_IM) W_PROG_LEN=0 GSS3F401.121
IF (Im_ident.EQ.A_IM) A_PROG_LOOKUP=0 GSS3F401.122
IF (Im_ident.EQ.O_IM) O_PROG_LOOKUP=0 GSS3F401.123
IF (Im_ident.EQ.S_IM) S_PROG_LOOKUP=0 GSS3F401.124
IF (Im_ident.EQ.W_IM) W_PROG_LOOKUP=0 GSS3F401.125
*IF DEF,RECON GSS1F400.821
IF(Im_ident.EQ.SUBMODEL_IDENT.OR.Im_ident.EQ.SLAB_IM)THEN GSS3F401.126
*ENDIF GSS1F400.823
PIrow = 0 ADDRES1.122
ISEC = 0 ADDRES1.123
! Loop over section zero items GSS3F401.127
DO IITM = 1,PPXREF_ITEMS ADDRES1.124
! Check whether there is a primary field corresponding ADDRES1.126
! to this item number ADDRES1.127
*IF DEF,RECON GSS1F400.824
IF (PPXPTR(Im_ident,ISEC,IITM).NE.0) THEN GSS1F400.825
*ELSE GSS1F400.826
IF (PPXPTR(Im_index,ISEC,IITM).NE.0) THEN GSS1F400.827
*ENDIF GSS1F400.828
VMSK = EXPPXI(Im_ident,ISEC,IITM,ppx_version_mask , GSS1F400.829
*CALL ARGPPX ADDRES1.131
& ErrorStatus,CMESSAGE) ADDRES1.132
ISPACE = EXPPXI(Im_ident,ISEC,IITM,ppx_space_code , GSS1F400.830
*CALL ARGPPX ADDRES1.134
& ErrorStatus,CMESSAGE) ADDRES1.135
IGP = EXPPXI(Im_ident,ISEC,IITM,ppx_grid_type , GSS1F400.831
*CALL ARGPPX ADDRES1.137
& ErrorStatus,CMESSAGE) ADDRES1.138
ILEV = EXPPXI(Im_ident,ISEC,IITM,ppx_lv_code , GSS1F400.832
*CALL ARGPPX ADDRES1.140
& ErrorStatus,CMESSAGE) ADDRES1.141
IBOT = EXPPXI(Im_ident,ISEC,IITM,ppx_lb_code , GSS1F400.833
*CALL ARGPPX ADDRES1.143
& ErrorStatus,CMESSAGE) ADDRES1.144
ITOP = EXPPXI(Im_ident,ISEC,IITM,ppx_lt_code , GSS1F400.834
*CALL ARGPPX ADDRES1.146
& ErrorStatus,CMESSAGE) ADDRES1.147
DO I=1,4 GSS3F401.128
IOPN(I) = EXPPXI(Im_ident,ISEC,IITM,ppx_opt_code+I-1 , GSS3F401.129
*CALL ARGPPX ADDRES1.149
& ErrorStatus,CMESSAGE) ADDRES1.150
END DO GSS3F401.130
IFLAG = EXPPXI(Im_ident,ISEC,IITM,ppx_lev_flag , GSS3F401.131
*CALL ARGPPX GSS3F401.132
& ErrorStatus,CMESSAGE) GSS3F401.133
IPSEUDO = EXPPXI(Im_ident,ISEC,IITM,ppx_pt_code , GSS3F401.134
*CALL ARGPPX GSS3F401.135
& ErrorStatus,CMESSAGE) GSS3F401.136
IPFIRST = EXPPXI(Im_ident,ISEC,IITM,ppx_pf_code , GSS3F401.137
*CALL ARGPPX GSS3F401.138
& ErrorStatus,CMESSAGE) GSS3F401.139
IPLAST = EXPPXI(Im_ident,ISEC,IITM,ppx_pl_code , GSS3F401.140
*CALL ARGPPX GSS3F401.141
& ErrorStatus,CMESSAGE) GSS3F401.142
IF((ISPACE.EQ.2).OR.(ISPACE.EQ.3).OR.(ISPACE.EQ.9) GSM2F403.99
*IF -DEF,RECON ADDRES1.153
& .OR.(ISPACE.EQ.4) ADDRES1.154
*ENDIF ADDRES1.155
& .OR.(ISPACE.EQ.5) GSS1F403.38
& .OR.(ISPACE.EQ.10) GSM4F404.2
& .OR.(ISPACE.EQ.8)) THEN ! Primary variable GSS1F403.39
CALL PRIMARY(IITM,Im_index,Im_ident,Sm_ident, GSS3F401.143
& RLEVS,RADDRESS,PIrow,ErrorStatus,CMESSAGE) GSS3F401.144
END IF ADDRES1.159
END IF ! PPXPTR(m,s,i) .ne. 0 ADDRES1.160
END DO ! Loop over items ADDRES1.161
*IF DEF,RECON GSS1F400.838
END IF GSS3F401.145
*ENDIF GSS1F400.840
END IF ! test whether SM contains IM GSS3F401.146
END DO ! Loop over Im_index GSS3F401.147
END DO ! Loop over SM partitions GSS3F401.148
ADDRES1.175
*IF DEF,RECON ADDRES1.176
! No. of levels & primary data lengths for reconfiguration GSS3F401.149
DO I=1,N_INTERNAL_MODEL_MAX GSS3F401.150
DumpProgLevs(I) = NHEAD (I) GSS3F401.151
PrimDataLen (I) = LPrimIM(I) GSS3F401.152
END DO GSS3F401.153
*ENDIF ADDRES1.184
*IF -DEF,RECON ADDRES1.186
! LOOKUP array lengths for TYPSIZE GSS3F401.154
A_PROG_LOOKUP = NHEAD(A_IM) GSS3F401.155
O_PROG_LOOKUP = NHEAD(O_IM) GSS3F401.156
S_PROG_LOOKUP = NHEAD(S_IM) GSS3F401.157
W_PROG_LOOKUP = NHEAD(W_IM) GSS3F401.158
! Primary data lengths for TYPSIZE GSS3F401.159
A_PROG_LEN = LPrimIM(A_IM) GSS3F401.160
O_PROG_LEN = LPrimIM(O_IM) GSS3F401.161
S_PROG_LEN = LPrimIM(S_IM) GSS3F401.162
W_PROG_LEN = LPrimIM(W_IM) GSS3F401.163
WRITE(6,*) ' ADDRES : A_PROG_LOOKUP = ',A_PROG_LOOKUP ADDRES1.192
WRITE(6,*) ' ADDRES : A_PROG_LEN = ',A_PROG_LEN ADDRES1.193
WRITE(6,*) ' ADDRES : S_PROG_LOOKUP = ',S_PROG_LOOKUP GSS1F400.844
WRITE(6,*) ' ADDRES : S_PROG_LEN = ',S_PROG_LEN GSS1F400.845
WRITE(6,*) ' ADDRES : O_PROG_LOOKUP = ',O_PROG_LOOKUP ADDRES1.194
WRITE(6,*) ' ADDRES : O_PROG_LEN = ',O_PROG_LEN ADDRES1.195
WRITE(6,*) ' ADDRES : W_PROG_LOOKUP = ',W_PROG_LOOKUP GSS3F401.164
WRITE(6,*) ' ADDRES : W_PROG_LEN = ',W_PROG_LEN GSS3F401.165
*ENDIF ADDRES1.196
ADDRES1.197
*IF -DEF,RECON ADDRES1.198
! 2. Loop through stash list to set output addresses and ADDRES1.201
! header positions for diagnostics ADDRES1.202
DO IREC=1,NRECS ADDRES1.204
ADDRES1.205
! Read internal model number from stash list. Stash list has already GSS3F401.166
! been ordered by internal model, section, item. Thus, all the atmos ADDRES1.207
! diagnostic addressing will be done first, followed by the slab ADDRES1.208
! addressing in the case of a slab model. ADDRES1.209
Im_ident = LIST_S(st_model_code,IREC) GSS1F400.846
! Obtain submodel partition id. GSS3F401.167
Sm_ident = SUBMODEL_PARTITION_INDEX(Im_ident) GSS3F401.168
ADDRES1.211
! Set output address relative to D1 ADDRES1.212
IF(LIST_S(st_output_code,IREC).EQ.1) THEN ADDRES1.213
ADDRES1.214
! Diagnostic output to dump rather than direct output pp file ADDRES1.215
! Add the output length for this diag to LDUMP; total length of GSS3F401.169
! dump so far = LPRIM + LDUMP; hence obtain the start address for GSS3F401.170
! the output from the next diagnostic to be stored in dump. GSS3F401.171
ADDRES1.219
LIST_S(st_output_addr,IREC) GSS3F401.172
& = LPRIM(Sm_ident)+LDUMP(Sm_ident)+1 GSS3F401.173
C Information for preliminary D1 addressing array GSM2F403.100
N_OBJ_D1(Sm_ident) =N_OBJ_D1(Sm_ident)+1 GSM2F403.101
IF (N_OBJ_D1(Sm_ident).LE.MAX_D1_LEN)THEN GSM2F403.102
D1_PADDR(d1_type,N_OBJ_D1(Sm_ident),Sm_ident)=diag GSM2F403.103
D1_PADDR(d1_im,N_OBJ_D1(Sm_ident),Sm_ident)=Im_ident GSM2F403.104
D1_PADDR(d1_extra_info,N_OBJ_D1(Sm_ident),Sm_ident)=IREC GSM2F403.105
ENDIF GSM2F403.106
*IF DEF,MPP GPB1F402.236
LIST_S(st_dump_output_addr,IREC)= GPB1F402.237
& global_LPRIM(Sm_ident)+global_LDUMP(Sm_ident)+1 GPB1F402.238
*ENDIF GPB1F402.239
LDUMP(Sm_ident) GSS3F401.174
& = LDUMP(Sm_ident)+LIST_S(st_output_length,IREC) GSS3F401.175
LDumpIM(Im_ident) GSS3F401.176
& = LDumpIM(Im_ident)+LIST_S(st_output_length,IREC) GSS3F401.177
*IF DEF,MPP GPB1F402.240
global_LDUMP(Sm_ident)= GPB1F402.241
& global_LDUMP(Sm_ident)+LIST_S(st_dump_output_length,IREC) GPB1F402.242
global_LDUMPIM(Sm_ident)= GPB1F402.243
& global_LDUMPIM(Im_ident)+LIST_S(st_dump_output_length,IREC) GPB1F402.244
*ENDIF GPB1F402.245
ADDRES1.232
IF(LIST_S(st_output_bottom,IREC).EQ.100) THEN ADDRES1.233
! Special levels ADDRES1.234
RLEVS=1 ADDRES1.235
ELSE IF(LIST_S(st_series_ptr,IREC).NE.0) THEN ADDRES1.236
! Time series domain ADDRES1.237
RLEVS=1 ADDRES1.238
ELSE IF(LIST_S(st_gridpoint_code,IREC).GE.10 ADDRES1.239
& .AND.LIST_S(st_gridpoint_code,IREC).LT.20) THEN ADDRES1.240
! Vertical ave. ADDRES1.241
RLEVS=1 ADDRES1.242
ELSE IF(LIST_S(st_output_bottom,IREC).LT.0) THEN ADDRES1.243
! Levels list ADDRES1.244
RLEVS=LEVLST_S(1,-LIST_S(st_output_bottom,IREC)) ADDRES1.245
ELSE ADDRES1.246
! Range of model levels ADDRES1.247
RLEVS=LIST_S(st_output_top ,IREC) ADDRES1.248
& -LIST_S(st_output_bottom,IREC)+1 ADDRES1.249
END IF ADDRES1.250
ADDRES1.251
IF (LIST_S(st_pseudo_out,IREC).GT.0) THEN ADDRES1.252
! Pseudo levels ADDRES1.253
RLEVS=RLEVS*LENPLST(LIST_S(st_pseudo_out,IREC)) ADDRES1.254
END IF ADDRES1.255
ADDRES1.256
! Set position of pp lookup header in the dump ADDRES1.257
LIST_S(st_lookup_ptr,IREC)=NHeadSub(Sm_ident)+1 GSS3F401.178
ADDRES1.258
! Increment NHEAD (there is one pp header for each level at GSS3F401.179
! which a diagnostic is output GSS3F401.180
NHEAD (Im_ident)=NHEAD (Im_ident)+RLEVS GSS3F401.181
NHeadSub(Sm_ident)=NHeadSub(Sm_ident)+RLEVS GSS3F401.182
ADDRES1.276
ELSE IF(LIST_S(st_output_code,IREC).EQ.2) THEN ADDRES1.277
ADDRES1.278
! Secondary data in D1. ADDRES1.279
! Compute and store secondary data lengths. Start address for ADDRES1.280
! secondary data is determined below, after total dump ADDRES1.281
! diagnostic length has been found. ADDRES1.282
ADDRES1.283
LIST_S(st_output_addr,IREC)=LSECD(Sm_ident)+1 GSS3F401.183
LSECD(Sm_ident) GSS3F401.184
& =LSECD(Sm_ident)+LIST_S(st_output_length,IREC) GSS3F401.185
LSecdIM(Im_ident) GSS3F401.186
& =LSecdIM(Im_ident)+LIST_S(st_output_length,IREC) GSS3F401.187
! Set pointer for pp header GSS3F401.188
LIST_S(st_lookup_ptr,IREC)=-1 GSS3F401.189
ADDRES1.294
ELSE IF(LIST_S(st_output_code,IREC).LT.0) THEN ADDRES1.297
ADDRES1.298
! Diagnostic output to PP file ADDRES1.299
ADDRES1.300
! Compute no. of pp headers for this diagnostic ADDRES1.301
! = output levels * pseudo output levels * output times ADDRES1.302
ADDRES1.303
! No. of levels ADDRES1.304
IF(LIST_S(st_output_bottom,IREC).EQ.100) THEN ADDRES1.305
! Special levels ADDRES1.306
IL=1 ADDRES1.307
ELSE IF(LIST_S(st_series_ptr,IREC).NE.0) THEN ADDRES1.308
! Time series dom ADDRES1.309
IL=1 ADDRES1.310
ELSE IF(LIST_S(st_gridpoint_code,IREC).GE.10 ADDRES1.311
& .AND.LIST_S(st_gridpoint_code,IREC).LT.20) THEN ADDRES1.312
! Vertical average ADDRES1.313
IL=1 ADDRES1.314
ELSE IF(LIST_S(st_output_bottom,IREC).LT.0) THEN ADDRES1.315
! Levels list ADDRES1.316
IL=LEVLST_S(1,-LIST_S(st_output_bottom,IREC)) ADDRES1.317
ELSE ADDRES1.318
! Range of mod levs ADDRES1.319
IL=LIST_S(st_output_top,IREC) ADDRES1.320
& -LIST_S(st_output_bottom,IREC)+1 ADDRES1.321
END IF ADDRES1.322
ADDRES1.323
! No. of pseudo levels ADDRES1.324
IF (LIST_S(st_pseudo_out,IREC).GT.0) THEN ADDRES1.325
IP=LENPLST(LIST_S(st_pseudo_out,IREC)) ADDRES1.326
ELSE ADDRES1.327
IP=1 ADDRES1.328
END IF ADDRES1.329
ADDRES1.330
! No. of output times ADDRES1.331
IF(LIST_S(st_freq_code,IREC).GT.0) THEN ADDRES1.332
IFIRST=LIST_S(st_start_time_code,IREC) ADDRES1.334
IFREQ =LIST_S(st_freq_code ,IREC) ADDRES1.335
IF(LIST_S(st_end_time_code,IREC).EQ.-1) THEN ADDRES1.337
! Output to continues to end of run ADDRES1.338
IHOURS=1+8760*RUN_TARGET_END(1) ADDRES1.339
& + 744*RUN_TARGET_END(2) ADDRES1.340
& + 24*RUN_TARGET_END(3) ADDRES1.341
& + RUN_TARGET_END(4) ADDRES1.342
ILAST=TOTIMP(IHOURS,'H ',Im_ident) GSS3F401.190
if (ILAST .eq. -999) then GDW1F404.232
errorStatus = 1 GDW1F404.233
cmessage = 'TOTIMP:UNEXPECTED TIME UNIT or GDW1F404.234
& IRREGULAR DUMPS FOR DUMP FREQUENCY' GDW1F404.235
GOTO 9999 GDW1F404.236
endif GDW1F404.237
ELSE ADDRES1.352
! Last output time before end of run ADDRES1.353
ILAST=LIST_S(st_end_time_code,IREC) ADDRES1.354
END IF ADDRES1.356
ADDRES1.357
IT= 1 + (ILAST-IFIRST)/IFREQ ADDRES1.358
IF (IT.LT.0) THEN ADDRES1.360
IT=0 ADDRES1.361
WRITE(6,*) GSS3F401.191
& ' Output time error detected in routine ADDRESS:' GSS3F401.192
WRITE(6,*) GSS3F401.193
& ' Output time starts after specified end of run' GSS3F401.194
WRITE(6,*) GSS3F401.195
& ' STASH record no.,MODEL,SECTION,ITEM as follows: ', GSS3F401.196
& IREC, LIST_S(st_model_code,IREC), ADDRES1.365
& LIST_S(st_sect_code ,IREC), ADDRES1.366
& LIST_S(st_item_code ,IREC) ADDRES1.367
WRITE(6,*) 'OUTPUT CODE: ', GSS3F401.197
& LIST_S(st_output_code,IREC) GSS3F401.198
END IF ADDRES1.369
ELSE GSS3F401.199
! Times table in STASH_times array GSS3F401.200
IT=1 ADDRES1.373
DO I=1,NTIMEP ADDRES1.374
IF (ITIM_S(I,-LIST_S(st_freq_code,IREC)).EQ.-1) THEN ADDRES1.375
IT=I-1 ADDRES1.376
GOTO 260 ADDRES1.377
END IF ADDRES1.378
END DO ADDRES1.379
260 CONTINUE ADDRES1.380
END IF ADDRES1.382
! No. of output "headers" - (levels)*(pseudo-levels)*(output times) ADDRES1.383
IH=IL*IP*IT ADDRES1.384
! Assign output unit no. (nn) to (st_output_addr) ADDRES1.385
LIST_S(st_output_addr,IREC)=-LIST_S(st_output_code,IREC) ADDRES1.386
! Assign no. of output headers to NHEAD_FILE(nn) ADDRES1.387
NHEAD_FILE(LIST_S(st_output_addr,IREC))= ADDRES1.388
& NHEAD_FILE(LIST_S(st_output_addr,IREC)) + IH ADDRES1.389
ELSE IF (LIST_S(st_output_code,IREC).EQ.0) THEN ADDRES1.390
! Inactive record, not output ADDRES1.392
LIST_S(st_output_addr,IREC)=-LIST_S(st_output_code,IREC) ADDRES1.393
ELSE ADDRES1.395
WRITE(6,*) 'ERROR detected in routine ADDRESS ' GSS3F401.201
WRITE(6,*) 'ILLEGAL OUTPUT CODE FOR STASH RECORD ' GSS3F401.202
WRITE(6,*) GSS3F401.203
& ' STASH record no.,MODEL,SECTION,ITEM as follows: ', GSS3F401.204
& IREC, LIST_S(st_model_code,IREC), GSS3F401.205
& LIST_S(st_sect_code ,IREC), GSS3F401.206
& LIST_S(st_item_code ,IREC) GSS3F401.207
END IF ADDRES1.400
ADDRES1.401
END DO ! End of loop over records for D1 addressing ADDRES1.402
ADDRES1.403
ADDRES1.404
C Correct the addressing of SPACE=9 items from being relative GSM2F403.107
C to start of LEXTRA space to being relative to start of dump GSM2F403.108
GSM2F403.109
C Loop over submodel partitions GSM2F403.110
DO Sm_ident = 1,N_SUBMODEL_PARTITION_MAX GSM2F403.111
GSM2F403.112
C Loop over internal models for each SM partition GSM2F403.113
DO Im_index = 1,N_INTERNAL_MODEL GSM2F403.114
GSM2F403.115
C Test whether current SM contains this IM GSM2F403.116
IF (SM_def(Sm_ident,Im_index).GT.0) THEN GSM2F403.117
GSM2F403.118
C Obtain internal model identifier GSM2F403.119
Im_ident = INTERNAL_MODEL_LIST(Im_index) GSM2F403.120
GSM2F403.121
DO IITM = 1,PPXREF_ITEMS GSM2F403.122
C Check whether there is a primary field corresponding GSM2F403.123
*IF DEF,RECON GSM2F403.124
IF (PPXPTR(Im_ident,ISEC,IITM).NE.0) THEN GSM2F403.125
*ELSE GSM2F403.126
IF (PPXPTR(Im_index,ISEC,IITM).NE.0) THEN GSM2F403.127
*ENDIF GSM2F403.128
ISPACE = EXPPXI(Im_ident,ISEC,IITM,ppx_space_code, GSM2F403.129
*CALL ARGPPX GSM2F403.130
& ErrorStatus,CMESSAGE) GSM2F403.131
IF (IN_S(1,Im_ident,0,IITM).ne.0 ! item is active ARB1F404.6
& .and. ISPACE.EQ.9) THEN ARB1F404.7
IN_S(1,Im_ident,0,IITM)=IN_S(1,Im_ident,0,IITM)+ GSM2F403.133
& LPRIM(Sm_ident)+LDUMP(Sm_ident) GSM2F403.134
IF (Im_ident.EQ.O_IM) THEN GSM2F403.135
IN_S(1,Im_ident,0,IITM)=IN_S(1,Im_ident,0,IITM) GSM2F403.136
& +LPRIM_O2 GSM2F403.137
ENDIF GSM2F403.138
ENDIF GSM2F403.139
ENDIF GSM2F403.140
ENDDO GSM2F403.141
ENDIF GSM2F403.142
ENDDO GSM2F403.143
ENDDO GSM2F403.144
GSM2F403.145
GSM2F403.146
! Set secondary data addresses relative to start of D1 ADDRES1.405
DO IREC=1,NRECS ADDRES1.406
Im_ident = LIST_S(st_model_code,IREC) GSS1F400.867
Sm_ident = SUBMODEL_PARTITION_INDEX(Im_ident) GSS3F401.208
ADDRES1.409
IF (LIST_S(st_output_code,IREC).EQ.2) THEN ADDRES1.410
LIST_S(st_output_addr,IREC) =LIST_S(st_output_addr,IREC) GSS3F401.209
& + LPRIM(Sm_ident)+LDUMP(Sm_ident)+LEXTRA(Sm_ident) GSS3F401.210
C Information for preliminary D1 addressing array GSM2F403.147
N_OBJ_D1(Sm_ident) =N_OBJ_D1(Sm_ident)+1 GSM2F403.148
IF (N_OBJ_D1(Sm_ident).LE.MAX_D1_LEN)THEN GSM2F403.149
D1_PADDR(d1_type,N_OBJ_D1(Sm_ident),Sm_ident)=seco GSM2F403.150
D1_PADDR(d1_im,N_OBJ_D1(Sm_ident),Sm_ident)=Im_ident GSM2F403.151
D1_PADDR(d1_extra_info,N_OBJ_D1(Sm_ident),Sm_ident)=IREC GSM2F403.152
ENDIF GSM2F403.153
IF (Im_ident.EQ.O_IM) THEN GSS3F401.211
LIST_S(st_output_addr,IREC)=LIST_S(st_output_addr,IREC) GSS3F401.212
& + LPRIM_O2 GSS3F401.213
END IF ADDRES1.425
END IF ADDRES1.426
END DO ADDRES1.427
ADDRES1.428
! 3. Set input addresses and work lengths for non-primary ADDRES1.430
! fields (i.e., ISPACE=0,1,6 or 7) GSS3F401.214
DO Im_ident=1,N_INTERNAL_MODEL_MAX GSS1F400.871
Sm_ident= SUBMODEL_PARTITION_INDEX(Im_ident) GSS3F401.215
DO ISEC =0,PPXREF_SECTIONS GSS1F400.872
! Re-initialise sectional work lengths GSS3F401.216
DO I=1,N_SUBMODEL_PARTITION_MAX GSS3F401.217
LWORK_S(I)=0 GSS3F401.218
END DO GSS3F401.219
DO IITM =1,PPXREF_ITEMS GSS1F400.876
IF(INDX_S(2,Im_ident,ISEC,IITM).GT.0) THEN GSS1F400.877
! Item in STASH list GSS1F400.878
! Obtain space code & section zero point-back code GSS3F401.220
! from ppxref lookup array GSS3F401.221
ISPACE = EXPPXI(Im_ident,ISEC,IITM,ppx_space_code , GSS1F400.879
*CALL ARGPPX ADDRES1.447
& ErrorStatus,CMESSAGE) ADDRES1.448
PTR_PROG= EXPPXI(Im_ident,ISEC,IITM,ppx_ptr_code , GSS1F400.880
*CALL ARGPPX ADDRES1.450
& ErrorStatus,CMESSAGE) ADDRES1.451
IF ( (ISPACE.EQ.0).OR.(ISPACE.EQ.1).OR. GSS1F403.40
& (ISPACE.EQ.6).OR.(ISPACE.EQ.7) ) THEN GSS1F403.41
! Compute length of work space required ADDRES1.455
IF (ISPACE.NE.7) THEN ADDRES1.457
! STASH_WORK address & length GSS3F401.222
IN_S(1,Im_ident,ISEC,IITM)=LWORK_S(Sm_ident)+1 GSS3F401.223
LWORK_S(Sm_ident)=LWORK_S(Sm_ident) GSS3F401.224
& +IN_S(2,Im_ident,ISEC,IITM) GSS3F401.225
ELSE ADDRES1.470
! Point-back to primary space in section 0 GSS3F401.226
IN_S(1,Im_ident,ISEC,IITM ) GSS3F401.227
& =IN_S(1,Im_ident,0 ,PTR_PROG) GSS3F401.228
IN_S(2,Im_ident,ISEC,IITM ) GSS1F400.892
& =IN_S(2,Im_ident,0 ,PTR_PROG) GSS1F400.893
END IF ADDRES1.475
END IF ADDRES1.476
END IF ADDRES1.477
END DO ! Items ADDRES1.479
ADDRES1.480
! Find max sectional work length for each submodel partition GSS3F401.229
DO I=1,N_SUBMODEL_PARTITION_MAX GSS3F401.230
LWORK(I)=MAX(LWORK(I),LWORK_S(I)) GSS3F401.231
END DO GSS3F401.232
ADDRES1.486
END DO ! Sections ADDRES1.487
IF(Sm_ident.NE.0)THEN GSM2F403.154
C Save the maximum value for dimensioning full D1 address array GSM2F403.155
N_OBJ_D1_MAX=MAX(N_OBJ_D1_MAX,N_OBJ_D1(Sm_ident)) GSM2F403.156
WRITE(6,*)N_OBJ_D1(Sm_ident),' D1 items in submodel ',Sm_ident GSM2F403.157
ENDIF GSM2F403.158
END DO ! Models ADDRES1.488
IF(N_OBJ_D1_MAX.GT.MAX_D1_LEN)THEN GSM2F403.159
WRITE(6,*)'ADDRES1: No of items in D1 exceeds maximum allowed:' GSM2F403.160
WRITE(6,*)'Number allowed ',MAX_D1_LEN,' Number requested ' GSM2F403.161
& ,N_OBJ_D1_MAX GSM2F403.162
WRITE(6,*)'Modify the COMDECK STEXTEND to increase' GSM2F403.163
WRITE(6,*)'MAX_D1_LEN parameter as required' GSM2F403.164
WRITE(6,*)'Such a change can be safely made' GSM2F403.165
CMESSAGE='ADDRES1: No of D1 items exceeds max: See output' GSM2F403.166
ErrorStatus=1 GSM2F403.167
ENDIF GSM2F403.168
*ENDIF ADDRES1.491
ADDRES1.492
9999 CONTINUE GPB1F402.246
RETURN ADDRES1.493
END ADDRES1.494
ADDRES1.495
!- End of subroutine code ------------------------------------------- ADDRES1.496
ADDRES1.497
ADDRES1.498
!+Compute data lengths and addresses for primary fields GSS3F401.233
! Subroutine Interface: ADDRES1.500
SUBROUTINE PRIMARY(IITM,Im_index,Im_ident,Sm_ident, 1,11GSS3F401.234
& RLEVS,RADDRESS,PIrow,ErrorStatus,CMESSAGE) GSS3F401.235
IMPLICIT NONE ADDRES1.504
! Description: ADDRES1.505
! ADDRES1.506
! Method: ADDRES1.507
! ADDRES1.508
! Current code owner: S.J.Swarbrick ADDRES1.509
! ADDRES1.510
! History: ADDRES1.511
! Version Date Comment ADDRES1.512
! ======= ==== ======= ADDRES1.513
! 3.5 Apr. 95 Original code. S.J.Swarbrick ADDRES1.514
! 4.0 Oct. 95 S.J.Swarbrick GSS3F401.236
! 4.1 Apr. 96 Generalisation GSS3F401.237
! of routine S.J.Swarbrick GSS3F401.238
! 4.2 28/11/96 MPP code : Added calculation of global (dump) GPB1F402.247
! lengths GPB1F402.248
! Generalise code for dual-time level prognostics GSS1F403.36
! S.J.Swarbrick GSS1F403.37
! ADDRES1.515
! Code description: ADDRES1.516
! FORTRAN 77 + common Fortran 90 extensions. ADDRES1.517
! Written to UM programming standards version 7. ADDRES1.518
! ADDRES1.519
! System component covered: ADDRES1.520
! System task: Sub-Models Project ADDRES1.521
! ADDRES1.522
! Global variables: ADDRES1.523
*CALL CSUBMODL ADDRES1.525
*CALL VERSION ADDRES1.526
*CALL TYPSIZE GSS3F401.239
*CALL MODEL ADDRES1.527
*CALL CSTASH GRB0F401.4
*CALL STEXTEND ADDRES1.529
*IF DEF,RECON ADDRES1.530
*CALL NRECON ADDRES1.531
*ENDIF ADDRES1.532
*IF DEF,MPP GPB1F402.249
*CALL PARPARM GPB1F402.250
*ENDIF GPB1F402.251
ADDRES1.533
! Subroutine arguments: ADDRES1.534
! Scalar arguments with intent(in): GSS3F401.240
INTEGER IITM ! Current section 0 item number GSS1F400.896
INTEGER Im_ident ! Current internal model number GSS1F400.897
INTEGER Im_index ! Current position in internal model list GSS1F400.898
INTEGER Sm_ident ! Submodel identifier (absolute) GSS3F401.241
! Scalar arguments with intent(out): GSS3F401.242
CHARACTER*80 CMESSAGE GSS3F401.243
ADDRES1.543
! ErrorStatus: ADDRES1.544
INTEGER ErrorStatus ADDRES1.545
ADDRES1.546
! Local scalars: ADDRES1.547
LOGICAL MODEL_LEV GSS3F401.244
LOGICAL LADDR ADDRES1.549
LOGICAL LMASK ADDRES1.550
INTEGER RLEVS ! No. of levels for reconfiguration GSS3F401.245
INTEGER DLEVS ! No of levels inc pseudo levels GSM2F403.169
INTEGER RPLEVS ! & of pseudo-levels AWI1F403.101
INTEGER RADDRESS ! Address for reconfiguration GSS3F401.246
INTEGER I ADDRES1.554
INTEGER IL1,IL2 GSS3F401.247
INTEGER IPL1,IPL2 GSS3F401.248
INTEGER LEN ! Data length for primary field GSS3F401.249
*IF DEF,MPP GPB1F402.252
INTEGER global_LEN ! Global data length for primary field GPB1F402.253
*ENDIF GPB1F402.254
INTEGER PIrow ! Counter for ProgItems array GSS3F401.250
ADDRES1.559
LOGICAL VAR_RECON UIE2F404.120
! Function and subroutine calls: ADDRES1.560
LOGICAL DISCT_LEV GSS3F401.251
EXTERNAL TSTMSK,ADDRLN,LEVCOD,OCNVOL ADDRES1.562
ADDRES1.563
!- End of Header --------------------------------------------------- ADDRES1.564
ADDRES1.565
! Find out whether the primary is included for this version GSS3F401.252
CALL TSTMSK(Im_ident,0,LMASK,LADDR,ErrorStatus,CMESSAGE) GSS3F401.253
IF (LADDR) THEN ADDRES1.568
IF (ISPACE.EQ.10) THEN GSM4F404.3
! Space code 10 means: no space is required for this item in D1 or GSM4F404.4
! the dump, but stashmaster data is required, so an "address" of GSM4F404.5
! -1 is set to ensure that the corresponding record will be read GSM4F404.6
! into PPXI in routine GET_PPX_PART (called by U_MODEL). GSM4F404.7
IN_S(1,Im_ident,0,IITM)=-1 GSM4F404.8
ELSE GSM4F404.9
ADDRES1.570
! Start address for model levels in PP array GSS3F401.254
PPIND_S(Im_ident,IITM) = NHEAD(Im_ident)+1 GSS3F401.255
GSS3F401.256
! Find address length per level GSS3F401.257
*IF -DEF,MPP GPB1F402.255
CALL ADDRLN(IGP,LEN,ErrorStatus) GSS3F401.258
*ELSE GPB1F402.256
CALL ADDRLN(IGP,LEN,local_data,ErrorStatus) GPB1F402.257
CALL ADDRLN(IGP,global_LEN,global_dump_data,ErrorStatus) GPB1F402.258
*ENDIF GPB1F402.259
GSS3F401.259
MODEL_LEV=DISCT_LEV(ILEV,ErrorStatus,CMESSAGE) GSS3F401.260
IF (MODEL_LEV .OR.(ILEV.EQ.5 .AND. IPSEUDO.NE.0)) THEN GSS1F403.42
! Field has model levels - decode level codes GSS3F401.262
IF (ILEV .NE. 5) THEN GSS1F403.43
CALL LEVCOD(IBOT,IL1,ErrorStatus,CMESSAGE) GSS3F401.263
CALL LEVCOD(ITOP,IL2,ErrorStatus,CMESSAGE) GSS3F401.264
ELSE GSS1F403.44
IL1=1 GSS1F403.45
IL2=1 GSS1F403.46
END IF GSS1F403.47
! No. of model levels (for reconfiguration) GSS3F401.265
RLEVS=IL2-IL1+1 GSS3F401.266
! No. of model levels for D1 addressing GSM2F403.170
DLEVS=RLEVS GSM2F403.171
! Initialise first & last pseudo level indices GSS3F401.267
IPL1 =0 GSS3F401.268
IPL2 =0 GSS3F401.269
IF (IFLAG.EQ.0.AND.IPSEUDO.NE.0) THEN GSS3F401.270
! Primary with input on all available pseudo levels - GSS3F401.271
! decode pseudo level codes GSS3F401.272
CALL PSLEVCOD(IPFIRST,IPL1,'F',ErrorStatus,CMESSAGE) GSS3F401.273
CALL PSLEVCOD(IPLAST ,IPL2,'L',ErrorStatus,CMESSAGE) GSS3F401.274
DLEVS=DLEVS*(IPL2-IPL1+1) GSM2F403.172
END IF GSS3F401.275
RPLEVS=IPL2-IPL1+1 AWI1F403.102
! Multiply length per level by no. of levels GSS3F401.276
IF(LEN.EQ.-1) THEN !Grid codes 31,32 GSS3F401.277
CALL OCNVOL(LEN,IL1,IL2) GSS3F401.278
*IF DEF,MPP GPB1F402.260
CALL OCNVOL(global_LEN,IL1,IL2) GPB1F402.261
*ENDIF GPB1F402.262
ELSE GSS3F401.279
LEN=LEN*(IL2-IL1+1)*(IPL2-IPL1+1) GSS3F401.280
*IF DEF,MPP GPB1F402.263
global_LEN=global_LEN*(IL2-IL1+1)*(IPL2-IPL1+1) GPB1F402.264
*ENDIF GPB1F402.265
END IF GSS3F401.281
IF (ISPACE.NE.4.AND.ISPACE.NE.9) THEN GSM2F403.173
! Increment no. of headers GSS3F401.283
NHEAD (Im_ident)= NHEAD(Im_ident) GSS3F401.284
& +(IL2-IL1+1)*(IPL2-IPL1+1) GSS3F401.285
NHeadSub(Sm_ident)=NHeadSub(Sm_ident) GSS3F401.286
& +(IL2-IL1+1)*(IPL2-IPL1+1) GSS3F401.287
END IF GSS3F401.288
ELSE GSS3F401.289
! Not model levels GSS3F401.290
RLEVS=1 GSS3F401.291
DLEVS=1 GSM2F403.174
RPLEVS=1 AWI1F403.103
IF (ISPACE.NE.4.AND.ISPACE.NE.9) THEN GDG0F404.3
NHEAD (Im_ident)=NHEAD (Im_ident)+1 GSS3F401.293
NHeadSub(Sm_ident)=NHeadSub(Sm_ident)+1 GSS3F401.294
END IF GSS3F401.295
END IF ADDRES1.577
ADDRES1.578
! The input start address for primary (m,0,i) is assigned GSS3F401.296
! to IN_S(1,m,0,i). GSS3F401.297
! Addresses are set relative to the beginning of the primary data, ADDRES1.620
! since the primary data starts at the beginning of D1. ADDRES1.621
*IF -DEF,RECON ADDRES1.622
IF(ISPACE.NE.5) THEN ADDRES1.623
*ENDIF ADDRES1.624
IF(ISPACE.NE.9) THEN GSM2F403.175
! Start address for this primary field GSS3F401.298
IN_S(1,Im_ident,0,IITM)=LPRIM(Sm_ident)+1 GSS3F401.299
! Increment LPRIM by LEN (=data length for this primary field) GSS3F401.300
LPRIM (Sm_ident) =LPRIM (Sm_ident)+LEN GSS3F401.301
LPrimIM(Im_ident) =LPrimIM(Im_ident)+LEN GSS3F401.302
C Information for preliminary D1 addressing array GSM2F403.176
N_OBJ_D1(Sm_ident) =N_OBJ_D1(Sm_ident)+1 GSM2F403.177
IF (N_OBJ_D1(Sm_ident).LE.MAX_D1_LEN)THEN GSM2F403.178
D1_PADDR(d1_type,N_OBJ_D1(Sm_ident),Sm_ident)=prog GSM2F403.179
D1_PADDR(d1_im,N_OBJ_D1(Sm_ident),Sm_ident)=Im_ident GSM2F403.180
D1_PADDR(d1_extra_info,N_OBJ_D1(Sm_ident),Sm_ident)=IITM GSM2F403.181
D1_PADDR(d1_levs,N_OBJ_D1(Sm_ident),Sm_ident)=DLEVS GSM2F403.182
ENDIF GSM2F403.183
*IF DEF,MPP GPB1F402.266
global_LPRIM (Sm_ident) =global_LPRIM (Sm_ident)+global_LEN GPB1F402.267
global_LPrimIM(Im_ident) =global_LPrimIM(Im_ident)+global_LEN GPB1F402.268
*ENDIF GPB1F402.269
! Dual addresses for ocean fields with dual time level GSS3F401.303
IF(ISPACE.EQ.8) THEN GSS1F403.48
LPRIM_O2 =LPRIM_O2+LEN GSS3F401.305
C Information for preliminary D1 addressing array GSM2F403.184
N_OBJ_D1(Sm_ident) =N_OBJ_D1(Sm_ident)+1 GSM2F403.185
IF (N_OBJ_D1(Sm_ident).LE.MAX_D1_LEN)THEN GSM2F403.186
D1_PADDR(d1_type,N_OBJ_D1(Sm_ident),Sm_ident)=extra_d1 GSM2F403.187
D1_PADDR(d1_im,N_OBJ_D1(Sm_ident),Sm_ident)=Im_ident GSM2F403.188
D1_PADDR(d1_extra_info,N_OBJ_D1(Sm_ident),Sm_ident)=IITM GSM2F403.189
D1_PADDR(d1_levs,N_OBJ_D1(Sm_ident),Sm_ident)=DLEVS GSM2F403.190
ENDIF GSM2F403.191
END IF ADDRES1.640
*IF DEF,RECON ADDRES1.642
! Increment NProgItems for this model; add item no. to ProgItems ADDRES1.643
VAR_RECON=.FALSE. UIE2F404.121
IF (.NOT.VAR_RECON) THEN UIE2F404.122
IF (IITM.NE.4.AND.IITM.NE.10) THEN ADDRES1.644
NProgItems(Im_index) = NProgItems(Im_index) + 1 GSS3F401.306
PIrow = PIrow + 1 GSS3F401.307
ProgItems (Im_index,PIrow)= IITM GSS3F401.308
END IF ADDRES1.648
END IF UIE2F404.123
*ENDIF ADDRES1.654
ELSE ! Space = 9 GSM2F403.192
C These are EXNER etc items. Record the address relative GSM2F403.193
C to start of LEXTRA space in D1. A loop in ADDRES GSM2F403.194
C will then add on LPRIM and LDUMP GSM2F403.195
IN_S(1,Im_ident,0,IITM)=LEXTRA(Sm_ident)+1 GSM2F403.196
LEXTRA(Sm_ident) = LEXTRA(Sm_ident)+LEN GSM2F403.197
C Information for preliminary D1 addressing array GSM2F403.198
N_OBJ_D1(Sm_ident) =N_OBJ_D1(Sm_ident)+1 GSM2F403.199
IF (N_OBJ_D1(Sm_ident).LE.MAX_D1_LEN)THEN GSM2F403.200
D1_PADDR(d1_type,N_OBJ_D1(Sm_ident),Sm_ident)=extra_d1 GSM2F403.201
D1_PADDR(d1_im,N_OBJ_D1(Sm_ident),Sm_ident)=Im_ident GSM2F403.202
D1_PADDR(d1_extra_info,N_OBJ_D1(Sm_ident),Sm_ident)=IITM GSM2F403.203
D1_PADDR(d1_levs,N_OBJ_D1(Sm_ident),Sm_ident)=DLEVS GSM2F403.204
ENDIF GSM2F403.205
ENDIF GSM2F403.206
*IF -DEF,RECON ADDRES1.655
ELSE ADDRES1.656
! ISP=5 means: set address of prim var in dump only. GSS3F401.309
! D1 address is then set to same address as previous item GSS3F401.310
IN_S(1,Im_ident,0,IITM)=IN_S(1,Im_ident,0,IITM-1) GSS1F400.921
END IF ADDRES1.661
*ENDIF ADDRES1.662
! The input length for primary (m,0,i) is assigned to IN_S(2,m,0,i). ADDRES1.663
IN_S(2,Im_ident,0,IITM)=LEN GSS1F400.922
ADDRES1.665
! Store levels, lengths and addresses required for reconfiguration ADDRES1.666
! in array Recondat ADDRES1.667
*IF DEF,RECON ADDRES1.669
IF (ISPACE.NE.4.AND.ISPACE.NE.9) THEN GSM2F403.207
Recondat(Im_index,IITM,1)=RLEVS GSS3F401.311
Recondat(Im_index,IITM,2)=LEN GSS3F401.312
Recondat(Im_index,IITM,3)=RADDRESS GSS3F401.313
Recondat(Im_index,IITM,4)=RPLEVS AWI1F403.104
RADDRESS =RADDRESS+LEN GSS3F401.314
END IF ADDRES1.680
*ENDIF GSS3F401.315
END IF ! ISPACE .ne. 10 GSM4F404.10
END IF ! LADDR ADDRES1.684
ADDRES1.685
RETURN ADDRES1.686
END ADDRES1.687
GSS3F401.316
!+Test whether level type is discrete (model) or continuous (non-model) GSS3F401.317
! Function Interface: GSS3F401.318
LOGICAL FUNCTION DISCT_LEV(LEV_CODE,ErrorStatus,CMESSAGE) 8GSS3F401.319
IMPLICIT NONE GSS3F401.320
GSS3F401.321
! Description: GSS3F401.322
! GSS3F401.323
! Method: GSS3F401.324
! GSS3F401.325
! Current code owner: S.J.Swarbrick GSS3F401.326
! GSS3F401.327
! History: GSS3F401.328
! Version Date Comment GSS3F401.329
! ======= ==== ======= GSS3F401.330
! 4.1 Apr. 96 Original code. S.J.Swarbrick GSS3F401.331
! Code description: GSS3F401.332
! FORTRAN 77 + common Fortran 90 extensions. GSS3F401.333
! Written to UM programming standards version 7. GSS3F401.334
! GSS3F401.335
! System component covered: GSS3F401.336
! System task: Sub-Models Project GSS3F401.337
! GSS3F401.338
! Global variables: GSS3F401.339
*CALL CSUBMODL GSS3F401.340
*CALL VERSION GSS3F401.341
*CALL MODEL GSS3F401.342
GSS3F401.343
! Function arguments: GSS3F401.344
! Scalar arguments with intent(in): GSS3F401.345
INTEGER LEV_CODE !Level code from STASHmaster GSS3F401.346
GSS3F401.347
! ErrorStatus GSS3F401.348
INTEGER ErrorStatus GSS3F401.349
CHARACTER*80 CMESSAGE GSS3F401.350
GSS3F401.351
!- End of Header ---------------------------------------------- GSS3F401.352
GSS3F401.353
IF (LEV_CODE.EQ.1 .OR. LEV_CODE.EQ.2 .OR. LEV_CODE.EQ.6 .OR. GSS3F401.354
& LEV_CODE.EQ.10) THEN GSS3F401.355
DISCT_LEV=.TRUE. GSS3F401.356
ELSE IF (LEV_CODE .GE. 0 .AND. LEV_CODE .LE. 10) THEN GSS3F401.357
DISCT_LEV=.FALSE. GSS3F401.358
ELSE GSS3F401.359
DISCT_LEV=.FALSE. GSS3F401.360
ErrorStatus=1 GSS3F401.361
CMESSAGE='DISCT_LEV : Invalid level type in STASHmaster' GSS3F401.362
END IF GSS3F401.363
END GSS3F401.364
!- End of Function code -------------------------------------------- GSS3F401.365
GSS3F401.366
!+Decode the STASH pseudo level code GSS3F401.367
! Subroutine Interface: GSS3F401.368
SUBROUTINE PSLEVCOD(ILIN,ILOUT,SWTCH,ErrorStatus,CMESSAGE) 4GSS3F401.369
IMPLICIT NONE GSS3F401.370
! Description: GSS3F401.371
! Sets ILOUT to an appropriate pseudo level size according GSS3F401.372
! to the value of IL GSS3F401.373
! Level sizes are parametrised in comdeck MODEL. GSS3F401.374
! GSS3F401.375
! Current code owner: S.J.Swarbrick GSS3F401.376
! GSS3F401.377
! History: GSS3F401.378
! Version Date Comment GSS3F401.379
! ======= ==== ======= GSS3F401.380
! 4.1 Apr. 96 Original code. S.J.Swarbrick GSS3F401.381
! 4.4 29/9/97 Allow for surface type pseudo-levels. R.A.Betts ABX2F404.70
! GSS3F401.382
! Code description: GSS3F401.383
! FORTRAN 77 + common Fortran 90 extensions. GSS3F401.384
! Written to UM programming standards version 7. GSS3F401.385
! GSS3F401.386
! System component covered: GSS3F401.387
! System task: Sub-Models Project GSS3F401.388
! GSS3F401.389
! Global variables: GSS3F401.390
*CALL CSUBMODL GSS3F401.391
*CALL VERSION GSS3F401.392
*CALL MODEL GSS3F401.393
*CALL TYPSIZE GSS3F401.394
*CALL CNTLATM GSS3F401.395
*CALL CSENARIO AWI1F403.56
*CALL NSTYPES ABX2F404.71
GSS3F401.396
! Subroutine arguments: GSS3F401.397
! Scalar arguments with intent(in): GSS3F401.398
INTEGER ILIN ! Model pseudo level code GSS3F401.399
CHARACTER*1 SWTCH GSS3F401.400
GSS3F401.401
! Scalar arguments with intent(out): GSS3F401.402
INTEGER ILOUT ! An actual pseudo level GSS3F401.403
CHARACTER*80 CMESSAGE GSS3F401.404
GSS3F401.405
! Local scalars: GSS3F401.406
INTEGER I GSS3F401.407
INTEGER J GSS3F401.408
GSS3F401.409
! Error Status: GSS3F401.410
INTEGER ErrorStatus GSS3F401.411
GSS3F401.412
!- End of Header -------------------------------------------------- GSS3F401.413
GSS3F401.414
IF (SWTCH.EQ.'F') THEN GSS3F401.415
IF(ILIN.EQ.1) THEN GSS3F401.416
ILOUT=1 GSS3F401.417
! Ocean assimilation groups GSS3F401.418
ELSE IF(ILIN.EQ.41) THEN GSS3F401.419
ILOUT=OASLEV(1) GSS3F401.420
ELSE IF(ILIN.EQ.42) THEN GSS3F401.421
ILOUT=OASLEV(2) GSS3F401.422
ELSE IF(ILIN.EQ.43) THEN GSS3F401.423
ILOUT=OASLEV(3) GSS3F401.424
ELSE IF(ILIN.EQ.44) THEN GSS3F401.425
ILOUT=OASLEV(4) GSS3F401.426
ELSE IF(ILIN.EQ.45) THEN GSS3F401.427
ILOUT=OASLEV(5) GSS3F401.428
ELSE IF(ILIN.EQ.46) THEN GSS3F401.429
ILOUT=OASLEV(6) GSS3F401.430
ELSE GSS3F401.431
WRITE(6,*) GSS3F401.432
& 'MSG FROM PSLEVCOD: ', GSS3F401.433
& 'INAPPROPRIATE FIRST PSEUDO LEVEL CODE FOUND ',ILIN GSS3F401.434
ErrorStatus=2 GSS3F401.435
END IF GSS3F401.436
ELSE IF (SWTCH.EQ.'L') THEN GSS3F401.437
IF(ILIN.EQ.1) THEN GSS3F401.438
ILOUT=H_SWBANDS GSS3F401.439
ELSE IF(ILIN.EQ.2) THEN GSS3F401.440
ILOUT=H_LWBANDS GSS3F401.441
ELSE IF(ILIN.EQ.4) THEN GSS3F401.442
! Last frequency (wave model) GSS3F401.443
ILOUT=NFRE GSS3F401.444
ELSE IF(ILIN.EQ.5) THEN GSS3F401.445
! Last wave train (wave model) GSS3F401.446
ILOUT=NWTRAIN GSS3F401.447
ELSEIF ( ILIN .EQ. 6 ) THEN AWI1F403.57
! Last index for HadCM2 sulphate loading patterns. AWI1F403.58
ILOUT = NSULPAT AWI1F403.59
ELSEIF ( ILIN .EQ. 7 ) THEN ABX2F404.72
! All surface types ABX2F404.73
ILOUT = NTYPE ABX2F404.74
ELSEIF ( ILIN .EQ. 8 ) THEN ABX2F404.75
! Plant functional types only ABX2F404.76
ILOUT = NPFT ABX2F404.77
ELSEIF ( ILIN .EQ. 9 ) THEN ABX2F404.78
! All surface types except ice ABX2F404.79
ILOUT = NTYPE-1 ABX2F404.80
ELSE GSS3F401.448
WRITE(6,*) GSS3F401.449
& 'MSG FROM PSLEVCOD: ', GSS3F401.450
& 'INAPPROPRIATE LAST PSEUDO LEVEL CODE FOUND ',ILIN GSS3F401.451
ErrorStatus=2 GSS3F401.452
END IF GSS3F401.453
GSS3F401.454
END IF GSS3F401.455
GSS3F401.456
RETURN GSS3F401.457
END GSS3F401.458
*ENDIF ADDRES1.688