PROGRAM MAIN_PRINTDUMP ,10PRINTDU1.26
PRINTDU1.27
IMPLICIT NONE PRINTDU1.28
PRINTDU1.29
INTEGER PRINTDU1.30
& FIXHD(256) !Space for fixed length header PRINTDU1.31
&,INTHD(100) !Space for integer header PRINTDU1.32
PRINTDU1.33
INTEGER PRINTDU1.34
& LEN_FIXHD !Length of fixed length header on input file PRINTDU1.35
&,LEN_INTHD !Length of integer header on input file PRINTDU1.36
&,LEN_REALHD !Length of real header on input file PRINTDU1.37
&,LEN1_LEVDEPC !1st dim of lev dependent consts on input file PRINTDU1.38
&,LEN2_LEVDEPC !2nd dim of lev dependent consts on input file PRINTDU1.39
&,LEN1_ROWDEPC !1st dim of row dependent consts on input file PRINTDU1.40
&,LEN2_ROWDEPC !2nd dim of row dependent consts on input file PRINTDU1.41
&,LEN1_COLDEPC !1st dim of col dependent consts on input file PRINTDU1.42
&,LEN2_COLDEPC !2nd dim of col dependent consts on input file PRINTDU1.43
&,LEN1_FLDDEPC !1st dim of field dependent consts on input file PRINTDU1.44
&,LEN2_FLDDEPC !2nd dim of field dependent consts on input file PRINTDU1.45
&,LEN_EXTCNST !Length of extra consts on input file PRINTDU1.46
&,LEN_DUMPHIST !Length of history header on input file PRINTDU1.47
&,LEN_CFI1 !Length of index1 on input file PRINTDU1.48
&,LEN_CFI2 !Length of index2 on input file PRINTDU1.49
&,LEN_CFI3 !Length of index3 on input file PRINTDU1.50
&,LEN1_LOOKUP !1st dim of LOOKUP on input file PRINTDU1.51
&,LEN2_LOOKUP !2nd dim of LOOKUP on input file PRINTDU1.52
&,LEN_DATA !Length of data on input file PRINTDU1.53
&,ROW_LENGTH !No of points E-W on input file PRINTDU1.54
&,P_ROWS !No of p-rows on input file PRINTDU1.55
&,P_FIELD !No of p-points per level on input file PRINTDU1.56
&,MAX_FIELD_SIZE !Maximum field size on file AD311093.54
PRINTDU1.57
INTEGER ERR !Return code from OPEN UDG2F305.463
INTEGER I !Loop index UDG2F305.464
INTEGER ErrorStatus !Error code returned from FILE_OPEN UDG7F400.345
INTEGER OpenStatus !Error code returned from GET_FILE UDG7F400.346
INTEGER NFTIN !Unit number of input UM dump UDG2F305.466
INTEGER LEN_IO !Length of I/O returned by BUFFER IN UDG2F305.467
UDG2F305.468
REAL A !BUFFER IN UNIT function UDG2F305.469
CHARACTER*80 FILENAME !Name of user preSTASH master file UDG7F400.347
PRINTDU1.65
c UBC4F402.1
integer wgdos_expand UBC4F402.2
PRINTDU1.66
C External subroutines called:------------------------------------------ PRINTDU1.67
EXTERNAL IOERROR,ABORT_IO,BUFFIN,FILE_OPEN,SETPOS, GPB1F305.122
& ABORT,PRINTDUMP GPB1F305.123
C*---------------------------------------------------------------------- PRINTDU1.69
GDG0F401.1038
wgdos_expand=1 UBC4F402.3
c UBC4F402.4
CL 1. Assign unit numbers PRINTDU1.72
PRINTDU1.73
NFTIN=20 PRINTDU1.74
PRINTDU1.75
WRITE(6,*) " " UDG2F305.476
WRITE(6,'(20x,''FILE STATUS'')') PRINTDU1.76
WRITE(6,'(20x,''==========='')') PRINTDU1.77
C CALL OPEN(1,'PPXREF',6,0,0,ERR) PRINTDU1.78
CALL FILE_OPEN
(20,'FILE1',5,0,0,ERR) GPB1F305.124
PRINTDU1.80
PRINTDU1.81
CL 2. Buffer in fixed length header record PRINTDU1.82
PRINTDU1.83
CALL BUFFIN(NFTIN,FIXHD,256,LEN_IO,A) PRINTDU1.84
PRINTDU1.85
C Check for I/O errors PRINTDU1.86
IF(A.NE.-1.0.OR.LEN_IO.NE.256)THEN PRINTDU1.87
CALL IOERROR('buffer in of fixed length header of input dump', PRINTDU1.88
* A,LEN_IO,256) PRINTDU1.89
CALL ABORT PRINTDU1.90
ENDIF PRINTDU1.91
PRINTDU1.92
C Set missing data indicator to zero PRINTDU1.93
DO I=1,256 PRINTDU1.94
IF(FIXHD(I).LT.0)FIXHD(I)=0 PRINTDU1.95
ENDDO PRINTDU1.96
PRINTDU1.97
C Input file dimensions PRINTDU1.98
LEN_FIXHD=256 PRINTDU1.99
LEN_INTHD=FIXHD(101) PRINTDU1.100
LEN_REALHD=FIXHD(106) PRINTDU1.101
LEN1_LEVDEPC=FIXHD(111) PRINTDU1.102
LEN2_LEVDEPC=FIXHD(112) PRINTDU1.103
LEN1_ROWDEPC=FIXHD(116) PRINTDU1.104
LEN2_ROWDEPC=FIXHD(117) PRINTDU1.105
LEN1_COLDEPC=FIXHD(121) PRINTDU1.106
LEN2_COLDEPC=FIXHD(122) PRINTDU1.107
LEN1_FLDDEPC=FIXHD(126) PRINTDU1.108
LEN2_FLDDEPC=FIXHD(127) PRINTDU1.109
LEN_EXTCNST=FIXHD(131) PRINTDU1.110
LEN_DUMPHIST=FIXHD(136) PRINTDU1.111
LEN_CFI1=FIXHD(141) PRINTDU1.112
LEN_CFI2=FIXHD(143) PRINTDU1.113
LEN_CFI3=FIXHD(145) PRINTDU1.114
LEN1_LOOKUP=FIXHD(151) PRINTDU1.115
LEN2_LOOKUP=FIXHD(152) PRINTDU1.116
LEN_DATA=FIXHD(161) PRINTDU1.117
PRINTDU1.118
PRINTDU1.119
CL 3. Buffer in integer constants from dump PRINTDU1.120
PRINTDU1.121
CALL BUFFIN(NFTIN,INTHD,FIXHD(101),LEN_IO,A) PRINTDU1.122
PRINTDU1.123
C Check for I/O errors PRINTDU1.124
IF(A.NE.-1.0.OR.LEN_IO.NE.FIXHD(101))THEN PRINTDU1.125
CALL IOERROR('buffer in of integer constants in input dump', PRINTDU1.126
* A,LEN_IO,FIXHD(101)) PRINTDU1.127
CALL ABORT PRINTDU1.128
ENDIF PRINTDU1.129
PRINTDU1.130
C Set missing data indicator to zero PRINTDU1.131
DO I=1,FIXHD(101) PRINTDU1.132
IF(INTHD(I).LT.0)INTHD(I)=0 PRINTDU1.133
ENDDO PRINTDU1.134
PRINTDU1.135
ROW_LENGTH=INTHD(6) PRINTDU1.136
P_ROWS=INTHD(7) PRINTDU1.137
P_FIELD=ROW_LENGTH*P_ROWS PRINTDU1.138
PRINTDU1.139
AD311093.55
CL Extract maximum field size from LOOKUP header AD311093.56
CALL FIND_MAX_FIELD_SIZE AD311093.57
& (NFTIN,FIXHD(151),FIXHD(152),FIXHD,MAX_FIELD_SIZE, UBC4F402.5
& wgdos_expand) UBC4F402.6
C Rewind file PRINTDU1.140
CALL SETPOS(NFTIN,0,ErrorStatus) GTD0F400.115
PRINTDU1.142
CL 4. Call PRINTDUMP PRINTDU1.143
PRINTDU1.144
CALL PRINTDUMP(LEN_FIXHD,LEN_INTHD,LEN_REALHD, PRINTDU1.145
& LEN1_LEVDEPC,LEN2_LEVDEPC,LEN1_ROWDEPC, PRINTDU1.146
& LEN2_ROWDEPC,LEN1_COLDEPC,LEN2_COLDEPC, PRINTDU1.147
& LEN1_FLDDEPC,LEN2_FLDDEPC,LEN_EXTCNST, PRINTDU1.148
& LEN_DUMPHIST,LEN_CFI1,LEN_CFI2,LEN_CFI3, PRINTDU1.149
& LEN1_LOOKUP,LEN2_LOOKUP,LEN_DATA,P_FIELD, PRINTDU1.150
& nftin,max_field_size,wgdos_expand) UBC4F402.7
PRINTDU1.152
STOP PRINTDU1.153
END PRINTDU1.154
CLL SUBROUTINE PRINTDUMP--------------------------------------------- PRINTDU1.155
CLL PRINTDU1.156
CLL Purpose: Prints a summary of contents of atmosphere, ocean or PRINTDU1.157
CLL ancillary file. PRINTDU1.158
CLL PRINTDUMP reads in headers and data fields from unit NFTIN PRINTDU1.159
CLL printing out a summary of their contents. PRINTDU1.160
CLL Printout of headers is written to unit 7. PRINTDU1.161
CLL Printout of data fileds is written to unit 6. PRINTDU1.162
CLL PRINTDU1.163
CLL Written by A. Dickinson PRINTDU1.164
CLL PRINTDU1.165
CLL Model Modification history from model version 3.0: PRINTDU1.166
CLL version Date PRINTDU1.167
CLL PRINTDU1.168
CLL 3.3 08/12/93 Extra argument for READFLDS. D. Robinson. DR081293.101
CLL 4.0 10/07/95 Don't print out data section for VARobs, ASB1F400.79
CLL Cx and Cov files. C.Parrett. ASB1F400.80
CLL DR081293.102
CLL Documentation: UM Doc Paper F5 PRINTDU1.169
CLL PRINTDU1.170
CLL System Tasks: F3,F4,F6 PRINTDU1.171
CLL PRINTDU1.172
CLL ----------------------------------------------------------------- PRINTDU1.173
C*L Arguments:------------------------------------------------------- PRINTDU1.174
SUBROUTINE PRINTDUMP 1,39PRINTDU1.175
& (LEN_FIXHD,LEN_INTHD,LEN_REALHD, PRINTDU1.176
& LEN1_LEVDEPC,LEN2_LEVDEPC,LEN1_ROWDEPC, PRINTDU1.177
& LEN2_ROWDEPC,LEN1_COLDEPC,LEN2_COLDEPC, PRINTDU1.178
& LEN1_FLDDEPC,LEN2_FLDDEPC,LEN_EXTCNST, PRINTDU1.179
& LEN_DUMPHIST,LEN_CFI1,LEN_CFI2,LEN_CFI3, PRINTDU1.180
& LEN1_LOOKUP,LEN2_LOOKUP,LEN_DATA,P_FIELD, PRINTDU1.181
& nftin,max_field_size,wgdos_expand) UBC4F402.8
CL PRINTDU1.183
CL PRINTDU1.184
PRINTDU1.185
IMPLICIT NONE PRINTDU1.186
PRINTDU1.187
INTEGER PRINTDU1.188
PRINTDU1.189
& LEN_FIXHD !IN Length of fixed length header on input file PRINTDU1.190
&,LEN_INTHD !IN Length of integer header on input file PRINTDU1.191
&,LEN_REALHD !IN Length of real header on input file PRINTDU1.192
&,LEN1_LEVDEPC !IN 1st dim of lev dependent consts on input file PRINTDU1.193
&,LEN2_LEVDEPC !IN 2nd dim of lev dependent consts on input file PRINTDU1.194
&,LEN1_ROWDEPC !IN 1st dim of row dependent consts on input file PRINTDU1.195
&,LEN2_ROWDEPC !IN 2nd dim of row dependent consts on input file PRINTDU1.196
&,LEN1_COLDEPC !IN 1st dim of col dependent consts on input file PRINTDU1.197
&,LEN2_COLDEPC !IN 2nd dim of col dependent consts on input file PRINTDU1.198
&,LEN1_FLDDEPC !IN 1st dim of field dependent consts on input fi PRINTDU1.199
&,LEN2_FLDDEPC !IN 2nd dim of field dependent consts on input fi PRINTDU1.200
&,LEN_EXTCNST !IN Length of extra consts on input file PRINTDU1.201
&,LEN_DUMPHIST !IN Length of history header on input file PRINTDU1.202
&,LEN_CFI1 !IN Length of index1 on input file PRINTDU1.203
&,LEN_CFI2 !IN Length of index2 on input file PRINTDU1.204
&,LEN_CFI3 !IN Length of index3 on input file PRINTDU1.205
&,LEN1_LOOKUP !IN 1st dim of LOOKUP on input file PRINTDU1.206
&,LEN2_LOOKUP !IN 2nd dim of LOOKUP on input file PRINTDU1.207
&,LEN_DATA !IN Length of data on input file PRINTDU1.208
&,P_FIELD !IN No of p-points per level on input file PRINTDU1.209
&,MAX_FIELD_SIZE !IN Maximum field size on file AD311093.61
&,wgdos_expand ! IN set to 1 to exapnd WGDOS Fields for comparison UBC4F402.9
c UBC4F402.10
integer lblrec_1 UBC4F402.11
PRINTDU1.210
INTEGER PRINTDU1.211
& NFTIN, GEX1F403.11
& NFTOUT GEX1F403.12
PRINTDU1.213
*CALL CSUBMODL GDG0F401.1039
*CALL CPPXREF GDG0F401.1040
*CALL PPXLOOK GDG0F401.1041
*CALL CSTASH GDG0F401.1042
*CALL CLOOKADD UBC4F402.12
*CALL C_MDI UDG1F405.1298
PRINTDU1.214
C Local arrays:--------------------------------------------------------- PRINTDU1.215
INTEGER PRINTDU1.216
& FIXHD(LEN_FIXHD), ! PRINTDU1.217
& INTHD(LEN_INTHD), !\ integer PRINTDU1.218
& CFI1(LEN_CFI1+1),CFI2(LEN_CFI2+1), ! > file headers PRINTDU1.219
& CFI3(LEN_CFI3+1), !/ PRINTDU1.220
& LOOKUP(LEN1_LOOKUP,LEN2_LOOKUP) ! PRINTDU1.221
PRINTDU1.222
REAL PRINTDU1.223
& REALHD(LEN_REALHD), PRINTDU1.224
& LEVDEPC(1+LEN1_LEVDEPC*LEN2_LEVDEPC), ! PRINTDU1.225
& ROWDEPC(1+LEN1_ROWDEPC*LEN2_ROWDEPC), ! PRINTDU1.226
& COLDEPC(1+LEN1_COLDEPC*LEN2_COLDEPC), !\ real PRINTDU1.227
& FLDDEPC(1+LEN1_FLDDEPC*LEN2_FLDDEPC), ! > file headers PRINTDU1.228
& EXTCNST(LEN_EXTCNST+1), !/ PRINTDU1.229
& DUMPHIST(LEN_DUMPHIST+1), ! PRINTDU1.230
& D1(MAX_FIELD_SIZE) ! Data array used to read in each field AD311093.62
GDG0F401.1045
INTEGER RowNumber GDG0F401.1046
PRINTDU1.232
C External subroutines called:------------------------------------------ PRINTDU1.233
EXTERNAL ABORT,ABORT_IO,READFLDS,READHEAD,HDPPXRF,GETPPX, GDG0F401.1043
& PRINT_REAL,PRINT_INTE GDG0F401.1044
C*---------------------------------------------------------------------- PRINTDU1.235
C*L Local variables:--------------------------------------------------- PRINTDU1.236
PRINTDU1.237
INTEGER PRINTDU1.238
& ICODE ! Error return code from subroutines PRINTDU1.239
&,START_BLOCK ! READHEAD argument (not used) PRINTDU1.240
&,I,J,K,L ! Loop indices PRINTDU1.241
*IF DEF,CAMDUMP GEX1F403.13
&,ok_count ! no. of dumps we wrote out. GEX1F403.14
*ENDIF GEX1F403.15
PRINTDU1.242
CHARACTER PRINTDU1.243
& CMESSAGE*100 ! Character string returned if ICODE .ne. 0 PRINTDU1.244
&,STRING*20 ! Format control for header printout PRINTDU1.245
&,FILENAME*80 !Name of user preSTASH master file GNF2F401.1
INTEGER NFT1,NFT2 GDG0F401.1047
PARAMETER (NFT1=22, NFT2=2) GDG0F401.1048
UDG1F405.4
INTEGER POS_MAX,POS_MIN UDG1F405.5
REAL F_MAX,F_MIN UDG1F405.6
! Variables for printing out observation fields UDG1F405.1299
INTEGER IIII !loop counter UDG1F405.1300
INTEGER BLK, NBLK, PBEGIN, PEND, OBS_LEFT UDG1F405.1301
INTEGER NumMeta, NumLevs, Lev, NumObs, NumObs_print, N UDG1F405.1302
INTEGER NumItem,NumObVariables, Variable, Shift, IPGE UDG1F405.1303
UDG1F405.1304
character*5 CNPRINT UDG1F405.1305
c UDG1F405.1306
real PGE(8),PGE1(8),PGE2(8) UDG1F405.1307
C*---------------------------------------------------------------------- PRINTDU1.246
PRINTDU1.247
NFTOUT=7 ! Out file on unit 7. GEX1F403.16
cmessage = ' ' GDW1F404.148
GEX1F403.17
CL 0. Read in PPXREF GDG0F401.1049
GDG0F401.1050
ppxRecs=1 GDG0F401.1051
RowNumber=0 GDG0F401.1052
ICODE=0 UDG9F404.83
CALL HDPPXRF(NFT1,'STASHmaster_A',ppxRecs,ICODE,CMESSAGE) GDG0F401.1053
IF(ICODE.GT.0)THEN UDG9F404.84
WRITE(6,*) 'Error reading STASHmaster_A' UDG9F404.85
WRITE(6,*) CMESSAGE UDG9F404.86
CALL ABORT UDG9F404.87
END IF UDG9F404.88
CALL HDPPXRF(NFT1,'STASHmaster_O',ppxRecs,ICODE,CMESSAGE) GDG0F401.1054
IF(ICODE.GT.0)THEN UDG9F404.89
WRITE(6,*) 'Error reading STASHmaster_O' UDG9F404.90
WRITE(6,*) CMESSAGE UDG9F404.91
CALL ABORT UDG9F404.92
END IF UDG9F404.93
CALL HDPPXRF(NFT1,'STASHmaster_S',ppxRecs,ICODE,CMESSAGE) GDG0F401.1055
IF(ICODE.GT.0)THEN UDG9F404.94
WRITE(6,*) 'Error reading STASHmaster_S' UDG9F404.95
WRITE(6,*) CMESSAGE UDG9F404.96
CALL ABORT UDG9F404.97
END IF UDG9F404.98
CALL HDPPXRF(NFT1,'STASHmaster_W',ppxRecs,ICODE,CMESSAGE) GDG0F401.1056
IF(ICODE.GT.0)THEN GDW1F404.149
WRITE(6,*) 'Error reading STASHmaster_W' UDG9F404.99
WRITE(6,*) CMESSAGE GDG0F401.1058
CALL ABORT GDG0F401.1059
ENDIF GDG0F401.1060
GDG0F401.1061
CALL GETPPX(NFT1,NFT2,'STASHmaster_A',RowNumber, GDG0F401.1062
*CALL ARGPPX GDG0F401.1063
& ICODE,CMESSAGE) GDG0F401.1064
CALL GETPPX(NFT1,NFT2,'STASHmaster_O',RowNumber, GDG0F401.1065
*CALL ARGPPX GDG0F401.1066
& ICODE,CMESSAGE) GDG0F401.1067
CALL GETPPX(NFT1,NFT2,'STASHmaster_S',RowNumber, GDG0F401.1068
*CALL ARGPPX GDG0F401.1069
& ICODE,CMESSAGE) GDG0F401.1070
CALL GETPPX(NFT1,NFT2,'STASHmaster_W',RowNumber, GDG0F401.1071
*CALL ARGPPX GDG0F401.1072
& ICODE,CMESSAGE) GDG0F401.1073
IF(ICODE.NE.0)THEN GDG0F401.1074
WRITE(6,*) CMESSAGE GDG0F401.1075
CALL ABORT GDG0F401.1076
ENDIF GDG0F401.1077
GDG0F401.1078
!User STASHmaster GDG0F401.1079
CALL HDPPXRF(0,' ',ppxRecs,ICODE,CMESSAGE) GDG0F401.1080
IF(ICODE.NE.0)THEN GDG0F401.1081
WRITE(6,*) CMESSAGE GDG0F401.1082
CALL ABORT GDG0F401.1083
ENDIF GDG0F401.1084
GDG0F401.1085
CALL GETPPX(0,NFT2,' ',RowNumber, GDG0F401.1086
*CALL ARGPPX GDG0F401.1087
& ICODE,CMESSAGE) GDG0F401.1088
IF(ICODE.NE.0)THEN GDG0F401.1089
WRITE(6,*) CMESSAGE GDG0F401.1090
CALL ABORT GDG0F401.1091
ENDIF GDG0F401.1092
GDG0F401.1093
*IF DEF,CAMDUMP GEX1F403.18
CLL Initialise counter for no of dumps written out GEX1F403.19
OK_COUNT=0 GEX1F403.20
GEX1F403.21
*ENDIF GEX1F403.22
CL 1. Read in file header PRINTDU1.248
PRINTDU1.249
CALL READHEAD(NFTIN,FIXHD,LEN_FIXHD, PRINTDU1.250
& INTHD,LEN_INTHD, PRINTDU1.251
& REALHD,LEN_REALHD, PRINTDU1.252
& LEVDEPC,LEN1_LEVDEPC,LEN2_LEVDEPC, PRINTDU1.253
& ROWDEPC,LEN1_ROWDEPC,LEN2_ROWDEPC, PRINTDU1.254
& COLDEPC,LEN1_COLDEPC,LEN2_COLDEPC, PRINTDU1.255
& FLDDEPC,LEN1_FLDDEPC,LEN2_FLDDEPC, PRINTDU1.256
& EXTCNST,LEN_EXTCNST, PRINTDU1.257
& DUMPHIST,LEN_DUMPHIST, PRINTDU1.258
& CFI1,LEN_CFI1, PRINTDU1.259
& CFI2,LEN_CFI2, PRINTDU1.260
& CFI3,LEN_CFI3, PRINTDU1.261
& LOOKUP,LEN1_LOOKUP,LEN2_LOOKUP, PRINTDU1.262
& LEN_DATA, PRINTDU1.263
*CALL ARGPPX GDG0F401.1094
& START_BLOCK,ICODE,CMESSAGE) PRINTDU1.264
PRINTDU1.265
IF(ICODE.NE.0)THEN PRINTDU1.266
WRITE(6,*)CMESSAGE,ICODE PRINTDU1.267
CALL ABORT PRINTDU1.268
ENDIF PRINTDU1.269
C GNF2F401.2
C Open up unit NFTOUT (N.Farnon) GEX1F403.23
C GNF2F401.4
CALL GET_FILE(NFTOUT,FILENAME,80,ICODE) GEX1F403.24
*IF DEF,CAMDUMP GEX1F403.25
OPEN(NFTOUT,RECL=5000,FILE=FILENAME,STATUS='NEW',IOSTAT=ICODE) GEX1F403.26
*ELSE GEX1F403.27
OPEN(NFTOUT,FILE=FILENAME,STATUS='NEW',IOSTAT=ICODE) GEX1F403.28
*ENDIF GEX1F403.29
IF (ICODE.NE.0) THEN GNF2F401.7
WRITE(6,*) 'Can not write to ',FILENAME GNF2F401.8
ELSE GNF2F401.9
WRITE(6,*) 'OPEN: ',NFTOUT,':',FILENAME,'has been created' GEX1F403.30
ENDIF GNF2F401.11
C GNF2F401.12
PRINTDU1.270
*IF DEF,PUMF GEX1F403.31
CL 2. Print out Fixed Length Header PRINTDU1.271
WRITE(NFTOUT,*) GEX1F403.32
WRITE(NFTOUT,*)' FIXED LENGTH HEADER' GEX1F403.33
WRITE(NFTOUT,*)' -------------------' GEX1F403.34
WRITE(NFTOUT,*) GEX1F403.35
CALL PRINT_INTE(FIXHD,LEN_FIXHD,LEN_FIXHD,1,NFTOUT) GEX1F403.36
PRINTDU1.277
CL 3. Print out Integer Header PRINTDU1.278
IF(LEN_INTHD.GT.0)THEN PRINTDU1.279
WRITE(NFTOUT,*) GEX1F403.37
WRITE(NFTOUT,*)' INTEGER HEADER' GEX1F403.38
WRITE(NFTOUT,*)' --------------' GEX1F403.39
WRITE(NFTOUT,*) GEX1F403.40
CALL PRINT_INTE(INTHD,LEN_INTHD,LEN_INTHD,1,NFTOUT) GEX1F403.41
ENDIF PRINTDU1.285
PRINTDU1.286
CL 4. Print out Real Header PRINTDU1.287
IF(LEN_REALHD.GT.0)THEN PRINTDU1.288
WRITE(NFTOUT,*) GEX1F403.42
WRITE(NFTOUT,*)' REAL HEADER' GEX1F403.43
WRITE(NFTOUT,*)' -----------' GEX1F403.44
WRITE(NFTOUT,*) GEX1F403.45
CALL PRINT_REAL(REALHD,LEN_REALHD,LEN_REALHD,1,NFTOUT) GEX1F403.46
ENDIF PRINTDU1.294
PRINTDU1.295
CL 5. Print out Level Dependent Constants PRINTDU1.296
IF(FIXHD(110).GT.0 .AND. LEN2_LEVDEPC.GT.0)THEN DR221193.123
WRITE(NFTOUT,*) GEX1F403.47
WRITE(NFTOUT,*)' LEVEL DEPENDENT CONSTS' GEX1F403.48
WRITE(NFTOUT,*)' ----------------------' GEX1F403.49
WRITE(NFTOUT,*) GEX1F403.50
DO K=1,LEN2_LEVDEPC PRINTDU1.302
WRITE(NFTOUT,*)K,':' GEX1F403.51
CALL PRINT_REAL(LEVDEPC,LEN1_LEVDEPC,LEN1_LEVDEPC,K,NFTOUT) GEX1F403.52
ENDDO PRINTDU1.305
ENDIF PRINTDU1.306
PRINTDU1.307
CL 7. Print out Row Dependent Constants PRINTDU1.308
IF(FIXHD(115).GT.0 .AND. LEN2_ROWDEPC.GT.0)THEN DR221193.124
WRITE(NFTOUT,*) GEX1F403.53
WRITE(NFTOUT,*)' ROW DEPENDENT CONSTS' GEX1F403.54
WRITE(NFTOUT,*)' --------------------' GEX1F403.55
WRITE(NFTOUT,*) GEX1F403.56
DO K=1,LEN2_ROWDEPC PRINTDU1.314
WRITE(NFTOUT,*)K,':' GEX1F403.57
CALL PRINT_REAL(ROWDEPC,LEN1_ROWDEPC,LEN1_ROWDEPC,K,NFTOUT) GEX1F403.58
ENDDO PRINTDU1.317
ENDIF PRINTDU1.318
PRINTDU1.319
CL 8. Print out Column Dependent Consts PRINTDU1.320
IF(FIXHD(120).GT.0 .AND. LEN2_COLDEPC.GT.0)THEN DR221193.125
WRITE(NFTOUT,*) GEX1F403.59
WRITE(NFTOUT,*)' COLUMN DEPENDENT CONSTS' GEX1F403.60
WRITE(NFTOUT,*)' -----------------------' GEX1F403.61
WRITE(NFTOUT,*) GEX1F403.62
DO K=1,LEN2_COLDEPC PRINTDU1.326
WRITE(NFTOUT,*)K,':' GEX1F403.63
CALL PRINT_REAL(COLDEPC,LEN1_COLDEPC,LEN1_COLDEPC,K,NFTOUT) GEX1F403.64
ENDDO PRINTDU1.329
ENDIF PRINTDU1.330
PRINTDU1.331
CL 9. Print out Field Dependent Consts PRINTDU1.332
IF(FIXHD(125).GT.0 .AND. LEN2_FLDDEPC.GT.0)THEN DR221193.126
WRITE(NFTOUT,*) GEX1F403.65
WRITE(NFTOUT,*)' FIELD DEPENDENT CONSTS' GEX1F403.66
WRITE(NFTOUT,*)' ----------------------' GEX1F403.67
WRITE(NFTOUT,*) GEX1F403.68
DO K=1,LEN2_FLDDEPC PRINTDU1.338
WRITE(NFTOUT,*)K,':' GEX1F403.69
CALL PRINT_REAL(FLDDEPC,LEN1_FLDDEPC,LEN1_FLDDEPC,K,NFTOUT) GEX1F403.70
ENDDO PRINTDU1.341
ENDIF PRINTDU1.342
PRINTDU1.343
CL 10. Print out Extra Constants PRINTDU1.344
IF(FIXHD(130).GT.0 .AND. LEN_EXTCNST.GT.0)THEN DR221193.127
WRITE(NFTOUT,*) GEX1F403.71
WRITE(NFTOUT,*)' EXTRA CONSTS' GEX1F403.72
WRITE(NFTOUT,*)' ------------' GEX1F403.73
WRITE(NFTOUT,*) GEX1F403.74
CALL PRINT_REAL(EXTCNST,LEN_EXTCNST,LEN_EXTCNST,1,NFTOUT) GEX1F403.75
ENDIF PRINTDU1.351
PRINTDU1.352
CL 11. Print out CFI1 PRINTDU1.353
IF(FIXHD(140).GT.0 .AND. LEN_CFI1.GT.0)THEN DR221193.128
WRITE(NFTOUT,*) GEX1F403.76
WRITE(NFTOUT,*)' COMPRESSED FIELD INDEX 1' GEX1F403.77
WRITE(NFTOUT,*)' ------------------------' GEX1F403.78
WRITE(NFTOUT,*) GEX1F403.79
CALL PRINT_INTE(CFI1,LEN_CFI1,LEN_CFI1,1,NFTOUT) GEX1F403.80
ENDIF PRINTDU1.360
PRINTDU1.361
CL 12. Print out CFI2 PRINTDU1.362
IF(FIXHD(142).GT.0 .AND. LEN_CFI2.GT.0)THEN DR221193.129
WRITE(NFTOUT,*) GEX1F403.81
WRITE(NFTOUT,*)' COMPRESSED FIELD INDEX 2' GEX1F403.82
WRITE(NFTOUT,*)' ------------------------' GEX1F403.83
WRITE(NFTOUT,*) GEX1F403.84
CALL PRINT_INTE(CFI2,LEN_CFI2,LEN_CFI2,1,NFTOUT) GEX1F403.85
ENDIF PRINTDU1.369
PRINTDU1.370
CL 12. Print out CFI3 PRINTDU1.371
IF(FIXHD(144).GT.0 .AND. LEN_CFI3.GT.0)THEN DR221193.130
WRITE(NFTOUT,*) GEX1F403.86
WRITE(NFTOUT,*)' COMPRESSED FIELD INDEX 3' GEX1F403.87
WRITE(NFTOUT,*)' ------------------------' GEX1F403.88
WRITE(NFTOUT,*) GEX1F403.89
CALL PRINT_INTE(CFI3,LEN_CFI3,LEN_CFI3,1,NFTOUT) GEX1F403.90
ENDIF PRINTDU1.378
PRINTDU1.379
CL 13. Print out LOOKUP Headers PRINTDU1.380
IF(LEN2_LOOKUP.GT.0)THEN PRINTDU1.381
WRITE(NFTOUT,*) GEX1F403.91
WRITE(NFTOUT,*)' LOOKUP HEADERS' GEX1F403.92
WRITE(NFTOUT,*)' --------------' GEX1F403.93
WRITE(NFTOUT,*) GEX1F403.94
DO K=1,LEN2_LOOKUP PRINTDU1.386
IF (LOOKUP(1,K).NE.-99) THEN DR221193.131
WRITE(NFTOUT,*)K,':' GEX1F403.95
WRITE(NFTOUT,*) 'Words 1-45' GEX1F403.96
CALL PRINT_INTE(LOOKUP(1,1),45,LEN1_LOOKUP,K,NFTOUT) GEX1F403.97
WRITE(NFTOUT,*) 'Words 46-64' GEX1F403.98
CALL PRINT_REAL(LOOKUP(46,1),19,LEN1_LOOKUP,K,NFTOUT) GEX1F403.99
IF (LEN1_LOOKUP.GT.64) THEN DR221193.134
WRITE(NFTOUT,*) 'Words 65-128' GEX1F403.100
CALL PRINT_INTE(LOOKUP(65,1),64,LEN1_LOOKUP,K,NFTOUT) GEX1F403.101
ENDIF DR221193.137
ENDIF DR221193.138
ENDDO PRINTDU1.390
ENDIF PRINTDU1.391
PRINTDU1.392
CL 13. Print out individual fields PRINTDU1.393
DR221193.139
WRITE(6,*) DR221193.140
WRITE(6,*)' DATA FIELDS' DR221193.141
WRITE(6,*)' -----------' DR221193.142
WRITE(6,*) DR221193.143
DR221193.144
IF (FIXHD(5).GE.8 .AND. FIXHD(5).LE.10) THEN !Cx/Cov/ObS UDG1F405.1308
DR221193.146
WRITE (6,*) DR221193.147
WRITE (6,*) 'Observation file : Observations not printed out' DR221193.148
WRITE (6,*) DR221193.149
DR221193.150
ELSE DR221193.151
DR221193.152
DR221193.159
DO I=1,LEN2_LOOKUP PRINTDU1.394
PRINTDU1.395
lblrec_1=lookup(lblrec, i) UBC4F402.14
IF (LOOKUP(1,I).NE.-99) THEN DR221193.160
CALL READFLDS(NFTIN,1,I,LOOKUP,LEN1_LOOKUP, GDG0F401.1095
& D1,MAX_FIELD_SIZE,FIXHD, GDG0F401.1096
*CALL ARGPPX GDG0F401.1097
& wgdos_expand,icode,cmessage) UBC4F402.15
IF(ICODE.NE.0)CALL ABORT_IO('PRINTDUMP',CMESSAGE,ICODE,NFTIN) PRINTDU1.398
IF(FIXHD(5).EQ.5)THEN UDG1F405.7
! Boundary dataset. READFLDS does not write out max and min values UDG1F405.8
! for boundary datasets. UDG1F405.9
F_MIN=D1(1) UDG1F405.10
F_MAX=D1(1) UDG1F405.11
POS_MAX=1 UDG1F405.12
POS_MIN=1 UDG1F405.13
DO J=1,LOOKUP(LBLREC,I) UDG1F405.14
IF(D1(J).GT.F_MAX)THEN UDG1F405.15
F_MAX=D1(J) UDG1F405.16
POS_MAX=J UDG1F405.17
ENDIF UDG1F405.18
IF(D1(J).LT.F_MIN)THEN UDG1F405.19
F_MIN=D1(J) UDG1F405.20
POS_MIN=J UDG1F405.21
END IF UDG1F405.22
END DO UDG1F405.23
UDG1F405.24
WRITE(6,'('' MINIMUM='',E12.5,'' POSITION='',I8, UDG1F405.25
& '' MAXIMUM='',E12.5,'' POSITION='',I8)') UDG1F405.26
& F_MIN,POS_MIN,F_MAX,POS_MAX UDG1F405.27
UDG1F405.28
WRITE(6,'('' '')') UDG1F405.29
END IF UDG1F405.30
IF (FIXHD(5) .EQ. 6) THEN ! ACOBS file UDG1F405.1309
NumMeta=5 UDG1F405.1310
NumLevs=INT(LEVDEPC((I-1)*LEN1_LEVDEPC+2)) UDG1F405.1311
NumObs=LOOKUP(66,I) UDG1F405.1312
CALL FORT_GET_ENV("NPRINT",6,CNPRINT,5,ICODE) UDG1F405.1313
IF (ICODE .NE. 0) THEN UDG1F405.1314
WRITE(6,'(A33)') 'ERROR ENCOUNTERED IN FORT_GET_ENV' UDG1F405.1315
RETURN UDG1F405.1316
END IF UDG1F405.1317
READ(CNPRINT,'(I5)') NumObs_print UDG1F405.1318
NumObs_print=MIN(NumObs_print,NumObs) UDG1F405.1319
NBLK=INT(NumObs_print/8) UDG1F405.1320
WRITE (6,'(/,A10,I5,A6,I3,A13)') 'There are ', UDG1F405.1321
& NumObs,' type ', UDG1F405.1322
& LOOKUP(65,I),' observations' UDG1F405.1323
PEND=0 UDG1F405.1324
DO BLK = 1, NBLK UDG1F405.1325
N=0 UDG1F405.1326
PBEGIN=((BLK-1)*8)+1 UDG1F405.1327
PEND=((BLK-1)*8)+8 UDG1F405.1328
WRITE (6,*) UDG1F405.1329
WRITE (6,'(A12,8I12)') 'Observation:', UDG1F405.1330
& ((PBEGIN-1+IIII),IIII=1,8) UDG1F405.1331
WRITE (6,'(A12,8F12.2)') 'Latitude : ', UDG1F405.1332
& (D1(0*NumObs+IIII),IIII=PBEGIN,PEND) UDG1F405.1333
WRITE (6,'(A12,8F12.2)') 'Longitude : ', UDG1F405.1334
& (D1(1*NumObs+IIII),IIII=PBEGIN,PEND) UDG1F405.1335
WRITE (6,'(A12,8F12.2)') 'Time : ', UDG1F405.1336
& (D1(2*NumObs+IIII),IIII=PBEGIN,PEND) UDG1F405.1337
WRITE (6,'(A12,8F12.2)') 'MOT : ', UDG1F405.1338
& (D1(3*NumObs+IIII),IIII=PBEGIN,PEND) UDG1F405.1339
IF (INT(LEVDEPC((I-1)*LEN1_LEVDEPC+1)) .EQ. 1) THEN UDG1F405.1340
N=1 UDG1F405.1341
WRITE (6,'(A12,8F12.2)') 'Pressure : ', UDG1F405.1342
& (D1(5*NumObs+IIII)/100.,IIII=PBEGIN,PEND) UDG1F405.1343
END IF UDG1F405.1344
DO Lev = 1, NumLevs UDG1F405.1345
WRITE (6,'(A6,I3,3X,8F12.3)') ' Level',Lev, UDG1F405.1346
& (D1((5+N)*NumObs+(NumObs*(Lev-1))+IIII), UDG1F405.1347
& IIII=PBEGIN,PEND) UDG1F405.1348
END DO UDG1F405.1349
DO Lev = 1, NumLevs UDG1F405.1350
WRITE (6,'(A6,I3,3X,8F12.3)') ' Level',Lev, UDG1F405.1351
& (D1((5+N)*NumObs+(NumObs*(NumLevs+Lev-1))+IIII), UDG1F405.1352
& IIII=PBEGIN,PEND) UDG1F405.1353
END DO UDG1F405.1354
IF ( LOOKUP(65,I) .EQ. 301 .OR. UDG1F405.1355
& LOOKUP(65,I) .EQ. 302 .OR. UDG1F405.1356
& LOOKUP(65,I) .EQ. 303 .OR. UDG1F405.1357
& LOOKUP(65,I) .EQ. 304 .OR. UDG1F405.1358
& LOOKUP(65,I) .EQ. 305 .OR. UDG1F405.1359
& LOOKUP(65,I) .EQ. 306 ) THEN UDG1F405.1360
DO Lev = 1, NumLevs UDG1F405.1361
WRITE (6,'(A6,I3,3X,8F12.3)') ' Level',Lev, UDG1F405.1362
& (D1((5+N)*NumObs+(NumObs*(2*NumLevs+Lev-1))+IIII), UDG1F405.1363
& IIII=PBEGIN,PEND) UDG1F405.1364
END DO UDG1F405.1365
END IF UDG1F405.1366
END DO UDG1F405.1367
OBS_LEFT=NumObs_print - NBLK*8 UDG1F405.1368
IF (OBS_LEFT .NE. 0 .AND. NumObs .NE. 0) THEN UDG1F405.1369
N=0 UDG1F405.1370
WRITE (6,*) UDG1F405.1371
WRITE (6,'(A12,8I12)') 'Observation:', UDG1F405.1372
& (IIII,IIII=PEND+1,PEND+OBS_LEFT) UDG1F405.1373
WRITE (6,'(A12,8F12.2)') 'Latitude : ', UDG1F405.1374
& (D1(0*NumObs+IIII),IIII=PEND+1,PEND+OBS_LEFT) UDG1F405.1375
WRITE (6,'(A12,8F12.2)') 'Longitude : ', UDG1F405.1376
& (D1(1*NumObs+IIII),IIII=PEND+1,PEND+OBS_LEFT) UDG1F405.1377
WRITE (6,'(A12,8F12.2)') 'Time : ', UDG1F405.1378
& (D1(2*NumObs+IIII),IIII=PEND+1,PEND+OBS_LEFT) UDG1F405.1379
WRITE (6,'(A12,8F12.2)') 'MOT : ', UDG1F405.1380
& (D1(3*NumObs+IIII),IIII=PEND+1,PEND+OBS_LEFT) UDG1F405.1381
IF (INT(LEVDEPC((I-1)*LEN1_LEVDEPC+1)) .EQ. 1) THEN UDG1F405.1382
N=1 UDG1F405.1383
WRITE (6,'(A12,8F12.2)') 'Pressure : ', UDG1F405.1384
& (D1(5*NumObs+IIII)/100.,IIII=PEND+1,PEND+OBS_LEFT) UDG1F405.1385
END IF UDG1F405.1386
DO Lev = 1, NumLevs UDG1F405.1387
WRITE (6,'(A6,I3,3X,8F12.3)') ' Level',Lev, UDG1F405.1388
& (D1((5+N)*NumObs+(NumObs*(Lev-1))+IIII), UDG1F405.1389
& IIII=PEND+1,PEND+OBS_LEFT) UDG1F405.1390
END DO UDG1F405.1391
DO Lev = 1, NumLevs UDG1F405.1392
WRITE (6,'(A6,I3,3X,8F12.3)') ' Level',Lev, UDG1F405.1393
& (D1((5+N)*NumObs+(NumObs*(NumLevs+Lev-1))+IIII), UDG1F405.1394
& IIII=PEND+1,PEND+OBS_LEFT) UDG1F405.1395
END DO UDG1F405.1396
IF ( LOOKUP(65,I) .EQ. 301 .OR. UDG1F405.1397
& LOOKUP(65,I) .EQ. 302 .OR. UDG1F405.1398
& LOOKUP(65,I) .EQ. 303 .OR. UDG1F405.1399
& LOOKUP(65,I) .EQ. 304 .OR. UDG1F405.1400
& LOOKUP(65,I) .EQ. 305 .OR. UDG1F405.1401
& LOOKUP(65,I) .EQ. 306 ) THEN UDG1F405.1402
DO Lev = 1, NumLevs UDG1F405.1403
WRITE (6,'(A6,I3,3X,8F12.3)') ' Level',Lev, UDG1F405.1404
& (D1((5+N)*NumObs+(NumObs*(2*NumLevs+Lev-1))+IIII), UDG1F405.1405
& IIII=PEND+1,PEND+OBS_LEFT) UDG1F405.1406
END DO UDG1F405.1407
END IF UDG1F405.1408
ENDIF UDG1F405.1409
ENDIF UDG1F405.1410
UDG1F405.1411
IF (FIXHD(5) .EQ. 7) THEN ! VAROBS file UDG1F405.1412
NumMeta=7 UDG1F405.1413
NumItem=3 UDG1F405.1414
NumObVariables=(LOOKUP(67,I)-NumMeta)/NumItem UDG1F405.1415
NumLevs=INT(LEVDEPC((I-1)*LEN1_LEVDEPC+2)) UDG1F405.1416
Shift=NumMeta+(NumLevs*NumObVariables*NumItem) UDG1F405.1417
NumObs=LOOKUP(66,I) UDG1F405.1418
CALL FORT_GET_ENV("NPRINT",6,CNPRINT,5,ICODE) UDG1F405.1419
IF (ICODE .NE. 0) THEN UDG1F405.1420
WRITE(6,'(A33)') 'ERROR ENCOUNTERED IN FORT_GET_ENV' UDG1F405.1421
RETURN UDG1F405.1422
END IF UDG1F405.1423
READ(CNPRINT,'(I5)') NumObs_print UDG1F405.1424
NumObs_print=MIN(NumObs_print,NumObs) UDG1F405.1425
NBLK=INT(NumObs_print/8) UDG1F405.1426
PEND=0 UDG1F405.1427
DO BLK = 1, NBLK UDG1F405.1428
PBEGIN=((BLK-1)*8)+1 UDG1F405.1429
PEND=((BLK-1)*8)+8 UDG1F405.1430
WRITE (6,*) UDG1F405.1431
WRITE (6,'(A12,8I12)') 'Observation:', UDG1F405.1432
& ((PBEGIN-1+IIII),IIII=1,8) UDG1F405.1433
WRITE (6,'(A12,8F12.2)') 'Latitude : ', UDG1F405.1434
& (D1((IIII-1)*Shift+1),IIII=PBEGIN,PEND) UDG1F405.1435
WRITE (6,'(A12,8F12.2)') 'Longitude : ', UDG1F405.1436
& (D1((IIII-1)*Shift+2),IIII=PBEGIN,PEND) UDG1F405.1437
WRITE (6,'(A12,8F12.2)') 'Time : ', UDG1F405.1438
& (D1((IIII-1)*Shift+3),IIII=PBEGIN,PEND) UDG1F405.1439
WRITE (6,'(A12,8F12.2)') 'MOT : ', UDG1F405.1440
& (D1((IIII-1)*Shift+4),IIII=PBEGIN,PEND) UDG1F405.1441
DO Variable = 1, NumObVariables UDG1F405.1442
WRITE (6,*) UDG1F405.1443
DO Lev = 1, NumLevs UDG1F405.1444
WRITE (6,'(A6,I3,3X,8F12.3)') ' Level',Lev, UDG1F405.1445
& (D1((IIII-1)*Shift+NumMeta+ UDG1F405.1446
& (NumObVariables*NumItem*(Lev-1))+(Variable-1)*NumItem+1), UDG1F405.1447
& IIII=PBEGIN,PEND) UDG1F405.1448
WRITE (6,'(A6,I3,3X,8F12.3)') ' Level',Lev, UDG1F405.1449
& (D1((IIII-1)*Shift+NumMeta+ UDG1F405.1450
& (NumObVariables*NumItem*(Lev-1))+ UDG1F405.1451
& (Variable-1)*NumItem+2), UDG1F405.1452
& IIII=PBEGIN,PEND) UDG1F405.1453
WRITE (6,'(A6,I3,3X,8F12.3)') ' Level',Lev, UDG1F405.1454
& (D1((IIII-1)*Shift+NumMeta+ UDG1F405.1455
& (NumObVariables*NumItem*(Lev-1))+ UDG1F405.1456
& (Variable-1)*NumItem+3), UDG1F405.1457
& IIII=PBEGIN,PEND) UDG1F405.1458
DO IPGE=1,8 UDG1F405.1459
PGE(IPGE)=D1((PBEGIN+IPGE-2)*Shift+NumMeta+ UDG1F405.1460
& (NumObVariables*NumItem*(Lev-1))+ UDG1F405.1461
& (Variable-1)*NumItem+3) UDG1F405.1462
IF (PGE(IPGE) .NE. RMDI) THEN UDG1F405.1463
PGE2(IPGE)=INT(PGE(IPGE)) UDG1F405.1464
PGE1(IPGE)=PGE(IPGE)-PGE2(IPGE) UDG1F405.1465
PGE2(IPGE)=PGE2(IPGE)/10000.0 UDG1F405.1466
ELSE UDG1F405.1467
PGE1(IPGE)=RMDI UDG1F405.1468
PGE2(IPGE)=RMDI UDG1F405.1469
END IF UDG1F405.1470
END DO UDG1F405.1471
WRITE (6,'(A6,I3,3X,8F12.3)') ' Level',Lev, UDG1F405.1472
& (PGE1(IIII),IIII=1,8) UDG1F405.1473
WRITE (6,'(A6,I3,3X,8F12.3)') ' Level',Lev, UDG1F405.1474
& (PGE2(IIII),IIII=1,8) UDG1F405.1475
END DO UDG1F405.1476
END DO UDG1F405.1477
END DO UDG1F405.1478
OBS_LEFT=NumObs_print - NBLK*8 UDG1F405.1479
IF (OBS_LEFT .NE. 0 .AND. NumObs .NE. 0) THEN UDG1F405.1480
WRITE (6,*) UDG1F405.1481
WRITE (6,'(A12,8I12)') 'Observation:', UDG1F405.1482
& (IIII,IIII=PEND+1,PEND+OBS_LEFT) UDG1F405.1483
WRITE (6,'(A12,8F12.2)') 'Latitude : ', UDG1F405.1484
& (D1((IIII-1)*Shift+1),IIII=PEND+1,PEND+OBS_LEFT) UDG1F405.1485
WRITE (6,'(A12,8F12.2)') 'Longitude : ', UDG1F405.1486
& (D1((IIII-1)*Shift+2),IIII=PEND+1,PEND+OBS_LEFT) UDG1F405.1487
WRITE (6,'(A12,8F12.2)') 'Time : ', UDG1F405.1488
& (D1((IIII-1)*Shift+3),IIII=PEND+1,PEND+OBS_LEFT) UDG1F405.1489
WRITE (6,'(A12,8F12.2)') 'MOT : ', UDG1F405.1490
& (D1((IIII-1)*Shift+4),IIII=PEND+1,PEND+OBS_LEFT) UDG1F405.1491
DO Variable = 1, NumObVariables UDG1F405.1492
WRITE (6,*) UDG1F405.1493
DO Lev = 1, NumLevs UDG1F405.1494
WRITE (6,'(A6,I3,3X,8F12.3)') ' Level',Lev, UDG1F405.1495
& (D1((IIII-1)*Shift+NumMeta+ UDG1F405.1496
& (NumObVariables*NumItem*(Lev-1))+ UDG1F405.1497
& (Variable-1)*NumItem+1), UDG1F405.1498
& IIII=PEND+1,PEND+OBS_LEFT) UDG1F405.1499
WRITE (6,'(A6,I3,3X,8F12.3)') ' Level',Lev, UDG1F405.1500
& (D1((IIII-1)*Shift+NumMeta+ UDG1F405.1501
& (NumObVariables*NumItem*(Lev-1))+ UDG1F405.1502
& (Variable-1)*NumItem+2), UDG1F405.1503
& IIII=PEND+1,PEND+OBS_LEFT) UDG1F405.1504
WRITE (6,'(A6,I3,3X,8F12.3)') ' Level',Lev, UDG1F405.1505
& (D1((IIII-1)*Shift+NumMeta+ UDG1F405.1506
& (NumObVariables*NumItem*(Lev-1))+ UDG1F405.1507
& (Variable-1)*NumItem+3), UDG1F405.1508
& IIII=PEND+1,PEND+OBS_LEFT) UDG1F405.1509
DO IPGE=1,OBS_LEFT UDG1F405.1510
PGE(IPGE)=D1((IPGE+PEND-2)*Shift+NumMeta+ UDG1F405.1511
& (NumObVariables*NumItem*(Lev-1))+ UDG1F405.1512
& (Variable-1)*NumItem+3) UDG1F405.1513
IF (PGE(IPGE) .NE. RMDI) THEN UDG1F405.1514
PGE2(IPGE)=INT(PGE(IPGE)) UDG1F405.1515
PGE1(IPGE)=PGE(IPGE)-PGE2(IPGE) UDG1F405.1516
PGE2(IPGE)=PGE2(IPGE)/10000.0 UDG1F405.1517
ELSE UDG1F405.1518
PGE1(IPGE)=RMDI UDG1F405.1519
PGE2(IPGE)=RMDI UDG1F405.1520
END IF UDG1F405.1521
END DO UDG1F405.1522
WRITE (6,'(A6,I3,3X,8F12.3)') ' Level',Lev, UDG1F405.1523
& (PGE1(IIII),IIII=PEND+1,PEND+OBS_LEFT) UDG1F405.1524
WRITE (6,'(A6,I3,3X,8F12.3)') ' Level',Lev, UDG1F405.1525
& (PGE2(IIII),IIII=PEND+1,PEND+OBS_LEFT) UDG1F405.1526
END DO UDG1F405.1527
END DO UDG1F405.1528
END IF UDG1F405.1529
END IF UDG1F405.1530
ENDIF DR221193.161
lookup(lblrec, i)=lblrec_1 UBC4F402.16
PRINTDU1.399
ENDDO PRINTDU1.400
DR221193.162
ENDIF DR221193.163
*ELSEIF DEF,CAMDUMP GEX1F403.102
GEX1F403.103
C Print out LOOKUP Headers GEX1F403.104
IF(LEN2_LOOKUP.GT.0)THEN GEX1F403.105
DO K=1,LEN2_LOOKUP GEX1F403.106
IF (LOOKUP(1,K).NE.-99) THEN GEX1F403.107
OK_COUNT=OK_COUNT+1 GEX1F403.108
CALL PRINTCAM(LOOKUP(1,K),LOOKUP(1,K),LEN1_LOOKUP, GEX1F403.109
& LEN1_LOOKUP,K,NFTOUT,ICODE,CMESSAGE) GEX1F403.110
IF(ICODE.NE.0)THEN GEX1F403.111
WRITE(6,*)CMESSAGE,ICODE GEX1F403.112
CALL ABORT GEX1F403.113
ENDIF GEX1F403.114
ENDIF GEX1F403.115
ENDDO GEX1F403.116
ENDIF GEX1F403.117
GEX1F403.118
IF (OK_COUNT.EQ.0) THEN GEX1F403.119
WRITE(6,*)'FATAL ERROR: All headers contain -99' GEX1F403.120
ENDIF GEX1F403.121
*ENDIF GEX1F403.122
PRINTDU1.401
RETURN PRINTDU1.402
END PRINTDU1.403
CLL SUBROUTINE PRINT_REAL-------------------------------------------- PRINTDU1.404
CLL PRINTDU1.405
CLL Purpose: Prints out a real array to unit 7, formatting as four PRINTDU1.406
CLL numbers across a page. PRINTDU1.407
CLL PRINTDU1.408
CLL Written by A. Dickinson 20/03/92 PRINTDU1.409
CLL PRINTDU1.410
CLL Model Modification history from model version 3.0: PRINTDU1.411
CLL version Date PRINTDU1.412
CLL PRINTDU1.413
CLL Documentation: None PRINTDU1.414
CLL PRINTDU1.415
CLL ----------------------------------------------------------------- PRINTDU1.416
C*L Arguments:------------------------------------------------------- PRINTDU1.417
SUBROUTINE PRINT_REAL(A,N_POINTS,N_FIELD,K,NFTOUT) 7GEX1F403.123
PRINTDU1.419
IMPLICIT NONE PRINTDU1.420
PRINTDU1.421
INTEGER PRINTDU1.422
& N_POINTS !IN No of values to be printed PRINTDU1.423
&,N_FIELD !IN 1st dimension of array A PRINTDU1.424
&,K !IN Element in 2nd dimension of array A PRINTDU1.425
&,NFTOUT !IN Output file unit number GEX1F403.124
PRINTDU1.426
REAL PRINTDU1.427
& A(N_FIELD) !IN Array to be printed out PRINTDU1.428
PRINTDU1.429
C*---------------------------------------------------------------------- PRINTDU1.430
C*L Local variables:--------------------------------------------------- PRINTDU1.431
INTEGER PRINTDU1.432
& I,J ! Loop indices PRINTDU1.433
PRINTDU1.434
C*---------------------------------------------------------------------- PRINTDU1.435
PRINTDU1.436
CL 1. Print out data modulo 4 PRINTDU1.437
DO I=1,N_POINTS-3,4 PRINTDU1.438
WRITE(NFTOUT,'(1x,4(I5,'':'',G12.6))') GEX1F403.125
& I,A(I+(K-1)*N_FIELD), PRINTDU1.440
& I+1,A(I+1+(K-1)*N_FIELD), PRINTDU1.441
& I+2,A(I+2+(K-1)*N_FIELD), PRINTDU1.442
& I+3,A(I+3+(K-1)*N_FIELD) PRINTDU1.443
ENDDO PRINTDU1.444
PRINTDU1.445
CL 2. Print out remainder of data PRINTDU1.446
IF(I.LE.N_POINTS)THEN PRINTDU1.447
DO J=I,N_POINTS PRINTDU1.448
WRITE(NFTOUT,'(T2,I5,'':'',G12.6,$)') GEX1F403.126
& J,A(J+(K-1)*N_FIELD) PRINTDU1.450
ENDDO PRINTDU1.451
WRITE(NFTOUT,'(/)') GEX1F403.127
ENDIF PRINTDU1.453
PRINTDU1.454
RETURN PRINTDU1.455
END PRINTDU1.456
CLL SUBROUTINE PRINT_INTE-------------------------------------------- PRINTDU1.457
CLL PRINTDU1.458
CLL Purpose: Prints out a integer array to unit 7, formatting as four PRINTDU1.459
CLL numbers across a page. PRINTDU1.460
CLL PRINTDU1.461
CLL Written by A. Dickinson PRINTDU1.462
CLL PRINTDU1.463
CLL Model Modification history from model version 3.0: PRINTDU1.464
CLL version Date PRINTDU1.465
CLL PRINTDU1.466
CLL Documentation: None PRINTDU1.467
CLL PRINTDU1.468
CLL ----------------------------------------------------------------- PRINTDU1.469
C*L Arguments:------------------------------------------------------- PRINTDU1.470
SUBROUTINE PRINT_INTE(A,N_POINTS,N_FIELD,K,NFTOUT) 7GEX1F403.128
PRINTDU1.472
IMPLICIT NONE PRINTDU1.473
PRINTDU1.474
INTEGER PRINTDU1.475
& N_POINTS !IN No of values to be printed PRINTDU1.476
&,N_FIELD !IN 1st dimension of array A PRINTDU1.477
&,K !IN Element in 2nd dimension of array A PRINTDU1.478
&,NFTOUT !IN Output file unit number GEX1F403.129
PRINTDU1.479
INTEGER PRINTDU1.480
& A(N_FIELD) !IN Array to be printed out PRINTDU1.481
PRINTDU1.482
C*---------------------------------------------------------------------- PRINTDU1.483
C*L Local variables:--------------------------------------------------- PRINTDU1.484
INTEGER PRINTDU1.485
& I,J ! Loop indices PRINTDU1.486
PRINTDU1.487
C*---------------------------------------------------------------------- PRINTDU1.488
PRINTDU1.489
CL 1. Print out data modulo 4 PRINTDU1.490
DO I=1,N_POINTS-3,4 PRINTDU1.491
WRITE(NFTOUT,'(1x,4(I5,'':'',I12))') GEX1F403.130
& I,A(I+(K-1)*N_FIELD), PRINTDU1.493
& I+1,A(I+1+(K-1)*N_FIELD), PRINTDU1.494
& I+2,A(I+2+(K-1)*N_FIELD), PRINTDU1.495
& I+3,A(I+3+(K-1)*N_FIELD) PRINTDU1.496
ENDDO PRINTDU1.497
PRINTDU1.498
CL 2. Print out remainder of data PRINTDU1.499
IF(I.LE.N_POINTS)THEN PRINTDU1.500
DO J=I,N_POINTS PRINTDU1.501
WRITE(NFTOUT,'(T2,I5,'':'',I12,$)') GEX1F403.131
& J,A(J+(K-1)*N_FIELD) PRINTDU1.503
ENDDO PRINTDU1.504
WRITE(NFTOUT,'(/)') GEX1F403.132
ENDIF PRINTDU1.506
PRINTDU1.507
RETURN PRINTDU1.508
END PRINTDU1.509
*ENDIF PRINTDU1.510