PROGRAM MAIN_CONVPP ,12CONVPP1.21
CONVPP1.25
IMPLICIT NONE CONVPP1.26
CONVPP1.27
CONVPP1.28
CHARACTER*80 ARG1,ARG2 ! Filenames CONVPP1.29
CONVPP1.30
CONVPP1.31
INTEGER CONVPP1.32
& FIXHD(256) !Space for fixed length header CONVPP1.33
&,INTHD(100) !Space for integer header CONVPP1.34
CONVPP1.35
INTEGER CONVPP1.36
& LEN_FIXHD !Length of fixed length header on input file CONVPP1.37
&,LEN_INTHD !Length of integer header on input file CONVPP1.38
&,JOC_NO_SEAPTS !Number of points in compressed array UDG2F304.5
&,LEN_OCFLD !Length of uncompressed ocean field UDG2F304.6
&,LEN_REALHD !Length of real header on input file CONVPP1.39
&,LEN1_LEVDEPC !1st dim of lev dependent consts on input file CONVPP1.40
&,LEN2_LEVDEPC !2nd dim of lev dependent consts on input file CONVPP1.41
&,LEN1_ROWDEPC !1st dim of row dependent consts on input file CONVPP1.42
&,LEN2_ROWDEPC !2nd dim of row dependent consts on input file CONVPP1.43
&,LEN1_COLDEPC !1st dim of col dependent consts on input file CONVPP1.44
&,LEN2_COLDEPC !2nd dim of col dependent consts on input file CONVPP1.45
&,LEN1_FLDDEPC !1st dim of field dependent consts on input file CONVPP1.46
&,LEN2_FLDDEPC !2nd dim of field dependent consts on input file CONVPP1.47
&,LEN_EXTCNST !Length of extra consts on input file CONVPP1.48
&,LEN_DUMPHIST !Length of history header on input file CONVPP1.49
&,LEN_CFI1 !Length of index1 on input file CONVPP1.50
&,LEN_CFI2 !Length of index2 on input file CONVPP1.51
&,LEN_CFI3 !Length of index3 on input file CONVPP1.52
&,LEN1_LOOKUP !1st dim of LOOKUP on input file CONVPP1.53
&,LEN2_LOOKUP !2nd dim of LOOKUP on input file CONVPP1.54
&,LEN_DATA !Length of data on input file CONVPP1.55
&,ROW_LENGTH !No of points E-W on input file CONVPP1.56
&,P_ROWS !No of p-rows on input file CONVPP1.57
&,P_FIELD !No of p-points per level on input file CONVPP1.58
&,MAX_FIELD_SIZE !Maximum field size on file AD311093.20
CONVPP1.59
INTEGER CONVPP1.60
& LEN_IO !Length of I/O returned by BUFFER IN CONVPP1.61
&,I !Loop index CONVPP1.62
&,NFTIN !Unit number of input UM dump 1 CONVPP1.63
&,ERR !Return code from OPEN CONVPP1.64
CONVPP1.65
&,ICODE !Return code from setpos GTD0F400.52
REAL A !BUFFER IN UNIT function CONVPP1.66
CONVPP1.67
CONVPP1.68
C External subroutines called:------------------------------------------ CONVPP1.69
EXTERNAL IOERROR,ABORT_IO,BUFFIN,FILE_OPEN,SETPOS,ABORT, GPB1F305.24
& ATMOS_CONVPP,OCEAN_CONVPP UDG2F304.8
C*---------------------------------------------------------------------- CONVPP1.71
CONVPP1.72
CONVPP1.73
CL 1. Assign unit numbers CONVPP1.74
CONVPP1.75
NFTIN=20 CONVPP1.76
CONVPP1.77
WRITE(6,'(20x,''FILE STATUS'')') CONVPP1.78
WRITE(6,'(20x,''==========='')') CONVPP1.79
CONVPP1.80
CALL FILE_OPEN
(20,'FILE1',5,0,0,ERR) GPB1F305.26
CALL GET_FILE(10,ARG2,80,ICODE) GTD0F400.151
OPEN(10,FILE=ARG2,FORM='UNFORMATTED') CONVPP1.85
CONVPP1.90
CL 2. Buffer in fixed length header record CONVPP1.91
CONVPP1.92
CALL BUFFIN(NFTIN,FIXHD,256,LEN_IO,A) CONVPP1.93
CONVPP1.94
C Check for I/O errors CONVPP1.95
IF(A.NE.-1.0.OR.LEN_IO.NE.256)THEN CONVPP1.96
CALL IOERROR('buffer in of fixed length header of input dump', CONVPP1.97
* A,LEN_IO,256) CONVPP1.98
CALL ABORT CONVPP1.99
ENDIF CONVPP1.100
CONVPP1.101
C Set missing data indicator to zero CONVPP1.102
DO I=1,256 CONVPP1.103
IF(FIXHD(I).LT.0)FIXHD(I)=0 CONVPP1.104
ENDDO CONVPP1.105
CONVPP1.106
C Input file dimensions CONVPP1.107
LEN_FIXHD=256 CONVPP1.108
LEN_INTHD=FIXHD(101) CONVPP1.109
LEN_REALHD=FIXHD(106) CONVPP1.110
LEN1_LEVDEPC=FIXHD(111) CONVPP1.111
LEN2_LEVDEPC=FIXHD(112) CONVPP1.112
LEN1_ROWDEPC=FIXHD(116) CONVPP1.113
LEN2_ROWDEPC=FIXHD(117) CONVPP1.114
LEN1_COLDEPC=FIXHD(121) CONVPP1.115
LEN2_COLDEPC=FIXHD(122) CONVPP1.116
LEN1_FLDDEPC=FIXHD(126) CONVPP1.117
LEN2_FLDDEPC=FIXHD(127) CONVPP1.118
LEN_EXTCNST=FIXHD(131) CONVPP1.119
LEN_DUMPHIST=FIXHD(136) CONVPP1.120
LEN_CFI1=FIXHD(141) CONVPP1.121
LEN_CFI2=FIXHD(143) CONVPP1.122
LEN_CFI3=FIXHD(145) CONVPP1.123
LEN1_LOOKUP=FIXHD(151) CONVPP1.124
LEN2_LOOKUP=FIXHD(152) CONVPP1.125
LEN_DATA=FIXHD(161) CONVPP1.126
CONVPP1.127
CONVPP1.128
CL 3. Buffer in integer constants from dump CONVPP1.129
CONVPP1.130
CALL BUFFIN(NFTIN,INTHD,FIXHD(101),LEN_IO,A) CONVPP1.131
CONVPP1.132
C Check for I/O errors CONVPP1.133
IF(A.NE.-1.0.OR.LEN_IO.NE.FIXHD(101))THEN CONVPP1.134
CALL IOERROR('buffer in of integer constants in input dump', CONVPP1.135
* A,LEN_IO,FIXHD(101)) CONVPP1.136
CALL ABORT CONVPP1.137
ENDIF CONVPP1.138
CONVPP1.139
C Set missing data indicator to zero CONVPP1.140
DO I=1,FIXHD(101) CONVPP1.141
IF(INTHD(I).LT.0)INTHD(I)=0 CONVPP1.142
ENDDO CONVPP1.143
CONVPP1.144
ROW_LENGTH=INTHD(6) CONVPP1.145
P_ROWS=INTHD(7) CONVPP1.146
P_FIELD=ROW_LENGTH*P_ROWS CONVPP1.147
AD311093.21
CL Extract maximum field size from LOOKUP header AD311093.22
CALL FIND_MAX_FIELD_SIZE AD311093.23
& (NFTIN,FIXHD(151),FIXHD(152),FIXHD,MAX_FIELD_SIZE) AD311093.24
CONVPP1.148
C Calculate sizes of compressed and uncompressed ocean fields UDG2F304.9
JOC_NO_SEAPTS=INTHD(11) UDG2F304.10
IF(FIXHD(2).EQ.2)THEN UDG2F304.11
LEN_OCFLD=INTHD(6)*INTHD(7)*INTHD(8) UDG2F304.12
ELSE UDG2F304.13
LEN_OCFLD=0 UDG2F304.14
ENDIF UDG2F304.15
C Rewind file CONVPP1.149
CALL SETPOS(NFTIN,0,ICODE) GTD0F400.53
CONVPP1.151
IF(FIXHD(2).EQ.1)THEN UDG2F304.16
UDG2F304.17
C Atmospheric dump UDG2F304.18
CALL ATMOS_CONVPP (LEN_FIXHD,LEN_INTHD,LEN_REALHD, UDG2F304.19
UDG2F304.20
& LEN1_LEVDEPC,LEN2_LEVDEPC,LEN1_ROWDEPC, CONVPP1.155
& LEN2_ROWDEPC,LEN1_COLDEPC,LEN2_COLDEPC, CONVPP1.156
& LEN1_FLDDEPC,LEN2_FLDDEPC,LEN_EXTCNST, CONVPP1.157
& LEN_DUMPHIST,LEN_CFI1,LEN_CFI2,LEN_CFI3, CONVPP1.158
& LEN1_LOOKUP,LEN2_LOOKUP,LEN_DATA,P_FIELD, CONVPP1.159
& NFTIN,MAX_FIELD_SIZE) AD311093.25
UDG2F304.21
ELSEIF (FIXHD(2).EQ.2)THEN UDG2F304.22
UDG2F304.23
C Oceanic dump UDG2F304.24
CALL OCEAN_CONVPP (LEN_FIXHD,LEN_INTHD,LEN_REALHD, UDG2F304.25
& LEN1_LEVDEPC,LEN2_LEVDEPC,LEN1_ROWDEPC, UDG2F304.26
& LEN2_ROWDEPC,LEN1_COLDEPC,LEN2_COLDEPC, UDG2F304.27
& LEN1_FLDDEPC,LEN2_FLDDEPC,LEN_EXTCNST, UDG2F304.28
& LEN_DUMPHIST,LEN_CFI1,LEN_CFI2,LEN_CFI3, UDG2F304.29
& LEN1_LOOKUP,LEN2_LOOKUP,LEN_DATA,P_FIELD, UDG2F304.30
& NFTIN,MAX_FIELD_SIZE,JOC_NO_SEAPTS,LEN_OCFLD) UDG2F304.31
ENDIF UDG2F304.32
CONVPP1.161
STOP CONVPP1.162
END CONVPP1.163
CLL SUBROUTINE ATMOS_CONVPP ----------------------------------------- UDG2F304.33
CLL CONVPP1.165
CLL Purpose: Converts UM file to PP format. CONVPP1.166
CLL CONVPP1.167
CLL Written by A. Dickinson CONVPP1.168
CLL CONVPP1.169
CLL Model Modification history from model version 3.0: CONVPP1.170
CLL version Date CONVPP1.171
CLL CONVPP1.172
CLL 3.4 23/09/94 New output lookup table array introduced because UDG2F304.35
CLL element 21 set to 0 for output file would need UDG2F304.36
CLL to be reset before attempting to read next record UDG2F304.37
CLL Routine renamed because separate routine for UDG2F304.38
CLL ocean dump introduced. UDG2F304.39
CLL Author D.M.Goddard UDG2F304.40
! 4.1 18/06/96 Changes to cope with changes in STASH addressing GDG0F401.467
! Author D.M. Goddard. GDG0F401.468
CLL UDG2F304.41
CLL Documentation: UM Doc Paper F5 CONVPP1.173
CLL CONVPP1.174
CLL System Tasks: F3,F4,F6 CONVPP1.175
CLL CONVPP1.176
CLL ----------------------------------------------------------------- CONVPP1.177
C*L Arguments:------------------------------------------------------- CONVPP1.178
SUBROUTINE ATMOS_CONVPP 1,21UDG2F304.34
& (LEN_FIXHD,LEN_INTHD,LEN_REALHD, CONVPP1.180
& LEN1_LEVDEPC,LEN2_LEVDEPC,LEN1_ROWDEPC, CONVPP1.181
& LEN2_ROWDEPC,LEN1_COLDEPC,LEN2_COLDEPC, CONVPP1.182
& LEN1_FLDDEPC,LEN2_FLDDEPC,LEN_EXTCNST, CONVPP1.183
& LEN_DUMPHIST,LEN_CFI1,LEN_CFI2,LEN_CFI3, CONVPP1.184
& LEN1_LOOKUP,LEN2_LOOKUP,LEN_DATA,P_FIELD, CONVPP1.185
& NFTIN,MAX_FIELD_SIZE) AD311093.26
CL CONVPP1.187
CL CONVPP1.188
CONVPP1.189
IMPLICIT NONE CONVPP1.190
CONVPP1.191
INTEGER CONVPP1.192
CONVPP1.193
& LEN_FIXHD !IN Length of fixed length header on input file CONVPP1.194
&,LEN_INTHD !IN Length of integer header on input file CONVPP1.195
&,LEN_REALHD !IN Length of real header on input file CONVPP1.196
&,LEN1_LEVDEPC !IN 1st dim of lev dependent consts on input file CONVPP1.197
&,LEN2_LEVDEPC !IN 2nd dim of lev dependent consts on input file CONVPP1.198
&,LEN1_ROWDEPC !IN 1st dim of row dependent consts on input file CONVPP1.199
&,LEN2_ROWDEPC !IN 2nd dim of row dependent consts on input file CONVPP1.200
&,LEN1_COLDEPC !IN 1st dim of col dependent consts on input file CONVPP1.201
&,LEN2_COLDEPC !IN 2nd dim of col dependent consts on input file CONVPP1.202
&,LEN1_FLDDEPC !IN 1st dim of field dependent consts on input fi CONVPP1.203
&,LEN2_FLDDEPC !IN 2nd dim of field dependent consts on input fi CONVPP1.204
&,LEN_EXTCNST !IN Length of extra consts on input file CONVPP1.205
&,LEN_DUMPHIST !IN Length of history header on input file CONVPP1.206
&,LEN_CFI1 !IN Length of index1 on input file CONVPP1.207
&,LEN_CFI2 !IN Length of index2 on input file CONVPP1.208
&,LEN_CFI3 !IN Length of index3 on input file CONVPP1.209
&,LEN1_LOOKUP !IN 1st dim of LOOKUP on input file CONVPP1.210
&,LEN2_LOOKUP !IN 2nd dim of LOOKUP on input file CONVPP1.211
&,LEN_DATA !IN Length of data on input file CONVPP1.212
&,P_FIELD !IN No of p-points per level on input file CONVPP1.213
&,MAX_FIELD_SIZE !Maximum field size on file AD311093.27
CONVPP1.214
INTEGER CONVPP1.215
& NFTIN CONVPP1.216
CONVPP1.217
CONVPP1.218
C Local arrays:--------------------------------------------------------- CONVPP1.219
INTEGER CONVPP1.220
& FIXHD(LEN_FIXHD), ! CONVPP1.221
& INTHD(LEN_INTHD), !\ integer CONVPP1.222
& CFI1(LEN_CFI1+1),CFI2(LEN_CFI2+1), ! > file headers CONVPP1.223
& CFI3(LEN_CFI3+1), !/ CONVPP1.224
& LOOKUP(LEN1_LOOKUP,LEN2_LOOKUP) ! CONVPP1.225
&,LOOKUP_OUT(LEN1_LOOKUP) ! Output lookup table UDG2F304.42
CONVPP1.226
REAL CONVPP1.227
& REALHD(LEN_REALHD), CONVPP1.228
& LEVDEPC(1+LEN1_LEVDEPC*LEN2_LEVDEPC), ! CONVPP1.229
& ROWDEPC(1+LEN1_ROWDEPC*LEN2_ROWDEPC), ! CONVPP1.230
& COLDEPC(1+LEN1_COLDEPC*LEN2_COLDEPC), !\ real CONVPP1.231
& FLDDEPC(1+LEN1_FLDDEPC*LEN2_FLDDEPC), ! > file headers CONVPP1.232
& EXTCNST(LEN_EXTCNST+1), !/ CONVPP1.233
& DUMPHIST(LEN_DUMPHIST+1), ! CONVPP1.234
& D1(MAX_FIELD_SIZE) ! Data array used to read in each field AD311093.28
REAL D1_TMP(MAX_FIELD_SIZE) UDG5F404.4
UDG5F404.5
LOGICAL LAND_SEA_MASK(MAX_FIELD_SIZE) UDG5F404.6
CONVPP1.236
C External subroutines called:------------------------------------------ CONVPP1.237
EXTERNAL ABORT,ABORT_IO,READHEAD,READFLDS,HDPPXRF,GETPPX, UDG5F404.7
& FROM_LAND_POINTS UDG5F404.8
C*---------------------------------------------------------------------- CONVPP1.239
*CALL CSUBMODL GDG0F401.471
*CALL CPPXREF GDG0F401.472
*CALL PPXLOOK GDG0F401.473
*CALL CSTASH GDG0F401.474
C*---------------------------------------------------------------------- GDG0F401.475
C*L Local variables:--------------------------------------------------- CONVPP1.240
CONVPP1.241
INTEGER CONVPP1.242
& ICODE ! Error return code from subroutines CONVPP1.243
&,START_BLOCK ! READHEAD argument (not used) CONVPP1.244
&,I,J,K,L ! Loop indices CONVPP1.245
INTEGER ROWNUMBER ! Row number UDG5F404.9
REAL NROWS ! Number of points north-south UDG5F404.10
REAL NCOLS ! Number of points east-west UDG5F404.11
REAL RMDI ! Real missing data indicator UDG5F404.12
UDG5F404.13
CONVPP1.246
CHARACTER CONVPP1.247
& CMESSAGE*100 ! Character string returned if ICODE .ne. 0 CONVPP1.248
&,STRING*20 ! Format control for header printout CONVPP1.249
INTEGER NFT1,NFT2 GDG0F401.476
PARAMETER (NFT1=22, NFT2=2) GDG0F401.477
C*---------------------------------------------------------------------- CONVPP1.250
CONVPP1.251
CL 0. Read in PPXREF GDG0F401.478
GDG0F401.479
ppxRecs=1 GDG0F401.480
RowNumber=0 GDG0F401.481
cmessage = ' ' GDW1F404.158
ICODE=0 UDG9F404.45
CALL HDPPXRF(NFT1,'STASHmaster_A',ppxRecs,ICODE,CMESSAGE) GDG0F401.482
IF(ICODE.GT.0)THEN UDG9F404.46
WRITE(6,*) 'Error reading STASHmaster_A' UDG9F404.47
WRITE(6,*) CMESSAGE UDG9F404.48
CALL ABORT UDG9F404.49
END IF UDG9F404.50
CALL HDPPXRF(NFT1,'STASHmaster_O',ppxRecs,ICODE,CMESSAGE) GDG0F401.483
IF(ICODE.GT.0)THEN UDG9F404.51
WRITE(6,*) 'Error reading STASHmaster_O' UDG9F404.52
WRITE(6,*) CMESSAGE UDG9F404.53
CALL ABORT UDG9F404.54
END IF UDG9F404.55
CALL HDPPXRF(NFT1,'STASHmaster_S',ppxRecs,ICODE,CMESSAGE) GDG0F401.484
IF(ICODE.GT.0)THEN UDG9F404.56
WRITE(6,*) 'Error reading STASHmaster_S' UDG9F404.57
WRITE(6,*) CMESSAGE UDG9F404.58
CALL ABORT UDG9F404.59
END IF UDG9F404.60
CALL HDPPXRF(NFT1,'STASHmaster_W',ppxRecs,ICODE,CMESSAGE) GDG0F401.485
IF(ICODE.GT.0)THEN GDW1F404.159
WRITE(6,*) 'Error reading STASHmaster_W' UDG9F404.61
WRITE(6,*) CMESSAGE GDG0F401.487
CALL ABORT GDG0F401.488
ENDIF GDG0F401.489
GDG0F401.490
CALL GETPPX(NFT1,NFT2,'STASHmaster_A',RowNumber, GDG0F401.491
*CALL ARGPPX GDG0F401.492
& ICODE,CMESSAGE) GDG0F401.493
CALL GETPPX(NFT1,NFT2,'STASHmaster_O',RowNumber, GDG0F401.494
*CALL ARGPPX GDG0F401.495
& ICODE,CMESSAGE) GDG0F401.496
CALL GETPPX(NFT1,NFT2,'STASHmaster_S',RowNumber, GDG0F401.497
*CALL ARGPPX GDG0F401.498
& ICODE,CMESSAGE) GDG0F401.499
IF(ICODE.NE.0)THEN GDG0F401.500
WRITE(6,*) CMESSAGE GDG0F401.501
CALL ABORT GDG0F401.502
ENDIF GDG0F401.503
GDG0F401.504
!User STASHmaster GDG0F401.505
CALL HDPPXRF(0,' ',ppxRecs,ICODE,CMESSAGE) GDG0F401.506
IF(ICODE.NE.0)THEN GDG0F401.507
WRITE(6,*) CMESSAGE GDG0F401.508
CALL ABORT GDG0F401.509
ENDIF GDG0F401.510
GDG0F401.511
CALL GETPPX(0,NFT2,' ',RowNumber, GDG0F401.512
*CALL ARGPPX GDG0F401.513
& ICODE,CMESSAGE) GDG0F401.514
IF(ICODE.NE.0)THEN GDG0F401.515
WRITE(6,*) CMESSAGE GDG0F401.516
CALL ABORT GDG0F401.517
ENDIF GDG0F401.518
GDG0F401.519
CL 1. Read in file header CONVPP1.252
CONVPP1.253
CALL READHEAD(NFTIN,FIXHD,LEN_FIXHD, CONVPP1.254
& INTHD,LEN_INTHD, CONVPP1.255
& REALHD,LEN_REALHD, CONVPP1.256
& LEVDEPC,LEN1_LEVDEPC,LEN2_LEVDEPC, CONVPP1.257
& ROWDEPC,LEN1_ROWDEPC,LEN2_ROWDEPC, CONVPP1.258
& COLDEPC,LEN1_COLDEPC,LEN2_COLDEPC, CONVPP1.259
& FLDDEPC,LEN1_FLDDEPC,LEN2_FLDDEPC, CONVPP1.260
& EXTCNST,LEN_EXTCNST, CONVPP1.261
& DUMPHIST,LEN_DUMPHIST, CONVPP1.262
& CFI1,LEN_CFI1, CONVPP1.263
& CFI2,LEN_CFI2, CONVPP1.264
& CFI3,LEN_CFI3, CONVPP1.265
& LOOKUP,LEN1_LOOKUP,LEN2_LOOKUP, CONVPP1.266
& LEN_DATA, CONVPP1.267
*CALL ARGPPX GDG0F401.520
& START_BLOCK,ICODE,CMESSAGE) CONVPP1.268
CONVPP1.269
IF(ICODE.NE.0)THEN CONVPP1.270
WRITE(6,*)CMESSAGE,ICODE CONVPP1.271
CALL ABORT CONVPP1.272
ENDIF CONVPP1.273
CONVPP1.274
NROWS = INTHD(7) UDG5F404.14
NCOLS = INTHD(6) UDG5F404.15
RMDI = REALHD(29) UDG5F404.16
UDG5F404.17
DO I=1,LEN2_LOOKUP UDG5F404.18
IF(LOOKUP(42,I).EQ.30)THEN UDG5F404.19
CALL READFLDS(NFTIN,1,I,LOOKUP,LEN1_LOOKUP, UDG5F404.20
& LAND_SEA_MASK,MAX_FIELD_SIZE,FIXHD, UDG5F404.21
*CALL ARGPPX UDG5F404.22
& ICODE,CMESSAGE) UDG5F404.23
IF(ICODE.NE.0)CALL ABORT_IO('CONVPP',CMESSAGE,ICODE,NFTIN) UDG5F404.24
END IF UDG5F404.25
END DO UDG5F404.26
CONVPP1.276
CL Print out individual fields CONVPP1.277
DO I=1,LEN2_LOOKUP CONVPP1.278
IF(LOOKUP(1,I).EQ.-99)GOTO 100 CONVPP1.279
CONVPP1.280
C Fill output lookup table UDG2F304.43
DO K=1,LEN1_LOOKUP UDG2F304.44
LOOKUP_OUT(K)=LOOKUP(K,I) UDG2F304.45
ENDDO UDG2F304.46
UDG2F304.47
CALL READFLDS(NFTIN,1,I,LOOKUP,LEN1_LOOKUP, GDG0F401.521
& D1,MAX_FIELD_SIZE,FIXHD, GDG0F401.522
*CALL ARGPPX GDG0F401.523
& ICODE,CMESSAGE) GDG0F401.524
CONVPP1.284
LOOKUP_OUT(21)=MOD(LOOKUP_OUT(21),1000) UDG1F405.36
LOOKUP_OUT(21)=MOD(LOOKUP_OUT(21),1000) UDG5F404.27
IF((LOOKUP_OUT(21)/10)*10.EQ.120)THEN UDG5F404.28
!Data compressed on to land points. UDG5F404.29
!Copy data to temporary array UDG5F404.30
DO K=1,LOOKUP_OUT(15) UDG5F404.31
D1_TMP(K)=D1(K) UDG5F404.32
END DO UDG5F404.33
!Set unpacked array to RMDI UDG5F404.34
DO K=1,NROWS*NCOLS UDG5F404.35
D1(K)=RMDI UDG5F404.36
END DO UDG5F404.37
UDG5F404.38
!Uncompress data UDG5F404.39
CALL FROM_LAND_POINTS(D1,D1_TMP,LAND_SEA_MASK, UDG5F404.40
& MAX_FIELD_SIZE,LOOKUP_OUT(15)) UDG5F404.41
LOOKUP_OUT(15)=NROWS*NCOLS UDG5F404.42
LOOKUP_OUT(18)=NROWS UDG5F404.43
LOOKUP_OUT(19)=NCOLS UDG5F404.44
LOOKUP_OUT(21)=0 UDG5F404.45
END IF UDG5F404.46
WRITE(10)(LOOKUP_OUT(K),K=1,64) UDG2F304.49
WRITE(10) (D1(K),K=1,LOOKUP_OUT(15)) UDG2F304.50
ENDDO CONVPP1.288
CONVPP1.289
100 CONTINUE CONVPP1.290
WRITE(6,*)I-1,' pp fields written out' CONVPP1.291
CONVPP1.292
RETURN CONVPP1.293
END CONVPP1.294
CLL SUBROUTINE OCEAN_CONVPP----------------------------------------- UDG2F304.51
CLL UDG2F304.52
CLL Purpose: Converts UM ocean file to PP format. UDG2F304.53
CLL UDG2F304.54
CLL Written by D.M. Goddard UDG2F304.55
CLL UDG2F304.56
CLL Model Modification history from model version 3.4: UDG2F304.57
CLL version Date UDG2F304.58
CLL UDG2F304.59
CLL 3.4 23/09/94 New routine at version 3.4 UDG2F304.60
CLL UDG2F304.61
CLL Documentation: UM Doc Paper F5 UDG2F304.62
CLL UDG2F304.63
CLL System Tasks: F3,F4,F6 UDG2F304.64
CLL UDG2F304.65
CLL ----------------------------------------------------------------- UDG2F304.66
C*L Arguments:------------------------------------------------------- UDG2F304.67
SUBROUTINE OCEAN_CONVPP 1,22UDG2F304.68
& (LEN_FIXHD,LEN_INTHD,LEN_REALHD, UDG2F304.69
& LEN1_LEVDEPC,LEN2_LEVDEPC,LEN1_ROWDEPC, UDG2F304.70
& LEN2_ROWDEPC,LEN1_COLDEPC,LEN2_COLDEPC, UDG2F304.71
& LEN1_FLDDEPC,LEN2_FLDDEPC,LEN_EXTCNST, UDG2F304.72
& LEN_DUMPHIST,LEN_CFI1,LEN_CFI2,LEN_CFI3, UDG2F304.73
& LEN1_LOOKUP,LEN2_LOOKUP,LEN_DATA,P_FIELD, UDG2F304.74
& NFTIN,MAX_FIELD_SIZE,JOC_NO_SEAPTS,LEN_OCFLD) UDG2F304.75
CL UDG2F304.76
CL UDG2F304.77
UDG2F304.78
IMPLICIT NONE UDG2F304.79
UDG2F304.80
INTEGER UDG2F304.81
UDG2F304.82
& LEN_FIXHD !IN Length of fixed length header on input file UDG2F304.83
&,LEN_INTHD !IN Length of integer header on input file UDG2F304.84
&,LEN_REALHD !IN Length of real header on input file UDG2F304.85
&,LEN1_LEVDEPC !IN 1st dim of lev dependent consts on input file UDG2F304.86
&,LEN2_LEVDEPC !IN 2nd dim of lev dependent consts on input file UDG2F304.87
&,LEN1_ROWDEPC !IN 1st dim of row dependent consts on input file UDG2F304.88
&,LEN2_ROWDEPC !IN 2nd dim of row dependent consts on input file UDG2F304.89
&,LEN1_COLDEPC !IN 1st dim of col dependent consts on input file UDG2F304.90
&,LEN2_COLDEPC !IN 2nd dim of col dependent consts on input file UDG2F304.91
&,LEN1_FLDDEPC !IN 1st dim of field dependent consts on input fi UDG2F304.92
&,LEN2_FLDDEPC !IN 2nd dim of field dependent consts on input fi UDG2F304.93
&,LEN_EXTCNST !IN Length of extra consts on input file UDG2F304.94
&,LEN_DUMPHIST !IN Length of history header on input file UDG2F304.95
&,LEN_CFI1 !IN Length of index1 on input file UDG2F304.96
&,LEN_CFI2 !IN Length of index2 on input file UDG2F304.97
&,LEN_CFI3 !IN Length of index3 on input file UDG2F304.98
&,LEN1_LOOKUP !IN 1st dim of LOOKUP on input file UDG2F304.99
&,LEN2_LOOKUP !IN 2nd dim of LOOKUP on input file UDG2F304.100
&,LEN_DATA !IN Length of data on input file UDG2F304.101
&,P_FIELD !IN No of p-points per level on input file UDG2F304.102
&,MAX_FIELD_SIZE !IN Maximum field size on file UDG2F304.103
&,JOC_NO_SEAPTS !IN Number of points in compressed array UDG2F304.104
&,LEN_OCFLD !IN Length of uncompressed ocean field UDG2F304.105
UDG2F304.106
INTEGER UDG2F304.107
& NFTIN UDG2F304.108
UDG2F304.109
UDG2F304.110
C Local arrays:--------------------------------------------------------- UDG2F304.111
INTEGER UDG2F304.112
& FIXHD(LEN_FIXHD), ! UDG2F304.113
& INTHD(LEN_INTHD), !\ integer UDG2F304.114
& CFI1(LEN_CFI1+1),CFI2(LEN_CFI2+1), ! > file headers UDG2F304.115
& CFI3(LEN_CFI3+1), !/ UDG2F304.116
& LOOKUP(LEN1_LOOKUP,LEN2_LOOKUP) ! UDG2F304.117
&,LOOKUP_OUT(LEN1_LOOKUP) ! Output lookup table UDG2F304.118
UDG2F304.119
REAL UDG2F304.120
& REALHD(LEN_REALHD), UDG2F304.121
& LEVDEPC(1+LEN1_LEVDEPC*LEN2_LEVDEPC), ! UDG2F304.122
& ROWDEPC(1+LEN1_ROWDEPC*LEN2_ROWDEPC), ! UDG2F304.123
& COLDEPC(1+LEN1_COLDEPC*LEN2_COLDEPC), !\ real UDG2F304.124
& FLDDEPC(1+LEN1_FLDDEPC*LEN2_FLDDEPC), ! > file headers UDG2F304.125
& EXTCNST(LEN_EXTCNST+1), !/ UDG2F304.126
& DUMPHIST(LEN_DUMPHIST+1), ! UDG2F304.127
& D1(MAX_FIELD_SIZE), ! Array used to read in non-compressed fields UDG2F304.128
& E1(MAX_FIELD_SIZE), ! Array used to read in non-compressed fields UDG5F404.55
! without wrap points UDG5F404.56
& C1(JOC_NO_SEAPTS), ! Array used to read in compressed fields UDG2F304.129
& U1(LEN_OCFLD) ! Array used to hold uncompressed fields UDG2F304.130
UDG2F304.131
UDG2F304.132
C External subroutines called:------------------------------------------ UDG2F304.133
EXTERNAL ABORT,ABORT_IO,READHEAD,READFLDS,HDPPXRF,GETPPX,UNPACK GDG0F401.525
C*---------------------------------------------------------------------- UDG2F304.135
*CALL CSUBMODL GDG0F401.526
*CALL CPPXREF GDG0F401.527
*CALL PPXLOOK GDG0F401.528
*CALL CSTASH GDG0F401.529
C*---------------------------------------------------------------------- GDG0F401.530
C*L Local variables:--------------------------------------------------- UDG2F304.136
UDG2F304.137
INTEGER UDG2F304.138
& ICODE ! Error return code from subroutines UDG2F304.139
&,START_BLOCK ! READHEAD argument (not used) UDG2F304.140
&,I,J,K,L ! Loop indices UDG2F304.141
&,IJ_IN,IJ_OUT ! More loop indices UDG5F404.57
&,NROWS ! Number of points north-south UDG2F304.142
&,NROWS_FIELD ! Number of rows in a field UDG5F404.58
&,NCOLS_IN ! Number of points east-west UDG5F404.59
&,NCOLS_OUT ! Number of points east-west for pp fields UDG5F404.60
&,NLEVS ! Number of points in vertical UDG2F304.144
&,NT ! Number of tracers UDG2F304.145
&,NCOMP ! Number of compressed fields UDG2F304.147
&,RECNUM ! Record number of field in lookup table UDG2F304.148
&,POSIN ! Start position of field within C1 UDG2F304.149
&,POSU1 ! Start position of field within U1 UDG5F404.61
&,FIELD_CODE ! field code for this field UDG5F404.62
&,LBPACK ! packing indicator from lookup table UDG5F404.63
UDG2F304.151
CHARACTER UDG2F304.152
& CMESSAGE*100 ! Character string returned if ICODE .ne. 0 UDG2F304.153
&,STRING*20 ! Format control for header printout UDG2F304.154
UDG2F304.155
REAL UDG2F304.156
& RMDI ! Real missing data indicator UDG2F304.157
UDG2F304.158
LOGICAL UDG5F404.64
& LL_CYCLIC_IN ! T => cyclic ; F => not cyclic UDG5F404.65
UDG5F404.66
INTEGER RowNumber GDG0F401.531
GDG0F401.532
INTEGER NFT1,NFT2 GDG0F401.533
PARAMETER (NFT1=22, NFT2=2) GDG0F401.534
GDG0F401.535
C*---------------------------------------------------------------------- UDG2F304.159
UDG2F304.160
CL 0. Read in PPXREF GDG0F401.536
GDG0F401.537
ppxRecs=1 GDG0F401.538
RowNumber=0 GDG0F401.539
CMESSAGE='' UDG9F404.62
ICODE=0 UDG9F404.63
CALL HDPPXRF(NFT1,'STASHmaster_A',ppxRecs,ICODE,CMESSAGE) GDG0F401.540
IF(ICODE.GT.0)THEN UDG9F404.64
WRITE(6,*) 'Error reading STASHmaster_A' UDG9F404.65
WRITE(6,*) CMESSAGE UDG9F404.66
CALL ABORT UDG9F404.67
END IF UDG9F404.68
CALL HDPPXRF(NFT1,'STASHmaster_O',ppxRecs,ICODE,CMESSAGE) GDG0F401.541
IF(ICODE.GT.0)THEN UDG9F404.69
WRITE(6,*) 'Error reading STASHmaster_O' UDG9F404.70
WRITE(6,*) CMESSAGE UDG9F404.71
CALL ABORT UDG9F404.72
END IF UDG9F404.73
CALL HDPPXRF(NFT1,'STASHmaster_S',ppxRecs,ICODE,CMESSAGE) GDG0F401.542
IF(ICODE.GT.0)THEN UDG9F404.74
WRITE(6,*) 'Error reading STASHmaster_S' UDG9F404.75
WRITE(6,*) CMESSAGE UDG9F404.76
CALL ABORT UDG9F404.77
END IF UDG9F404.78
CALL HDPPXRF(NFT1,'STASHmaster_W',ppxRecs,ICODE,CMESSAGE) GDG0F401.543
IF(ICODE.NE.0)THEN GDG0F401.544
WRITE(6,*) 'Error reading STASHmaster_W' UDG9F404.79
WRITE(6,*) CMESSAGE GDG0F401.545
CALL ABORT GDG0F401.546
ENDIF GDG0F401.547
GDG0F401.548
CALL GETPPX(NFT1,NFT2,'STASHmaster_A',RowNumber, GDG0F401.549
*CALL ARGPPX GDG0F401.550
& ICODE,CMESSAGE) GDG0F401.551
CALL GETPPX(NFT1,NFT2,'STASHmaster_O',RowNumber, GDG0F401.552
*CALL ARGPPX GDG0F401.553
& ICODE,CMESSAGE) GDG0F401.554
CALL GETPPX(NFT1,NFT2,'STASHmaster_S',RowNumber, GDG0F401.555
*CALL ARGPPX GDG0F401.556
& ICODE,CMESSAGE) GDG0F401.557
CALL GETPPX(NFT1,NFT2,'STASHmaster_W',RowNumber, GDG0F401.558
*CALL ARGPPX GDG0F401.559
& ICODE,CMESSAGE) GDG0F401.560
IF(ICODE.NE.0)THEN GDG0F401.561
WRITE(6,*) CMESSAGE GDG0F401.562
CALL ABORT GDG0F401.563
ENDIF GDG0F401.564
GDG0F401.565
!User STASHmaster GDG0F401.566
CALL HDPPXRF(0,' ',ppxRecs,ICODE,CMESSAGE) GDG0F401.567
IF(ICODE.NE.0)THEN GDG0F401.568
WRITE(6,*) CMESSAGE GDG0F401.569
CALL ABORT GDG0F401.570
ENDIF GDG0F401.571
GDG0F401.572
CALL GETPPX(0,NFT2,' ',RowNumber, GDG0F401.573
*CALL ARGPPX GDG0F401.574
& ICODE,CMESSAGE) GDG0F401.575
IF(ICODE.NE.0)THEN GDG0F401.576
WRITE(6,*) CMESSAGE GDG0F401.577
CALL ABORT GDG0F401.578
ENDIF GDG0F401.579
GDG0F401.580
CL 1. Read in file header UDG2F304.161
UDG2F304.162
CALL READHEAD(NFTIN,FIXHD,LEN_FIXHD, UDG2F304.163
& INTHD,LEN_INTHD, UDG2F304.164
& REALHD,LEN_REALHD, UDG2F304.165
& LEVDEPC,LEN1_LEVDEPC,LEN2_LEVDEPC, UDG2F304.166
& ROWDEPC,LEN1_ROWDEPC,LEN2_ROWDEPC, UDG2F304.167
& COLDEPC,LEN1_COLDEPC,LEN2_COLDEPC, UDG2F304.168
& FLDDEPC,LEN1_FLDDEPC,LEN2_FLDDEPC, UDG2F304.169
& EXTCNST,LEN_EXTCNST, UDG2F304.170
& DUMPHIST,LEN_DUMPHIST, UDG2F304.171
& CFI1,LEN_CFI1, UDG2F304.172
& CFI2,LEN_CFI2, UDG2F304.173
& CFI3,LEN_CFI3, UDG2F304.174
& LOOKUP,LEN1_LOOKUP,LEN2_LOOKUP, UDG2F304.175
& LEN_DATA, UDG2F304.176
*CALL ARGPPX UDG5F404.47
& START_BLOCK,ICODE,CMESSAGE) UDG2F304.177
UDG2F304.178
IF(ICODE.NE.0)THEN UDG2F304.179
WRITE(6,*)CMESSAGE,ICODE UDG2F304.180
CALL ABORT UDG2F304.181
ENDIF UDG2F304.182
UDG2F304.183
UDG5F404.67
NROWS = INTHD(7) UDG2F304.185
NCOLS_IN = INTHD(6) UDG5F404.68
LBPACK = 21 UDG5F404.69
NLEVS = INTHD(8) UDG2F304.187
RMDI = REALHD(29) UDG2F304.188
NT = INTHD(14) UDG2F304.189
UDG2F304.191
! Determine whether input data is cyclic and number of columns to output UDG5F404.70
UDG5F404.71
IF ( MOD ( FIXHD(4), 100 ) .NE. 3 ) THEN UDG5F404.72
LL_CYCLIC_IN = .TRUE. UDG5F404.73
ELSE UDG5F404.74
LL_CYCLIC_IN = .FALSE. UDG5F404.75
ENDIF UDG5F404.76
UDG5F404.77
CL 2. Read in compressed data UDG2F304.192
UDG5F404.78
RECNUM=1 UDG2F304.193
UDG5F404.79
C Decide whether there are any compressed fields and on number of UDG5F404.80
C compressed fields. Use LBPACK to work out whether the first field UDG5F404.81
C contains sea points only. UDG5F404.82
UDG5F404.83
IF ( MOD(LOOKUP(LBPACK,1)/10,10) .EQ. 0) THEN UDG5F404.84
UDG5F404.85
NCOMP = 0 UDG5F404.86
UDG5F404.87
ELSE UDG5F404.88
UDG5F404.89
NCOMP = NT + 2 UDG5F404.90
UDG5F404.91
DO L=1,NCOMP UDG2F304.194
UDG2F304.195
C Loop over levels storing all levels in one 1-D array UDG2F304.196
POSIN=1 UDG2F304.197
DO K=1,NLEVS UDG2F304.198
UDG2F304.199
CALL READFLDS(NFTIN,1,RECNUM,LOOKUP,LEN1_LOOKUP,C1(POSIN), UDG2F304.200
& MAX_FIELD_SIZE,FIXHD, GDG0F401.581
*CALL ARGPPX GDG0F401.582
& ICODE,CMESSAGE) GDG0F401.583
IF(ICODE.NE.0)CALL ABORT_IO('CONVPP',CMESSAGE,ICODE,NFTIN) UDG2F304.202
POSIN=POSIN+LOOKUP(15,K+(L-1)*NLEVS) UDG2F304.203
RECNUM=RECNUM+1 UDG2F304.204
UDG2F304.205
ENDDO UDG2F304.206
UDG2F304.207
CL 3. Uncompress 3-D field UDG2F304.208
CALL UNPACK(1,NROWS,1,NLEVS,NROWS,NLEVS,NCOLS_IN,NROWS,NLEVS, UDG5F404.92
& CFI1,CFI2,LEN_CFI1,CFI3,JOC_NO_SEAPTS, UDG2F304.210
& C1,U1,RMDI,LL_CYCLIC_IN) UDG5F404.93
UDG2F304.212
CL 4. Output data level by level UDG2F304.213
DO K=1,NLEVS UDG5F404.94
UDG2F304.215
C Fill output lookup table UDG2F304.216
DO I=1,LEN1_LOOKUP UDG5F404.95
LOOKUP_OUT(I)=LOOKUP(I,K+(L-1)*NLEVS) UDG5F404.96
ENDDO UDG2F304.220
UDG5F404.97
FIELD_CODE = LOOKUP_OUT(23) UDG5F404.98
UDG5F404.99
IF ( FIELD_CODE .GT. 600 .AND. FIELD_CODE .LT. 700) THEN UDG5F404.100
NROWS_FIELD = NROWS UDG5F404.101
ELSE IF ( FIELD_CODE .GT. 699 .AND. FIELD_CODE .LT. 800 ) THEN UDG5F404.102
NROWS_FIELD = NROWS - 1 UDG5F404.103
ELSE UDG5F404.104
write(6,*) ' unknown field code : exiting ' UDG5F404.105
go to 9999 UDG5F404.106
END IF UDG5F404.107
UDG5F404.108
! Determine number of columns to output UDG5F404.109
UDG5F404.110
IF ( LL_CYCLIC_IN ) THEN UDG5F404.111
NCOLS_OUT = NCOLS_IN - 2 UDG5F404.112
ELSE UDG5F404.113
NCOLS_OUT = NCOLS_IN UDG5F404.114
ENDIF UDG5F404.115
UDG5F404.116
LOOKUP_OUT(15)=NROWS_FIELD*NCOLS_OUT UDG5F404.117
LOOKUP_OUT(18)=NROWS_FIELD UDG5F404.118
LOOKUP_OUT(19)=NCOLS_OUT UDG5F404.119
LOOKUP_OUT(21)=0 UDG2F304.224
WRITE(10)(LOOKUP_OUT(I),I=1,64) UDG5F404.120
UDG2F304.227
POSU1=(K-1)*NROWS*NCOLS_IN UDG5F404.121
DO J=1,NROWS_FIELD UDG5F404.122
DO I=1,NCOLS_OUT UDG5F404.123
IJ_IN = I + (J-1) * NCOLS_IN UDG5F404.124
IJ_OUT = I + (J-1) * NCOLS_OUT UDG5F404.125
E1(IJ_OUT) = U1(IJ_IN+POSU1) UDG5F404.126
ENDDO UDG2F304.228
ENDDO UDG5F404.127
UDG2F304.229
UDG5F404.128
WRITE(10) (E1(I),I=1,NROWS_FIELD*NCOLS_OUT) UDG5F404.129
UDG5F404.130
ENDDO UDG2F304.230
UDG2F304.231
ENDDO UDG5F404.131
UDG5F404.132
END IF ! LBPACK UDG5F404.133
UDG5F404.134
UDG5F404.135
CL 5. Now processing non compressed fields UDG2F304.232
C Print out individual fields UDG2F304.233
DO L=RECNUM,LEN2_LOOKUP UDG5F404.136
UDG2F304.235
IF(LOOKUP(1,L).EQ.-99)GOTO 100 UDG5F404.137
CALL READFLDS(NFTIN,1,L,LOOKUP,LEN1_LOOKUP, UDG5F404.138
& D1,MAX_FIELD_SIZE,FIXHD, GDG0F401.584
*CALL ARGPPX GDG0F401.585
& ICODE,CMESSAGE) GDG0F401.586
IF(ICODE.NE.0)CALL ABORT_IO('CONVPP',CMESSAGE,ICODE,NFTIN) UDG2F304.239
IF(FIXHD(3).NE.3)THEN UDG5F404.139
UDG5F404.140
! Take off the extra columns if the dump is cyclic using the E1 array UDG5F404.141
UDG5F404.142
IF ( LL_CYCLIC_IN ) THEN UDG5F404.143
NCOLS_OUT = NCOLS_IN - 2 UDG5F404.144
ELSE UDG5F404.145
NCOLS_OUT = NCOLS_IN UDG5F404.146
ENDIF UDG5F404.147
UDG5F404.148
DO J=1,NROWS UDG5F404.149
DO I=1,NCOLS_OUT UDG5F404.150
IJ_IN = I + (J-1) * NCOLS_IN UDG5F404.151
IJ_OUT = I + (J-1) * NCOLS_OUT UDG5F404.152
E1(IJ_OUT) = D1(IJ_IN) UDG5F404.153
ENDDO UDG5F404.154
ENDDO UDG5F404.155
UDG5F404.156
ELSE UDG5F404.157
UDG5F404.158
! Fieldsfile. NO cyclic columns UDG5F404.159
UDG5F404.160
DO I=1,LOOKUP(15,L) UDG5F404.161
E1(I) = D1(I) UDG5F404.162
ENDDO UDG5F404.163
UDG5F404.164
ENDIF UDG5F404.165
DO K=1,LEN1_LOOKUP UDG2F304.240
LOOKUP_OUT(K)=LOOKUP(K,L) UDG5F404.166
ENDDO UDG2F304.242
UDG5F404.167
IF(FIXHD(3).NE.3)THEN UDG5F404.168
LOOKUP_OUT(15)=NROWS*NCOLS_OUT UDG5F404.169
LOOKUP_OUT(19)=NCOLS_OUT UDG5F404.170
ENDIF UDG5F404.171
LOOKUP_OUT(21)=MOD(LOOKUP_OUT(21),1000) UDG5F404.172
WRITE(10)(LOOKUP_OUT(K),K=1,64) UDG2F304.244
WRITE(10) (E1(K),K=1,LOOKUP_OUT(15)) UDG5F404.173
UDG2F304.246
ENDDO UDG2F304.247
UDG2F304.248
100 CONTINUE UDG2F304.249
WRITE(6,*)L-1,' pp fields written out' UDG5F404.174
UDG5F404.175
9999 continue UDG5F404.176
UDG2F304.251
RETURN UDG2F304.252
END UDG2F304.253
UDG2F304.254
*ENDIF AD311093.2