SUBROUTINE WSTLST(NRECS,NTIMES,NLEVELS) 1GSS1F400.1007
IMPLICIT NONE WSTLST1.4
! Description: GSS1F400.1008
! GSS1F400.1009
! Method: GSS1F400.1010
! GSS1F400.1011
! Current code owner: S.J.Swarbrick GSS1F400.1012
! GSS1F400.1013
! History: GSS1F400.1014
! Version Date Comment GSS1F400.1015
! ======= ==== ======= GSS1F400.1016
! 3.5 Mar. 95 Original code. S.J.Swarbrick GSS3F401.2003
! 4.0 Sept.95 S.J.Swarbrick GSS3F401.2004
! 4.1 Apr. 96 Mods relating to code GSS3F401.2005
! generalisation. S.J.Swarbrick GSS3F401.2006
! 4.2 29/11/96 MPP code : Added global version of A_LEN_DATA GPB1F402.651
! P.Burton GPB1F402.652
! 4.2 11/10/96 Enable atmos-ocean coupling for MPP. GRR1F402.73
! (2): Swap D1 memory. Add copies of D1 for atmos GRR1F402.74
! and ocean. R.Rawlins GRR1F402.75
! Initialise O_LEN_DUALDATA. S.Ineson GRR1F402.76
! 4.5 05/08/98 Remove redundant code. Ft_Output for GDR2F405.155
! boundary files now initialised in GDR2F405.156
! INTF_CTL. D. Robinson. GDR2F405.157
! GSS1F400.1019
! Code description: GSS1F400.1020
! FORTRAN 77 + common Fortran 90 extensions. GSS1F400.1021
! Written to UM programming standards version 7. GSS1F400.1022
! GSS1F400.1023
! System component covered: GSS1F400.1024
! System task: Sub-Models Project GSS1F400.1025
! GSS1F400.1026
! Global variables: GSS1F400.1027
WSTLST1.5
*CALL LENFIL 
WSTLST1.6
*CALL CSUBMODL WSTLST1.7
*CALL VERSION WSTLST1.8
*CALL STPARAM WSTLST1.9
*CALL CSTASH GRB0F401.9
*CALL STEXTEND WSTLST1.11
*CALL TYPSIZE GSS3F401.2007
*CALL MODEL GSS3F401.2008
WSTLST1.15
INTEGER NUMBER_TIMES WSTLST1.16
INTEGER I,J,K GSS3F401.2009
INTEGER ft_unit WSTLST1.20
INTEGER IZERO WSTLST1.21
INTEGER LEND1A WSTLST1.22
INTEGER LEND1O WSTLST1.23
INTEGER LEND1S GSS3F401.2010
INTEGER LEND1W GSS3F401.2011
INTEGER NLEVELS WSTLST1.24
INTEGER NRECS WSTLST1.25
INTEGER NTIMES WSTLST1.27
INTEGER BlkId !Time series block identifier GSS1F400.1028
INTEGER BlkSt !Start position of ts block data GSS1F400.1029
INTEGER IDP !Domain profile loop counter GSS1F400.1030
INTEGER IPOS GSS1F400.1031
INTEGER Nrecs_prev !No of recs in previous time ser block GSS1F400.1032
WSTLST1.28
! EXTERNAL FILNAM WSTLST1.29
WSTLST1.30
NAMELIST/STSIZES/ WSTLST1.31
& A_LEN2_LOOKUP,A_LEN_DATA,A_LEN_D1, GRR1F402.77
& S_LEN2_LOOKUP,S_LEN_DATA, GSS1F400.1033
& O_LEN2_LOOKUP,O_LEN_DATA,O_LEN_DUALDATA,O_LEN_D1, GRR1F402.78
& W_LEN2_LOOKUP,W_LEN_DATA,W_LEN_D1, GRR1F402.79
& LEN_TOT, WSTLST1.34
& NSECTS,N_REQ_ITEMS,NITEMS,TOTITEMS, WSTLST1.35
& NSTTABL,NUM_STASH_LEVELS,NUM_LEVEL_LISTS, WSTLST1.36
& NUM_STASH_PSEUDO,NUM_PSEUDO_LISTS, WSTLST1.37
& NSTTIMS,NSTASH_SERIES_BLOCK, WSTLST1.38
& NSTASH_SERIES_RECORDS,N_PPXRECS WSTLST1.39
C WSTLST1.40
C WSTLST1.41
LEND1A=0 GSS3F401.2013
LEND1O=0 GSS3F401.2014
LEND1S=0 GSS3F401.2015
LEND1W=0 GSS3F401.2016
GSS3F401.2017
write(6,120) NRECS WSTLST1.42
120 FORMAT(I5,' STASH LIST RECORDS') WSTLST1.43
DO 100 J=1,NRECS WSTLST1.44
WRITE(6,*) ' ' GSS3F401.2018
write(6,110)(LIST_S(I,J),I=1,NELEMP) WSTLST1.45
110 FORMAT(10I8) WSTLST1.46
100 CONTINUE WSTLST1.47
C WSTLST1.48
write(6,310) NTIMES WSTLST1.49
310 FORMAT(I4,' STASH TIMES') WSTLST1.50
DO I=1,NTIMES WSTLST1.51
NUMBER_TIMES=0 WSTLST1.52
DO J=1,NTIMEP WSTLST1.53
IF (ITIM_S(J,I).GT.0) THEN WSTLST1.54
NUMBER_TIMES=NUMBER_TIMES+1 WSTLST1.55
END IF WSTLST1.56
END DO WSTLST1.57
write(6,320) (ITIM_S(J,I),J=1,NUMBER_TIMES) WSTLST1.58
END DO WSTLST1.59
320 FORMAT(100I5) WSTLST1.60
C WSTLST1.61
write(6,410) NLEVELS WSTLST1.62
410 FORMAT(I4,' STASH LEVELS LIST(S)') WSTLST1.63
DO 400 I=1,NLEVELS WSTLST1.64
write(6,420) LEVLST_S(1,I),LLISTTY(I) WSTLST1.65
420 FORMAT(I5,A1) WSTLST1.66
IF(LLISTTY(I).EQ.'I') THEN WSTLST1.67
write(6,430) (LEVLST_S(J,I),J=2,LEVLST_S(1,I)+1) WSTLST1.68
430 FORMAT(16I4) WSTLST1.69
ELSE WSTLST1.70
write(6,440) (RLEVLST_S(J,I),J=2,LEVLST_S(1,I)+1) WSTLST1.71
440 FORMAT(6F12.3) WSTLST1.72
END IF WSTLST1.73
400 CONTINUE WSTLST1.74
C WSTLST1.75
C WSTLST1.76
write(6,710) NPSLISTS WSTLST1.77
710 FORMAT(I4,' STASH PSEUDO DIMENSION LIST(S)') WSTLST1.78
DO 700 I=1,NPSLISTS WSTLST1.79
write(6,720) LENPLST(I) WSTLST1.80
720 FORMAT(I5) WSTLST1.81
write(6,730) (PSLIST_D(J,I),J=1,LENPLST(I)) WSTLST1.82
730 FORMAT(16I4) WSTLST1.83
700 CONTINUE WSTLST1.84
C WSTLST1.85
write(6,510) NSERBLK_S GSS1F400.1034
510 FORMAT(I4,' STASH TIME SERIES BLOCKS') WSTLST1.87
C WSTLST1.88
BlkSt =1 GSS1F400.1035
DO IDP=1,NDPROF GSS1F400.1036
IF(NPOS_TS(IDP).GT.0) THEN GSS1F400.1037
BlkId = NPOS_TS (IDP) GSS1F400.1038
IF (BlkId.GT.1) THEN GSS1F400.1039
BlkSt=BlkSt+Nrecs_prev GSS1F400.1040
END IF GSS1F400.1041
WRITE(6,530) NPOS_TS(IDP),NRECS_TS(NPOS_TS(IDP)) GSS1F400.1042
530 FORMAT('SERIES NUMBER',I4,' WITH ',I4,' RECORDS') GSS1F400.1043
WRITE(6,*) ' NORTH SOUTH EAST WEST BOTTOM TOP' GSS1F400.1044
DO IPOS=BlkSt,BlkSt+NRECS_TS(NPOS_TS(IDP))-1 GSS1F400.1045
WRITE(6,560) NLIM_TS(IPOS),SLIM_TS(IPOS),ELIM_TS(IPOS), GSS1F400.1046
& WLIM_TS(IPOS),BLIM_TS(IPOS),TLIM_TS(IPOS) GSS1F400.1047
END DO GSS1F400.1048
560 FORMAT(6I8) GSS1F400.1049
WRITE(6,*) GSS1F400.1050
Nrecs_prev=NRECS_TS(NPOS_TS(IDP)) ! For next TS block GSS1F400.1051
END IF GSS1F400.1052
END DO GSS1F400.1053
WSTLST1.111
write(6,*) WSTLST1.112
&' MODL SECT ITEM IN_S(1) IN_S(2) INDX_S(1) INDX_S(2)', WSTLST1.113
&' PPIND_S' WSTLST1.114
write(6,*) GSS1F400.1054
&' St addr St len StListPos StListNum ' GSS1F400.1055
N_PPXRECS=0 WSTLST1.115
ITEM_MAX_REQ=1 WSTLST1.116
WSTLST1.117
DO K=1,N_INTERNAL_MODEL_MAX WSTLST1.118
DO J=0,44 WSTLST1.119
DO I=1,512 WSTLST1.120
IF(IN_S(1,K,J,I).NE.0) THEN WSTLST1.121
N_PPXRECS=N_PPXRECS+1 WSTLST1.122
ITEM_MAX_REQ=MAX(J,ITEM_MAX_REQ) WSTLST1.123
IZERO=0 WSTLST1.124
IF(J.EQ.0) THEN WSTLST1.125
write(6,610) WSTLST1.126
& K,J,I, IN_S(1,K,J,I), IN_S(2,K,J,I), WSTLST1.127
& INDX_S(1,K,J,I),INDX_S(2,K,J,I),PPIND_S(K,I) WSTLST1.128
610 FORMAT(3I5,5I10) WSTLST1.129
ELSE WSTLST1.130
write(6,610) WSTLST1.131
& K,J,I, IN_S(1,K,J,I), IN_S(2,K,J,I), WSTLST1.132
& INDX_S(1,K,J,I),INDX_S(2,K,J,I),IZERO WSTLST1.133
END IF WSTLST1.134
END IF WSTLST1.135
END DO WSTLST1.136
END DO WSTLST1.137
END DO WSTLST1.138
WSTLST1.139
I=-1 WSTLST1.140
write(6,610) I,I,I,I,I,I WSTLST1.141
WSTLST1.142
! Variables in COMMON STSIZES - for UMINDEX routine. WSTLST1.143
! N_PPXRECS was obtained in the loop above. WSTLST1.144
WSTLST1.145
A_LEN2_LOOKUP=NHEAD(A_IM) GSS3F401.2019
A_LEN_DATA =MAX(1,LPrimIM(A_IM)+LDumpIM(A_IM)) GSS3F401.2020
*IF DEF,MPP GPB1F402.653
global_A_LEN_DATA = GPB1F402.654
& MAX(1,global_LPrimIM(A_IM)+global_LDumpIM(A_IM)) GPB1F402.655
*ENDIF GPB1F402.656
LEND1A =LPrimIM(A_IM)+LDumpIM(A_IM)+LSecdIM(A_IM) GSS3F401.2021
& +LEXTRA (A_SM) GSS3F401.2022
S_LEN2_LOOKUP=NHEAD(S_IM) GSS3F401.2023
S_LEN_DATA =MAX(1,LPrimIM(S_IM)+LDumpIM(S_IM)) GSS3F401.2024
LEND1S =LPrimIM(S_IM)+LDumpIM(S_IM)+LSecdIM(S_IM) GSS3F401.2025
O_LEN2_LOOKUP=NHEAD(O_IM) GSS3F401.2026
O_LEN_DATA =MAX(1,LPrimIM(O_IM)+LDumpIM(O_IM)) GSS3F401.2027
LEND1O =LPrimIM(O_IM)+LDumpIM(O_IM)+LSecdIM(O_IM) GSS3F401.2028
& +LPRIM_O2 GSS3F401.2029
*IF DEF,MPP GPB0F403.3111
global_O_LEN_DATA = GPB0F403.3112
& MAX(1,global_LPrimIM(O_IM)+global_LDumpIM(O_IM)) GPB0F403.3113
*ENDIF GPB0F403.3114
W_LEN2_LOOKUP=NHEAD(W_IM) GSS3F401.2030
W_LEN_DATA =MAX(1,LPrimIM(W_IM)+LDumpIM(W_IM)) GSS3F401.2031
LEND1W =LPrimIM(W_IM)+LDumpIM(W_IM)+LSecdIM(W_IM) GSS3F401.2032
LEN_TOT =MAX(LEND1A+LEND1S,LEND1O,LEND1W) GSS3F401.2033
GRR1F402.80
O_LEN_DUALDATA=LPRIM_O2 GRR1F402.81
GRR1F402.82
A_LEN_D1=LEND1A GRR1F402.83
O_LEN_D1=LEND1O GRR1F402.84
W_LEN_D1=LEND1W GRR1F402.85
GSS3F401.2034
*IF DEF,SLAB GSS3F401.2035
a_len2_lookup = a_len2_lookup + s_len2_lookup GSS3F401.2036
a_len_data = a_len_data + s_len_data GSS3F401.2037
! len_tot = len_tot + s_len_data GSS3F401.2038
write (6,*) ' wtslst ; slab: a_len2_lookup updated to ', GSS3F401.2039
& a_len2_lookup GSS3F401.2040
write (6,*) ' wstlst ; slab: a_len_data updated to', GSS3F401.2041
& a_len_data GSS3F401.2042
write (6,*) ' wstlst ; slab: len_tot updated to', GSS3F401.2043
& len_tot GSS3F401.2044
write (6,*) ' slab: stsizes with updated values' GSS3F401.2045
write (6,stsizes) GSS3F401.2046
*ENDIF GSS3F401.2047
NSECTS =NSECTP WSTLST1.153
N_REQ_ITEMS =ITEM_MAX_REQ WSTLST1.154
NITEMS =NITEMP WSTLST1.155
TOTITEMS =MAX(1,NRECS) WSTLST1.156
NSTTABL =MAX(1,NTIMES) WSTLST1.157
WSTLST1.158
NUM_STASH_LEVELS=MAX(1,NMAXLEV_S) WSTLST1.159
NUM_LEVEL_LISTS =MAX(1,NLEVL_S) WSTLST1.160
NUM_STASH_PSEUDO=MAX(1,NMAXPSL_S) WSTLST1.161
NUM_PSEUDO_LISTS=MAX(1,NPSLISTS_S) WSTLST1.162
NSTTIMS =NTIMEP WSTLST1.163
WSTLST1.164
NSTASH_SERIES_BLOCK =MAX(1,NSERBLK_S) WSTLST1.165
NSTASH_SERIES_RECORDS=MAX(1,NSERREC_S) WSTLST1.166
WSTLST1.167
!Assign values to PPlen2LkUp, FTOutUnit WSTLST1.168
DO I = OUTFILE_S,OUTFILE_E WSTLST1.169
PPlen2LkUp(I) = MAX(4096,NHEAD_FILE(I)) WSTLST1.170
IF ((NHEAD_FILE(I).GT.0).AND.(I.NE.27)) THEN WSTLST1.171
FTOutUnit(I)='Y' WSTLST1.172
ELSE WSTLST1.173
FTOutUnit(I)='N' WSTLST1.174
END IF WSTLST1.175
END DO WSTLST1.176
PPlen2LkUp(27) = 4096 WSTLST1.177
!Output unit numbers for pp files and macros WSTLST1.178
DO I = 1,NRECS WSTLST1.179
IF (LIST_S(st_output_code,I).LT.0) THEN WSTLST1.180
!Note that for pp files GSS3F401.2048
! -LIST_S(st_output_code,I)=LIST_S(st_output_addr,I)=FT unit no. GSS3F401.2049
ft_unit =-LIST_S(st_output_code,I) WSTLST1.181
IF (ft_unit .ne. 27) THEN GSS1F400.1058
PPlen2LkUp(ft_unit) = 4096 WSTLST1.182
FTOutUnit (ft_unit) = 'Y' WSTLST1.183
END IF GSS1F400.1059
END IF WSTLST1.184
END DO WSTLST1.185
write(6,STSIZES) WSTLST1.193
WSTLST1.194
RETURN WSTLST1.195
END WSTLST1.196
!- End of subroutine code -------------------------------------------- WSTLST1.197
*ENDIF WSTLST1.198