subroutine gtvar(invar,varalls,varalls_cwm,nsig,jcapstat,& 1,16 factsml,mype,nlath,nlon,jcap,nc,nc1,pln,trigs,& npe,nsig1,my1,ncd2) !$$$ subprogram documentation block ! . . . . ! subprogram: gtvar read in lattitudinally varying variance ! prgmmr: derber org: w/nmc23 date: 98-01-16 ! ! abstract: read in lattitudinally varing variances and convert them to ! grid ! ! program history log: ! 98-01-16 derber ! 98-07-10 weiyu yang ! 99-08-24 derber, j., treadon, r., yang, w., first frozen mpp version ! ! input argument list: ! invar - input error variance file ! nsig - number of sigma levels ! nsig1 - number of sigma levels distributed in each processor ! jcapstat - triangular truncation for statistics ! factsml - mask to ensure proper modes zeroed ! myout - the first processor of each variable group ! nvari - id number of each variable group ! mype - pe number ! nlath - number of gaussian lats in one hemisphere ! nlon - number of longitudes ! jcap - triangular truncation ! pln,trigs - used by fft ! ! output argument list: ! varalls - variance output array ! ! attributes: ! language: f90 ! machine: ibm RS/6000 SP ! !$$$ use type_kinds, only: fp_kind,single implicit none #include <machine.h> include 'constant.h' ! note assuming mean surface pressure == 100. real(fp_kind) ocon parameter (ocon=100./(grav*21.4e-9)) integer ns1,nlat,nlon2,izero,kk,k1,i,kn,ncd2,mype,nlath,jcapstat integer invar,nsig,nlon,npe,nsig1,nc1,jcap,nc,k2 integer,dimension(nsig1):: my1 integer,dimension(4):: idateg real(single),dimension((jcapstat+1)*(jcapstat+2)):: z real(single) hourg4,sigl4(nsig),sigi4(nsig+1) real(fp_kind) zero,delgi real(fp_kind),dimension(3,2*nlath,nsig1):: varalls real(fp_kind),dimension(nc):: factsml,zsf real(fp_kind),dimension(2*nlath,nlon+2):: grid real(fp_kind),dimension(2*nlath,nsig1):: varalls_cwm real(fp_kind),dimension(ncd2,nlath):: pln #ifdef ibm_sp real(fp_kind),dimension(50000+nlon*4):: trigs #else real(fp_kind),dimension(nlon+15):: trigs #endif !ibm* prefetch_for_store(zero,izero,nlon2,ns1,nlat) zero=0.0; izero=0 nlon2=(nlon+1)/2 ns1=2*nsig+1 nlat=2*nlath do kk=1,nsig1 if(my1(kk)==nsig) then do i=1,nlat !ibm* prefetch_for_store(varalls(1,i,kk),varalls(2,i,kk)) varalls(1,i,kk)=zero varalls(2,i,kk)=zero end do end if if(my1(kk)==ns1) then do i=1,nlat !ibm* prefetch_for_store(varalls(1,i,kk),varalls(2,i,kk)) varalls(1,i,kk)=zero varalls(2,i,kk)=zero end do end if if(my1(kk)<nsig) then do i=1,nlat !ibm* prefetch_for_store(varalls(2,i,kk)) varalls(2,i,kk)=zero end do end if end do !-------- terrain coefs open(invar,file='vars',form='unformatted') read(invar,end=333,err=333) read(invar,end=333,err=333) hourg4,idateg,sigi4,sigl4 read(invar,end=333,err=333) z ! -------- sfcp coefficients read(invar,end=333,err=333) z if(jcap==jcapstat) then do i=1,nc !ibm* prefetch_for_store(zsf(i)) zsf(i)=factsml(i)*z(i) end do else call jcaptrans(zsf,z,jcap,nc1,jcapstat,nc,factsml) end if call s2g1(zsf,grid,nc,nc1,nlon,nlath,pln,trigs,ncd2) do kk=1,nsig1 if(my1(kk)==nsig) then do i=1,nlat !ibm* prefetch_for_store(varalls(3,i,kk)) varalls(3,i,kk)=grid(i,nlon2) !ps. end do end if end do !-------- temp coefficients do kn=nsig+1,2*nsig read(invar,end=333,err=333) z if(jcap==jcapstat) then do i=1,nc !ibm* prefetch_for_store(zsf(i)) zsf(i)=factsml(i)*z(i) end do else call jcaptrans(zsf,z,jcap,nc1,jcapstat,nc,factsml) end if call s2g1(zsf,grid,nc,nc1,nlon,nlath,pln,trigs,ncd2) do kk=1,nsig1 if(my1(kk)==kn) then do i=1,nlat !ibm* prefetch_for_store(varalls(3,i,kk)) varalls(3,i,kk)=grid(i,nlon2) !hs. end do end if end do end do !-------- div and vort do k1=izero,nsig-1 read(invar,end=333,err=333) z if(jcap==jcapstat) then do i=1,nc !ibm* prefetch_for_store(zsf(i)) zsf(i)=factsml(i)*z(i) end do else call jcaptrans(zsf,z,jcap,nc1,jcapstat,nc,factsml) end if call s2g1(zsf,grid,nc,nc1,nlon,nlath,pln,trigs,ncd2) do kk=1,nsig1 if(my1(kk)==k1) then do i=1,nlat !ibm* prefetch_for_store(varalls(1,i,kk)) varalls(1,i,kk)=grid(i,nlon2) !for ds end do end if end do read(invar,end=333,err=333) z if(jcap==jcapstat) then do i=1,nc !ibm* prefetch_for_store(zsf(i)) zsf(i)=factsml(i)*z(i) end do else call jcaptrans(zsf,z,jcap,nc1,jcapstat,nc,factsml) end if call s2g1(zsf,grid,nc,nc1,nlon,nlath,pln,trigs,ncd2) do kk=1,nsig1 if(my1(kk)==k1) then do i=1,nlat !ibm* prefetch_for_store(varalls(3,i,kk)) varalls(3,i,kk)=grid(i,nlon2) ! for zs. end do end if end do end do ! -------- q coefs do k1=nsig+1,2*nsig read(invar,end=333,err=333) z if(jcap==jcapstat) then do i=1,nc !ibm* prefetch_for_store(zsf(i)) zsf(i)=factsml(i)*z(i) end do else call jcaptrans(zsf,z,jcap,nc1,jcapstat,nc,factsml) end if call s2g1(zsf,grid,nc,nc1,nlon,nlath,pln,trigs,ncd2) do kk=1,nsig1 if(my1(kk)==k1) then do i=1,nlat !ibm* prefetch_for_store(varalls(1,i,kk)) varalls(1,i,kk)=grid(i,nlon2) !qs. end do end if end do end do ! -------- ozone coefs do k1=nsig+1,2*nsig k2=k1-nsig delgi=ocon*(sigi4(k2)-sigi4(k2+1)) read(invar,end=333,err=333) z if(jcap==jcapstat) then do i=1,nc !ibm* prefetch_for_store(zsf(i)) zsf(i)=factsml(i)*z(i) end do else call jcaptrans(zsf,z,jcap,nc1,jcapstat,nc,factsml) end if call s2g1(zsf,grid,nc,nc1,nlon,nlath,pln,trigs,ncd2) do kk=1,nsig1 if(my1(kk)==k1) then do i=1,nlat !ibm* prefetch_for_store(varalls(1,i,kk)) ! print *,i,k2,kk,nlon2,ncd2,nc,nc1,grid(i,nlon2) varalls(2,i,kk)=grid(i,nlon2)*delgi !oz. end do end if end do end do ! -------- clw coefs do k1=izero,nsig-1 read(invar,end=333,err=333) z if(jcap==jcapstat) then do i=1,nc !ibm* prefetch_for_store(zsf(i)) zsf(i)=factsml(i)*z(i) end do else call jcaptrans(zsf,z,jcap,nc1,jcapstat,nc,factsml) end if call s2g1(zsf,grid,nc,nc1,nlon,nlath,pln,trigs,ncd2) do kk=1,nsig1 if(my1(kk)==k1) then do i=1,nlat !ibm* prefetch_for_store(varalls(1,i,kk)) varalls_cwm(i,kk)=grid(i,nlon2) !cwm. end do end if end do end do close (invar) return 333 close(invar) print *,' error reading variance file, possibly old format ' call stop2(55) return end subroutine jcaptrans(zsf,z,jcap,nc1,jcapstat,nc,factsml) 7,1 use type_kinds, only: fp_kind,single implicit none integer j2,j,jcap2,k1,k,jc2,jjz,jcapstat,nc1,jcap,jj,izero,nc real(fp_kind),dimension(nc):: factsml,zsf real(single),dimension((jcapstat+1)*(jcapstat+2)):: z !ibm* prefetch_for_store(izero,jj,jjz,jcap2) izero=0 jj=izero jjz=izero jcap2=nc1+2 do j=1,jcap+1 !ibm* prefetch_for_store(j2,jc2) j2=2*j; jc2=jcap2-j2 do k=1,jc2 !ibm* prefetch_for_store(k1) k1=jj+k !ibm* prefetch_for_store(zsf(k1)) zsf(k1)=factsml(k1)*z(jjz+k) end do jj=jj+jc2; jjz=jjz+2*jcapstat+4-j2 end do return end