SUBROUTINE RDBASIS 1,4GSS3F401.984
& (IU,CMESSAGE,ErrorStatus) GSS3F401.985
IMPLICIT NONE RDBASIS1.7
RDBASIS1.8
! Description: RDBASIS1.9
! RDBASIS1.10
! Method: RDBASIS1.11
! RDBASIS1.12
! Current code owner: S.J.Swarbrick RDBASIS1.13
! RDBASIS1.14
! History: RDBASIS1.15
! Version Date Comment RDBASIS1.16
! ======= ==== ======= RDBASIS1.17
! 3.5 Mar. 95 Original code. S.J.Swarbrick RDBASIS1.18
! 4.0 Sept.95 Original code. S.J.Swarbrick GSS1F400.495
! 4.0 18/10/95 Add ErrorStatus to GET_FILE call. RTHBarnes GRB2F400.12
! 4.1 June 96 DISCT_LEV function used to check for model GSS3F401.986
! levels S.J.Swarbrick GSS3F401.987
! 4.4 Sep. 97 Add IOFF to namelist for offset to sampling GSM5F404.19
! frequency. S.D. Mullerworth GSM5F404.20
! 4.5 July 98 Remove call to INTRFACE (A Van der Wal) GAV0F405.7
! 4.5 30/10/97 Read stash data on PE 0 for the T3E GBCVF405.166
! and distribute it. GBCVF405.167
! Author: Bob Carruthers, Cray Research GBCVF405.168
! RDBASIS1.19
! Code description: RDBASIS1.20
! FORTRAN 77 + common Fortran 90 extensions. RDBASIS1.21
! Written to UM programming standards version 7. RDBASIS1.22
! RDBASIS1.23
! System component covered: RDBASIS1.24
! System task: Sub-Models Project RDBASIS1.25
! RDBASIS1.26
! Global variables: RDBASIS1.27
RDBASIS1.28
*CALL C_MDI 
GSS1F400.496
*CALL LENFIL RDBASIS1.29
*CALL CSUBMODL RDBASIS1.30
*CALL VERSION RDBASIS1.31
*CALL CSTASH GRB0F401.13
*CALL TYPSIZE GSS3F401.988
*CALL MODEL RDBASIS1.34
*CALL STEXTEND GSS1F400.497
*CALL COCNINDX ORH6F402.11
RDBASIS1.35
! Subroutine arguments RDBASIS1.36
RDBASIS1.37
! Scalar arguments with intent(in): RDBASIS1.38
INTEGER IU ! Unit no. of stash basis file RDBASIS1.39
INTEGER IE RDBASIS1.40
! Scalar arguments with intent(out): GSS1F400.498
CHARACTER*80 CMESSAGE ! Error return message GSS1F400.499
RDBASIS1.41
! Error status: RDBASIS1.42
INTEGER ErrorStatus ! Error return code RDBASIS1.43
RDBASIS1.44
! Local variables: RDBASIS1.45
LOGICAL MODEL_LEV !TRUE for model levels GSS3F401.989
INTEGER I,J,L GSS3F401.990
INTEGER IDUM RDBASIS1.49
INTEGER IOSTAT RDBASIS1.50
INTEGER NtsRecs !Counter for time series records GSS1F400.500
*IF DEF,MPP,AND,DEF,T3E GBCVF405.169
c GBCVF405.170
integer shmem_n_pes, msg, info, nproc, shmem_my_pe, mype, k GBCVF405.171
*ENDIF GBCVF405.172
RDBASIS1.51
! Namelist STASHNUM RDBASIS1.52
INTEGER NUM_REQ,NUM_DOM,NUM_TIM,NUM_USE RDBASIS1.53
NAMELIST/STASHNUM/ NUM_REQ,NUM_DOM,NUM_TIM,NUM_USE RDBASIS1.54
*IF DEF,MPP,AND,DEF,T3E GBCVF405.173
common/shmem_stashnum/ num_req,num_dom,num_tim,num_use GBCVF405.174
cdir$ cache_align /shmem_stashnum/ GBCVF405.175
*ENDIF GBCVF405.176
RDBASIS1.55
! Namelist STREQ: STASH requests RDBASIS1.56
INTEGER IMOD,ISEC,ITEM,IDOM,ITIM,IUSE RDBASIS1.57
NAMELIST/STREQ/ IMOD,ISEC,ITEM,IDOM,ITIM,IUSE RDBASIS1.58
*IF DEF,MPP,AND,DEF,T3E GBCVF405.177
common/shmem_streq/ imod,isec,item,idom,itim,iuse GBCVF405.178
cdir$ cache_align /shmem_streq/ GBCVF405.179
*ENDIF GBCVF405.180
RDBASIS1.59
! Namelist TIME: Time profiles GSS1F400.501
CHARACTER*8 NAME RDBASIS1.61
CHARACTER*2 UNT1,UNT2,UNT3 RDBASIS1.62
INTEGER ITYP,ISAM,INTV,IOPT RDBASIS1.63
INTEGER ISTR,IEND,IFRE,IOFF,ITIMES,ISER(NTIMEP) GSM5F404.21
NAMELIST/TIME/ITYP,ISAM,INTV,UNT1 ,UNT2,UNT3,IOPT RDBASIS1.65
& ,ISTR,IEND,IFRE,IOFF,ITIMES,ISER,NAME GSM5F404.22
RDBASIS1.67
*IF DEF,MPP,AND,DEF,T3E GBCVF405.181
common/shmem_time/ ityp,isam,intv,iopt GBCVF405.182
& ,istr,iend,ifre,ioff,itimes,iser GBCVF405.183
cdir$ cache_align /shmem_time/ GBCVF405.184
common/shmem_time_c/ name, unt1, unt2, unt3 GBCVF405.185
cdir$ cache_align /shmem_time_c/ GBCVF405.186
*ENDIF GBCVF405.187
! Namelist DOMAIN: Domain profiles GSS1F400.502
INTEGER IOPL !Level type code GSS1F400.503
INTEGER ILEVS !Flag for range/selected model levels GSS1F400.504
INTEGER LEVB,LEVT !Bottom/top levels for range GSS1F400.505
INTEGER PLT !Pseudo level type code GSS1F400.506
INTEGER IOPA !Horizontal domain type code GSS1F400.507
INTEGER INTH,ISTH,IEST,IWST !Horiz domain limits (IOPA=9,10) GSS1F400.508
INTEGER IMSK !Grid type code GSS1F400.509
INTEGER IMN !Spatial meaning code GSS1F400.510
INTEGER IWT !Weighting code GSS1F400.511
INTEGER LEVLST (NLEVP) !Levels lists array: integer GSS1F400.512
REAL RLEVLST(NLEVP) ! real GSS1F400.513
INTEGER PSLIST (NPSLEVP) ! pseudo GSS1F400.514
CHARACTER*1 TS !Flag for time series domain GSS1F400.515
INTEGER TSNUM !No. of time ser doms in prof GSS1F400.516
INTEGER TBLIM (tsdp),TTLIM (tsdp) !TS dom limits (top/bottom) GSS1F400.517
REAL TBLIMR(tsdp),TTLIMR(tsdp) !ditto for real levels GSS1F400.518
INTEGER TNLIM (tsdp),TSLIM (tsdp) !TS dom limits (N/S) GSS1F400.519
INTEGER TWLIM (tsdp),TELIM (tsdp) !TS dom limits (E/W) GSS1F400.520
GSS1F400.521
NAMELIST/DOMAIN/IOPL ,ILEVS ,LEVB ,LEVT ,PLT ,IOPA ,IMSK , GSS1F400.522
& IMN ,IWT ,TS ,LEVLST,RLEVLST,NAME , GSS1F400.523
& INTH ,ISTH ,IEST ,IWST ,PSLIST , GSS1F400.524
& TSNUM,TBLIM ,TTLIM ,TNLIM ,TSLIM ,TELIM,TWLIM, GSS1F400.525
& TBLIMR,TTLIMR GSS1F400.526
*IF DEF,MPP,AND,DEF,T3E GBCVF405.188
GBCVF405.189
common/shmem_domain/ IOPL ,ILEVS ,LEVB ,LEVT ,PLT ,IOPA , GBCVF405.190
& IMSK , GBCVF405.191
& IMN ,IWT ,LEVLST,RLEVLST, GBCVF405.192
& INTH ,ISTH ,IEST ,IWST ,PSLIST , GBCVF405.193
& TSNUM,TBLIM ,TTLIM ,TNLIM ,TSLIM ,TELIM,TWLIM, GBCVF405.194
& TBLIMR,TTLIMR GBCVF405.195
cdir$ cache_align /shmem_domain/ GBCVF405.196
common/shmem_domain_c/ ts GBCVF405.197
cdir$ cache_align /shmem_domain_c/ GBCVF405.198
*ENDIF GBCVF405.199
GSS1F400.527
! Namelist USE: Useage profiles GSS1F400.528
INTEGER LOCN,IUNT RDBASIS1.80
NAMELIST/USE/LOCN,IUNT,NAME RDBASIS1.81
*IF DEF,MPP,AND,DEF,T3E GBCVF405.200
common/shmem_use/locn, iunt GBCVF405.201
cdir$ cache_align /shmem_use/ GBCVF405.202
*ENDIF GBCVF405.203
RDBASIS1.82
! Function and subroutine calls: RDBASIS1.83
LOGICAL DISCT_LEV GSS3F401.991
EXTERNAL GET_FILE RDBASIS1.84
RDBASIS1.85
!- End of Header ------------------------------------------------------ RDBASIS1.86
RDBASIS1.87
! Initialisation RDBASIS1.88
NDIAG =0 GSS1F400.529
NTPROF =0 GSS1F400.530
NDPROF =0 GSS1F400.531
NUPROF =0 GSS1F400.532
NUM_REQ =0 GSS1F400.533
NUM_TIM =0 GSS1F400.534
NUM_DOM =0 GSS1F400.535
NUM_USE =0 GSS1F400.536
NtsRecs =0 GSS1F400.537
RDBASIS1.97
DO I = 1,NDIAGPM RDBASIS1.98
MODL_B(I)=0 RDBASIS1.99
ISEC_B(I)=0 RDBASIS1.100
ITEM_B(I)=0 RDBASIS1.101
ITIM_B(I)=0 RDBASIS1.102
IDOM_B(I)=0 RDBASIS1.103
IUSE_B(I)=0 RDBASIS1.104
END DO RDBASIS1.105
RDBASIS1.106
ITIMES =0 RDBASIS1.107
DO I=1,NPROFTP RDBASIS1.108
TIMPRO(I)=' ' RDBASIS1.109
ITYP_T(I)=0 RDBASIS1.110
INTV_T(I)=0 RDBASIS1.111
UNT1_T(I)=' ' RDBASIS1.112
ISAM_T(I)=0 RDBASIS1.113
UNT2_T(I)=' ' RDBASIS1.114
IOPT_T(I)=0 RDBASIS1.115
ISTR_T(I)=0 RDBASIS1.116
IEND_T(I)=0 RDBASIS1.117
IFRE_T(I)=0 RDBASIS1.118
IOFF_T(I)=0 GSM5F404.23
UNT3_T(I)=' ' RDBASIS1.119
ITIM_T(I)=0 RDBASIS1.120
MODL_T(I)=0 GSS3F401.992
DO J = 1,NTIMEP RDBASIS1.121
ISER_T(J,I)=0 RDBASIS1.122
END DO RDBASIS1.123
END DO RDBASIS1.124
RDBASIS1.125
DO I=1,NPROFDP RDBASIS1.126
DOMPRO (I)=' ' RDBASIS1.127
IOPL_D (I)=0 RDBASIS1.128
LEVB_D (I)=0 RDBASIS1.129
LEVT_D (I)=0 RDBASIS1.130
PLT_D (I)=0 RDBASIS1.131
IOPA_D (I)=0 RDBASIS1.132
INTH_D (I)=0 RDBASIS1.133
ISTH_D (I)=0 RDBASIS1.134
IEST_D (I)=0 RDBASIS1.135
IWST_D (I)=0 RDBASIS1.136
IMSK_D (I)=0 RDBASIS1.137
IMN_D (I)=0 RDBASIS1.138
IWT_D (I)=0 RDBASIS1.139
TS_D (I)=' ' RDBASIS1.140
PLLEN_D (I)=0 RDBASIS1.141
PLPOS_D (I)=0 RDBASIS1.142
ILEV_D (I)=0 RDBASIS1.143
END DO RDBASIS1.144
DO I = 1,NLEVP RDBASIS1.145
DO J = 1,NPROFDP RDBASIS1.146
LEVLST_D (I,J)=0 RDBASIS1.147
RLEVLST_D(I,J)=0 RDBASIS1.148
END DO RDBASIS1.149
END DO RDBASIS1.150
DO I = 1,NPSLEVP RDBASIS1.151
DO J = 1,NPSLISTP RDBASIS1.152
PSLIST_D(I,J)=0 RDBASIS1.153
END DO RDBASIS1.154
END DO RDBASIS1.155
RDBASIS1.156
DO I = 1,NPROFUP RDBASIS1.157
USEPRO(I)=' ' RDBASIS1.158
LOCN_U(I)=0 RDBASIS1.159
IUNT_U(I)=0 RDBASIS1.160
END DO RDBASIS1.161
RDBASIS1.162
*IF DEF,MPP,AND,DEF,T3E GBCVF405.204
mype=shmem_my_pe() GBCVF405.205
nproc=shmem_n_pes() GBCVF405.206
if(mype.eq.0) then GBCVF405.207
*ENDIF GBCVF405.208
CALL GET_FILE(IU,FILE,80,ErrorStatus) ! Get name for stash file GRB2F400.13
RDBASIS1.164
! Rewind stash control file GSS1F400.538
REWIND(IU) GSS1F400.539
*IF DEF,MPP,AND,DEF,T3E GBCVF405.209
endif GBCVF405.210
*ENDIF GBCVF405.211
RDBASIS1.175
!STASH control file header namelist RDBASIS1.176
*IF DEF,MPP,AND,DEF,T3E GBCVF405.212
99 continue GBCVF405.213
if(mype.eq.0) READ(IU,STASHNUM) GBCVF405.214
c GBCVF405.215
msg=7010 GBCVF405.216
info=0 GBCVF405.217
call gc_ibcast(msg, 4, 0, nproc, info, num_req) GBCVF405.218
*IF DEF,DIAG190 GBCVF405.219
if(my_pe().le.1) write(190+my_pe(), STASHNUM) GBCVF405.220
*ENDIF GBCVF405.221
c GBCVF405.222
*ELSE GBCVF405.223
99 READ(IU,STASHNUM) RDBASIS1.177
*ENDIF GBCVF405.224
IF (NUM_REQ.EQ.-1) GOTO 999 RDBASIS1.178
NDIAG =NDIAG +NUM_REQ RDBASIS1.179
NTPROF=NTPROF+NUM_TIM RDBASIS1.180
NDPROF=NDPROF+NUM_DOM RDBASIS1.181
NUPROF=NUPROF+NUM_USE RDBASIS1.182
IF (NDIAG .GT.NRECDP ) THEN GSS1F400.540
WRITE(6,*) 'NUMBER OF DIAGNOSTIC REQUESTS EXCEEDS LIMIT OF ', GSS1F400.541
& NRECDP ,' SOME HAVE BEEN IGNORED' GSS1F400.542
GO TO 999 GSS1F400.543
END IF GSS1F400.544
IF (NDPROF.GT.NPROFDP) THEN GSS1F400.545
WRITE(6,*) 'ERROR IN STASHC:' GSS1F400.546
WRITE(6,*) 'NUMBER OF DOMAIN PROFILES EXCEEDS LIMIT OF ', GSS1F400.547
& NPROFDP GSS1F400.548
WRITE(6,*) 'ARRAYS WILL BE OVERWRITTEN' GSS3F401.993
ErrorStatus=1 GSS1F400.549
GO TO 9999 GSS1F400.550
END IF GSS1F400.551
IF (NUPROF.GT.NPROFUP) THEN GSS1F400.552
WRITE(6,*) 'ERROR IN STASHC:' GSS1F400.553
WRITE(6,*) 'NUMBER OF USEAGE PROFILES EXCEEDS LIMIT OF ', GSS1F400.554
& NPROFUP GSS1F400.555
WRITE(6,*) 'ARRAYS WILL BE OVERWRITTEN' GSS3F401.994
ErrorStatus=1 GSS1F400.556
GO TO 9999 GSS1F400.557
END IF GSS1F400.558
IF (NTPROF.GT.NPROFTP) THEN GSS1F400.559
WRITE(6,*) 'ERROR IN STASHC:' GSS1F400.560
WRITE(6,*) 'NUMBER OF TIME PROFILES EXCEEDS LIMIT OF ', GSS1F400.561
& NPROFTP GSS1F400.562
WRITE(6,*) 'ARRAYS WILL BE OVERWRITTEN' GSS3F401.995
ErrorStatus=1 GSS1F400.563
GO TO 9999 GSS1F400.564
END IF GSS1F400.565
RDBASIS1.183
!STASH request namelists RDBASIS1.184
IF (NUM_REQ.GT.0) THEN RDBASIS1.185
DO I = NDIAG-NUM_REQ+1,NDIAG RDBASIS1.186
IMOD=0 RDBASIS1.187
ISEC=0 RDBASIS1.188
ITEM=0 RDBASIS1.189
ITIM=0 RDBASIS1.190
IDOM=0 RDBASIS1.191
IUSE=0 RDBASIS1.192
*IF DEF,MPP,AND,DEF,T3E GBCVF405.225
if(mype.eq.0) READ(IU,STREQ) GBCVF405.226
c GBCVF405.227
msg=7011 GBCVF405.228
info=0 GBCVF405.229
call gc_ibcast(msg, 6, 0, nproc, info, imod) GBCVF405.230
*IF DEF,DIAG190 GBCVF405.231
if(my_pe().le.1) write(190+my_pe(), STREQ) GBCVF405.232
*ENDIF GBCVF405.233
c GBCVF405.234
*ELSE GBCVF405.235
READ(IU,STREQ) RDBASIS1.193
*ENDIF GBCVF405.236
MODL_B(I)=IMOD RDBASIS1.194
ISEC_B(I)=ISEC RDBASIS1.195
ITEM_B(I)=ITEM RDBASIS1.196
IF (ITIM.NE.0) THEN GSS3F401.996
ITIM =ITIM+NTPROF-NUM_TIM GSS3F401.997
END IF GSS3F401.998
IDOM =IDOM+NDPROF-NUM_DOM GSS1F400.567
IUSE =IUSE+NUPROF-NUM_USE GSS1F400.568
ITIM_B(I)=ITIM RDBASIS1.197
IDOM_B(I)=IDOM RDBASIS1.198
IUSE_B(I)=IUSE RDBASIS1.199
END DO RDBASIS1.200
END IF RDBASIS1.201
RDBASIS1.202
!Time profile namelists RDBASIS1.203
IF (NUM_TIM.GT.0) THEN RDBASIS1.204
DO I = NTPROF-NUM_TIM+1,NTPROF RDBASIS1.205
NAME=' ' RDBASIS1.206
ISAM=0 RDBASIS1.207
INTV=0 RDBASIS1.208
IOPT=0 RDBASIS1.209
ISTR=0 RDBASIS1.210
IEND=0 RDBASIS1.211
IFRE=0 RDBASIS1.212
IOFF=0 GSM5F404.24
DO J = 1,NTIMEP RDBASIS1.213
ISER(J)=0 RDBASIS1.214
END DO RDBASIS1.215
! Read namelist RDBASIS1.216
*IF DEF,MPP,AND,DEF,T3E GBCVF405.237
if(mype.eq.0) READ(IU,TIME) GBCVF405.238
c GBCVF405.239
msg=7011 GBCVF405.240
info=0 GBCVF405.241
call gc_ibcast(msg, 9+ntimep, 0, nproc, info, ityp) GBCVF405.242
msg=7012 GBCVF405.243
info=0 GBCVF405.244
call gc_cbcast(msg, 14, 0, nproc, info, name) GBCVF405.245
*IF DEF,DIAG190 GBCVF405.246
if(my_pe().le.1) write(190+my_pe(), TIME) GBCVF405.247
*ENDIF GBCVF405.248
c GBCVF405.249
*ELSE GBCVF405.250
READ(IU,TIME) RDBASIS1.217
*ENDIF GBCVF405.251
TIMPRO(I)=NAME RDBASIS1.218
ITYP_T(I)=ITYP RDBASIS1.219
IF (ITYP.NE.1) THEN RDBASIS1.220
! Diagnostic output is time-processed RDBASIS1.221
ISAM_T(I)=ISAM !Sampling frequency RDBASIS1.222
UNT2_T(I)=UNT2 RDBASIS1.223
INTV_T(I)=INTV !Processing interval RDBASIS1.224
UNT1_T(I)=UNT1 RDBASIS1.225
END IF RDBASIS1.226
! Diag. output time option RDBASIS1.227
IOPT_T(I)=IOPT RDBASIS1.228
UNT3_T(I)=UNT3 RDBASIS1.229
IF (IOPT.EQ.1) THEN RDBASIS1.230
! Regular output time interval RDBASIS1.231
ISTR_T(I)=ISTR RDBASIS1.232
IEND_T(I)=IEND RDBASIS1.233
IFRE_T(I)=IFRE RDBASIS1.234
IOFF_T(I)=IOFF GSM5F404.25
ELSE IF (IOPT.EQ.2) THEN RDBASIS1.235
! Specified list of output times RDBASIS1.236
! Length of times table GSS3F401.999
ITIM_T(I)=ITIMES RDBASIS1.237
! Internal model label for times table GSS3F401.1000
IF (NDIAG.GT.0) THEN GSS3F401.1001
MODL_T(I)=MODL_B(NDIAG) GSS3F401.1002
END IF GSS3F401.1003
! Times table GSS3F401.1004
DO J = 1,ITIMES RDBASIS1.238
ISER_T(J,I)=ISER(J) RDBASIS1.239
END DO RDBASIS1.240
END IF RDBASIS1.241
END DO RDBASIS1.242
END IF RDBASIS1.243
RDBASIS1.244
!Domain profile namelists RDBASIS1.245
IF (NUM_DOM.GT.0) THEN RDBASIS1.246
DO I = NDPROF-NUM_DOM+1,NDPROF RDBASIS1.247
!Initialise RDBASIS1.248
NAME =' ' RDBASIS1.249
IOPL =0 RDBASIS1.250
LEVB =0 RDBASIS1.251
LEVT =0 RDBASIS1.252
ILEVS=0 RDBASIS1.253
LEVLST (1)= IMDI GSS1F400.569
RLEVLST (1)= RMDI GSS1F400.570
DO J = 2,NLEVP GSS1F400.571
LEVLST (J)= 0 GSS1F400.572
RLEVLST(J)= 0.0 GSS1F400.573
END DO GSS1F400.574
DO J = 1,NPSLEVP RDBASIS1.258
PSLIST(J)=0 RDBASIS1.259
END DO RDBASIS1.260
DO J = 1,tsdp GSS1F400.575
TBLIM (J)=0 GSS1F400.576
TTLIM (J)=0 GSS1F400.577
TBLIMR(J)=0. GSS1F400.578
TTLIMR(J)=0. GSS1F400.579
TNLIM (J)=0 GSS1F400.580
TSLIM (J)=0 GSS1F400.581
TELIM (J)=0 GSS1F400.582
TWLIM (J)=0 GSS1F400.583
END DO GSS1F400.584
!Read namelist RDBASIS1.261
*IF DEF,MPP,AND,DEF,T3E GBCVF405.252
if(mype.eq.0) READ(IU,DOMAIN) GBCVF405.253
c GBCVF405.254
msg=7013 GBCVF405.255
info=0 GBCVF405.256
j=loc(ttlimr(tsdp)) GBCVF405.257
k=loc(iopl) GBCVF405.258
j=(j-k+8)/8 GBCVF405.259
if(mype.eq.0) write(6,*) 'Length of DOMAIN is ',j, GBCVF405.260
2 ' Words' GBCVF405.261
call gc_ibcast(msg, j, 0, nproc, info, iopl) GBCVF405.262
msg=7014 GBCVF405.263
info=0 GBCVF405.264
call gc_cbcast(msg, 1, 0, nproc, info, ts) GBCVF405.265
msg=7015 GBCVF405.266
info=0 GBCVF405.267
call gc_cbcast(msg, 8, 0, nproc, info, name) GBCVF405.268
*IF DEF,DIAG190 GBCVF405.269
if(my_pe().le.1) write(190+my_pe(), DOMAIN) GBCVF405.270
*ENDIF GBCVF405.271
c GBCVF405.272
*ELSE GBCVF405.273
READ(IU,DOMAIN) RDBASIS1.262
*ENDIF GBCVF405.274
!Check for errors in levels lists GSS1F400.585
MODEL_LEV=DISCT_LEV(IOPL,ErrorStatus,CMESSAGE) GSS3F401.1005
IF (MODEL_LEV) THEN GSS3F401.1006
! Model levels GSS3F401.1007
IF (ILEVS.EQ.2) THEN GSS1F400.587
IF ( LEVLST(1).EQ.IMDI ) THEN GSS1F400.588
WRITE(6,*) GSS1F400.589
& 'ERROR,RDBASIS: LEVELS LIST IN DOMAIN PROFILE ' GSS1F400.590
& ,I,' HAS NO ENTRIES' GSS1F400.591
CMESSAGE='ERROR,RDBASIS: LEVELS LIST HAS NO ENTRIES' GSS1F400.592
ErrorStatus=1 GSS1F400.593
GO TO 9999 GSS1F400.594
END IF GSS1F400.595
END IF GSS1F400.596
ELSE IF (IOPL.NE.5) THEN GSS3F401.1008
IF (RLEVLST(1).EQ.RMDI) THEN GSS1F400.598
WRITE(6,*) GSS1F400.599
& 'ERROR,RDBASIS: LEVELS LIST IN DOMAIN PROFILE ' GSS1F400.600
& ,I,' HAS NO ENTRIES' GSS1F400.601
CMESSAGE='ERROR,RDBASIS: LEVELS LIST HAS NO ENTRIES' GSS1F400.602
ErrorStatus=1 GSS1F400.603
GO TO 9999 GSS1F400.604
END IF GSS1F400.605
END IF GSS1F400.606
!Profile name GSS1F400.607
DOMPRO(I)=NAME RDBASIS1.263
!Store level type code in IOPL_D RDBASIS1.264
IOPL_D(I)=IOPL RDBASIS1.265
MODEL_LEV=DISCT_LEV(IOPL,ErrorStatus,CMESSAGE) GSS3F401.1009
IF (MODEL_LEV) THEN GSS3F401.1010
!Integer levels RDBASIS1.267
ILEV_D(I)=ILEVS RDBASIS1.268
IF (ILEVS.EQ.1) THEN RDBASIS1.269
! Range of model levels RDBASIS1.270
LEVB_D(I)=LEVB RDBASIS1.271
LEVT_D(I)=LEVT RDBASIS1.272
END IF RDBASIS1.273
IF (ILEVS.EQ.2) THEN RDBASIS1.274
! List of selected model levels RDBASIS1.275
LEVB_D(I)=-1 RDBASIS1.276
DO J=1,NLEVP RDBASIS1.277
LEVLST_D(J,I) = LEVLST(J) RDBASIS1.278
IF (LEVLST(J).GT.0) THEN RDBASIS1.279
! Store no. of levels in LEVT_D(I) RDBASIS1.280
LEVT_D(I)=LEVT_D(I)+1 RDBASIS1.281
END IF RDBASIS1.282
END DO RDBASIS1.283
END IF RDBASIS1.284
ELSE IF (IOPL.NE.5) THEN RDBASIS1.285
!Real levels RDBASIS1.286
LEVB_D(I)=-1 RDBASIS1.287
DO J=1,NLEVP RDBASIS1.288
RLEVLST_D(J,I) = RLEVLST(J) RDBASIS1.289
IF (RLEVLST(J).GT.0.0) THEN RDBASIS1.290
! Store no. of levels in LEVT_D(I) RDBASIS1.291
LEVT_D(I)=LEVT_D(I)+1 RDBASIS1.292
END IF RDBASIS1.293
END DO RDBASIS1.294
END IF RDBASIS1.295
!Store pseudo level type code in PLT_D RDBASIS1.296
PLT_D (I)=PLT RDBASIS1.297
IF (PLT.GT.0) THEN RDBASIS1.298
!Domain profile 'I' has pseudo levels list RDBASIS1.299
! Count total no. of pseudo levels lists RDBASIS1.300
NPSLISTS = NPSLISTS + 1 RDBASIS1.301
! Store list in column 'NPSLISTS' of PSLIST_D RDBASIS1.302
DO J=1,NPSLEVP RDBASIS1.303
PSLIST_D(J,NPSLISTS) = PSLIST (J) RDBASIS1.304
! PPLEN_D(I) stores length of ps.lev.list for domain 'I' RDBASIS1.305
IF (PSLIST(J).GT.0) THEN RDBASIS1.306
PLLEN_D (I) = PLLEN_D(I) + 1 RDBASIS1.307
END IF RDBASIS1.308
END DO RDBASIS1.309
! PLPOS(I) stores the column no. in PSLIST_D for dom. prof. 'I' RDBASIS1.310
PLPOS_D(I) = NPSLISTS RDBASIS1.311
END IF RDBASIS1.312
!Store horizontal domain type in IOPA_D RDBASIS1.313
IOPA_D(I)=IOPA RDBASIS1.314
IF (IOPA.EQ.9.OR.IOPA.EQ.10) THEN RDBASIS1.315
! Specified area RDBASIS1.316
INTH_D(I)=INTH RDBASIS1.317
ISTH_D(I)=ISTH RDBASIS1.318
IEST_D(I)=IEST RDBASIS1.319
IWST_D(I)=IWST RDBASIS1.320
END IF RDBASIS1.321
IMSK_D(I)=IMSK ! Gridpoint option RDBASIS1.322
IMN_D (I)=IMN ! Meaning option RDBASIS1.323
IWT_D (I)=IWT ! Weighting option RDBASIS1.324
TS_D (I)=TS ! Time series domain RDBASIS1.325
IF (TS_D(I) .EQ. 'Y') THEN GSS1F400.608
!This domain profile has a block of time series domains GSS1F400.609
! Store time series data for current profile in _TS arrays GSS1F400.610
NSERIES = NSERIES+1 ! Time series block number: GSS1F400.611
NPOS_TS(I) = NSERIES ! used as a pointer GSS1F400.612
NRECS_TS(NSERIES) = TSNUM ! No. of records in ts block GSS1F400.613
NSERREC_S = NSERREC_S+TSNUM ! Cumulative total ts records GSS1F400.614
IF (NSERREC_S.LE.NTimSerP) THEN GSS1F400.615
DO J = 1,TSNUM GSS1F400.616
IF (J.LE.tsdp) THEN GSS1F400.617
NtsRecs = NtsRecs+1 GSS1F400.618
MODEL_LEV=DISCT_LEV(IOPL,ErrorStatus,CMESSAGE) GSS3F401.1011
IF (MODEL_LEV) THEN GSS3F401.1012
BLIM_TS (NtsRecs)= TBLIM (J) GSS1F400.620
TLIM_TS (NtsRecs)= TTLIM (J) GSS1F400.621
ELSE IF (IOPL.NE.5) THEN GSS1F400.622
BLIMR_TS(NtsRecs)= TBLIMR(J) GSS1F400.623
TLIMR_TS(NtsRecs)= TTLIMR(J) GSS1F400.624
END IF GSS1F400.625
NLIM_TS(NtsRecs) = TNLIM(J) GSS1F400.626
SLIM_TS(NtsRecs) = TSLIM(J) GSS1F400.627
ELIM_TS(NtsRecs) = TELIM(J) GSS1F400.628
WLIM_TS(NtsRecs) = TWLIM(J) GSS1F400.629
ELSE GSS1F400.630
WRITE(6,*) GSS1F400.631
& 'MESSAGE FROM ROUTINE RDBASIS: ', GSS3F401.1013
& 'no. of time series in domain profile ',I, GSS3F401.1014
& ' exceeds allowed limit of ',tsdp,' some will be', GSS1F400.633
& ' ignored' GSS1F400.634
END IF GSS1F400.635
END DO GSS1F400.636
ELSE GSS1F400.637
WRITE(6,*) GSS1F400.638
& 'TIMSER: total no. of time series requested exceeds ', GSS1F400.639
& 'allowed limit of ',NTimSerP,'; some will be ignored.' GSS1F400.640
END IF GSS1F400.641
ELSE GSS1F400.642
NPOS_TS (I)=-1 GSS1F400.643
END IF GSS1F400.644
END DO RDBASIS1.326
END IF RDBASIS1.327
NSERBLK_S = NSERIES GSS1F400.645
RDBASIS1.328
!Useage profile namelists RDBASIS1.329
IF (NUM_USE.GT.0) THEN RDBASIS1.330
NAME=' ' RDBASIS1.331
LOCN=0 RDBASIS1.332
IUNT=0 RDBASIS1.333
DO I = NUPROF-NUM_USE+1,NUPROF RDBASIS1.334
*IF DEF,MPP,AND,DEF,T3E GBCVF405.275
if(mype.eq.0) READ(IU,USE) GBCVF405.276
c GBCVF405.277
msg=7016 GBCVF405.278
info=0 GBCVF405.279
call gc_ibcast(msg, 2, 0, nproc, info, locn) GBCVF405.280
msg=7017 GBCVF405.281
info=0 GBCVF405.282
call gc_cbcast(msg, 8, 0, nproc, info, name) GBCVF405.283
*IF DEF,DIAG190 GBCVF405.284
if(my_pe().le.1) write(190+my_pe(), USE) GBCVF405.285
*ENDIF GBCVF405.286
c GBCVF405.287
*ELSE GBCVF405.288
READ(IU,USE) RDBASIS1.335
*ENDIF GBCVF405.289
USEPRO(I)=NAME RDBASIS1.336
LOCN_U(I)=LOCN RDBASIS1.337
IUNT_U(I)=IUNT RDBASIS1.338
END DO RDBASIS1.339
END IF RDBASIS1.340
GO TO 99 RDBASIS1.341
RDBASIS1.342
999 CONTINUE RDBASIS1.343
GSS1F400.646
!Initialise model config. arrays before reading STSHCOMP GSS3F401.1015
DO I = 0,NSECTP GSS1F400.648
ATMOS_SR(I)=' ' GSS1F400.649
OCEAN_SR(I)=' ' GSS1F400.650
SLAB_SR(I)=' ' GSS1F400.651
WAVE_SR(I)=' ' GSS3F401.1016
INDEP_SR(I)=' ' GSS1F400.652
END DO GSS1F400.653
*IF DEF,MPP,AND,DEF,T3E GBCVF405.290
if(mype.eq.0) then GBCVF405.291
*ENDIF GBCVF405.292
READ(5,STSHCOMP) GSS3F401.1017
*IF DEF,MPP,AND,DEF,T3E GBCVF405.293
endif GBCVF405.294
c GBCVF405.295
msg=7018 GBCVF405.296
info=0 GBCVF405.297
j=loc(oasfldid(4)) GBCVF405.298
k=loc(run_target_end) GBCVF405.299
j=(j-k+8)/8 GBCVF405.300
if(mype.eq.0) write(6,*) 'Length of STSHCOMM is ',j, GBCVF405.301
2 ' Words' GBCVF405.302
call gc_ibcast(msg, j, 0, nproc, info, run_target_end) GBCVF405.303
msg=7019 GBCVF405.304
info=0 GBCVF405.305
j=loc(wave_sr(nsectp)) GBCVF405.306
k=loc(bspmsl) GBCVF405.307
j=j-k+1 GBCVF405.308
if(mype.eq.0) write(6,*) 'Length of STSHCHAR is ',j, GBCVF405.309
2 ' Bytes' GBCVF405.310
call gc_cbcast(msg, j, 0, nproc, info, bspmsl) GBCVF405.311
*IF DEF,DIAG190 GBCVF405.312
if(my_pe().le.1) write(190+my_pe(), STSHCOMP) GBCVF405.313
*ENDIF GBCVF405.314
c GBCVF405.315
*ENDIF GBCVF405.316
RDBASIS1.345
*IF DEF,MPP,AND,DEF,OCEAN ORH6F402.12
NROWSO = JFIN - JST + 1 + (2*O_NS_HALO) ORH6F402.13
*ENDIF ORH6F402.14
*IF DEF,MPP,AND,DEF,T3E GBCVF405.317
if(mype.eq.0) then GBCVF405.318
*ENDIF GBCVF405.319
CLOSE(UNIT=IU,STATUS='KEEP',IOSTAT=IOSTAT) RDBASIS1.346
*IF DEF,MPP,AND,DEF,T3E GBCVF405.320
endif GBCVF405.321
*ENDIF GBCVF405.322
RDBASIS1.347
9999 RETURN RDBASIS1.348
END RDBASIS1.349
RDBASIS1.350
!- End of subroutine code ------------------------------------------ RDBASIS1.351
*ENDIF RDBASIS1.352