[Fortran] 纯文本查看 复制代码
implicit none
c
include 'common_blocks.h'
c
real dp0kf,dpm,dpms,ds0kf,dsm,dsms
real hmina,hminb,hmaxa,hmaxb
integer i,ios,j,k,ktr,l
character preambl(5)*79,cline*80
#if defined(USE_CCSM3)
real plinei(itdm),plinej(jtdm)
save plinei,plinej
#endif
c
real aspmax
parameter (aspmax=2.0) ! maximum grid aspect ratio for diffusion
* parameter (aspmax=1.0) ! ignore grid aspect ratio in diffusion
c
c --- read grid location,spacing,coriolis arrays
c
if (mnproc.eq.1) then ! .b file from 1st tile only
write (lp,'(3a)') ' reading grid file from ',
& trim(flnmgrd),'.[ab]'
open (unit=uoff+9,file=trim(flnmgrd)//'.b',
& status='old')
endif
call xcsync(flush_lp)
call zagetc(cline,ios, uoff+9)
if (ios.ne.0) then
if (mnproc.eq.1) then
write(lp,'(/ a,i4,i9 /)')
& 'geopar: I/O error from zagetc, iunit,ios = ',uoff+9,ios
endif !1st tile
call xcstop('(geopar)')
stop '(geopar)'
endif
read(cline,*) i
c
call zagetc(cline,ios, uoff+9)
if (ios.ne.0) then
if (mnproc.eq.1) then
write(lp,'(/ a,i4,i9 /)')
& 'geopar: I/O error from zagetc, iunit,ios = ',uoff+9,ios
endif !1st tile
call xcstop('(geopar)')
stop '(geopar)'
endif
read (cline,*) j
c
if (i.ne.itdm .or. j.ne.jtdm) then
if (mnproc.eq.1) then
write(lp,'(/ a /)')
& 'error - wrong array size in grid file'
endif
call xcstop('(geopar)')
stop '(geopar)'
endif
call zagetc(cline,ios, uoff+9)
if (ios.ne.0) then
if (mnproc.eq.1) then
write(lp,'(/ a,i4,i9 /)')
& 'geopar: I/O error from zagetc, iunit,ios = ',uoff+9,ios
endif !1st tile
call xcstop('(geopar)')
stop '(geopar)'
endif
if (mnproc.eq.1) then
write (lp,'(a)') trim(cline)
endif
read (cline,*) mapflg
c
call zaiopf(trim(flnmgrd)//'.a','old', 9)
c
do k= 1,15
call zagetc(cline,ios, uoff+9)
if (ios.ne.0) then
if (mnproc.eq.1) then
write(lp,'(/ a,i4,i9 /)')
& 'geopar: I/O error from zagetc, iunit,ios = ',uoff+9,ios
endif !1st tile
call xcstop('(geopar)')
stop '(geopar)'
endif
i = index(cline,'=')
read (cline(i+1:),*) hminb,hmaxb
if (mnproc.eq.1) then
write (lp,'(a)') trim(cline)
endif
call xcsync(flush_lp)
c
if (k.eq.1) then
call zaiord(plon, ip,.false., hmina,hmaxa, 9)
elseif (k.eq.2) then
call zaiord(plat, ip,.false., hmina,hmaxa, 9)
do i= 1,2 !skip qlon,qlat
call zagetc(cline,ios, uoff+9)
if (ios.ne.0) then
if (mnproc.eq.1) then
write(lp,'(/ a,i4,i9 /)')
& 'geopar: I/O error from zagetc, iunit,ios = ',
& uoff+9,ios
endif !1st tile
call xcstop('(geopar)')
stop '(geopar)'
endif
call zaiosk(9)
enddo
elseif (k.eq.3) then
call zaiord(ulon, ip,.false., hmina,hmaxa, 9)
elseif (k.eq.4) then
call zaiord(ulat, ip,.false., hmina,hmaxa, 9)
elseif (k.eq.5) then
call zaiord(vlon, ip,.false., hmina,hmaxa, 9)
elseif (k.eq.6) then
call zaiord(vlat, ip,.false., hmina,hmaxa, 9)
call zagetc(cline,ios, uoff+9)
if (ios.ne.0) then
if (mnproc.eq.1) then
write(lp,'(/ a,i4,i9 /)')
& 'geopar: I/O error from zagetc, iunit,ios = ',uoff+9,ios
endif !1st tile
call xcstop('(geopar)')
stop '(geopar)'
endif
#if defined(USE_CCSM3)
c pang in ANGLET
i = index(cline,'=')
read (cline(i+1:),*) hminb,hmaxb
if (mnproc.eq.1) then
write (lp,'(a)') trim(cline)
endif
call xcsync(flush_lp)
call zaiord(ANGLET, ip,.false., hmina,hmaxa, 9)
#else
c skip pang
call zaiosk(9)
#endif
elseif (k.eq.7) then
call zaiord(scpx, ip,.false., hmina,hmaxa, 9)
elseif (k.eq.8) then
call zaiord(scpy, ip,.false., hmina,hmaxa, 9)
elseif (k.eq.9) then
call zaiord(scqx, iq,.false., hmina,hmaxa, 9)
elseif (k.eq.10) then
call zaiord(scqy, iq,.false., hmina,hmaxa, 9)
elseif (k.eq.11) then
call zaiord(scux, iu,.false., hmina,hmaxa, 9)
elseif (k.eq.12) then
call zaiord(scuy, iu,.false., hmina,hmaxa, 9)
elseif (k.eq.13) then
call zaiord(scvx, iv,.false., hmina,hmaxa, 9)
elseif (k.eq.14) then
call zaiord(scvy, iv,.false., hmina,hmaxa, 9)
else
call zaiord(corio,iq,.false., hmina,hmaxa, 9)
endif
c
if (abs(hmina-hminb).gt.abs(hminb)*1.e-4 .or.
& abs(hmaxa-hmaxb).gt.abs(hmaxb)*1.e-4 ) then
if (mnproc.eq.1) then
write(lp,'(/ a / a,1p3e14.6 / a,1p3e14.6 /)')
& 'error - .a and .b files not consistent:',
& '.a,.b min = ',hmina,hminb,hmina-hminb,
& '.a,.b max = ',hmaxa,hmaxb,hmaxa-hmaxb
endif
call xcstop('(geopar)')
stop '(geopar)'
endif
enddo
c
call zaiocl(9)
if (mnproc.eq.1) then ! .b file from 1st tile only
close(unit=uoff+9)
endif
c
if (itest.gt.0 .and. jtest.gt.0) then
i=itest
j=jtest
write (lp,'(/ a,2i5,a,f8.3,a,f12.9,2f10.2/)')
& ' i,j=',i+i0,j+j0,
& ' plat=',plat(i,j),
& ' corio,scux,vy=',corio(i,j),scux(i,j),scvy(i,j)
endif
call xcsync(flush_lp)
#if defined(USE_CCSM3)
c --- printout similar to ccsm ice model
call xclget(plinei,itdm, plon, 1,1, +1, 0, 1)
call xclget(plinej,jtdm, plat, 1,1, 0,+1, 1)
if (mnproc.eq.1) then
write (lp,*)
write (lp,'(a,4f9.3,a,4f9.3)')
& '(domain) plon(:,1): ',
& plinei(1:4),' ...', plinei(itdm-2:itdm)
write (lp,'(a,4f9.3,a,4f9.3)')
& '(domain) plat(1,:): ',
& plinej(1:4),' ...', plinej(jtdm-2:jtdm)
write (lp,*)
endif
call xcsync(flush_lp)
#endif