SUBROUTINE DERV_LAND_FIELD (unit_no,icode,cmessage) 1,3DLANDF1A.25
DLANDF1A.26
implicit none DLANDF1A.27
! DLANDF1A.28
! Description : Calculates the no of land points on each PE. DLANDF1A.29
! DLANDF1A.30
! Method : Call READ_LAND_SEA to read in Land-Sea Mask from DLANDF1A.31
! Atmosphere Dump and then calculate no of land points. DLANDF1A.32
! DLANDF1A.33
! Current Code Owner : Dave Robinson, NWP DLANDF1A.34
! DLANDF1A.35
! History : DLANDF1A.36
! Version Date Comment DLANDF1A.37
! ------- ---- ------- DLANDF1A.38
! 4.5 15/04/98 Original Code DLANDF1A.39
! DLANDF1A.40
! Code Description : DLANDF1A.41
! Language : FORTRAN 77 + common extensions DLANDF1A.42
! DLANDF1A.43
! Declarations : DLANDF1A.44
DLANDF1A.45
! Arguments DLANDF1A.46
integer unit_no ! IN Unit number for atmos dump DLANDF1A.47
integer icode ! OUT Error Code DLANDF1A.48
character*80 cmessage ! OUT Error message DLANDF1A.49
DLANDF1A.50
! Local variables DLANDF1A.51
integer ilen1_lookup ! First dimesion of look-up table DLANDF1A.52
integer ilen2_lookup ! Second dimension of look-up table DLANDF1A.53
integer fixhd(256) ! Fixed header DLANDF1A.54
DLANDF1A.55
*CALL CENVIR 
DLANDF1A.56
*CALL TYPSIZE DLANDF1A.57
DLANDF1A.58
! land_field is the global no of land-points. DLANDF1A.59
DLANDF1A.60
! Initialise global_land_field DLANDF1A.61
global_land_field = land_field DLANDF1A.62
DLANDF1A.63
write (6,*) ' global_land_field set to ',land_field DLANDF1A.64
DLANDF1A.65
! Open atmos input dump DLANDF1A.66
call file_open (unit_no,ft_environ(unit_no), DLANDF1A.67
& len_ft_envir(unit_no),0,0,icode) DLANDF1A.68
DLANDF1A.69
! Check error code from file_open DLANDF1A.70
if (icode.gt.0) then DLANDF1A.71
write (6,*) 'Error in FILE_OPEN called from DERV_LAND_FIELD.' DLANDF1A.72
write (6,*) 'Trying to open atmos dump.' DLANDF1A.73
write (cmessage,*) 'DRLANDF1 : Error in FILE_OPEN.' DLANDF1A.74
go to 9999 ! Return DLANDF1A.75
endif DLANDF1A.76
DLANDF1A.77
! Read fixed header DLANDF1A.78
call read_flh(unit_no,fixhd,256,icode,cmessage) DLANDF1A.79
DLANDF1A.80
! Check error code from read_flh DLANDF1A.81
if (icode.gt.0) then DLANDF1A.82
write (6,*) 'Error in READ_FLH called from DERV_LAND_FIELD.' DLANDF1A.83
write (6,*) 'Trying to read fixed header from atmos dump.' DLANDF1A.84
go to 9999 ! Return DLANDF1A.85
endif DLANDF1A.86
DLANDF1A.87
! Get dimensions of look-up table DLANDF1A.88
ilen1_lookup=fixhd(151) DLANDF1A.89
ilen2_lookup=fixhd(152) DLANDF1A.90
DLANDF1A.91
! Proceed to calculate no of land points on each PE. DLANDF1A.92
CALL CALC_LAND_FIELD (unit_no,fixhd,ilen1_lookup,ilen2_lookup, DLANDF1A.93
& icode,cmessage) DLANDF1A.94
DLANDF1A.95
! land_field now contains the no of land_points for this PE. DLANDF1A.96
DLANDF1A.97
! Initialise local_land_field DLANDF1A.98
local_land_field = land_field DLANDF1A.99
DLANDF1A.100
write (6,*) ' local_land_field set to ',land_field DLANDF1A.101
DLANDF1A.102
9999 continue DLANDF1A.103
DLANDF1A.104
RETURN DLANDF1A.105
END DLANDF1A.106
SUBROUTINE CALC_LAND_FIELD (unit_no,fixhd, 1,3DLANDF1A.107
& len1_lookup,len2_lookup, DLANDF1A.108
& icode,cmessage) DLANDF1A.109
DLANDF1A.110
implicit none DLANDF1A.111
DLANDF1A.112
! Arguments DLANDF1A.113
integer unit_no ! IN Unit Number DLANDF1A.114
integer fixhd(256) ! IN Fixed header DLANDF1A.115
integer len1_lookup ! IN First dimension of lookup table DLANDF1A.116
integer len2_lookup ! IN Seconf dimension of lookup table DLANDF1A.117
integer icode ! OUT Return code DLANDF1A.118
DLANDF1A.119
character*80 cmessage ! OUT Error message DLANDF1A.120
DLANDF1A.121
! Local variables DLANDF1A.122
integer len_io ! length of data returned from buffin DLANDF1A.123
integer lookup(len1_lookup,len2_lookup) ! Lookup table DLANDF1A.124
real rcode ! Real return code DLANDF1A.125
! DLANDF1A.126
! Position atmos dump to read in lookup-table DLANDF1A.127
call setpos (unit_no,fixhd(150)-1,icode) DLANDF1A.128
DLANDF1A.129
! Check error code from setpos DLANDF1A.130
if (icode.gt.0) then DLANDF1A.131
write (6,*) 'Error in SETPOS called from CALC_LAND_FIELD.' DLANDF1A.132
write (6,*) 'Trying to point to start of lookup table '// DLANDF1A.133
& 'in atmos dump.' DLANDF1A.134
write (cmessage,*) 'DRLANDF1 : Error in SETPOS.' DLANDF1A.135
go to 9999 ! Return DLANDF1A.136
endif DLANDF1A.137
DLANDF1A.138
! Read in the look-up table DLANDF1A.139
call buffin (unit_no,lookup,len1_lookup*len2_lookup,len_io,rcode) DLANDF1A.140
DLANDF1A.141
! Check error code from buffin DLANDF1A.142
if (rcode.ne.-1.0) then DLANDF1A.143
write (6,*) 'Error in BUFFIN called from CALC_LAND_FIELD.' DLANDF1A.144
write (6,*) 'Trying to read lookup table from atmos dump.' DLANDF1A.145
write (6,*) 'Return code from BUFFIN ',rcode DLANDF1A.146
ICODE = 100 DLANDF1A.147
write (cmessage,*) 'DRLANDF1 : Error in BUFFIN.' DLANDF1A.148
go to 9999 ! Return DLANDF1A.149
endif DLANDF1A.150
DLANDF1A.151
! Read in land-sea mask and then DLANDF1A.152
! compute the number of land points for each PE DLANDF1A.153
CALL READ_LAND_SEA (unit_no,rcode,lookup,len1_lookup,len2_lookup, DLANDF1A.154
& fixhd,256) DLANDF1A.155
DLANDF1A.156
! Check error code from read_land_sea DLANDF1A.157
if (rcode.ne.-1.0) then DLANDF1A.158
write (6,*) 'Error in READ_LAND_SEA.' DLANDF1A.159
write (6,*) 'Return code from READ_LAND_SEA ',rcode DLANDF1A.160
ICODE = 200 DLANDF1A.161
write (cmessage,*) 'DRLANDF1 : Error in READ_LAND_SEA.' DLANDF1A.162
go to 9999 ! Return DLANDF1A.163
endif DLANDF1A.164
DLANDF1A.165
9999 continue DLANDF1A.166
RETURN DLANDF1A.167
END DLANDF1A.168
*ENDIF DLANDF1A.169
*ENDIF DLANDF1A.170