SUBROUTINE DUPLIC(NRECS,NTIMES,NLEVELS) 1,2DUPLIC1.7
IMPLICIT NONE DUPLIC1.8
! DUPLIC1.9
! Description: DUPLIC1.10
! Deletes duplicate diagnostic entries from STASH list; deletes DUPLIC1.11
! duplicate STASH times; DUPLIC1.12
! checks for overlap of levels and times, to some extent. DUPLIC1.13
! Called by STPROC. DUPLIC1.14
! Input : NRECS No. of STASH list records DUPLIC1.15
! NTIMES No. of STASH times DUPLIC1.16
! NLEVELS No. of STASH levels DUPLIC1.17
! LIST_S STASH list array with prelim. pointer system DUPLIC1.18
! ITIM_S STASH times array DUPLIC1.19
! Output: NRECS Reduced no. of STASH list records DUPLIC1.20
! NTIMES Reduced no. of STASH times DUPLIC1.21
! NLEVEL Reduced no. of STASH levels DUPLIC1.22
! ITIM_S Reduced STASH times array DUPLIC1.23
! LIST_S Reduced STASH list with prelim. pointers, DUPLIC1.24
! consistent with STASH times. DUPLIC1.25
! DUPLIC1.26
! Method: DUPLIC1.27
! DUPLIC1.28
! (a) STASH times tables in ITIM_S. DUPLIC1.29
! The times at which STASH processing occurs for a diagnostic DUPLIC1.30
! IREC may be specified by the entries (start_time,end_time,period) DUPLIC1.31
! in LIST_S. DUPLIC1.32
! Alternatively, if LIST_S(st_freq_code,IREC) has value '-n', DUPLIC1.33
! then STASH processing times for this diagnostic are given by a DUPLIC1.34
! 'times table' in ITIM_S. DUPLIC1.35
! (In such a case, the above 3 entries in LIST_S are ignored). DUPLIC1.36
! The times table is given by column 'n' of ITIM_S, i.e., DUPLIC1.37
! ITIM_S(time,n). DUPLIC1.38
! In this routine, the logical array entry LTUSE(n) is set to DUPLIC1.39
! .TRUE. if col 'n' of ITIM_S contains a times table. Any column DUPLIC1.40
! of ITIM_S which does not contain a times table is filled with DUPLIC1.41
! -1's. The cols which contain times tables are then shuffled along, DUPLIC1.42
! so that they occupy the first NTIMES cols of ITIM_S. The pointers DUPLIC1.43
! in LIST_S(st_freq_code,IREC) are altered accordingly. DUPLIC1.44
! DUPLIC1.45
! (b) STASH levels lists in LEVLST_S. DUPLIC1.46
! The levels on which STASH processing occurs for a diagnostic DUPLIC1.47
! IREC is specified by the entries (output_bottom, output_top) in DUPLIC1.48
! LIST_S. DUPLIC1.49
! If LIST_S(bot)=m, then output is on a range of model levels, DUPLIC1.50
! with level m as the bottom level, and LIST_S(top) points to the DUPLIC1.51
! top output model level. DUPLIC1.52
! If LIST_S(bot)=-n, then there is a levels list in col 'n' of DUPLIC1.53
! LEVLST_S, and LIST_S(top) contains a code value indicating the DUPLIC1.54
! type of levels (model, pressures, heights or theta). Each levels DUPLIC1.55
! list also has a corresponding entry in LLISTTY, indicating whether DUPLIC1.56
! the list is real or integer. DUPLIC1.57
! In this routine, the cols of LEVLST_S which contain levels lists DUPLIC1.58
! are shuffled along so that they occupy the first NLEVELS cols of DUPLIC1.59
! LEVLST_S. The pointers in LIST_S(output_bottom,IREC), and the DUPLIC1.60
! entries in LLISTTY, are altered accordingly. DUPLIC1.61
! DUPLIC1.62
! Current code owner: S.J.Swarbrick DUPLIC1.63
! DUPLIC1.64
! History: DUPLIC1.65
! Version Date Comment DUPLIC1.66
! ======= ==== ======= DUPLIC1.67
! 3.5 Mar. 95 Original code. S.J.Swarbrick DUPLIC1.68
! DUPLIC1.69
! Code description: DUPLIC1.70
! FORTRAN 77 + common Fortran 90 extensions. DUPLIC1.71
! Written to UM programming standards version 7. DUPLIC1.72
! DUPLIC1.73
! System component covered: DUPLIC1.74
! System task: Sub-Models Project DUPLIC1.75
! DUPLIC1.76
! Global variables: DUPLIC1.77
DUPLIC1.78
*CALL CSUBMODL 
DUPLIC1.79
*CALL CPPXREF DUPLIC1.80
*CALL VERSION DUPLIC1.81
*CALL CSTASH GRB0F401.2
*CALL STEXTEND DUPLIC1.83
*CALL STPARAM DUPLIC1.84
DUPLIC1.86
! Subroutine Arguments: DUPLIC1.87
! DUPLIC1.88
! Scalar arguments with intent(InOut): DUPLIC1.89
DUPLIC1.90
INTEGER NRECS ! No. of STASH list records DUPLIC1.91
INTEGER NTIMES ! No. of STASH times DUPLIC1.92
INTEGER NLEVELS ! No. of STASH levels DUPLIC1.93
DUPLIC1.94
! Local scalars: DUPLIC1.95
DUPLIC1.96
LOGICAL LTRPT DUPLIC1.97
INTEGER I DUPLIC1.98
INTEGER I1 DUPLIC1.99
INTEGER I2 DUPLIC1.100
INTEGER IEND DUPLIC1.101
INTEGER IITM DUPLIC1.102
INTEGER IL DUPLIC1.103
INTEGER IREC DUPLIC1.104
INTEGER ISEC DUPLIC1.105
INTEGER ISTR DUPLIC1.106
INTEGER IT DUPLIC1.107
INTEGER ITAGS1 DUPLIC1.108
INTEGER ITAGS2 DUPLIC1.109
INTEGER ITAGU1 DUPLIC1.110
INTEGER ITAGU2 DUPLIC1.111
INTEGER ITEND1 DUPLIC1.112
INTEGER ITEND2 DUPLIC1.113
INTEGER MODL DUPLIC1.114
INTEGER NLEVSW DUPLIC1.115
INTEGER NRECSW DUPLIC1.116
INTEGER NTIMESW DUPLIC1.117
DUPLIC1.118
! Local arrays: DUPLIC1.119
DUPLIC1.120
LOGICAL LTUSE(2*NPROFTP+2) ! LTUSE(n) set to .T. if column n DUPLIC1.121
! in ITIM_S contains a STASH times DUPLIC1.122
! table. DUPLIC1.123
DUPLIC1.124
! Function and subroutine calls: DUPLIC1.125
DUPLIC1.126
EXTERNAL SINDX,ORDER DUPLIC1.127
DUPLIC1.128
!- End of Header ----------------------------------------------------- DUPLIC1.129
DUPLIC1.130
DUPLIC1.131
! Initialise LTUSE array DUPLIC1.132
DUPLIC1.133
DO I=1,NTIMES DUPLIC1.134
LTUSE(I)=.FALSE. DUPLIC1.135
END DO DUPLIC1.136
DUPLIC1.137
DUPLIC1.138
! Blank out unused STASH times DUPLIC1.139
DUPLIC1.140
DO IREC=1,NRECS DUPLIC1.141
IF (LIST_S(st_freq_code,IREC).LT.0) THEN ! STASH times table DUPLIC1.142
LTUSE(-LIST_S(st_freq_code,IREC))=.TRUE. ! exists for IREC DUPLIC1.143
END IF DUPLIC1.144
END DO DUPLIC1.145
DUPLIC1.146
DO I=1,NTIMES DUPLIC1.147
IF(.NOT.LTUSE(I)) ITIM_S(1,I)=-1 ! Fill unused columns in DUPLIC1.148
END DO ! ITIM_S with -1 in each row. DUPLIC1.149
DUPLIC1.150
DUPLIC1.151
! Delete blank STASH times DUPLIC1.152
DUPLIC1.153
NTIMESW=1 DUPLIC1.154
DUPLIC1.155
DO IT=1,NTIMES DUPLIC1.156
DUPLIC1.157
! If col 'IT' contains a times table, find DUPLIC1.158
! corresponding record IREC in LIST_S, and replace entry '-IT' DUPLIC1.159
! by '-NTIMESW'. In each case, NTIMESW <= IT. DUPLIC1.160
DUPLIC1.161
IF(ITIM_S(1,IT).NE.-1) THEN DUPLIC1.162
DO IREC=1,NRECS DUPLIC1.163
DUPLIC1.164
IF (LIST_S(st_freq_code,IREC).EQ.-IT) THEN DUPLIC1.165
LIST_S(st_freq_code,IREC)=-NTIMESW DUPLIC1.166
END IF DUPLIC1.167
DUPLIC1.168
END DO DUPLIC1.169
DUPLIC1.170
IF (IT.NE.NTIMESW) THEN DUPLIC1.171
! Move times table in col 'IT' to col 'NTIMESW'. Hence array DUPLIC1.172
! ITIM_S is compressed. DUPLIC1.173
DO I=1,NTIMEP DUPLIC1.174
ITIM_S(I,NTIMESW)=ITIM_S(I,IT) DUPLIC1.175
END DO DUPLIC1.176
END IF DUPLIC1.177
DUPLIC1.178
NTIMESW=NTIMESW+1 DUPLIC1.179
END IF DUPLIC1.180
END DO DUPLIC1.181
DUPLIC1.182
NTIMES=NTIMESW-1 ! No. of STASH-times tables remaining, so far DUPLIC1.183
DUPLIC1.184
DUPLIC1.185
! Delete blank STASH levels DUPLIC1.186
DUPLIC1.187
NLEVSW=1 DUPLIC1.188
DUPLIC1.189
DO IL=1,NLEVELS DUPLIC1.190
DUPLIC1.191
! If col 'IL' of LEVLST_S contains a levs list, then find corresponding DUPLIC1.192
! record IREC in LIST_S and replace entry '-IL' by '-NLEVSW'. In each DUPLIC1.193
! case, NLEVSW <= IL. DUPLIC1.194
DUPLIC1.195
IF(LEVLST_S(1,IL).NE.0) THEN DUPLIC1.196
DO IREC=1,NRECS DUPLIC1.197
IF (LIST_S(st_output_bottom,IREC).EQ.-IL) THEN DUPLIC1.198
LIST_S(st_output_bottom,IREC)=-NLEVSW DUPLIC1.199
END IF DUPLIC1.200
END DO DUPLIC1.201
IF(IL.NE.NLEVSW) THEN DUPLIC1.202
! Move levels list in col 'IL' to col 'NLEVSW'. Hence array DUPLIC1.203
! LEVLST_S is compressed. DUPLIC1.204
DO I=1,NLEVP_S DUPLIC1.205
LEVLST_S(I,NLEVSW)=LEVLST_S(I,IL) DUPLIC1.206
END DO DUPLIC1.207
LLISTTY(NLEVSW)=LLISTTY(IL) ! Move corresponding entry in DUPLIC1.208
END IF ! LLISTTY DUPLIC1.209
DUPLIC1.210
NLEVSW=NLEVSW+1 DUPLIC1.211
END IF DUPLIC1.212
END DO DUPLIC1.213
DUPLIC1.214
NLEVELS=NLEVSW-1 DUPLIC1.215
DUPLIC1.216
DUPLIC1.217
! Check for duplication/overlap of STASH levels DUPLIC1.218
DUPLIC1.219
NRECSW=NRECS DUPLIC1.220
DUPLIC1.221
DO MODL = 1,N_INTERNAL_MODEL_MAX DUPLIC1.222
DO ISEC = 0,NSECTP GSS1F400.1201
DO IITM = 1,NITEMP GSS1F400.1202
DUPLIC1.225
IF(INDX_S(2,MODL,ISEC,IITM).GE.2) THEN !More than one STASH rec DUPLIC1.226
! for (model,sec,item) DUPLIC1.227
ISTR= INDX_S(1,MODL,ISEC,IITM) !1st record with m,s,i DUPLIC1.228
IEND=ISTR+INDX_S(2,MODL,ISEC,IITM)-1 !Last record with m,s,i DUPLIC1.229
DUPLIC1.230
DO I1=ISTR,IEND-1 DUPLIC1.231
DUPLIC1.232
ITAGS1=LIST_S(st_macrotag,I1)/1000 ! System tag DUPLIC1.233
ITAGU1=LIST_S(st_macrotag,I1)-1000*ITAGS1 ! User tag DUPLIC1.234
DUPLIC1.235
IF (LIST_S(st_model_code,I1).LE.N_INTERNAL_MODEL_MAX) THEN GGH2F400.35
! Not flagged redundant GGH2F400.36
DO I2=I1+1,IEND DUPLIC1.238
DUPLIC1.239
ITAGS2=LIST_S(st_macrotag,I2)/1000 ! System tag DUPLIC1.240
ITAGU2=LIST_S(st_macrotag,I2)-1000*ITAGS2 ! User tag DUPLIC1.241
DUPLIC1.242
IF((LIST_S(st_proc_no_code,I1).EQ. DUPLIC1.243
& LIST_S(st_proc_no_code,I2)).AND. DUPLIC1.244
& (LIST_S(st_freq_code,I1).EQ. DUPLIC1.245
& LIST_S(st_freq_code,I2)).AND. DUPLIC1.246
& (LIST_S(st_period_code,I1).EQ. DUPLIC1.247
& LIST_S(st_period_code,I2)).AND. DUPLIC1.248
& (LIST_S(st_gridpoint_code,I1).EQ. DUPLIC1.249
& LIST_S(st_gridpoint_code,I2)).AND. DUPLIC1.250
& (LIST_S(st_weight_code,I1).EQ. DUPLIC1.251
& LIST_S(st_weight_code,I2)).AND. DUPLIC1.252
& (LIST_S(st_north_code,I1).EQ. DUPLIC1.253
& LIST_S(st_north_code,I2)).AND. DUPLIC1.254
& (LIST_S(st_south_code,I1).EQ. DUPLIC1.255
& LIST_S(st_south_code,I2)).AND. DUPLIC1.256
& (LIST_S(st_west_code,I1).EQ. DUPLIC1.257
& LIST_S(st_west_code,I2)).AND. DUPLIC1.258
& (LIST_S(st_east_code,I1).EQ. DUPLIC1.259
& LIST_S(st_east_code,I2)).AND. DUPLIC1.260
& (LIST_S(st_input_code,I1).EQ. DUPLIC1.261
& LIST_S(st_input_code,I2)).AND. DUPLIC1.262
& (LIST_S(st_output_code,I1).EQ. DUPLIC1.263
& LIST_S(st_output_code,I2)).AND. DUPLIC1.264
& (LIST_S(st_series_ptr,I1).EQ. DUPLIC1.265
& LIST_S(st_series_ptr,I2)).AND. DUPLIC1.266
& (LIST_S(st_pseudo_out,I1).EQ. DUPLIC1.267
& LIST_S(st_pseudo_out,I2)).AND. DUPLIC1.268
& ((ITAGS1.EQ.ITAGS2).OR.(ITAGS1.EQ.0).OR. DUPLIC1.269
& (ITAGS2.EQ.0)).AND. DUPLIC1.270
& ((ITAGU1.EQ.ITAGU2).OR.(ITAGU1.EQ.0).OR. DUPLIC1.271
& (ITAGU2.EQ.0)).AND. DUPLIC1.272
& (LIST_S(st_model_code,I2).LE.N_INTERNAL_MODEL_MAX)) THEN GGH2F400.37
! Not flagged redundant GGH2F400.38
DUPLIC1.275
! If they are the same in all but time and level DUPLIC1.276
DUPLIC1.277
ITEND1=LIST_S(st_end_time_code,I1) DUPLIC1.278
ITEND2=LIST_S(st_end_time_code,I2) DUPLIC1.279
DUPLIC1.280
IF(ITEND1.EQ.-1) ITEND1= DUPLIC1.281
& LIST_S(st_start_time_code,I2)+1 ! Force overlap DUPLIC1.282
DUPLIC1.283
IF(ITEND2.EQ.-1) ITEND2= DUPLIC1.284
& LIST_S(st_start_time_code,I1)+1 ! Force overlap DUPLIC1.285
DUPLIC1.286
IF((.NOT.((LIST_S(st_start_time_code,I1) DUPLIC1.287
& .GT.ITEND2).OR. DUPLIC1.288
& (ITEND1.LT.LIST_S(st_start_time_code,I2))).OR. DUPLIC1.289
& (LIST_S(st_output_code,I1).GT.0)).AND. DUPLIC1.290
& (MOD(LIST_S(st_start_time_code,I2)- DUPLIC1.291
& LIST_S(st_start_time_code,I1), DUPLIC1.292
& LIST_S(st_freq_code,I1)).EQ.0).AND. DUPLIC1.293
& ((LIST_S(st_period_code,I1).EQ.0).OR. DUPLIC1.294
& (LIST_S(st_period_code,I1).EQ.-1).OR. DUPLIC1.295
& (MOD(LIST_S(st_start_time_code,I2)- DUPLIC1.296
& LIST_S(st_start_time_code,I1), DUPLIC1.297
& LIST_S(st_period_code,I1)).EQ.0)).AND. DUPLIC1.298
& (LIST_S(st_output_bottom,I2).EQ. DUPLIC1.299
& LIST_S(st_output_bottom,I1)).AND. DUPLIC1.300
& (LIST_S(st_output_top,I2).EQ. DUPLIC1.301
& LIST_S(st_output_top,I1))) THEN DUPLIC1.302
DUPLIC1.303
! (Times overlap or in dump) and overlay in freq & period DUPLIC1.304
! and levels the same DUPLIC1.305
DUPLIC1.306
IF(ITAGU1.EQ.0) THEN DUPLIC1.307
LIST_S(st_macrotag,I1)=ITAGU2 DUPLIC1.308
ITAGU1=ITAGU2 DUPLIC1.309
ELSE DUPLIC1.310
LIST_S(st_macrotag,I1)=ITAGU1 DUPLIC1.311
END IF DUPLIC1.312
DUPLIC1.313
IF(ITAGS1.EQ.0) THEN DUPLIC1.314
LIST_S(st_macrotag,I1)= DUPLIC1.315
& ITAGS2*1000+LIST_S(st_macrotag,I1) DUPLIC1.316
ITAGS1=ITAGS2 DUPLIC1.317
ELSE DUPLIC1.318
LIST_S(st_macrotag,I1)= DUPLIC1.319
& ITAGS1*1000+LIST_S(st_macrotag,I1) DUPLIC1.320
END IF DUPLIC1.321
DUPLIC1.322
LIST_S(st_start_time_code,I1)= DUPLIC1.323
& MIN(LIST_S(st_start_time_code,I1), DUPLIC1.324
& LIST_S(st_start_time_code,I2)) DUPLIC1.325
DUPLIC1.326
IF((LIST_S(st_end_time_code,I1).EQ.-1).OR. DUPLIC1.327
& (LIST_S(st_end_time_code,I2).EQ.-1)) THEN DUPLIC1.328
LIST_S(st_end_time_code,I1)=-1 DUPLIC1.329
ELSE DUPLIC1.330
LIST_S(st_end_time_code,I1)= DUPLIC1.331
& MAX(LIST_S(st_end_time_code,I1), DUPLIC1.332
& LIST_S(st_end_time_code,I2)) DUPLIC1.333
END IF DUPLIC1.334
DUPLIC1.335
LIST_S(st_model_code,I2)=N_INTERNAL_MODEL_MAX+1 GGH2F400.39
! Sets model id to be greater than no of models, GGH2F400.40
! so that this diag is put at the end of any sorted list. GGH2F400.41
DUPLIC1.337
NRECSW=NRECSW-1 DUPLIC1.338
DUPLIC1.339
DO I=ISTR,IEND !Change pointers DUPLIC1.340
IF(LIST_S(st_input_code,I ) .EQ. DUPLIC1.341
& -LIST_S(NELEMP+1 ,I2)) THEN DUPLIC1.342
LIST_S(st_input_code,I ) = DUPLIC1.343
& -LIST_S(NELEMP+1 ,I1) DUPLIC1.344
END IF DUPLIC1.345
END DO DUPLIC1.346
END IF DUPLIC1.347
DUPLIC1.348
END IF ! I1,I2 comparison DUPLIC1.349
END DO ! I2 DUPLIC1.350
END IF ! I1 Not flagged redundant DUPLIC1.351
END DO ! I1 DUPLIC1.352
DUPLIC1.353
END IF ! More than one STASH record for m,s,i DUPLIC1.354
END DO ! Items DUPLIC1.355
END DO ! Sections DUPLIC1.356
END DO ! Models DUPLIC1.357
DUPLIC1.358
! Remove unwanted records (i.e., those flagged redundant) DUPLIC1.359
DUPLIC1.360
CALL ORDER(NRECS) DUPLIC1.361
NRECS=NRECSW DUPLIC1.362
CALL SINDX(NRECS) DUPLIC1.363
C DUPLIC1.364
RETURN DUPLIC1.365
END DUPLIC1.366
*ENDIF DUPLIC1.367