subroutine read_lsm_anc(InUnit, Len_FixHd_P, Len1_Lookup_P, 3,11FPRDLSMA.36
# FixHd, Lookup, ncols, nrows, lsm, lambda, phi, FPRDLSMA.37
*CALL ARGPPX 
FPRDLSMA.38
# icode) FPRDLSMA.39
FPRDLSMA.40
implicit none FPRDLSMA.41
FPRDLSMA.42
! parameters used in argument list FPRDLSMA.43
*CALL DUMP_LEN FPRDLSMA.44
FPRDLSMA.45
! declaration of argument list FPRDLSMA.46
integer InUnit ! IN unit number of file FPRDLSMA.47
integer Len_FixHd_P ! IN length of fixed header FPRDLSMA.48
integer Len1_Lookup_P ! IN length of first dimension of Lookup FPRDLSMA.49
integer FixHd(Len_FixHd_P) ! IN fixed header FPRDLSMA.50
integer Lookup(Len1_Lookup_P) ! IN lookup table from file FPRDLSMA.51
integer ncols ! IN number of columns in grid FPRDLSMA.52
integer nrows ! IN number of rows in grid FPRDLSMA.53
integer lsm(ncols,nrows) ! OUT land / sea mask FPRDLSMA.54
real lambda(ncols) ! OUT coords of longitudes FPRDLSMA.55
real phi(nrows) ! OUT coords of latitudes FPRDLSMA.56
integer icode ! IN/OUT error code ; > 0 => fatal error detected FPRDLSMA.57
FPRDLSMA.58
! declaration of globals used FPRDLSMA.59
*CALL CSUBMODL FPRDLSMA.60
*CALL CPPXREF FPRDLSMA.61
*CALL PPXLOOK FPRDLSMA.62
*CALL CMESS FPRDLSMA.63
*CALL CLOOKADD FPRDLSMA.64
FPRDLSMA.65
! declaration of local arrays FPRDLSMA.66
real rowdepc(nrows) ! row dependent constants FPRDLSMA.67
real coldepc(ncols) ! column dependent constants FPRDLSMA.68
logical ll_lsm(ncols,nrows) ! land / sea mask T = land points FPRDLSMA.69
real flt_lsm(ncols,nrows) ! land / sea mask 1.0 = land point FPRDLSMA.70
FPRDLSMA.71
! declaration of local scalars FPRDLSMA.72
real DPhi ! latitude interval FPRDLSMA.73
real Phi0 ! Zeroth latitude FPRDLSMA.74
real DLambda ! Zeroth longitude FPRDLSMA.75
real Lambda0 ! Longitude interval FPRDLSMA.76
FPRDLSMA.77
integer jrow, icol ! loop indices for rows and columns FPRDLSMA.78
integer fld_no ! field number in file FPRDLSMA.79
integer Len_data ! length of data in file FPRDLSMA.80
FPRDLSMA.81
character*256 CMessage ! error messages FPRDLSMA.82
FPRDLSMA.83
external copy_to_real FPRDLSMA.84
!---------------------------------------------------------------------- FPRDLSMA.85
! 0. Preliminaries FPRDLSMA.86
CSub = 'read_lsm_anc' ! subroutine name for error messages FPRDLSMA.87
FPRDLSMA.88
FPRDLSMA.89
! 1. get dimensions from lookup table FPRDLSMA.90
FPRDLSMA.91
call setpos(InUnit, 0, icode) ! reset to start of file FPRDLSMA.92
if ( icode .ne. 0 ) then FPRDLSMA.93
write(UnErr,*)CErr,CSub, FPRDLSMA.94
# ' Step 1. Unable to reset ancillary file' FPRDLSMA.95
icode = 20 FPRDLSMA.96
goto 9999 FPRDLSMA.97
endif FPRDLSMA.98
FPRDLSMA.99
LEN_FIXHD = LEN_FIXHD_P FPRDLSMA.100
CALL GET_DIM(FIXHD, FPRDLSMA.101
*CALL DUMP_AR2 FPRDLSMA.102
# Len_data) FPRDLSMA.103
FPRDLSMA.104
! 2. if row and column dependent constants have non-zero length FPRDLSMA.105
! extract them from the lsm file FPRDLSMA.106
FPRDLSMA.107
! N.B. this code is schematic only at this stage and would need FPRDLSMA.108
! proper checking if it was to be used !!!! FPRDLSMA.109
! I assume that rowdepc and coldepc are set up as implied in FPRDLSMA.110
! section 4. below. FPRDLSMA.111
FPRDLSMA.112
if ( LEN1_COLDEPC .gt. 1 .and. LEN1_ROWDEPC .gt. 1) then FPRDLSMA.113
FPRDLSMA.114
! 2.1 check that the lengths match nrows and ncols FPRDLSMA.115
FPRDLSMA.116
if ( nrows .ne. LEN1_ROWDEPC FPRDLSMA.117
# .or. ncols. ne. LEN1_COLDEPC) then FPRDLSMA.118
write(UnErr,*)CErr,CSub, FPRDLSMA.119
# ' step 2.1. dimensions do not match ' FPRDLSMA.120
go to 9999 FPRDLSMA.121
end if FPRDLSMA.122
FPRDLSMA.123
! 2.2 get the row and column dependent constants (which are row FPRDLSMA.124
! and column spacings FPRDLSMA.125
FPRDLSMA.126
call setpos(InUnit, 0, icode) FPRDLSMA.127
if ( icode .ne. 0 ) then FPRDLSMA.128
write(UnErr,*)CErr,CSub, FPRDLSMA.129
# ' Step 2.2. Unable to reset ancillary file' FPRDLSMA.130
icode = 20 FPRDLSMA.131
goto 9999 FPRDLSMA.132
endif FPRDLSMA.133
FPRDLSMA.134
call get_rows_cols(InUnit, icode, FPRDLSMA.135
*CALL DUMP_AR2 FPRDLSMA.136
*CALL ARGPPX FPRDLSMA.137
# Len_data, rowdepc, coldepc) FPRDLSMA.138
FPRDLSMA.139
if ( icode .ne. 0 ) then FPRDLSMA.140
write(UnErr,*)CErr,CSub, FPRDLSMA.141
# ' Step 2.2. Failed to retreive grid spacings' FPRDLSMA.142
goto 9999 FPRDLSMA.143
endif FPRDLSMA.144
FPRDLSMA.145
! 3. else take the row and column spacings from the lookup table FPRDLSMA.146
else ! LEN1_COLDEPC etc. FPRDLSMA.147
FPRDLSMA.148
call copy_to_real ( Lookup(BDY), DPhi ) FPRDLSMA.149
do jrow = 1, nrows FPRDLSMA.150
rowdepc(jrow) = DPhi FPRDLSMA.151
end do FPRDLSMA.152
FPRDLSMA.153
call copy_to_real ( Lookup(BDX), DLambda ) FPRDLSMA.154
do icol = 1, ncols FPRDLSMA.155
coldepc(icol) = DLambda FPRDLSMA.156
end do FPRDLSMA.157
FPRDLSMA.158
end if ! LEN1_COLDEPC etc. FPRDLSMA.159
FPRDLSMA.160
FPRDLSMA.161
! 4. copy to row and column coordinates FPRDLSMA.162
call copy_to_real ( Lookup(BZY), Phi0 ) FPRDLSMA.163
Phi(1) = Phi0 + rowdepc(1) FPRDLSMA.164
do jrow = 2, nrows FPRDLSMA.165
Phi(jrow) = Phi(jrow-1) + rowdepc(jrow) FPRDLSMA.166
end do FPRDLSMA.167
FPRDLSMA.168
call copy_to_real ( Lookup(BZX), Lambda0 ) FPRDLSMA.169
Lambda(1) = Lambda0 + coldepc(1) FPRDLSMA.170
do icol = 2, ncols FPRDLSMA.171
Lambda(icol) = Lambda(icol-1) + coldepc(icol) FPRDLSMA.172
end do FPRDLSMA.173
FPRDLSMA.174
! 5. read in the land sea mask itself; assumed to be the first field FPRDLSMA.175
! in the file FPRDLSMA.176
FPRDLSMA.177
fld_no = 1 FPRDLSMA.178
FPRDLSMA.179
! 5.1 if land sea mask data is of type logical read it into a FPRDLSMA.180
! temporary array and convert T = land => 1 and F = sea => 0 FPRDLSMA.181
FPRDLSMA.182
if ( Lookup(data_type) .eq. 3) then ! logical FPRDLSMA.183
FPRDLSMA.184
call readflds (InUnit , 1, fld_no, Lookup, FPRDLSMA.185
# Len1_Lookup_P, ll_lsm, ncols*nrows, FIXHD, FPRDLSMA.186
*CALL ARGPPX FPRDLSMA.187
# icode, cmessage) FPRDLSMA.188
FPRDLSMA.189
if ( icode .gt. 0 ) then FPRDLSMA.190
write(UnErr,*)CErr,CSub, FPRDLSMA.191
# ' step 5.1 unable to read logicals land sea mask: ', FPRDLSMA.192
# ' cmessage is ', cmessage FPRDLSMA.193
icode = 23 FPRDLSMA.194
go to 9999 FPRDLSMA.195
end if FPRDLSMA.196
FPRDLSMA.197
do jrow = 1, nrows FPRDLSMA.198
do icol = 1, ncols FPRDLSMA.199
if ( ll_lsm(icol, jrow) ) then FPRDLSMA.200
lsm(icol, jrow) = 1 FPRDLSMA.201
else FPRDLSMA.202
lsm(icol, jrow) = 0 FPRDLSMA.203
end if FPRDLSMA.204
end do ! icol FPRDLSMA.205
end do ! jrow FPRDLSMA.206
FPRDLSMA.207
! 5.2 else if land sea mask data is of type integer read it FPRDLSMA.208
FPRDLSMA.209
else if( Lookup(data_type) .eq. 2) then ! integer FPRDLSMA.210
FPRDLSMA.211
call readflds (InUnit , 1, fld_no, Lookup, FPRDLSMA.212
# Len1_Lookup_P, lsm, ncols*nrows, FIXHD, FPRDLSMA.213
*CALL ARGPPX FPRDLSMA.214
# icode, cmessage) FPRDLSMA.215
FPRDLSMA.216
if ( icode .gt. 0 ) then FPRDLSMA.217
write(UnErr,*)CErr,CSub, FPRDLSMA.218
# ' step 5.2 unable to read integer land sea mask:', FPRDLSMA.219
# ' cmessage is ', cmessage FPRDLSMA.220
icode = 24 FPRDLSMA.221
go to 9999 FPRDLSMA.222
end if FPRDLSMA.223
FPRDLSMA.224
! 5.3 else if land sea mask data is of type real, read it and FPRDLSMA.225
! convert: 1.0 = land => 1 0.0 = sea => 0 FPRDLSMA.226
FPRDLSMA.227
else if( Lookup(data_type) .eq. 1) then ! real FPRDLSMA.228
call readflds (InUnit , 1, fld_no, Lookup, FPRDLSMA.229
# Len1_Lookup_P, flt_lsm, ncols*nrows, FIXHD, FPRDLSMA.230
*CALL ARGPPX FPRDLSMA.231
# icode, cmessage) FPRDLSMA.232
FPRDLSMA.233
if ( icode .gt. 0 ) then FPRDLSMA.234
write(UnErr,*)CErr,CSub, FPRDLSMA.235
# ' step 5.2 unable to read real land sea mask:', FPRDLSMA.236
# ' cmessage is ', cmessage FPRDLSMA.237
icode = 25 FPRDLSMA.238
go to 9999 FPRDLSMA.239
end if FPRDLSMA.240
FPRDLSMA.241
do jrow = 1, nrows FPRDLSMA.242
do icol = 1, ncols FPRDLSMA.243
if ( flt_lsm(icol, jrow) .ne. 0.0 ) then FPRDLSMA.244
lsm(icol, jrow) = 1 FPRDLSMA.245
else FPRDLSMA.246
lsm(icol, jrow) = 0 FPRDLSMA.247
end if FPRDLSMA.248
end do ! icol FPRDLSMA.249
end do ! jrow FPRDLSMA.250
FPRDLSMA.251
! 5.4 else there is an error in data type of land sea mask FPRDLSMA.252
FPRDLSMA.253
else FPRDLSMA.254
icode = 26 FPRDLSMA.255
write(UnErr,*)CErr,CSub, FPRDLSMA.256
# ' step 5.3 land sea mask is of data type:', Lookup(data_type) FPRDLSMA.257
# , '. Change this to indicator for integer or logical data' FPRDLSMA.258
FPRDLSMA.259
end if ! Lookup(data_type) FPRDLSMA.260
FPRDLSMA.261
9999 continue FPRDLSMA.262
return FPRDLSMA.263
end FPRDLSMA.264
!---------------------------------------------------------------------- FPRDLSMA.265
*ENDIF FPRDLSMA.266