SUBROUTINE READ_LAND_SEA(NFT,IOSTAT,LOOKUP,LOC_LEN1_LOOKUP, 1,5RDLSM1A.6
& LOC_LEN2_LOOKUP,FIXHD,LOC_LEN_FIXHD) RDLSM1A.7
IMPLICIT NONE RDLSM1A.8
! RDLSM1A.9
! Description: RDLSM1A.10
! This routine reads the land-sea mask (LSM) from the dump and puts RDLSM1A.11
! it in a COMMON block defined in IOVARS. It is required for RDLSM1A.12
! unpacking and packing fields which are stored compressed to RDLSM1A.13
! land points. RDLSM1A.14
! RDLSM1A.15
! Method: RDLSM1A.16
! The position of the LSM within the dump is found from examining RDLSM1A.17
! the LOOKUP headers, it is then read in, and the relevant part RDLSM1A.18
! of the field sent to each processor. The local number of land RDLSM1A.19
! points is counted, and the LAND_FIELD variable is reset to this RDLSM1A.20
! new value. RDLSM1A.21
! Note : Halos can contain land points - but only those halos RDLSM1A.22
! which are updated by SWAPBNDS. RDLSM1A.23
! RDLSM1A.24
! Current Code Owner: Paul Burton RDLSM1A.25
! RDLSM1A.26
! History: RDLSM1A.27
! Model Date Modification history from model version 3.5 RDLSM1A.28
! version RDLSM1A.29
! 3.5 4/1/95 New DECK created for the Parallel Unified RDLSM1A.30
! Model. P.Burton + D.Salmond RDLSM1A.31
! 4.1 18/3/96 Simplified communications P.Burton GPB0F401.303
! 4.2 18/11/96 Added *CALL AMAXSIZE for IOVARS GPB3F402.68
! Added atmos_ prefix to landmask fields P.Burton GPB3F402.69
! 4.2 16/8/96 Add IOSTAT argument to SETPOS_SINGLE and APB1F402.10
! check return code. P.Burton APB1F402.11
! 4.2 17/10/96 New name for group of processors in gather_field GPB0F402.208
! P.Burton GPB0F402.209
! 4.3 11/03/97 Corrected calculation of global LAND_FIELD GPB4F403.718
! Store full global LSM on each PE. P.Burton GPB4F403.719
! 4.4 25/04/97 Changes to read well-formed records if the GBC5F404.186
! input dumpfile is in that format (almost PP file GBC5F404.187
! format) GBC5F404.188
! Author: Bob Carruthers, Cray Research GBC5F404.189
! 4.5 13/01/98 Removed reference to SHMEM COMMON block P.Burton GPB2F405.153
! 4.5 15/04/98 Modify output. D. Robinson. GDR5F405.40
! RDLSM1A.32
! Subroutine Arguments: RDLSM1A.33
RDLSM1A.34
INTEGER RDLSM1A.35
& NFT ! IN : FORTRAN unit number RDLSM1A.36
& ,LOC_LEN1_LOOKUP ! IN : Dimension of the LOOKUP array RDLSM1A.37
& ,LOC_LEN2_LOOKUP ! IN : Dimension of the LOOKUP array RDLSM1A.38
& ,LOC_LEN_FIXHD ! IN : Dimension of the FIXHD array RDLSM1A.39
RDLSM1A.40
INTEGER RDLSM1A.41
& LOOKUP(LOC_LEN1_LOOKUP,LOC_LEN2_LOOKUP), RDLSM1A.42
! ! IN : LOOKUP array from dump header RDLSM1A.43
& FIXHD(LOC_LEN_FIXHD) ! IN : FIXHD array from dump header RDLSM1A.44
RDLSM1A.45
REAL RDLSM1A.46
& IOSTAT ! OUT : Return code RDLSM1A.47
RDLSM1A.48
! Parameters and Common blocks RDLSM1A.49
RDLSM1A.50
*CALL CLOOKADD 
RDLSM1A.51
*CALL TYPSIZE RDLSM1A.52
*CALL CNTL_IO GBC5F404.190
*CALL C_MDI GBC5F404.191
*CALL PARVARS RDLSM1A.53
*CALL AMAXSIZE GPB3F402.70
*CALL ATM_LSM GPB2F405.154
*CALL GCCOM GPB0F401.304
RDLSM1A.55
! Local variables RDLSM1A.56
RDLSM1A.57
INTEGER i,j,k,word_address,ipts,iproc,info,len_io, RDLSM1A.58
& landpts_local,local_off,global_off GPB4F403.720
RDLSM1A.60
! -------------------------------------------------------------------- RDLSM1A.61
RDLSM1A.62
IOSTAT=-1.0 RDLSM1A.63
RDLSM1A.64
! Find location of LSM in the dump RDLSM1A.65
RDLSM1A.66
IF (mype .EQ. 0) THEN RDLSM1A.67
RDLSM1A.68
DO i=1,LOC_LEN2_LOOKUP RDLSM1A.69
IF (LOOKUP(ITEM_CODE,i) .EQ. 30) GOTO 100 RDLSM1A.70
ENDDO RDLSM1A.71
100 CONTINUE RDLSM1A.72
RDLSM1A.73
k=i GBC5F404.192
word_address=1 GBC5F404.193
C Old Format dumpfiles GBC5F404.194
if((lookup(lbnrec,k).eq.0) .or. GBC5F404.195
C Prog lookups in dump before vn3.2: GBC5F404.196
2 ((lookup(lbnrec,k).eq.imdi) .and. (fixhd(12).le.301))) then GBC5F404.197
C Dump and ancillary files GBC5F404.198
word_address=1 RDLSM1A.74
IF (i .GT. 1) THEN RDLSM1A.75
DO k=2,i RDLSM1A.76
IF(MOD((LOOKUP(LBPACK,k-1)),10).EQ.2) THEN RDLSM1A.77
ipts=(LOOKUP(LBLREC,k-1)+1)/2 RDLSM1A.78
ELSE RDLSM1A.79
ipts=(LOOKUP(LBLREC,k-1)) RDLSM1A.80
ENDIF RDLSM1A.81
word_address=word_address+ipts RDLSM1A.82
ENDDO RDLSM1A.83
ENDIF RDLSM1A.84
word_address=FIXHD(160)+word_address-2 RDLSM1A.85
ipts=lookup(lblrec, i) GBC5F404.199
else GBC5F404.200
C PP type files and new format Dumpfiles (vn4.4 onwards) GBC5F404.201
word_address=lookup(lbegin,i) GBC5F404.202
C Use the stored round-up value GBC5F404.203
ipts=lookup(lbnrec,i) GBC5F404.204
endif GBC5F404.205
RDLSM1A.86
CALL SETPOS_SINGLE(NFT,word_address,IOSTAT) APB1F402.12
IF (IOSTAT .NE. 0) THEN APB1F402.13
WRITE(6,*) 'READ_LAND_SEA: Error Return from SETPOS_SINGLE', APB1F402.14
& ' Status is ',IOSTAT APB1F402.15
CALL ABORT() APB1F402.16
ENDIF APB1F402.17
RDLSM1A.88
! Read the LSM in to PE 0 GPB4F403.721
GPB4F403.722
RDLSM1A.90
c--check that there is space to read the data GBC5F404.206
if(ipts.gt.MaxFieldSize) then GBC5F404.207
write(6,9921) ipts, MaxFieldSize, lookup(lblrec, i) GBC5F404.208
9921 format(/'READ_LAND_SEA_MASK: The number of Words', GBC5F404.209
2 ' to be Read ',i10,' is larger than the Buffer Size ', GBC5F404.210
3 i10//,'Record length is ',i10/) GBC5F404.211
*IF DEF,MPP,AND,DEF,T3E GBC5F404.212
if(my_pe().eq.0) GBC5F404.213
2 write(0,9921) ipts, MaxFieldSize, lookup(lblrec, i) GBC5F404.214
*ENDIF GBC5F404.215
call abort('Insufficient Space for Land Sea Mask') GBC5F404.216
endif GBC5F404.217
c GBC5F404.218
call buffin_single(nft,atmos_landmask,ipts, GBC5F404.219
& len_io,IOSTAT) GPB3F402.72
GPB0F401.305
ENDIF ! (mype.eq.0) GPB0F401.306
GPB4F403.723
! Broadcast the global LSM to all processors GPB4F403.724
GPB4F403.725
CALL GC_IBCAST(100,glsize(1)*glsize(2),0,nproc,info, GPB4F403.726
& atmos_landmask) GPB4F403.727
GPB4F403.728
GPB0F401.307
DO i=1,lasize(1)*lasize(2) GPB0F401.308
atmos_landmask_local(i)=.FALSE. GPB3F402.73
ENDDO GPB0F401.310
GPB0F401.311
! Copy my local part of the full LSM into atmos_landmask_local GPB4F403.729
GPB4F403.730
DO j=1,blsizep(2) GPB4F403.731
GPB4F403.732
local_off=(j-1+Offy)*lasize(1)+Offx GPB4F403.733
global_off=(j-1+datastart(2)-1)*glsize(1)+datastart(1)-1 GPB4F403.734
GPB4F403.735
DO i=1,blsizep(1) GPB4F403.736
GPB4F403.737
atmos_landmask_local(local_off+i)= GPB4F403.738
& atmos_landmask(global_off+i) GPB4F403.739
GPB4F403.740
ENDDO ! i GPB4F403.741
ENDDO ! j GPB4F403.742
GPB4F403.743
! Count the number of global land points GPB4F403.744
GPB4F403.745
atmos_number_of_landpts=0 GPB4F403.746
DO i=1,glsize(1)*glsize(2) GPB4F403.747
IF (atmos_landmask(i)) GPB4F403.748
& atmos_number_of_landpts=atmos_number_of_landpts+1 GPB4F403.749
ENDDO GPB4F403.750
RDLSM1A.115
! Do a swap to get land points in halo areas RDLSM1A.132
CALL SWAPBOUNDS(atmos_landmask_local,lasize(1),lasize(2), GPB3F402.76
& Offx,Offy,1) GPB3F402.77
RDLSM1A.134
landpts_local=0 RDLSM1A.135
DO i=1,lasize(1)*lasize(2) GPB0F401.319
IF (atmos_landmask_local(i)) GPB3F402.78
& landpts_local=landpts_local+1 GPB0F401.321
ENDDO GPB0F401.322
RDLSM1A.142
RDLSM1A.143
IF (landpts_local .NE. LAND_FIELD) THEN RDLSM1A.144
WRITE(6,*) 'PE ',mype,' : LAND_FIELD is being reset from ', GDR5F405.41
& LAND_FIELD,' to ',landpts_local RDLSM1A.146
LAND_FIELD=landpts_local RDLSM1A.147
ENDIF RDLSM1A.148
RDLSM1A.149
RETURN RDLSM1A.150
END RDLSM1A.151
RDLSM1A.152
*ENDIF RDLSM1A.153
*ENDIF GPB3F403.256