PROGRAM MAIN_CONVIEEE ,14CONVIEE1.26
CONVIEE1.27
IMPLICIT NONE CONVIEE1.28
CONVIEE1.29
INTEGER CONVIEE1.30
& FIXHD(256) !Space for fixed length header CONVIEE1.31
&,INTHD(100) !Space for integer header CONVIEE1.32
CONVIEE1.33
INTEGER CONVIEE1.34
& LEN_FIXHD !Length of fixed length header on input file CONVIEE1.35
&,LEN_INTHD !Length of integer header on input file CONVIEE1.36
&,LEN_REALHD !Length of real header on input file CONVIEE1.37
&,LEN1_LEVDEPC !1st dim of lev dependent consts on input file CONVIEE1.38
&,LEN2_LEVDEPC !2nd dim of lev dependent consts on input file CONVIEE1.39
&,LEN1_ROWDEPC !1st dim of row dependent consts on input file CONVIEE1.40
&,LEN2_ROWDEPC !2nd dim of row dependent consts on input file CONVIEE1.41
&,LEN1_COLDEPC !1st dim of col dependent consts on input file CONVIEE1.42
&,LEN2_COLDEPC !2nd dim of col dependent consts on input file CONVIEE1.43
&,LEN1_FLDDEPC !1st dim of field dependent consts on input file CONVIEE1.44
&,LEN2_FLDDEPC !2nd dim of field dependent consts on input file CONVIEE1.45
&,LEN_EXTCNST !Length of extra consts on input file CONVIEE1.46
&,LEN_DUMPHIST !Length of history header on input file CONVIEE1.47
&,LEN_CFI1 !Length of index1 on input file CONVIEE1.48
&,LEN_CFI2 !Length of index2 on input file CONVIEE1.49
&,LEN_CFI3 !Length of index3 on input file CONVIEE1.50
&,LEN1_LOOKUP !1st dim of LOOKUP on input file CONVIEE1.51
&,LEN2_LOOKUP !2nd dim of LOOKUP on input file CONVIEE1.52
&,LEN_DATA !Length of data on input file CONVIEE1.53
&,ROW_LENGTH !No of points E-W on input file CONVIEE1.54
&,P_ROWS !No of p-rows on input file CONVIEE1.55
&,P_FIELD !No of p-points per level on input file CONVIEE1.56
&,MAX_FIELD_SIZE !Maximum field size on file AD311093.6
CONVIEE1.57
INTEGER CONVIEE1.58
& LEN_IO !Length of I/O returned by BUFFER IN CONVIEE1.59
&,I !Loop index CONVIEE1.60
&,NFTIN !Unit number of input UM dump CONVIEE1.61
&,NFTOUT !Unit number of output IEEE dump CONVIEE1.62
&,ERR !Return code from OPEN CONVIEE1.63
&,IEEE_TYPE ! Output file precision CONVIEE1.64
&,ICODE !Return code from setpos GTD0F400.50
&,LEN !Length of string returned by PXFGETARG UDG1F402.1
&,IERR !Return code from PXFGETARG UDG1F402.2
CONVIEE1.66
LOGICAL LPVP !TRUE if output required in PVP format UDG2F404.19
CHARACTER *80 CONVIEE1.67
& STRING ! Character string holding command line arg CONVIEE1.68
CONVIEE1.69
REAL A !Return code from BUFFIN; -1.0 = O.K. CONVIEE1.70
CONVIEE1.71
integer wgdos_expand UBC2F402.1
CONVIEE1.72
*CALL CNTL_IO 
UDG2F404.20
UDG2F404.21
C External subroutines called:------------------------------------------ CONVIEE1.73
EXTERNAL IOERROR,ABORT_IO,BUFFIN,FILE_OPEN, GPB1F305.19
& SETPOS,ABORT,CONVIEEE,PXFGETARG UDG1F402.3
C*---------------------------------------------------------------------- CONVIEE1.75
UDG2F404.22
LPVP=.FALSE. UDG2F404.23
CONVIEE1.76
c--select no WGDOS expansion UBC2F402.2
wgdos_expand=0 UBC2F402.3
CONVIEE1.77
CL 0. Read in precision of output file CONVIEE1.78
CALL PXFGETARG(1,STRING,LEN,IERR) UDG1F402.4
IF(LEN.NE.2.OR.IERR.NE.0)THEN UDG1F402.5
IEEE_TYPE=32 CONVIEE1.81
if(len.eq.3 .and. ierr.eq.0) then UBC2F402.4
if(string.eq.'32e' .or. string.eq.'32E') then UBC2F402.5
wgdos_expand=1 UBC2F402.6
else if(string.eq.'64e' .or. string.eq.'64E') then UBC2F402.7
ieee_type=64 UBC2F402.8
wgdos_expand=1 UBC2F402.9
else if(string.eq.'64c' .or. string.eq.'64C') then UDG2F404.24
ieee_type=64 UDG2F404.25
lpvp=.true. UDG2F404.26
else UDG2F404.27
WRITE(6,*)'Unsupported word length ',STRING UDG2F404.28
CALL ABORT UDG2F404.29
endif UBC2F402.10
elseif(len.eq.4 .and. ierr.eq.0) then UDG2F404.30
if(string.eq.'64ce' .or. string.eq.'64ec' .or. UDG2F404.31
& string.eq.'64CE' .or. string.eq.'64EC' ) then UDG2F404.32
ieee_type=64 UDG2F404.33
lpvp=.true. UDG2F404.34
wgdos_expand=1 UDG2F404.35
else UDG2F404.36
WRITE(6,*)'Unsupported word length ',STRING UDG2F404.37
CALL ABORT UDG2F404.38
end if UDG2F404.39
endif UBC2F402.11
ELSE CONVIEE1.82
IF(STRING.EQ.'32')THEN CONVIEE1.83
IEEE_TYPE=32 CONVIEE1.84
ELSEIF(STRING.EQ.'64')THEN CONVIEE1.85
IEEE_TYPE=64 CONVIEE1.86
ELSE CONVIEE1.87
WRITE(6,*)'Unsupported word length ',STRING CONVIEE1.88
CALL ABORT CONVIEE1.89
ENDIF CONVIEE1.90
ENDIF CONVIEE1.91
c UBC2F402.12
IF(WGDOS_EXPAND.EQ.0) THEN UDG2F404.40
IF(LPVP)THEN UDG2F404.41
WRITE(6,'(/''Conversion to PVP '',i2,''-bit Format'', UDG2F404.42
& '' with no expansion of WGDOS Fields''/)') ieee_type UDG2F404.43
ELSE UDG2F404.44
WRITE(6,'(/''Conversion to IEEE '',i2,''-bit Format'', UDG2F404.45
& '' with no expansion of WGDOS Fields''/)') ieee_type UDG2F404.46
END IF UDG2F404.47
ELSE UDG2F404.48
IF(LPVP)THEN UDG2F404.49
WRITE(6,'(/''Conversion to PVP '',i2,''-bit Format'', UDG2F404.50
& '' with expansion of WGDOS Fields''/)') ieee_type UDG2F404.51
ELSE UDG2F404.52
WRITE(6,'(/''Conversion to IEEE '',i2,''-bit Format'', UDG2F404.53
& '' with expansion of WGDOS Fields''/)') ieee_type UDG2F404.54
END IF UDG2F404.55
END IF UDG2F404.56
CONVIEE1.92
CONVIEE1.93
CL 1. Assign unit numbers CONVIEE1.94
CONVIEE1.95
NFTIN=20 CONVIEE1.96
NFTOUT=21 CONVIEE1.97
CONVIEE1.98
WRITE(6,'(20x,''FILE STATUS'')') CONVIEE1.99
WRITE(6,'(20x,''==========='')') CONVIEE1.100
C CALL OPEN(1,'PPXREF',6,0,0,ERR) CONVIEE1.101
CALL FILE_OPEN(20,'FILE1',5,0,0,ERR) GPB1F305.21
CALL FILE_OPEN(21,'FILE2',5,1,0,ERR) GPB1F305.22
CONVIEE1.104
CONVIEE1.105
CL 2. Buffer in fixed length header record CONVIEE1.106
CONVIEE1.107
CALL BUFFIN(NFTIN,FIXHD,256,LEN_IO,A) CONVIEE1.108
CONVIEE1.109
C Check for I/O errors CONVIEE1.110
IF(A.NE.-1.0.OR.LEN_IO.NE.256)THEN CONVIEE1.111
CALL IOERROR('buffer in of fixed length header of input dump', CONVIEE1.112
* A,LEN_IO,256) CONVIEE1.113
CALL ABORT CONVIEE1.114
ENDIF CONVIEE1.115
CONVIEE1.116
C Set missing data indicator to zero CONVIEE1.117
DO I=1,256 CONVIEE1.118
IF(FIXHD(I).LT.0)FIXHD(I)=0 CONVIEE1.119
ENDDO CONVIEE1.120
CONVIEE1.121
C Input file dimensions CONVIEE1.122
LEN_FIXHD=256 CONVIEE1.123
LEN_INTHD=FIXHD(101) CONVIEE1.124
LEN_REALHD=FIXHD(106) CONVIEE1.125
LEN1_LEVDEPC=FIXHD(111) CONVIEE1.126
LEN2_LEVDEPC=FIXHD(112) CONVIEE1.127
LEN1_ROWDEPC=FIXHD(116) CONVIEE1.128
LEN2_ROWDEPC=FIXHD(117) CONVIEE1.129
LEN1_COLDEPC=FIXHD(121) CONVIEE1.130
LEN2_COLDEPC=FIXHD(122) CONVIEE1.131
LEN1_FLDDEPC=FIXHD(126) CONVIEE1.132
LEN2_FLDDEPC=FIXHD(127) CONVIEE1.133
LEN_EXTCNST=FIXHD(131) CONVIEE1.134
LEN_DUMPHIST=FIXHD(136) CONVIEE1.135
LEN_CFI1=FIXHD(141) CONVIEE1.136
LEN_CFI2=FIXHD(143) CONVIEE1.137
LEN_CFI3=FIXHD(145) CONVIEE1.138
LEN1_LOOKUP=FIXHD(151) CONVIEE1.139
LEN2_LOOKUP=FIXHD(152) CONVIEE1.140
LEN_DATA=FIXHD(161) CONVIEE1.141
CONVIEE1.142
CONVIEE1.143
CL 3. Buffer in integer constants from dump CONVIEE1.144
CONVIEE1.145
CALL BUFFIN(NFTIN,INTHD,FIXHD(101),LEN_IO,A) CONVIEE1.146
CONVIEE1.147
C Check for I/O errors CONVIEE1.148
IF(A.NE.-1.0.OR.LEN_IO.NE.FIXHD(101))THEN CONVIEE1.149
CALL IOERROR('buffer in of integer constants in input dump', CONVIEE1.150
* A,LEN_IO,FIXHD(101)) CONVIEE1.151
CALL ABORT CONVIEE1.152
ENDIF CONVIEE1.153
CONVIEE1.154
C Set missing data indicator to zero CONVIEE1.155
DO I=1,FIXHD(101) CONVIEE1.156
IF(INTHD(I).LT.0)INTHD(I)=0 CONVIEE1.157
ENDDO CONVIEE1.158
CONVIEE1.159
ROW_LENGTH=INTHD(6) CONVIEE1.160
P_ROWS=INTHD(7) CONVIEE1.161
P_FIELD=ROW_LENGTH*P_ROWS CONVIEE1.162
CONVIEE1.163
! If converting to CRAY format reset um_sector_size = 1 UDG2F404.57
IF(LPVP)THEN UDG2F404.58
um_sector_size = 1 UDG2F404.59
ENDIF UDG2F404.60
AD311093.7
CL Extract maximum field size from LOOKUP header AD311093.8
CALL FIND_MAX_FIELD_SIZE AD311093.9
& (NFTIN,FIXHD(151),FIXHD(152),FIXHD,MAX_FIELD_SIZE, UBC2F402.20
& wgdos_expand) UBC2F402.21
C Rewind file CONVIEE1.164
CALL SETPOS(NFTIN,0,ICODE) GTD0F400.51
CONVIEE1.166
CL 4. Call CONVIEEE CONVIEE1.167
CONVIEE1.168
CALL CONVIEEE(LEN_FIXHD,LEN_INTHD,LEN_REALHD, CONVIEE1.169
& LEN1_LEVDEPC,LEN2_LEVDEPC,LEN1_ROWDEPC, CONVIEE1.170
& LEN2_ROWDEPC,LEN1_COLDEPC,LEN2_COLDEPC, CONVIEE1.171
& LEN1_FLDDEPC,LEN2_FLDDEPC,LEN_EXTCNST, CONVIEE1.172
& LEN_DUMPHIST,LEN_CFI1,LEN_CFI2,LEN_CFI3, CONVIEE1.173
& LEN1_LOOKUP,LEN2_LOOKUP,LEN_DATA,P_FIELD, CONVIEE1.174
& NFTIN,NFTOUT,IEEE_TYPE,LPVP, UDG2F404.61
& MAX_FIELD_SIZE, WGDOS_EXPAND) UDG2F404.62
CONVIEE1.176
STOP CONVIEE1.177
END CONVIEE1.178
C*L Arguments:------------------------------------------------------- CONVIEE1.179
SUBROUTINE CONVIEEE 1,26CONVIEE1.180
& (LEN_FIXHD,LEN_INTHD,LEN_REALHD, CONVIEE1.181
& LEN1_LEVDEPC,LEN2_LEVDEPC,LEN1_ROWDEPC, CONVIEE1.182
& LEN2_ROWDEPC,LEN1_COLDEPC,LEN2_COLDEPC, CONVIEE1.183
& LEN1_FLDDEPC,LEN2_FLDDEPC,LEN_EXTCNST, CONVIEE1.184
& LEN_DUMPHIST,LEN_CFI1,LEN_CFI2,LEN_CFI3, CONVIEE1.185
& LEN1_LOOKUP,LEN2_LOOKUP,LEN_DATA,P_FIELD, CONVIEE1.186
& NFTIN,NFTOUT,IEEE_TYPE,LPVP, UDG2F404.63
& MAX_FIELD_SIZE, WGDOS_EXPAND) UDG2F404.64
CONVIEE1.188
IMPLICIT NONE CONVIEE1.189
CONVIEE1.190
INTEGER CONVIEE1.191
CONVIEE1.192
& LEN_FIXHD !IN Length of fixed length header on input file CONVIEE1.193
&,LEN_INTHD !IN Length of integer header on input file CONVIEE1.194
&,LEN_REALHD !IN Length of real header on input file CONVIEE1.195
&,LEN1_LEVDEPC !IN 1st dim of lev dependent consts on input file CONVIEE1.196
&,LEN2_LEVDEPC !IN 2nd dim of lev dependent consts on input file CONVIEE1.197
&,LEN1_ROWDEPC !IN 1st dim of row dependent consts on input file CONVIEE1.198
&,LEN2_ROWDEPC !IN 2nd dim of row dependent consts on input file CONVIEE1.199
&,LEN1_COLDEPC !IN 1st dim of col dependent consts on input file CONVIEE1.200
&,LEN2_COLDEPC !IN 2nd dim of col dependent consts on input file CONVIEE1.201
&,LEN1_FLDDEPC !IN 1st dim of field dependent consts on input fi CONVIEE1.202
&,LEN2_FLDDEPC !IN 2nd dim of field dependent consts on input fi CONVIEE1.203
&,LEN_EXTCNST !IN Length of extra consts on input file CONVIEE1.204
&,LEN_DUMPHIST !IN Length of history header on input file CONVIEE1.205
&,LEN_CFI1 !IN Length of index1 on input file CONVIEE1.206
&,LEN_CFI2 !IN Length of index2 on input file CONVIEE1.207
&,LEN_CFI3 !IN Length of index3 on input file CONVIEE1.208
&,LEN1_LOOKUP !IN 1st dim of LOOKUP on input file CONVIEE1.209
&,LEN2_LOOKUP !IN 2nd dim of LOOKUP on input file CONVIEE1.210
&,LEN_DATA !IN Length of data on input file CONVIEE1.211
&,P_FIELD !IN No of p-points per level on input file CONVIEE1.212
&,MAX_FIELD_SIZE !Maximum field size on file AD311093.13
integer wgdos_expand ! set to 1 for expansion of WGDOS Fields UBC2F402.24
CONVIEE1.213
INTEGER CONVIEE1.214
& NFTIN !IN Unit number of input UM dump CONVIEE1.215
&,NFTOUT !IN Unit number of output IEEE dump CONVIEE1.216
&,IEEE_TYPE ! Output file precision CONVIEE1.217
CONVIEE1.218
LOGICAL LPVP !IN: TRUE if output required in PVP format UDG2F404.65
C Local arrays:--------------------------------------------------------- CONVIEE1.219
INTEGER CONVIEE1.220
& FIXHD(LEN_FIXHD), ! CONVIEE1.221
& INTHD(LEN_INTHD), !\ integer CONVIEE1.222
& CFI1(LEN_CFI1+1),CFI2(LEN_CFI2+1), ! > file headers CONVIEE1.223
& CFI3(LEN_CFI3+1), !/ CONVIEE1.224
& LOOKUP(LEN1_LOOKUP,LEN2_LOOKUP), ! CONVIEE1.225
& LOOKUP_21(LEN2_LOOKUP) ! Holds values of input LOOKUP(21,K) CONVIEE1.226
&,LOOKUP_LBNREC(LEN2_LOOKUP) AD060593.27
&,lookup_lblrec(len2_lookup) UBC2F402.25
&,lookup_lbegin(len2_lookup) ! Old value of lbegin in lookup GBCYF404.4
&,lookup_lblrec_new(len2_lookup) ! New value of lblrec in lookup GBCYF404.5
&,lookup_lbnrec_new(len2_lookup) ! New value of lbnrec in lookup GBCYF404.6
&,lookup_lbegin_new(len2_lookup) ! New value of lbegin in lookup GBCYF404.7
&,disk_address ! Current rounded disk address GBCYF404.8
&,number_of_data_words_on_disk ! Number of data words on disk GBCYF404.9
&,number_of_data_words_in_memory ! Number of Data Words in memory GBCYF404.10
&,old_fixhd_160 ! Input value of FIXHD(160) GBCYF404.11
&,new_fixhd_160 ! Output value of FIXHD(160) GBCYF404.12
CONVIEE1.227
REAL CONVIEE1.228
& REALHD(LEN_REALHD), CONVIEE1.229
& LEVDEPC(1+LEN1_LEVDEPC*LEN2_LEVDEPC), ! CONVIEE1.230
& ROWDEPC(1+LEN1_ROWDEPC*LEN2_ROWDEPC), ! CONVIEE1.231
& COLDEPC(1+LEN1_COLDEPC*LEN2_COLDEPC), !\ real CONVIEE1.232
& FLDDEPC(1+LEN1_FLDDEPC*LEN2_FLDDEPC), ! > file headers CONVIEE1.233
& EXTCNST(LEN_EXTCNST+1), !/ CONVIEE1.234
& DUMPHIST(LEN_DUMPHIST+1) UDG8F304.5
INTEGER UDG8F304.6
& D1(MAX_FIELD_SIZE) ! Data array used to read in each field AD311093.14
REAL*4 IEEE_32(MAX_FIELD_SIZE) !Array containing 32 bit IEEE data UDG7F403.5
REAL*8 IEEE_64(MAX_FIELD_SIZE) !Array containing 64 bit IEEE data UDG7F403.6
CONVIEE1.238
C External subroutines called:------------------------------------------ CONVIEE1.239
EXTERNAL READHEAD,WRITHEAD,ABORT,READFLDS,ABORT_IO,HDPPXRF,GETPPX UDG1F405.55
C*---------------------------------------------------------------------- CONVIEE1.243
C*L Local variables:--------------------------------------------------- CONVIEE1.244
CONVIEE1.245
INTEGER CONVIEE1.246
& ICODE ! Error return code from subroutines CONVIEE1.247
&,START_BLOCK ! READHEAD argument (not used) CONVIEE1.248
&,I,J,K,L ! Loop indices CONVIEE1.249
&,LEN_IO ! I/O length CONVIEE1.250
&,ITYPE ! Conversion type CONVIEE1.251
&,MODEL ! Internal model number UDG1F405.56
&,SECTION ! Section number UDG1F405.57
&,ITEM ! Item code UDG1F405.58
&,JOC_NO_SEAPTS ! Number of points in compressed ocean field UDG1F405.59
&,LEN_OCFLD ! Length of uncompressed ocean field UDG1F405.60
&,INIT_FIXHD_161 ! Initialised value of FIXHD(161) UDG1F405.61
&,PPXREF_GRID_TYPE ! Grid type form ppxref UDG1F405.62
&,LEN_BUF ! Record length of boundary dataset UDG1F405.63
&,MAX_LEN_BUF ! Maximum record length of boundary dataset UDG1F405.64
&,POS ! Position of field in file UDG1F405.65
UDG1F405.66
INTEGER EXPPXI UDG1F405.67
EXTERNAL EXPPXI UDG1F405.68
INTEGER RowNumber GDG0F401.383
GDG0F401.384
CONVIEE1.253
REAL A !Return code from BUFFIN; -1.0 = O.K. CONVIEE1.254
CONVIEE1.255
CHARACTER CONVIEE1.256
& CMESSAGE*100 ! Character string returned if ICODE .ne. 0 CONVIEE1.257
INTEGER NFT1,NFT2 GDG0F401.385
PARAMETER (NFT1=22, NFT2=2) GDG0F401.386
C*---------------------------------------------------------------------- CONVIEE1.258
*CALL CLOOKADD AD060593.28
*CALL CSUBMODL GDG0F401.387
*CALL CPPXREF GDG0F401.388
*CALL PPXLOOK GDG0F401.389
*CALL CSTASH GDG0F401.390
*CALL C_MDI UDG7F403.7
*CALL CNTL_IO UDG1F405.69
CL 0. Read in PPXREF GDG0F401.391
cmessage = ' ' GDW1F404.153
ppxRecs=1 GDG0F401.392
RowNumber=0 GDG0F401.393
ICODE=0 UDG9F404.25
CALL HDPPXRF(NFT1,'STASHmaster_A',ppxRecs,ICODE,CMESSAGE) GDG0F401.394
IF(ICODE.GT.0)THEN UDG9F404.26
WRITE(6,*) 'Error reading STASHmaster_A' UDG9F404.27
WRITE(6,*) CMESSAGE UDG9F404.28
CALL ABORT UDG9F404.29
END IF UDG9F404.30
CALL HDPPXRF(NFT1,'STASHmaster_O',ppxRecs,ICODE,CMESSAGE) GDG0F401.395
IF(ICODE.GT.0)THEN UDG9F404.31
WRITE(6,*) 'Error reading STASHmaster_O' UDG9F404.32
WRITE(6,*) CMESSAGE UDG9F404.33
CALL ABORT UDG9F404.34
END IF UDG9F404.35
CALL HDPPXRF(NFT1,'STASHmaster_S',ppxRecs,ICODE,CMESSAGE) GDG0F401.396
IF(ICODE.GT.0)THEN UDG9F404.36
WRITE(6,*) 'Error reading STASHmaster_S' UDG9F404.37
WRITE(6,*) CMESSAGE UDG9F404.38
CALL ABORT UDG9F404.39
END IF UDG9F404.40
CALL HDPPXRF(NFT1,'STASHmaster_W',ppxRecs,ICODE,CMESSAGE) UDG1F402.12
IF(ICODE.GT.0)THEN GDW1F404.154
WRITE(6,*) 'Error reading STASHmaster_W' UDG9F404.41
WRITE(6,*) CMESSAGE GDG0F401.398
CALL ABORT GDG0F401.399
END IF GDG0F401.400
GDG0F401.401
CALL GETPPX(NFT1,NFT2,'STASHmaster_A',RowNumber, GDG0F401.402
*CALL ARGPPX GDG0F401.403
& ICODE,CMESSAGE) GDG0F401.404
CALL GETPPX(NFT1,NFT2,'STASHmaster_O',RowNumber, GDG0F401.405
*CALL ARGPPX GDG0F401.406
& ICODE,CMESSAGE) GDG0F401.407
CALL GETPPX(NFT1,NFT2,'STASHmaster_S',RowNumber, GDG0F401.408
*CALL ARGPPX GDG0F401.409
& ICODE,CMESSAGE) GDG0F401.410
CALL GETPPX(NFT1,NFT2,'STASHmaster_W',RowNumber, GDG0F401.411
*CALL ARGPPX GDG0F401.412
& ICODE,CMESSAGE) GDG0F401.413
IF(ICODE.NE.0)THEN GDG0F401.414
WRITE(6,*) CMESSAGE GDG0F401.415
CALL ABORT GDG0F401.416
END IF GDG0F401.417
GDG0F401.418
!User STASHmaster GDG0F401.419
CALL HDPPXRF(0,' ',ppxRecs,ICODE,CMESSAGE) GDG0F401.420
IF(ICODE.NE.0)THEN GDG0F401.421
WRITE(6,*) CMESSAGE GDG0F401.422
CALL ABORT GDG0F401.423
END IF GDG0F401.424
GDG0F401.425
CALL GETPPX(0,NFT2,' ',RowNumber, GDG0F401.426
*CALL ARGPPX GDG0F401.427
& ICODE,CMESSAGE) GDG0F401.428
IF(ICODE.NE.0)THEN GDG0F401.429
WRITE(6,*) CMESSAGE GDG0F401.430
CALL ABORT GDG0F401.431
END IF GDG0F401.432
CONVIEE1.259
CL 1. Read in file header CONVIEE1.260
CONVIEE1.261
CALL READHEAD(NFTIN,FIXHD,LEN_FIXHD, GDG0F401.433
& INTHD,LEN_INTHD,REALHD,LEN_REALHD, GDG0F401.434
& LEVDEPC,LEN1_LEVDEPC,LEN2_LEVDEPC, GDG0F401.435
& ROWDEPC,LEN1_ROWDEPC,LEN2_ROWDEPC, GDG0F401.436
& COLDEPC,LEN1_COLDEPC,LEN2_COLDEPC, GDG0F401.437
& FLDDEPC,LEN1_FLDDEPC,LEN2_FLDDEPC, GDG0F401.438
& EXTCNST,LEN_EXTCNST,DUMPHIST,LEN_DUMPHIST, GDG0F401.439
& CFI1,LEN_CFI1,CFI2,LEN_CFI2,CFI3,LEN_CFI3, GDG0F401.440
& LOOKUP,LEN1_LOOKUP,LEN2_LOOKUP,LEN_DATA, GDG0F401.441
*CALL ARGPPX GDG0F401.442
& START_BLOCK,ICODE,CMESSAGE) GDG0F401.443
CONVIEE1.277
IF(ICODE.NE.0)THEN CONVIEE1.278
WRITE(6,*)CMESSAGE,ICODE CONVIEE1.279
CALL ABORT CONVIEE1.280
ENDIF CONVIEE1.281
CONVIEE1.282
! 2: Check for PP format dataset if field to be expanded UDG1F405.70
UDG1F405.71
IF(LOOKUP(LBNREC,1).GT.0.AND.FIXHD(12).GT.0)THEN UDG1F405.72
! Check for WGDOS expansion UDG1F405.73
IF (WGDOS_EXPAND.EQ.1)THEN UDG1F405.74
! Issue a message on why we are doing this UDG1F405.75
write(6,'(//''***** Initial Scan for PP Format Dataset'', UDG1F405.76
& '' *****''/)') UDG1F405.77
DO I=1,LEN2_LOOKUP UDG1F405.78
IF(LOOKUP(1,I).EQ.-99) GOTO 195 UDG1F405.79
CALL READFLDS(NFTIN,1,I,LOOKUP,LEN1_LOOKUP, UDG1F405.80
& D1,MAX_FIELD_SIZE,FIXHD, UDG1F405.81
*CALL ARGPPX UDG1F405.82
& IEEE_TYPE,LPVP,WGDOS_EXPAND,ICODE,CMESSAGE) UDG1F405.83
IF(ICODE.NE.0)CALL ABORT_IO('CONVIEEE',CMESSAGE,ICODE,NFTIN) UDG1F405.84
END DO UDG1F405.85
195 CONTINUE UDG1F405.86
END IF UDG1F405.87
END IF UDG1F405.88
UDG1F405.89
! 3: Reset LOOKUP and FIXHD UDG1F405.90
UDG1F405.91
INIT_FIXHD_161=0 UDG1F405.92
DO K=1,LEN2_LOOKUP UDG1F405.93
UDG1F405.94
IF(LOOKUP(1,K).EQ.-99)GOTO 200 UDG1F405.95
! Set LOOKUP(LBNREC) = 0 in old dumps where UM version number UDG1F405.96
! not in fixed length header UDG1F405.97
IF(FIXHD(12).LT.0.AND.FIXHD(5).NE.3)THEN UDG1F405.98
LOOKUP(LBNREC,K)=0 UDG1F405.99
END IF UDG1F405.100
UDG1F405.101
! Packing code = -2 now obselete, reset packing code to 2 UDG1F405.102
IF(LOOKUP(LBPACK,K).EQ.-2)LOOKUP(LBPACK,K)=2 UDG1F405.103
UDG1F405.104
! Preserve the original length values for re-use UDG1F405.105
OLD_FIXHD_160=FIXHD(160) UDG1F405.106
LOOKUP_LBLREC(K)=LOOKUP(LBLREC,K) UDG1F405.107
LOOKUP_LBEGIN(K)=LOOKUP(LBEGIN,K) UDG1F405.108
LOOKUP_LBNREC(K)=LOOKUP(LBNREC,K) UDG1F405.109
UDG1F405.110
! Store values of packing indicator and set least significant UDG1F405.111
! number in LOOKUP(LBPACK,K) to 0 to indicate no packing UDG1F405.112
LOOKUP_21(K)=LOOKUP(LBPACK,K) UDG1F405.113
LOOKUP(LBPACK,K)=MOD(LOOKUP(LBPACK,K),1000) UDG1F405.114
IF(MOD(LOOKUP(LBPACK,K),10).NE.1)THEN UDG1F405.115
LOOKUP(LBPACK,K)=(LOOKUP(LBPACK,K)/10)*10 UDG1F405.116
ELSE IF(WGDOS_EXPAND.EQ.1) THEN UDG1F405.117
LOOKUP(LBPACK,K)=(LOOKUP(LBPACK,K)/10)*10 UDG1F405.118
END IF UDG1F405.119
UDG1F405.120
! Process compressed fields UDG1F405.121
IF(MOD(LOOKUP(LBPACK, K),1000).EQ.110)THEN UDG1F405.122
IF(K.LE.(INTHD(14)+2)*INTHD(8))THEN UDG1F405.123
! Calculate expanded field lengths for ocean compressed fields UDG1F405.124
MODEL=LOOKUP(MODEL_CODE, K) UDG1F405.125
ITEM=MOD(LOOKUP(ITEM_CODE, K),1000) UDG1F405.126
SECTION=(LOOKUP(ITEM_CODE, K)-ITEM)/1000 UDG1F405.127
PPXREF_GRID_TYPE=EXPPXI(MODEL,SECTION,ITEM,PPX_GRID_TYPE, UDG1F405.128
*CALL ARGPPX UDG1F405.129
& ICODE,CMESSAGE) UDG1F405.130
IF(PPXREF_GRID_TYPE.EQ.36)THEN UDG1F405.131
! Ocean mass points. UDG1F405.132
LOOKUP(LBNPT,K) = INTHD(6) UDG1F405.133
LOOKUP(LBROW,K) = INTHD(7) UDG1F405.134
LOOKUP(LBLREC, K) = INTHD(6)*INTHD(7) UDG1F405.135
ELSEIF(PPXREF_GRID_TYPE.EQ.37)THEN UDG1F405.136
! Ocean velocity points. One less row. UDG1F405.137
LOOKUP(LBNPT,K) = INTHD(6) UDG1F405.138
LOOKUP(LBROW,K) = INTHD(7)-1 UDG1F405.139
LOOKUP(LBLREC, K) = INTHD(6)*(INTHD(7)-1) UDG1F405.140
END IF UDG1F405.141
LOOKUP(LBPACK, K) = 0 UDG1F405.142
UDG1F405.143
ELSE UDG1F405.144
! Field not compressed onto sea points. Correct packing code UDG1F405.145
LOOKUP(LBPACK, K)=MOD(LOOKUP(LBPACK, K),10) UDG1F405.146
END IF UDG1F405.147
UDG1F405.148
END IF UDG1F405.149
! Add to length of data UDG1F405.150
INIT_FIXHD_161=INIT_FIXHD_161+LOOKUP(LBLREC,K) UDG1F405.151
UDG1F405.152
END DO UDG1F405.153
UDG1F405.154
200 CONTINUE UDG1F405.155
FIXHD(160)=FIXHD(150)+FIXHD(151)*FIXHD(152) UDG1F405.156
FIXHD(161)=INIT_FIXHD_161 UDG1F405.157
LEN_DATA=INIT_FIXHD_161 UDG1F405.158
UDG1F405.159
DO K=1,LEN2_LOOKUP UDG1F405.160
! indicate output format. UDG1F405.161
IF(LPVP)THEN UDG1F405.162
LOOKUP(LBPACK,K)=LOOKUP(LBPACK,K)+2000 UDG1F405.163
ELSE UDG1F405.164
LOOKUP(LBPACK,K)=LOOKUP(LBPACK,K)+3000 UDG1F405.165
END IF UDG1F405.166
UDG1F405.167
END DO UDG1F405.168
UDG1F405.169
IF(FIXHD(12).LT.208)FIXHD(12)=208 AD070493.4
CONVIEE1.290
! Boundary datasets are structured differently. UDG1F405.170
! Skip call to set_dumpfile_address for boundary datasets and UDG1F405.171
! Calculate addressing for well formed boundary datasets explicitly. UDG1F405.172
IF (FIXHD(5).NE.5.OR.LPVP)THEN UDG1F405.173
UDG1F405.174
! Not a boundary dataset. Call set_dumpfile_address UDG1F405.175
c GBCYF404.22
c--reset the 32/64 bit lookup headers after packing, etc GBCYF404.23
c has been removed GBCYF404.24
call set_dumpfile_address(fixhd, len_fixhd, GBCYF404.25
& lookup, len1_lookup, GBCYF404.26
& len2_lookup, GBCYF404.27
& number_of_data_words_in_memory, GBCYF404.28
& number_of_data_words_on_disk, GBCYF404.29
& disk_address) GBCYF404.30
ELSE UDG1F405.176
UDG1F405.177
! Boundary dataset. Calcuate start address from header and round it up UDG1F405.178
! to ensure we start on a sector boundary UDG1F405.179
DISK_ADDRESS=FIXHD(160)-1 UDG1F405.180
DISK_ADDRESS=((DISK_ADDRESS+UM_SECTOR_SIZE-1)/ UDG1F405.181
& UM_SECTOR_SIZE)*UM_SECTOR_SIZE UDG1F405.182
UDG1F405.183
! Loop over number of times for which data is present in dataset UDG1F405.184
DO K=1,INTHD(3) UDG1F405.185
UDG1F405.186
! Loop over number of different field types present UDG1F405.187
LEN_BUF=0 UDG1F405.188
MAX_LEN_BUF=0 UDG1F405.189
DO I=1,INTHD(15) UDG1F405.190
POS=(K-1)*INTHD(15)+I UDG1F405.191
LOOKUP(LBEGIN,POS)=DISK_ADDRESS+LEN_BUF UDG1F405.192
LOOKUP(LBNREC,POS)=LOOKUP(LBLREC,POS) UDG1F405.193
LEN_BUF=LEN_BUF+LOOKUP(LBLREC,POS) UDG1F405.194
END DO UDG1F405.195
MAX_LEN_BUF=MAX0(LEN_BUF,MAX_LEN_BUF) UDG1F405.196
UDG1F405.197
! Update disk address and ensure that next time starts UDG1F405.198
! on a sector boundary UDG1F405.199
DISK_ADDRESS=DISK_ADDRESS+LEN_BUF UDG1F405.200
DISK_ADDRESS=((DISK_ADDRESS+UM_SECTOR_SIZE-1)/ UDG1F405.201
& UM_SECTOR_SIZE)*UM_SECTOR_SIZE UDG1F405.202
UDG1F405.203
END DO UDG1F405.204
UDG1F405.205
END IF UDG1F405.206
c--preserve the new length values for re-use GBCYF404.31
new_fixhd_160=fixhd(160) GBCYF404.32
do k=1,len2_lookup GBCYF404.33
lookup_lblrec_new(k)=lookup(lblrec, k) GBCYF404.34
lookup_lbnrec_new(k)=lookup(lbnrec, k) GBCYF404.35
lookup_lbegin_new(k)=lookup(lbegin, k) GBCYF404.36
end do GBCYF404.37
CL 1. Write out file header CONVIEE1.291
CONVIEE1.292
CALL WRITHEAD(NFTOUT,FIXHD,LEN_FIXHD, GDG0F401.444
& INTHD,LEN_INTHD,REALHD,LEN_REALHD, GDG0F401.445
& LEVDEPC,LEN1_LEVDEPC,LEN2_LEVDEPC, GDG0F401.446
& ROWDEPC,LEN1_ROWDEPC,LEN2_ROWDEPC, GDG0F401.447
& COLDEPC,LEN1_COLDEPC,LEN2_COLDEPC, GDG0F401.448
& FLDDEPC,LEN1_FLDDEPC,LEN2_FLDDEPC, GDG0F401.449
& EXTCNST,LEN_EXTCNST,DUMPHIST,LEN_DUMPHIST, GDG0F401.450
& CFI1,LEN_CFI1,CFI2,LEN_CFI2,CFI3,LEN_CFI3, GDG0F401.451
& LOOKUP,LEN1_LOOKUP,LEN2_LOOKUP,LEN_DATA, GDG0F401.452
*IF DEF,IEEE GDG0F401.453
& IEEE_TYPE, GDG0F401.454
& LPVP, UDG2F404.68
*ENDIF GDG0F401.455
*CALL ARGPPX GDG0F401.456
& START_BLOCK,ICODE,CMESSAGE) GDG0F401.457
CONVIEE1.313
IF(ICODE.NE.0)THEN CONVIEE1.314
WRITE(6,*)CMESSAGE,ICODE CONVIEE1.315
CALL ABORT CONVIEE1.316
ENDIF CONVIEE1.317
CONVIEE1.318
C Reset PP file indicator AD060593.50
IF(LOOKUP_LBNREC(1).GT.0)THEN AD060593.51
DO K=1,LEN2_LOOKUP AD060593.52
LOOKUP(LBNREC,K)=LOOKUP_LBNREC(K) AD060593.53
lookup(lblrec,k)=lookup_lblrec(k) UBC2F402.62
lookup(lbegin,k)=lookup_lbegin(k) GBCYF404.38
ENDDO AD060593.54
ENDIF AD060593.55
C Restore value of packing indicator CONVIEE1.319
CONVIEE1.320
DO K=1,LEN2_LOOKUP CONVIEE1.321
LOOKUP(21,K)=LOOKUP_21(K) CONVIEE1.322
ENDDO CONVIEE1.323
CONVIEE1.324
CL 3. Read in each field, convert to IEEE format and write out CONVIEE1.325
CL results to new file CONVIEE1.326
CONVIEE1.327
IF (FIXHD(2).EQ.1)THEN UDG1F405.207
UDG1F405.208
! Atmosphere file UDG1F405.209
CALL ATMOS_CONVIEEE(NFTIN,NFTOUT,IEEE_TYPE,MAX_FIELD_SIZE UDG1F405.210
&, LEN_FIXHD,LEN1_LOOKUP,LEN2_LOOKUP UDG1F405.211
&, OLD_FIXHD_160,NEW_FIXHD_160 UDG1F405.212
&, LOOKUP_LBLREC UDG1F405.213
&, LOOKUP_LBEGIN,LOOKUP_LBNREC UDG1F405.214
&, LOOKUP_LBEGIN_NEW,LOOKUP_LBNREC_NEW, UDG1F405.215
*CALL ARGPPX UDG1F405.216
& FIXHD,LOOKUP,WGDOS_EXPAND,LPVP) UDG1F405.217
UDG1F405.218
ELSEIF (FIXHD(2).EQ.2)THEN UDG1F405.219
UDG1F405.220
! Ocean file UDG1F405.221
UDG1F405.222
! Calculate sizes of compressed and uncompressed ocean fields UDG1F405.223
JOC_NO_SEAPTS=INTHD(11) UDG1F405.224
LEN_OCFLD =INTHD(6)*INTHD(7)*INTHD(8) UDG1F405.225
UDG1F405.226
CALL OCEAN_CONVIEEE(NFTIN,NFTOUT,IEEE_TYPE,MAX_FIELD_SIZE UDG1F405.227
&, LEN_FIXHD,LEN_INTHD UDG1F405.228
&, LEN_CFI1,LEN_CFI2,LEN_CFI3 UDG1F405.229
&, LEN1_LOOKUP,LEN2_LOOKUP UDG1F405.230
&, JOC_NO_SEAPTS,LEN_OCFLD UDG1F405.231
&, OLD_FIXHD_160,NEW_FIXHD_160 UDG1F405.232
&, LOOKUP_LBLREC,LOOKUP_LBLREC_NEW UDG1F405.233
&, LOOKUP_LBEGIN,LOOKUP_LBEGIN_NEW UDG1F405.234
&, LOOKUP_LBNREC,LOOKUP_LBNREC_NEW UDG1F405.235
&, FIXHD,INTHD,LOOKUP,CFI1,CFI2,CFI3, UDG1F405.236
*CALL ARGPPX UDG1F405.237
& WGDOS_EXPAND,LPVP) UDG1F405.238
UDG1F405.239
END IF UDG1F405.240
UDG1F405.241
WRITE(6,'(I4,'' fields have been converted'')') LEN2_LOOKUP UDG1F405.242
UDG1F405.243
RETURN UDG1F405.244
END CONVIEE1.389
SUBROUTINE ATMOS_CONVIEEE(NFTIN,NFTOUT,IEEE_TYPE,MAX_FIELD_SIZE 1,12UDG1F405.245
&, LEN_FIXHD,LEN1_LOOKUP,LEN2_LOOKUP UDG1F405.246
&, OLD_FIXHD_160,NEW_FIXHD_160 UDG1F405.247
&, LOOKUP_LBLREC UDG1F405.248
&, LOOKUP_LBEGIN,LOOKUP_LBNREC UDG1F405.249
&, LOOKUP_LBEGIN_NEW,LOOKUP_LBNREC_NEW, UDG1F405.250
*CALL ARGPPX UDG1F405.251
& FIXHD,LOOKUP,WGDOS_EXPAND,LPVP) UDG1F405.252
IMPLICIT NONE UDG1F405.253
INTEGER IEEE_TYPE UDG1F405.254
INTEGER LEN_FIXHD UDG1F405.255
INTEGER LEN1_LOOKUP UDG1F405.256
INTEGER LEN2_LOOKUP UDG1F405.257
INTEGER MAX_FIELD_SIZE UDG1F405.258
INTEGER NEW_FIXHD_160 UDG1F405.259
INTEGER NFTIN UDG1F405.260
INTEGER NFTOUT UDG1F405.261
INTEGER OLD_FIXHD_160 UDG1F405.262
INTEGER WGDOS_EXPAND UDG1F405.263
LOGICAL LPVP UDG1F405.264
UDG1F405.265
INTEGER FIXHD(LEN_FIXHD) UDG1F405.266
INTEGER LOOKUP_LBLREC(LEN2_LOOKUP) UDG1F405.267
INTEGER LOOKUP_LBEGIN(LEN2_LOOKUP) UDG1F405.268
INTEGER LOOKUP_LBNREC(LEN2_LOOKUP) UDG1F405.269
INTEGER LOOKUP_LBEGIN_NEW(LEN2_LOOKUP) UDG1F405.270
INTEGER LOOKUP_LBNREC_NEW(LEN2_LOOKUP) UDG1F405.271
INTEGER LOOKUP(LEN1_LOOKUP,LEN2_LOOKUP) UDG1F405.272
! Local arrays:-------------------------------------------------------- UDG1F405.273
INTEGER D1(MAX_FIELD_SIZE) ! Data array used to read in each field UDG1F405.274
REAL*4 IEEE_32(MAX_FIELD_SIZE) !Array containing 32 bit IEEE data UDG1F405.275
REAL*8 IEEE_64(MAX_FIELD_SIZE) !Array containing 64 bit IEEE data UDG1F405.276
! External subroutines called:----------------------------------------- UDG1F405.277
EXTERNAL ABORT,READFLDS,ABORT_IO,BUFFO32,PR_LOOK UDG1F405.278
EXTERNAL CRI2IEG,CRAY2CRI,CRI2CRAY UDG1F405.279
!---------------------------------------------------------------------- UDG1F405.280
! Local variables:----------------------------------------------------- UDG1F405.281
INTEGER I,J ! Loop variables UDG1F405.282
INTEGER K ! Return code from CRAY intrinsic functions UDG1F405.283
INTEGER ICODE ! Error return code from READFLDS UDG1F405.284
INTEGER ITYPE ! Conversion type UDG1F405.285
INTEGER LEN_IO ! I/O length UDG1F405.286
INTEGER CRI2IEG ! Function to convert Cray IEEE numbers UDG1F405.287
! to generic IEEE numbers UDG1F405.288
INTEGER CRAY2CRI ! Function to convert Cray PVP numbers UDG1F405.289
! to Cray IEEE numbers UDG1F405.290
INTEGER CRI2CRAY ! Function to convert Cray IEEE numbers UDG1F405.291
! to Cray PVP numbers UDG1F405.292
REAL A ! Return code from BUFFIN; -1.0 = O.K. UDG1F405.293
CHARACTER*80 CMESSAGE ! Character string returned if ICODE .ne. 0 UDG1F405.294
!---------------------------------------------------------------------- UDG1F405.295
*CALL CSUBMODL UDG1F405.296
*CALL CPPXREF UDG1F405.297
*CALL PPXLOOK UDG1F405.298
*CALL CSTASH UDG1F405.299
*CALL CLOOKADD UDG1F405.300
*CALL C_MDI UDG1F405.301
UDG1F405.302
! Loop over all fields UDG1F405.303
DO I=1,LEN2_LOOKUP UDG1F405.304
UDG1F405.305
! Check for the end of a PP format lookup table UDG1F405.306
IF(LOOKUP(1,I).EQ.-99) GOTO 2000 UDG1F405.307
UDG1F405.308
! Reset the headers in case WDGOS packing has altered them UDG1F405.309
LOOKUP(LBLREC,I)=LOOKUP_LBLREC(I) UDG1F405.310
LOOKUP(LBEGIN,I)=LOOKUP_LBEGIN(I) UDG1F405.311
LOOKUP(LBNREC,I)=LOOKUP_LBNREC(I) UDG1F405.312
FIXHD(160)=OLD_FIXHD_160 UDG1F405.313
UDG1F405.314
! Check if this field has already been converted - WGDOS only UDG1F405.315
IF(MOD(LOOKUP(21,I),10).EQ.1 .AND. WGDOS_EXPAND.NE.1) THEN UDG1F405.316
! Read in field UDG1F405.317
IF(IEEE_TYPE.EQ.32)THEN UDG1F405.318
CALL READFLDS(NFTIN,1,I,LOOKUP,LEN1_LOOKUP, UDG1F405.319
& IEEE_32,MAX_FIELD_SIZE,FIXHD, UDG1F405.320
*CALL ARGPPX UDG1F405.321
& IEEE_TYPE,LPVP, UDG1F405.322
& WGDOS_EXPAND,ICODE,CMESSAGE) UDG1F405.323
ELSEIF(IEEE_TYPE.EQ.64)THEN UDG1F405.324
! Read in field UDG1F405.325
CALL READFLDS(NFTIN,1,I,LOOKUP,LEN1_LOOKUP, UDG1F405.326
& IEEE_64,MAX_FIELD_SIZE,FIXHD, UDG1F405.327
*CALL ARGPPX UDG1F405.328
& IEEE_TYPE,LPVP, UDG1F405.329
& WGDOS_EXPAND,ICODE,CMESSAGE) UDG1F405.330
END IF UDG1F405.331
IF(ICODE.NE.0)CALL ABORT_IO('CONVIEEE',CMESSAGE,ICODE,NFTIN) UDG1F405.332
UDG1F405.333
ELSE IF(MOD(LOOKUP(21,I),10).EQ.1 .AND. WGDOS_EXPAND.EQ.1) THEN UDG1F405.334
! Read in field UDG1F405.335
CALL READFLDS(NFTIN,1,I,LOOKUP,LEN1_LOOKUP, UDG1F405.336
& IEEE_64,MAX_FIELD_SIZE,FIXHD, UDG1F405.337
*CALL ARGPPX UDG1F405.338
& IEEE_TYPE,LPVP, UDG1F405.339
& WGDOS_EXPAND,ICODE,CMESSAGE) UDG1F405.340
IF(ICODE.NE.0)CALL ABORT_IO('CONVIEEE',CMESSAGE,ICODE,NFTIN) UDG1F405.341
UDG1F405.342
ELSE UDG1F405.343
! Read in field UDG1F405.344
CALL READFLDS(NFTIN,1,I,LOOKUP,LEN1_LOOKUP, UDG1F405.345
& D1,MAX_FIELD_SIZE,FIXHD, UDG1F405.346
*CALL ARGPPX UDG1F405.347
& IEEE_TYPE,LPVP, UDG1F405.348
& WGDOS_EXPAND,ICODE,CMESSAGE) UDG1F405.349
IF(ICODE.NE.0)CALL ABORT_IO('CONVIEEE',CMESSAGE,ICODE,NFTIN) UDG1F405.350
UDG1F405.351
C Set data type UDG1F405.352
IF(ABS(LOOKUP(DATA_TYPE,I)).EQ.1) THEN UDG1F405.353
C Type real UDG1F405.354
IF(IEEE_TYPE.EQ.32)THEN UDG1F405.355
ITYPE=3 UDG1F405.356
ELSEIF(IEEE_TYPE.EQ.64)THEN UDG1F405.357
ITYPE=2 UDG1F405.358
ENDIF UDG1F405.359
ELSE IF(ABS(LOOKUP(DATA_TYPE,I)).EQ.2) THEN UDG1F405.360
C Type integer UDG1F405.361
IF(IEEE_TYPE.EQ.32)THEN UDG1F405.362
ITYPE=2 UDG1F405.363
ELSEIF(IEEE_TYPE.EQ.64)THEN UDG1F405.364
ITYPE=1 UDG1F405.365
ENDIF UDG1F405.366
ELSE IF(ABS(LOOKUP(DATA_TYPE,I)).EQ.3) THEN UDG1F405.367
C Type logical UDG1F405.368
ITYPE=5 UDG1F405.369
ELSE UDG1F405.370
CALL PR_LOOK( UDG1F405.371
*CALL ARGPPX UDG1F405.372
& LOOKUP,LOOKUP,LEN1_LOOKUP,I) UDG1F405.373
ICODE=3 UDG1F405.374
CMESSAGE='CONVIEEE: Invalid code in LOOKUP(39,K)' UDG1F405.375
RETURN UDG1F405.376
ENDIF UDG1F405.377
UDG1F405.378
C Convert to IEEE format and write to disk UDG1F405.379
IF(ITYPE.GE.0)THEN UDG1F405.380
IF(IEEE_TYPE.EQ.32)THEN UDG1F405.381
K=CRI2IEG(ITYPE,LOOKUP(LBLREC,I),IEEE_32,0, UDG1F405.382
& D1,1,64,IEEE_TYPE) UDG1F405.383
IF(K.NE.0)THEN UDG1F405.384
WRITE(6,*)'Conversion Error - Return Code is ',K UDG1F405.385
DO J=1,LOOKUP(LBLREC,I) UDG1F405.386
IF(.NOT.IEEE_FINITE(IEEE_32(J)))THEN UDG1F405.387
WRITE(6,'(''Error converting field '',i5, UDG1F405.388
& '' : Stash Code '',i5, UDG1F405.389
& '' : Point No. '',i5,)') UDG1F405.390
& I, LOOKUP(ITEM_CODE,I),J UDG1F405.391
WRITE(6,*) 'Number unconvertable reset to RMDI' UDG1F405.392
IEEE_32(J)=RMDI UDG1F405.393
END IF UDG1F405.394
END DO UDG1F405.395
END IF UDG1F405.396
END IF UDG1F405.397
IF(IEEE_TYPE.EQ.64)THEN UDG1F405.398
IF(LPVP)THEN UDG1F405.399
K=CRI2CRAY(ITYPE,LOOKUP(LBLREC,I),IEEE_64,0,D1,1) UDG1F405.400
IF(K.NE.0)THEN UDG1F405.401
WRITE(6,*)'Conversion Error - Return Code is ',K UDG1F405.402
CALL ABORT('CRI2CRAY Conversion Error') UDG1F405.403
END IF UDG1F405.404
ELSE UDG1F405.405
K=CRAY2CRI(ITYPE,LOOKUP(LBLREC,I),D1,0,IEEE_64,1) UDG1F405.406
IF(K.NE.0)THEN UDG1F405.407
WRITE(6,*)'Conversion Error - Return Code is ',K UDG1F405.408
CALL ABORT('CRAY2CRI Conversion Error') UDG1F405.409
END IF UDG1F405.410
END IF UDG1F405.411
END IF UDG1F405.412
ELSE UDG1F405.413
DO K=1,LOOKUP(LBLREC,I) UDG1F405.414
IEEE_32(k)=IAND(D1(K),1) UDG1F405.415
IEEE_64(k)=IAND(D1(K),1) UDG1F405.416
END DO UDG1F405.417
ENDIF UDG1F405.418
ENDIF UDG1F405.419
UDG1F405.420
C Write out field UDG1F405.421
FIXHD(160)=NEW_FIXHD_160 UDG1F405.422
IF(IEEE_TYPE.EQ.32)THEN UDG1F405.423
CALL SETPOS32(NFTOUT, LOOKUP_LBEGIN_NEW(I), K) UDG1F405.424
CALL BUFFO32(NFTOUT, IEEE_32, LOOKUP_LBNREC_NEW(I), LEN_IO, A) UDG1F405.425
ELSEIF(IEEE_TYPE.EQ.64)THEN UDG1F405.426
CALL SETPOS(NFTOUT, LOOKUP_LBEGIN_NEW(I), K) UDG1F405.427
CALL BUFFOUT(NFTOUT, IEEE_64, LOOKUP_LBNREC_NEW(I), LEN_IO, A) UDG1F405.428
ENDIF UDG1F405.429
UDG1F405.430
C Check for I/O errors UDG1F405.431
if(A.NE.-1.0.OR.LEN_IO.NE.LOOKUP_LBNREC_NEW(I)) THEN UDG1F405.432
CALL IOERROR('buffer out of data field', UDG1F405.433
* A,LEN_IO,LOOKUP(15,I)) UDG1F405.434
CALL ABORT UDG1F405.435
ENDIF UDG1F405.436
UDG1F405.437
WRITE(6,'(''Field '',i5,'' : Stash Code '',i5, UDG1F405.438
& '' : has been converted'')') I, LOOKUP(42,I) UDG1F405.439
UDG1F405.440
! Reset the headers in case WDGOS packing has altered them UDG1F405.441
LOOKUP(LBLREC,I)=LOOKUP_LBLREC(I) UDG1F405.442
LOOKUP(LBEGIN,I)=LOOKUP_LBEGIN(I) UDG1F405.443
LOOKUP(LBNREC,I)=LOOKUP_LBNREC(I) UDG1F405.444
FIXHD(160)=OLD_FIXHD_160 UDG1F405.445
UDG1F405.446
END DO UDG1F405.447
2000 CONTINUE UDG1F405.448
UDG1F405.449
RETURN UDG1F405.450
END UDG1F405.451
SUBROUTINE OCEAN_CONVIEEE(NFTIN,NFTOUT,IEEE_TYPE,MAX_FIELD_SIZE 1,20UDG1F405.452
&, LEN_FIXHD,LEN_INTHD UDG1F405.453
&, LEN_CFI1,LEN_CFI2,LEN_CFI3 UDG1F405.454
&, LEN1_LOOKUP,LEN2_LOOKUP UDG1F405.455
&, JOC_NO_SEAPTS,LEN_OCFLD UDG1F405.456
&, OLD_FIXHD_160,NEW_FIXHD_160 UDG1F405.457
&, LOOKUP_LBLREC,LOOKUP_LBLREC_NEW UDG1F405.458
&, LOOKUP_LBEGIN,LOOKUP_LBEGIN_NEW UDG1F405.459
&, LOOKUP_LBNREC,LOOKUP_LBNREC_NEW UDG1F405.460
&, FIXHD,INTHD,LOOKUP,CFI1,CFI2,CFI3, UDG1F405.461
*CALL ARGPPX UDG1F405.462
& WGDOS_EXPAND,LPVP) UDG1F405.463
IMPLICIT NONE UDG1F405.464
INTEGER IEEE_TYPE UDG1F405.465
INTEGER JOC_NO_SEAPTS UDG1F405.466
INTEGER LEN_OCFLD UDG1F405.467
INTEGER LEN_FIXHD UDG1F405.468
INTEGER LEN_INTHD UDG1F405.469
INTEGER LEN_CFI1 UDG1F405.470
INTEGER LEN_CFI2 UDG1F405.471
INTEGER LEN_CFI3 UDG1F405.472
INTEGER LEN1_LOOKUP UDG1F405.473
INTEGER LEN2_LOOKUP UDG1F405.474
INTEGER MAX_FIELD_SIZE UDG1F405.475
INTEGER NEW_FIXHD_160 UDG1F405.476
INTEGER NFTIN UDG1F405.477
INTEGER NFTOUT UDG1F405.478
INTEGER OLD_FIXHD_160 UDG1F405.479
INTEGER WGDOS_EXPAND UDG1F405.480
LOGICAL LPVP UDG1F405.481
UDG1F405.482
INTEGER FIXHD(LEN_FIXHD) UDG1F405.483
INTEGER INTHD(LEN_INTHD) UDG1F405.484
INTEGER CFI1(LEN_CFI1+1) UDG1F405.485
INTEGER CFI2(LEN_CFI2+1) UDG1F405.486
INTEGER CFI3(LEN_CFI3+1) UDG1F405.487
INTEGER LOOKUP_LBLREC(LEN2_LOOKUP) UDG1F405.488
INTEGER LOOKUP_LBEGIN(LEN2_LOOKUP) UDG1F405.489
INTEGER LOOKUP_LBNREC(LEN2_LOOKUP) UDG1F405.490
INTEGER LOOKUP_LBLREC_NEW(LEN2_LOOKUP) UDG1F405.491
INTEGER LOOKUP_LBEGIN_NEW(LEN2_LOOKUP) UDG1F405.492
INTEGER LOOKUP_LBNREC_NEW(LEN2_LOOKUP) UDG1F405.493
INTEGER LOOKUP(LEN1_LOOKUP,LEN2_LOOKUP) UDG1F405.494
! Local arrays:-------------------------------------------------------- UDG1F405.495
INTEGER D1(MAX_FIELD_SIZE) !Data array used to read in each fieldl UDG1F405.496
REAL*4 IEEE_32(MAX_FIELD_SIZE) !Array containing 32 bit IEEE data UDG1F405.497
REAL*8 IEEE_64(MAX_FIELD_SIZE) !Array containing 64 bit IEEE data UDG1F405.498
REAL C1(JOC_NO_SEAPTS) !Array holding compressed field UDG1F405.499
REAL E1(JOC_NO_SEAPTS) !Array holding compressed field UDG1F405.500
REAL U1(LEN_OCFLD) !Array holding uncompressed field UDG1F405.501
! External subroutines called:----------------------------------------- UDG1F405.502
EXTERNAL ABORT,READFLDS,ABORT_IO,BUFFO32,PR_LOOK UDG1F405.503
EXTERNAL CRI2IEG,CRAY2CRI,CRI2CRAY UDG1F405.504
!---------------------------------------------------------------------- UDG1F405.505
! Local variables:----------------------------------------------------- UDG1F405.506
INTEGER I,J,L ! Loop variables UDG1F405.507
INTEGER K ! Return code from CRAY intrinsic functions UDG1F405.508
INTEGER ICODE ! Error return code from READFLDS UDG1F405.509
INTEGER ITYPE ! Conversion type UDG1F405.510
INTEGER LEN_IO ! I/O length UDG1F405.511
INTEGER NCOMP ! Number of compressed fields UDG1F405.512
INTEGER NCOLS ! Number of points east-west UDG1F405.513
INTEGER NROWS ! Number of points north-south UDG1F405.514
INTEGER NLEVS ! Number of levels UDG1F405.515
INTEGER NT ! Number of tracers UDG1F405.516
INTEGER RECNUM ! Record number of field in lookup table UDG1F405.517
INTEGER POSIN ! Start position of field within C1 UDG1F405.518
INTEGER CRI2IEG ! Function to convert Cray IEEE numbers UDG1F405.519
! to generic IEEE numbers UDG1F405.520
INTEGER CRAY2CRI ! Function to convert Cray PVP numbers UDG1F405.521
! to Cray IEEE numbers UDG1F405.522
INTEGER CRI2CRAY ! Function to convert Cray IEEE numbers UDG1F405.523
! to Cray PVP numbers UDG1F405.524
REAL A ! Return code from BUFFIN; -1.0 = O.K. UDG1F405.525
LOGICAL LL_CYCLIC! T => cyclic ; f=> not cyclic UDG1F405.526
CHARACTER*80 CMESSAGE ! Character string returned if ICODE .ne. 0 UDG1F405.527
!---------------------------------------------------------------------- UDG1F405.528
*CALL CSUBMODL UDG1F405.529
*CALL CPPXREF UDG1F405.530
*CALL PPXLOOK UDG1F405.531
*CALL CSTASH UDG1F405.532
*CALL CLOOKADD UDG1F405.533
*CALL C_MDI UDG1F405.534
UDG1F405.535
! 1: Process ocean compressed fields first UDG1F405.536
UDG1F405.537
NCOLS = INTHD(6) UDG1F405.538
NROWS = INTHD(7) UDG1F405.539
NLEVS = INTHD(8) UDG1F405.540
IF(FIXHD(12).GE.304)THEN UDG1F405.541
NT = INTHD(14) UDG1F405.542
ELSE UDG1F405.543
NT = INTHD(14)+2 UDG1F405.544
END IF UDG1F405.545
RECNUM = 1 UDG1F405.546
UDG1F405.547
IF( MOD (FIXHD(4), 100 ) .NE. 3) THEN UDG1F405.548
LL_CYCLIC = .TRUE. UDG1F405.549
ELSE UDG1F405.550
LL_CYCLIC = .FALSE. UDG1F405.551
END IF UDG1F405.552
UDG1F405.553
! Decide whether there are any compressed fields and how many of them. UDG1F405.554
! Use LBPACK to determine whether the first field contains sea points UDG1F405.555
! only UDG1F405.556
IF( MOD(LOOKUP(LBPACK, 1)/10,10) .EQ. 0) THEN UDG1F405.557
NCOMP = 0 UDG1F405.558
ELSE UDG1F405.559
NCOMP = NT + 2 UDG1F405.560
!Can only convert compressed fields from cray pvp format to UDG1F405.561
! 64-bit ieee format UDG1F405.562
IF(IEEE_TYPE.EQ.32.OR.LPVP)THEN UDG1F405.563
WRITE(6,*) 'CONVIEEE: Conversion not supported' UDG1F405.564
WRITE(6,*) 'Conversion of compressed ocean fields to ' UDG1F405.565
&, '32-bit IEEE format' UDG1F405.566
WRITE(6,*) 'and cray PVP format not supported' UDG1F405.567
CALL ABORT UDG1F405.568
END IF UDG1F405.569
END IF UDG1F405.570
UDG1F405.571
DO L = 1,NCOMP UDG1F405.572
UDG1F405.573
! Loop over levels storing all levels in one 1-D array and convert UDG1F405.574
POSIN = 1 UDG1F405.575
DO J = 1,NLEVS UDG1F405.576
UDG1F405.577
! Reset the headers in case WDGOS packing has altered them UDG1F405.578
LOOKUP(LBLREC,J+(L-1)*NLEVS)=LOOKUP_LBLREC(J+(L-1)*NLEVS) UDG1F405.579
LOOKUP(LBEGIN,J+(L-1)*NLEVS)=LOOKUP_LBEGIN(J+(L-1)*NLEVS) UDG1F405.580
LOOKUP(LBNREC,J+(L-1)*NLEVS)=LOOKUP_LBNREC(J+(L-1)*NLEVS) UDG1F405.581
FIXHD(160)=OLD_FIXHD_160 UDG1F405.582
UDG1F405.583
CALL READFLDS(NFTIN,1,RECNUM,LOOKUP,LEN1_LOOKUP, UDG1F405.584
& E1(POSIN),MAX_FIELD_SIZE,FIXHD, UDG1F405.585
*CALL ARGPPX UDG1F405.586
& IEEE_TYPE,LPVP, UDG1F405.587
& WGDOS_EXPAND,ICODE,CMESSAGE) UDG1F405.588
IF(ICODE.NE.0)CALL ABORT_IO('CONVIEEE',CMESSAGE, UDG1F405.589
& ICODE,NFTIN) UDG1F405.590
POSIN=POSIN+LOOKUP(LBLREC, J+(L-1)*NLEVS) UDG1F405.591
RECNUM=RECNUM+1 UDG1F405.592
END DO UDG1F405.593
UDG1F405.594
! Convert to IEEE format. UDG1F405.595
ITYPE = 2 !Assume compressed data are type 'real' UDG1F405.596
K=CRAY2CRI(ITYPE,JOC_NO_SEAPTS,E1,0,C1,1) UDG1F405.597
IF(K.NE.0)THEN UDG1F405.598
WRITE(6,*)'Conversion Error - Return Code is ',K UDG1F405.599
CALL ABORT('CRAY2CRI Conversion Error') UDG1F405.600
END IF UDG1F405.601
UDG1F405.602
! Uncompress 3-D field UDG1F405.603
CALL UNPACK(1,NROWS,1,NLEVS,NROWS,NLEVS,NCOLS,NROWS,NLEVS, UDG1F405.604
& CFI1,CFI2,LEN_CFI1,CFI3,JOC_NO_SEAPTS, UDG1F405.605
& C1,U1,RMDI,LL_CYCLIC) UDG1F405.606
UDG1F405.607
! Write uncompressed IEEE data to disk a level at a time UDG1F405.608
DO J = 1,NLEVS UDG1F405.609
DO I=1,LOOKUP_LBLREC_NEW(J+(L-1)*NLEVS) UDG1F405.610
IEEE_64(I)=U1(I+(J-1)*NROWS*NCOLS) UDG1F405.611
END DO !I UDG1F405.612
CALL SETPOS(NFTOUT,LOOKUP_LBEGIN_NEW(J+(L-1)*NLEVS),K) UDG1F405.613
CALL BUFFOUT(NFTOUT,IEEE_64, UDG1F405.614
& LOOKUP_LBNREC_NEW(J+(L-1)*NLEVS), UDG1F405.615
& LEN_IO,A) UDG1F405.616
UDG1F405.617
C Check for I/O errors UDG1F405.618
IF(A.NE.-1.0.OR. UDG1F405.619
& LEN_IO.NE.LOOKUP_LBNREC_NEW(J+(L-1)*NLEVS))THEN UDG1F405.620
CALL IOERROR('buffer out of data field' UDG1F405.621
&, A,LEN_IO UDG1F405.622
&, LOOKUP_LBLREC_NEW(J+(L-1)*NLEVS)) UDG1F405.623
CALL ABORT UDG1F405.624
END IF UDG1F405.625
UDG1F405.626
WRITE(6,'(''Field '',i5,'' : Stash Code '',i5, UDG1F405.627
& '' : has been converted'')') UDG1F405.628
& J+(L-1)*NLEVS,LOOKUP(ITEM_CODE,J+(L-1)*NLEVS) UDG1F405.629
UDG1F405.630
! Reset the headers in case WDGOS packing has altered them UDG1F405.631
LOOKUP(LBLREC,J+(L-1)*NLEVS)=LOOKUP_LBLREC(J+(L-1)*NLEVS) UDG1F405.632
LOOKUP(LBEGIN,J+(L-1)*NLEVS)=LOOKUP_LBEGIN(J+(L-1)*NLEVS) UDG1F405.633
LOOKUP(LBNREC,J+(L-1)*NLEVS)=LOOKUP_LBNREC(J+(L-1)*NLEVS) UDG1F405.634
FIXHD(160)=OLD_FIXHD_160 UDG1F405.635
UDG1F405.636
UDG1F405.637
END DO ! J UDG1F405.638
END DO ! L UDG1F405.639
UDG1F405.640
! 2. Process uncompressed ocean fields UDG1F405.641
UDG1F405.642
! Loop over all fields UDG1F405.643
DO I=NCOMP*NLEVS+1,LEN2_LOOKUP UDG1F405.644
UDG1F405.645
! Check for the end of a PP format lookup table UDG1F405.646
IF(LOOKUP(1,I).EQ.-99) GOTO 2000 UDG1F405.647
UDG1F405.648
! Reset the headers in case WDGOS packing has altered them UDG1F405.649
LOOKUP(LBLREC,I)=LOOKUP_LBLREC(I) UDG1F405.650
LOOKUP(LBEGIN,I)=LOOKUP_LBEGIN(I) UDG1F405.651
LOOKUP(LBNREC,I)=LOOKUP_LBNREC(I) UDG1F405.652
FIXHD(160)=OLD_FIXHD_160 UDG1F405.653
UDG1F405.654
! Check if this field has already been converted - WGDOS only UDG1F405.655
IF(MOD(LOOKUP(21,I),10).EQ.1 .AND. WGDOS_EXPAND.NE.1) THEN UDG1F405.656
! Read in field UDG1F405.657
IF(IEEE_TYPE.EQ.32)THEN UDG1F405.658
CALL READFLDS(NFTIN,1,I,LOOKUP,LEN1_LOOKUP, UDG1F405.659
& IEEE_32,MAX_FIELD_SIZE,FIXHD, UDG1F405.660
*CALL ARGPPX UDG1F405.661
& IEEE_TYPE,LPVP, UDG1F405.662
& WGDOS_EXPAND,ICODE,CMESSAGE) UDG1F405.663
ELSE IF(IEEE_TYPE.EQ.64)THEN UDG1F405.664
! Read in field UDG1F405.665
CALL READFLDS(NFTIN,1,I,LOOKUP,LEN1_LOOKUP, UDG1F405.666
& IEEE_64,MAX_FIELD_SIZE,FIXHD, UDG1F405.667
*CALL ARGPPX UDG1F405.668
& IEEE_TYPE,LPVP, UDG1F405.669
& WGDOS_EXPAND,ICODE,CMESSAGE) UDG1F405.670
END IF UDG1F405.671
IF(ICODE.NE.0)CALL ABORT_IO('CONVIEEE',CMESSAGE,ICODE,NFTIN) UDG1F405.672
UDG1F405.673
ELSE IF(MOD(LOOKUP(21,I),10).EQ.1 .AND. WGDOS_EXPAND.EQ.1)THEN UDG1F405.674
! Read in field UDG1F405.675
CALL READFLDS(NFTIN,1,I,LOOKUP,LEN1_LOOKUP, UDG1F405.676
& IEEE_64,MAX_FIELD_SIZE,FIXHD, UDG1F405.677
*CALL ARGPPX UDG1F405.678
& IEEE_TYPE,LPVP, UDG1F405.679
& WGDOS_EXPAND,ICODE,CMESSAGE) UDG1F405.680
IF(ICODE.NE.0)CALL ABORT_IO('CONVIEEE',CMESSAGE,ICODE,NFTIN) UDG1F405.681
UDG1F405.682
ELSE UDG1F405.683
! Read in field UDG1F405.684
CALL READFLDS(NFTIN,1,I,LOOKUP,LEN1_LOOKUP, UDG1F405.685
& D1,MAX_FIELD_SIZE,FIXHD, UDG1F405.686
*CALL ARGPPX UDG1F405.687
& IEEE_TYPE,LPVP, UDG1F405.688
& WGDOS_EXPAND,ICODE,CMESSAGE) UDG1F405.689
IF(ICODE.NE.0)CALL ABORT_IO('CONVIEEE',CMESSAGE,ICODE,NFTIN) UDG1F405.690
UDG1F405.691
C Set data type UDG1F405.692
IF(ABS(LOOKUP(DATA_TYPE,I)).EQ.1) THEN UDG1F405.693
C Type real UDG1F405.694
IF(IEEE_TYPE.EQ.32)THEN UDG1F405.695
ITYPE=3 UDG1F405.696
ELSEIF(IEEE_TYPE.EQ.64)THEN UDG1F405.697
ITYPE=2 UDG1F405.698
ENDIF UDG1F405.699
ELSE IF(ABS(LOOKUP(DATA_TYPE,I)).EQ.2) THEN UDG1F405.700
C Type integer UDG1F405.701
IF(IEEE_TYPE.EQ.32)THEN UDG1F405.702
ITYPE=2 UDG1F405.703
ELSEIF(IEEE_TYPE.EQ.64)THEN UDG1F405.704
ITYPE=1 UDG1F405.705
ENDIF UDG1F405.706
ELSE IF(ABS(LOOKUP(DATA_TYPE,I)).EQ.3) THEN UDG1F405.707
C Type logical UDG1F405.708
ITYPE=5 UDG1F405.709
ELSE UDG1F405.710
CALL PR_LOOK( UDG1F405.711
*CALL ARGPPX UDG1F405.712
& LOOKUP,LOOKUP,LEN1_LOOKUP,I) UDG1F405.713
ICODE=3 UDG1F405.714
CMESSAGE='CONVIEEE: Invalid code in LOOKUP(39,K)' UDG1F405.715
RETURN UDG1F405.716
ENDIF UDG1F405.717
UDG1F405.718
C Convert to IEEE format and write to disk UDG1F405.719
IF(ITYPE.GE.0)THEN UDG1F405.720
IF(IEEE_TYPE.EQ.32)THEN UDG1F405.721
K=CRI2IEG(ITYPE,LOOKUP(LBLREC,I),IEEE_32,0, UDG1F405.722
& D1,1,64,IEEE_TYPE) UDG1F405.723
IF(K.NE.0)THEN UDG1F405.724
WRITE(6,*)'Conversion Error - Return Code is ',K UDG1F405.725
DO J=1,LOOKUP(LBLREC,I) UDG1F405.726
IF(.NOT.IEEE_FINITE(IEEE_32(J)))THEN UDG1F405.727
WRITE(6,'(''Error converting field '',i5, UDG1F405.728
& '' : Stash Code '',i5, UDG1F405.729
& '' : Point No. '',i5,)') UDG1F405.730
& I, LOOKUP(ITEM_CODE,I),J UDG1F405.731
WRITE(6,*) 'Number unconvertable reset to RMDI' UDG1F405.732
IEEE_32(J)=RMDI UDG1F405.733
END IF UDG1F405.734
END DO UDG1F405.735
END IF UDG1F405.736
END IF UDG1F405.737
IF(IEEE_TYPE.EQ.64)THEN UDG1F405.738
IF(LPVP)THEN UDG1F405.739
K=CRI2CRAY(ITYPE,LOOKUP(LBLREC,I),IEEE_64,0,D1,1) UDG1F405.740
IF(K.NE.0)THEN UDG1F405.741
WRITE(6,*)'Conversion Error - Return Code is ',K UDG1F405.742
CALL ABORT('CRI2CRAY Conversion Error') UDG1F405.743
END IF UDG1F405.744
ELSE UDG1F405.745
K=CRAY2CRI(ITYPE,LOOKUP(LBLREC,I),D1,0,IEEE_64,1) UDG1F405.746
IF(K.NE.0)THEN UDG1F405.747
WRITE(6,*)'Conversion Error - Return Code is ',K UDG1F405.748
CALL ABORT('CRAY2CRI Conversion Error') UDG1F405.749
END IF UDG1F405.750
END IF UDG1F405.751
END IF UDG1F405.752
ELSE UDG1F405.753
DO K=1,LOOKUP(LBLREC,I) UDG1F405.754
IEEE_32(k)=IAND(D1(K),1) UDG1F405.755
IEEE_64(k)=IAND(D1(K),1) UDG1F405.756
END DO UDG1F405.757
ENDIF UDG1F405.758
ENDIF UDG1F405.759
UDG1F405.760
C Write out field UDG1F405.761
FIXHD(160)=NEW_FIXHD_160 UDG1F405.762
IF(IEEE_TYPE.EQ.32)THEN UDG1F405.763
CALL SETPOS32(NFTOUT, LOOKUP_LBEGIN_NEW(I), K) UDG1F405.764
CALL BUFFO32(NFTOUT,IEEE_32,LOOKUP_LBNREC_NEW(I),LEN_IO,A) UDG1F405.765
ELSEIF(IEEE_TYPE.EQ.64)THEN UDG1F405.766
CALL SETPOS(NFTOUT, LOOKUP_LBEGIN_NEW(I), K) UDG1F405.767
CALL BUFFOUT(NFTOUT,IEEE_64,LOOKUP_LBNREC_NEW(I),LEN_IO,A) UDG1F405.768
ENDIF UDG1F405.769
UDG1F405.770
C Check for I/O errors UDG1F405.771
IF(A.NE.-1.0.OR.LEN_IO.NE.LOOKUP_LBNREC_NEW(I)) THEN UDG1F405.772
CALL IOERROR('buffer out of data field', UDG1F405.773
* A,LEN_IO,LOOKUP(15,I)) UDG1F405.774
CALL ABORT UDG1F405.775
ENDIF UDG1F405.776
UDG1F405.777
WRITE(6,'(''Field '',i5,'' : Stash Code '',i5, UDG1F405.778
& '' : has been converted'')') I, LOOKUP(42,I) UDG1F405.779
UDG1F405.780
! Reset the headers in case WDGOS packing has altered them UDG1F405.781
LOOKUP(LBLREC,I)=LOOKUP_LBLREC(I) UDG1F405.782
LOOKUP(LBEGIN,I)=LOOKUP_LBEGIN(I) UDG1F405.783
LOOKUP(LBNREC,I)=LOOKUP_LBNREC(I) UDG1F405.784
FIXHD(160)=OLD_FIXHD_160 UDG1F405.785
UDG1F405.786
END DO UDG1F405.787
2000 CONTINUE UDG1F405.788
UDG1F405.789
RETURN UDG1F405.790
END UDG1F405.791
*ENDIF CONVIEE1.390