SUBROUTINE INACTR( 1,11INACTR1.7
*CALL ARGPPX 
INACTR1.8
& NRECS,ErrorStatus,CMESSAGE) GSS3F401.459
IMPLICIT NONE INACTR1.10
INACTR1.11
! Description: INACTR1.12
! INACTR1.13
! Method: INACTR1.14
! INACTR1.15
! Current code owner: S.J.Swarbrick INACTR1.16
! INACTR1.17
! History: INACTR1.18
! Version Date Comment INACTR1.19
! ======= ==== ======= INACTR1.20
! 3.5 Mar. 95 Original code. S.J.Swarbrick INACTR1.21
! 4.0 Oct. 95 S.J.Swarbrick GSS1F400.929
! 4.1 Apr. 96 Add ErrorStatus arguments & general GSS3F401.460
! improvements S.J.Swarbrick GSS3F401.461
! 4.5 Jul. 98 Clarify error message. S.D.Mullerworth GSM2F405.25
! INACTR1.22
! Code description: INACTR1.23
! FORTRAN 77 + common Fortran 90 extensions. INACTR1.24
! Written to UM programming standards version 7. INACTR1.25
! INACTR1.26
! System component covered: INACTR1.27
! System task: Sub-Models Project INACTR1.28
! INACTR1.29
! Global variables: INACTR1.30
*CALL CSUBMODL INACTR1.32
*CALL CPPXREF INACTR1.33
*CALL PPXLOOK GSS3F401.462
*CALL TYPSIZE GSS3F401.463
*CALL CSTASH GRB0F401.15
*CALL STEXTEND INACTR1.36
*CALL MODEL INACTR1.37
*CALL STPARAM INACTR1.38
INACTR1.40
! Subroutine arguments: INACTR1.41
! Scalar arguments with intent(in): INACTR1.43
INTEGER NRECS INACTR1.45
! Scalar arguments with intent(out): GSS3F401.464
CHARACTER*80 CMESSAGE GSS9F402.168
INACTR1.46
! ErrorStatus: INACTR1.47
INTEGER ErrorStatus INACTR1.48
INACTR1.49
! Local scalars INACTR1.50
LOGICAL LMASK INACTR1.52
LOGICAL LIMPLIED INACTR1.53
LOGICAL LDUM INACTR1.54
INTEGER I INACTR1.56
INTEGER ITEM INACTR1.57
INTEGER ISEC INACTR1.58
INTEGER Im_ident GSS1F400.930
INTEGER Im_index GSS1F400.931
INTEGER LBVC INACTR1.60
INACTR1.61
! Function and subroutine calls: INACTR1.62
INTEGER EXPPXI INACTR1.64
EXTERNAL EXPPXI,IMPLIED,TSTMSK,ADDIN INACTR1.65
INACTR1.66
!- End of Header ------------------------------------------------------ INACTR1.67
INACTR1.68
INACTR1.69
DO Im_ident=1,N_INTERNAL_MODEL_MAX GSS1F400.932
Im_index = INTERNAL_MODEL_INDEX(Im_ident) GSS1F400.933
IF (Im_index.GT.0) THEN GSS1F400.934
DO ISEC =0,PPXREF_SECTIONS GSS1F400.935
DO ITEM =1,PPXREF_ITEMS GSS1F400.936
INACTR1.73
IF ((INDX_S(2,Im_ident,ISEC,ITEM).EQ.0).AND. GSS1F400.937
& (PPXPTR( Im_index,ISEC,ITEM).NE.0)) THEN GSS1F400.938
INACTR1.76
! No requests for this diag; check whether it is an implied diag., INACTR1.77
! or one for which space is always required INACTR1.78
INACTR1.79
VMSK = EXPPXI(Im_ident ,ISEC ,ITEM ,ppx_version_mask, GSS1F400.939
*CALL ARGPPX INACTR1.81
& ErrorStatus,CMESSAGE) INACTR1.82
ISPACE = EXPPXI(Im_ident ,ISEC ,ITEM ,ppx_space_code , GSS1F400.940
*CALL ARGPPX INACTR1.84
& ErrorStatus,CMESSAGE) INACTR1.85
ILEV = EXPPXI(Im_ident ,ISEC ,ITEM ,ppx_lv_code , GSS1F400.941
*CALL ARGPPX INACTR1.87
& ErrorStatus,CMESSAGE) INACTR1.88
IBOT = EXPPXI(Im_ident ,ISEC ,ITEM ,ppx_lb_code , GSS1F400.942
*CALL ARGPPX INACTR1.90
& ErrorStatus,CMESSAGE) INACTR1.91
ITOP = EXPPXI(Im_ident ,ISEC ,ITEM ,ppx_lt_code , GSS1F400.943
*CALL ARGPPX INACTR1.93
& ErrorStatus,CMESSAGE) INACTR1.94
IFLAG = EXPPXI(Im_ident ,ISEC ,ITEM ,ppx_lev_flag , GSS1F400.944
*CALL ARGPPX INACTR1.96
& ErrorStatus,CMESSAGE) INACTR1.97
DO I=1,4 GSS3F401.466
IOPN(I) = EXPPXI(Im_ident ,ISEC ,ITEM ,ppx_opt_code+I-1, GSS3F401.467
*CALL ARGPPX INACTR1.99
& ErrorStatus,CMESSAGE) INACTR1.100
END DO GSS3F401.468
LBVC = EXPPXI(Im_ident ,ISEC ,ITEM ,ppx_lbvc_code , GSS1F400.946
*CALL ARGPPX INACTR1.102
& ErrorStatus,CMESSAGE) INACTR1.103
INACTR1.104
! Check whether this diag is implied by any of INACTR1.105
! the other diags in LIST_S INACTR1.106
INACTR1.107
IF(ISPACE.EQ.6) THEN INACTR1.108
CALL IMPLIED GSS3F401.469
& (Im_ident,ISEC,ITEM,LIMPLIED,ErrorStatus,CMESSAGE) GSS3F401.470
ELSE INACTR1.110
LIMPLIED=.FALSE. INACTR1.111
END IF INACTR1.112
INACTR1.113
IF((ISPACE.EQ.1).OR.LIMPLIED)THEN INACTR1.114
! Check availability of diag INACTR1.115
CALL TSTMSK GSS3F401.471
& (Im_ident,ISEC,LMASK,LDUM,ErrorStatus,CMESSAGE) GSS3F401.472
IF(LMASK.AND.(NRECS.LT.NRECDP)) THEN INACTR1.117
! Diag to be included INACTR1.118
NRECS=NRECS+1 INACTR1.119
! Add diag to LIST_S INACTR1.120
CALL ADDIN GSS3F401.473
& (NRECS,ITEM,ISEC,Im_ident,LBVC,ErrorStatus,CMESSAGE) GSS3F401.474
ELSE IF (NRECS.GE.NRECDP) THEN INACTR1.122
WRITE(6,*)'ERROR, INACTR: TOO MANY S_LIST ENTRIES ' GSS1F400.950
& ,'CANNOT ADD ENTRIES FOR ARRAYS REQUIRED BY THE MODEL' GSS1F400.951
END IF INACTR1.126
END IF INACTR1.127
INACTR1.128
END IF ! INDX_S INACTR1.129
INACTR1.130
END DO ! Items GSS1F400.952
END DO ! Sections GSS1F400.953
END IF ! Im_index>0 GSS1F400.954
END DO ! Models INACTR1.133
INACTR1.134
RETURN INACTR1.164
END INACTR1.165
INACTR1.166
INACTR1.167
!+Find whether ST_list entry (Im_ident,ISEC,ITEM) is an implied diag GSS1F400.955
! Subroutine Interface: INACTR1.169
INACTR1.170
SUBROUTINE IMPLIED 1,5GSS3F401.475
&(Im_ident,ISEC,ITEM,LIMPLIED,ErrorStatus,CMESSAGE) GSS3F401.476
IMPLICIT NONE INACTR1.172
! Description: INACTR1.173
! INACTR1.174
! Method: INACTR1.175
! INACTR1.176
! Current code owner: S.J.Swarbrick INACTR1.177
! INACTR1.178
! History: INACTR1.179
! Version Date Comment INACTR1.180
! ======= ==== ======= INACTR1.181
! 3.5 Mar. 95 Original code. S.J.Swarbrick INACTR1.182
! 4.5 09/12/97 Read the Implied data from PE 0 and GBCVF405.110
! distribute it. GBCVF405.111
! Author: Bob Carruthers GBCVF405.112
! INACTR1.183
! Code description: INACTR1.184
! FORTRAN 77 + common Fortran 90 extensions. INACTR1.185
! Written to UM programming standards version 7. INACTR1.186
! INACTR1.187
! System component covered: INACTR1.188
! System task: Sub-Models Project INACTR1.189
! INACTR1.190
! Global variables: INACTR1.191
*CALL CSUBMODL INACTR1.193
*CALL VERSION INACTR1.194
*CALL CSTASH GRB0F401.16
*CALL STEXTEND INACTR1.196
*CALL LENFIL INACTR1.197
*CALL CHSUNITS GSS1F400.957
*CALL CLFHIST GSS1F400.958
*IF DEF,MPP,AND,DEF,T3E GBCVF405.113
*CALL PARVARS GBCVF405.114
GBCVF405.115
integer info, msg GBCVF405.116
*ENDIF GBCVF405.117
INACTR1.198
! Subroutine arguments: INACTR1.199
! Scalar arguments with intent(in): INACTR1.201
INTEGER Im_ident GSS1F400.959
INTEGER ISEC INACTR1.204
INTEGER ITEM INACTR1.205
INTEGER ICODE,err ! return code GNF0F401.1
INACTR1.206
! Scalar argument with intent(out): INACTR1.207
LOGICAL LIMPLIED ! Set to T if diag is implied INACTR1.209
CHARACTER*80 CMESSAGE GSS9F402.169
INACTR1.210
! Local scalars: INACTR1.211
LOGICAL LSET ! Set to T when STASH_SET dir name has been obtained INACTR1.213
INTEGER I INACTR1.214
INTEGER J INACTR1.215
INTEGER IHOLD INACTR1.216
INTEGER N_IMPLICATORS INACTR1.217
CHARACTER*55 DIR GSS1F400.960
INACTR1.218
! Local arrays: INACTR1.219
INTEGER IMPLICS(100) INACTR1.221
GSS3F401.478
! ErrorStatus GSS3F401.479
INTEGER ErrorStatus GSS3F401.480
GSS3F401.481
GSS1F400.961
! External subroutine calls GSS1F400.962
INTEGER GETENV GSS1F400.963
INACTR1.222
! Function & Subroutine calls: GNF0F401.2
External GET_FILE,FORT_GET_ENV GNF0F401.3
!- End of Header ---------------------------------------------------- INACTR1.223
INACTR1.224
DATA LSET /.FALSE./ INACTR1.225
*IF DEF,MPP,AND,DEF,T3E GBCVF405.118
save lset, file, ihold, dir GBCVF405.119
*ELSE GBCVF405.120
SAVE FILE,IHOLD,LSET INACTR1.226
*ENDIF GBCVF405.121
INACTR1.227
! Construction of file name for "STASH sets" INACTR1.228
! (which specify implied diags) INACTR1.229
! On first call: assign directory name STASH_SET to FILE; add '/X' INACTR1.230
*IF DEF,MPP,AND,DEF,T3E GBCVF405.122
GBCVF405.123
if(.not.lset) then GBCVF405.124
dir = ' ' GBCVF405.125
stash_set = ' ' GBCVF405.126
call fort_get_env('STASETS_DIR', 11, dir, 55, err) GBCVF405.127
*ELSE GBCVF405.128
INACTR1.231
DIR =' ' GSS1F400.964
STASH_SET =' ' GSS1F400.965
C Correction for reading in the ~ctldata/stasets directory (N Farnon) GNF0F401.4
CALL FORT_GET_ENV('STASETS_DIR',11,DIR,55,err) GNF0F401.5
*ENDIF GBCVF405.129
IF (err .NE. 0) THEN GNF0F401.6
WRITE(6,*) 'Warning: Environment variable STASETS_DIR has GNF0F401.7
& not been set. Error code = ',err GNF0F401.8
*IF DEF,MPP,AND,DEF,T3E GBCVF405.130
call abort() GBCVF405.131
*ENDIF GBCVF405.132
ENDIF GNF0F401.9
*IF DEF,MPP,AND,DEF,T3E GBCVF405.133
stash_set=dir GBCVF405.134
*ELSE GBCVF405.135
STASH_SET=DIR GSS1F400.967
INACTR1.233
IF(.NOT.LSET) THEN INACTR1.234
*ENDIF GBCVF405.136
FILE=STASH_SET GSS1F400.968
LSET=.TRUE. INACTR1.236
DO J=1,55 INACTR1.237
IF (FILE(J:J).EQ.' ') THEN INACTR1.238
I = J INACTR1.239
GOTO 102 INACTR1.240
END IF INACTR1.241
END DO INACTR1.242
102 FILE(I:I+1)='/X' INACTR1.243
I=I+2 INACTR1.244
IHOLD=I INACTR1.245
END IF INACTR1.246
INACTR1.247
! Append rest of file name to FILE INACTR1.248
WRITE(FILE(IHOLD:IHOLD+9),501) Im_ident,ISEC,ITEM GSS1F400.969
501 FORMAT(I2.2,2I3.3) INACTR1.250
INACTR1.251
! Open STASH sets file; read diags listed in file into IMPLICS INACTR1.252
! These diags are implied by the diag Im_ident, ISEC, ITEM GSS1F400.970
C Error message added (N.Farnon) GNF0F401.10
*IF DEF,MPP,AND,DEF,T3E GBCVF405.137
if(mype.eq.0) then GBCVF405.138
*ENDIF GBCVF405.139
OPEN (3,FILE=FILE,IOSTAT=ICODE) GNF0F401.11
IF (ICODE.NE.0) THEN GNF0F401.12
WRITE(6,*) 'Can not open stash_sets file, ICODE=',ICODE GNF0F401.13
call abort() GBCVF405.140
ELSE GNF0F401.14
WRITE(6,*) 'OPEN: 3: ',FILE,': FILE EXISTS' GNF0F401.15
END IF GNF0F401.16
READ (3,600) N_IMPLICATORS INACTR1.255
600 FORMAT(I4) INACTR1.256
*IF DEF,MPP,AND,DEF,T3E GBCVF405.141
endif ! read on PE 0 GBCVF405.142
c GBCVF405.143
c--send the number of implicators to each PE GBCVF405.144
msg=7067 GBCVF405.145
call gc_ibcast(msg, 1, 0, nproc, info, n_implicators) GBCVF405.146
*ENDIF GBCVF405.147
c GBCVF405.148
if(n_implicators.gt.100) then GBCVF405.149
write(6,*)'IMPLIED: Too Many Implicators', GBCVF405.150
2 ' - ',N_IMPLICATORS,' Requested, but there is Space', GBCVF405.151
3 ' for only 100' GBCVF405.152
call abort() GBCVF405.153
endif GBCVF405.154
c GBCVF405.155
*IF DEF,MPP,AND,DEF,T3E GBCVF405.156
if(mype.eq.0) then GBCVF405.157
*ENDIF GBCVF405.158
READ (3,610) (IMPLICS(I),I=1,N_IMPLICATORS) INACTR1.257
610 FORMAT(10I4) INACTR1.258
*IF DEF,MPP,AND,DEF,T3E GBCVF405.159
endif ! read on PE 0 GBCVF405.160
c GBCVF405.161
msg=7068 GBCVF405.162
call gc_ibcast(msg, n_implicators, 0, nproc, info, GBCVF405.163
2 implics) GBCVF405.164
*ENDIF GBCVF405.165
INACTR1.259
!Find out whether any of the diags listed in FILE are present in LIST_S. INACTR1.260
! (Any diag in the STASH list has a non-zero entry in SINDX). If one INACTR1.261
! or more of them are present, set LIMPLIED=T - indicating that INACTR1.262
! diag Im_ident,ISEC,ITEM is implied. GSS1F400.971
INACTR1.264
DO I=1,N_IMPLICATORS INACTR1.265
IF(INDX_S(2,Im_ident,ISEC,IMPLICS(I)).NE.0) THEN GSS1F400.972
LIMPLIED=.TRUE. INACTR1.267
GO TO 9999 INACTR1.268
END IF INACTR1.269
END DO INACTR1.270
INACTR1.271
LIMPLIED=.FALSE. INACTR1.272
CLOSE(UNIT=3) GSS1F400.973
INACTR1.273
9999 RETURN INACTR1.274
END INACTR1.275
INACTR1.276
INACTR1.277
!+Add diagnostic to the STASH list (LIST_S) INACTR1.278
! Subroutine Interface: INACTR1.279
INACTR1.280
SUBROUTINE ADDIN 1,3GSS3F401.482
&(NRECS,ITEM,ISEC,Im_ident,LBVC,ErrorStatus,CMESSAGE) GSS3F401.483
IMPLICIT NONE INACTR1.282
! Description: INACTR1.283
! INACTR1.284
! Method: INACTR1.285
! INACTR1.286
! Current code owner: S.J.Swarbrick INACTR1.287
! INACTR1.288
! History: INACTR1.289
! Version Date Comment INACTR1.290
! ======= ==== ======= INACTR1.291
! 3.5 Mar. 95 Original code. S.J.Swarbrick INACTR1.292
! 4.1 May. 96 Various improvements. S.J.Swarbrick GSS3F401.484
! INACTR1.293
! Code description: INACTR1.294
! FORTRAN 77 + common Fortran 90 extensions. INACTR1.295
! Written to UM programming standards version 7. INACTR1.296
! INACTR1.297
! System component covered: INACTR1.298
! System task: Sub-Models Project INACTR1.299
! INACTR1.300
! Global variables: INACTR1.301
*CALL CSUBMODL INACTR1.303
*CALL VERSION INACTR1.304
*CALL CSTASH GRB0F401.17
*CALL STEXTEND INACTR1.306
*CALL STPARAM INACTR1.307
INACTR1.308
! Subroutine arguments: INACTR1.309
! Scalar arguments with intent(in): INACTR1.311
INTEGER NRECS INACTR1.313
INTEGER ITEM INACTR1.314
INTEGER ISEC INACTR1.315
INTEGER Im_ident GSS1F400.975
INTEGER LBVC INACTR1.317
INACTR1.318
! Scalar arguments with intent(out): GSS3F401.485
CHARACTER*80 CMESSAGE GSS9F402.170
GSS3F401.487
! Local scalars: INACTR1.319
LOGICAL MODEL_LEV GSS3F401.488
INTEGER IBOT1 INACTR1.321
INTEGER ITOP1 INACTR1.322
INACTR1.323
! ErrorStatus GSS3F401.489
INTEGER ErrorStatus GSS3F401.490
GSS3F401.491
! Function and subroutine calls: INACTR1.324
LOGICAL DISCT_LEV GSS3F401.492
EXTERNAL LEVCOD INACTR1.326
INACTR1.327
!- End of Header ---------------------------------------------------- INACTR1.328
INACTR1.329
INACTR1.330
LIST_S(st_item_code ,NRECS)=ITEM INACTR1.331
LIST_S(st_sect_no_code,NRECS)=ISEC INACTR1.332
LIST_S(st_model_code ,NRECS)=Im_ident GSS1F400.976
LIST_S(st_proc_no_code,NRECS)=0 INACTR1.334
INACTR1.335
IF(IFLAG.EQ.1)THEN GSS1F400.977
! Attempt to do vertical compression - not allowed GSS1F400.978
WRITE(6,*) GSS1F400.979
& 'INACTR: SPACECODE ',ISPACE,' INDICATES IMPLIED DIAGNOSTIC.' GSM2F405.26
WRITE(6,*) GSM2F405.27
& 'NOT ALLOWED WITH LEVEL COMPRESSION FLAG 1 - CHECK STASHMASTER' GSM2F405.28
WRITE(6,*) GSS1F400.981
& 'MODEL ',Im_ident,' SECTION ',ISEC,' ITEM ',ITEM GSS1F400.982
ELSE INACTR1.343
MODEL_LEV=DISCT_LEV(ILEV,ErrorStatus,CMESSAGE) GSS3F401.493
IF (MODEL_LEV) THEN GSS3F401.494
! Model levels GSS3F401.495
! Set bottom level GSS3F401.496
CALL LEVCOD(IBOT,IBOT1,ErrorStatus,CMESSAGE) GSS3F401.497
! Set top level GSS3F401.498
CALL LEVCOD(ITOP,ITOP1,ErrorStatus,CMESSAGE) GSS3F401.499
LIST_S(st_input_bottom,NRECS)=IBOT1 INACTR1.351
LIST_S(st_input_top ,NRECS)=ITOP1 INACTR1.352
ELSE IF(ILEV.EQ.5) THEN GSS3F401.500
LIST_S(st_input_bottom,NRECS)=100 INACTR1.356
LIST_S(st_input_top ,NRECS)=LBVC INACTR1.357
ELSE GSS3F401.501
WRITE(6,*) GSS1F400.983
& 'INACTR: LEVEL TYPE ERROR ON IMPLIED DIAGNOSTIC ', GSS1F400.984
& ' - ONLY MODEL LEVELS OR SINGLE LEVEL ALLOWED ' GSS1F400.985
WRITE(6,*) 'MODEL ',Im_ident, GSS1F400.986
& ' SECT ',ISEC,' ITEM ',ITEM,' LEV CODE ',ILEV GSS1F400.987
END IF INACTR1.366
END IF INACTR1.367
INACTR1.368
LIST_S(st_freq_code ,NRECS)=1 INACTR1.369
LIST_S(st_start_time_code,NRECS)=0 INACTR1.370
LIST_S(st_end_time_code ,NRECS)=0 INACTR1.371
LIST_S(st_period_code ,NRECS)=0 INACTR1.372
LIST_S(st_gridpoint_code ,NRECS)=1 INACTR1.373
LIST_S(st_weight_code ,NRECS)=0 INACTR1.374
LIST_S(st_north_code ,NRECS)=0 INACTR1.375
LIST_S(st_south_code ,NRECS)=0 INACTR1.376
LIST_S(st_west_code ,NRECS)=0 INACTR1.377
LIST_S(st_east_code ,NRECS)=0 INACTR1.378
LIST_S(st_input_code ,NRECS)=1 INACTR1.379
LIST_S(st_input_length ,NRECS)=0 INACTR1.380
LIST_S(st_output_code ,NRECS)=0 INACTR1.381
LIST_S(st_output_length ,NRECS)=0 INACTR1.382
LIST_S(st_output_addr ,NRECS)=0 INACTR1.383
LIST_S(st_output_bottom ,NRECS)=0 INACTR1.384
LIST_S(st_output_top ,NRECS)=0 INACTR1.385
LIST_S(st_lookup_ptr ,NRECS)=-1 INACTR1.386
LIST_S(st_series_ptr ,NRECS)=0 INACTR1.387
LIST_S(st_macrotag ,NRECS)=0 INACTR1.388
LIST_S(st_pseudo_in ,NRECS)=0 INACTR1.389
LIST_S(st_pseudo_out ,NRECS)=0 INACTR1.390
LIST_S(NELEMP+1 ,NRECS)=NRECS INACTR1.391
INACTR1.392
RETURN INACTR1.393
END INACTR1.394
*ENDIF INACTR1.395