[Fortran] syntaxhighlighter_viewsource syntaxhighlighter_copycode
 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