program ygrid implicit none integer nigauss, njgauss integer nigem, njgem integer gggd, gemgd integer ezqkdef, ezuvint, ezdefset, gdll, ezwdint, gdllsval, gdllwdval, ezsint,ezuvint integer gdwdfuv,gduvfwd,gdlluval,gdxyuval, gdxywdval integer gdxyfll, gdllfxy real, dimension(:,:), allocatable :: gz,uu,vv,lat,lon,gzdst,wddst,uvdst integer uukey,vvkey,latkey,lonkey,gzkey integer i, ni, nj, nk, gdin, gdout, iset integer ier, nrecs integer fnom, fstouv, fclos, fstfrm, fstinf, fstluk, fstprm, fstecr external fnom, fstouv, fclos, fstfrm, fstinf, fstluk, fstprm, fstecr character*4 nomvar, nomy character*2 typvar,grtyp,typy character*12 etiket,etiky character *1 grsrc,grdst integer ip1,ip2,ip3 integer ip1y, ip2y, ip3y integer extra1, extra2, extra3, deet, npas, nbits, datyp, dateo integer ig1src, ig2src, ig3src, ig4src, date, nidst, njdst integer ig1dst, ig2dst, ig3dst, ig4dst integer swa, lng, dltf, ubc integer npts,nnpas,idt,ipos ! character * 8 cle(2) character * 128 def(2), val(2) ! data cle /'src.', 'ygrid.'/ data def /'scrapyard', 'scrapyard'/ data val /'scrapyard', 'scrapyard'/ !------------------------------------------------------------------------------------------------ call ccard(cle,def,val, 2, ipos) ier = fnom(1, val(1),'STD+RND+OLD+R/O',0) nrecs = fstouv(1, 'RND') ier = fnom(2, val(2),'STD+RND+OLD',0) nrecs = fstouv(2, 'RND') gzkey=fstinf(1, ni, nj,nk,-1,' ',500,0,-1, ' ','GZ') uukey=fstinf(1, ni, nj,nk,-1,' ',500,0,-1, ' ','UU') vvkey=fstinf(1, ni, nj,nk,-1,' ',500,0,-1, ' ','VV') ier = fstprm(gzkey, dateo, deet, npas, ni, nj, nk, nbits, datyp, & ip1, ip2, ip3, typvar, nomvar, etiket, & grsrc, ig1src, ig2src, ig3src,& ig4src, swa, lng, dltf, ubc, extra1, extra2, extra3) allocate(gz(ni,nj)) allocate(uu(ni,nj)) allocate(vv(ni,nj)) ier=fstluk(gz,gzkey,ni,nj,nk) ier=fstluk(uu,uukey,ni,nj,nk) ier=fstluk(vv,vvkey,ni,nj,nk) call statfld('GZ','P',ip1,ip2,ip3,date,etiket,gz,ni, nj, nk) call statfld('UU','P',ip1,ip2,ip3,date,etiket,uu,ni, nj, nk) call statfld('VV','P',ip1,ip2,ip3,date,etiket,vv,ni, nj, nk) !------------------------------------------------------------------------------------------------ latkey=fstinf(2, nidst, njdst, nk,-1,' ',-1,-1,-1, ' ','^^') lonkey=fstinf(2, nidst, njdst, nk,-1,' ',-1,-1,-1, ' ','>>') allocate (gzdst(nidst,njdst)) allocate (wddst(nidst,njdst)) allocate (uvdst(nidst,njdst)) allocate (lat(nidst,njdst)) allocate (lon(nidst,njdst)) ier=fstluk(lat,latkey,nidst,njdst,nk) ier=fstluk(lon,lonkey,nidst,njdst,nk) gdin = ezqkdef(ni,nj,grsrc,ig1src,ig2src,ig3src,ig4src,1) call statfld('LA','P',ip1,ip2,ip3,date,etiket,lat,nidst, njdst, nk) call statfld('LO','P',ip1,ip2,ip3,date,etiket,lon,nidst, njdst, nk) !------------------------------------------------------------------------------------------------ print *, 'Test gdllsval' ier = gdllsval(gdin,gzdst,gz,lat,lon,nidst*njdst) !------------------------------------------------------------------------------------------------ print *, 'Test gdwduval' ier = gdllwdval(gdin,uvdst,wddst,uu,vv,lat,lon,nidst*njdst) call statfld('GZ','P',ip1,ip2,ip3,date,etiket,gzdst,nidst, njdst, nk) call statfld('UV','P',ip1,ip2,ip3,date,etiket,uvdst,nidst, njdst, nk) call statfld('WD','P',ip1,ip2,ip3,date,etiket,wddst,nidst, njdst, nk) !------------------------------------------------------------------------------------------------ ier = fstprm(latkey, dateo, deet, npas, nidst, njdst, nk, nbits, datyp, & ip1y, ip2y, ip3y, typy, nomy, etiky, & grdst, ig1dst, ig2dst, ig3dst,& ig4dst, swa, lng, dltf, ubc, extra1, extra2, extra3) grdst = 'Y' ig1dst = ip1y ig2dst = ip2y ig3dst = ip3y ig4dst = 0 gdout = ezqkdef(nidst,njdst,grdst,ig1dst, ig2dst, ig3dst, ig4dst, 2) ier = ezdefset(gdout, gdin) ier = ezsint(gzdst,gz) ier = ezwdint(uvdst,wddst,uu,vv) call statfld('GZ','P',ip1,ip2,ip3,date,etiket,gzdst,nidst, njdst, nk) call statfld('UV','P',ip1,ip2,ip3,date,etiket,uvdst,nidst, njdst, nk) call statfld('WD','P',ip1,ip2,ip3,date,etiket,wddst,nidst, njdst, nk) ier = FSTECR(gzdst, gzdst, -16, 2, date, deet, npas, nidst, njdst, & nk, ip1, ip2, ip3, typvar, 'GZ', etiket, grdst, & ig1dst, ig2dst, ig3dst, ig4dst, 1, .true.) ier = FSTECR(wddst, wddst, -16, 2, date, deet, npas, nidst, njdst, & nk, ip1, ip2, ip3, typvar, 'WD', etiket, grdst, & ig1dst, ig2dst, ig3dst, ig4dst, 1, .true.) ier = FSTECR(uvdst, uvdst, -16, 2, date, deet, npas, nidst, njdst, & nk, ip1, ip2, ip3, typvar, 'UV', etiket, grdst, & ig1dst, ig2dst, ig3dst, ig4dst, 1, .true.) ier = fstfrm(2) ier = fstfrm(1) ier = fclos(1) ier = fclos(2) stop end program ygrid !---------------------------------------------------------------------------------- subroutine statfld(nomvar,typvar,ip1,ip2,ip3,date,etiket,f,ni,nj,nk) implicit none character*2 nomvar character*1 typvar integer ip1,ip2,ip3,date character*8 etiket ! integer ni,nj,nk real f(ni,nj,nk) ! !OBJECT ! calcule et imprime: la moyenne (moy) ! la variance (var) ! le minimum et le maximum ! du champ f ! ! arguments: ! - f - champ sur lequel on veut faire des statistiques ! - n - dimensions du champ f ! - champ - identification du champ ! - no - compteur ! - from - identification du module d'ou on fait l'appel ! !METHOD ! !EXTERNALS ! !AUTHOR Michel Desgagne Nov 1992 ! !HISTORY ! !* integer i,j,k real sum,moy,var,rmin,rmax integer imin,jmin,kmin,imax,jmax,kmax !-------------------------------------------------------------------- ! ! ** On calcule la moyenne. ! sum = 0.0 do k=1,nk do j=1,nj do i=1,ni sum = sum + f(i,j,k) enddo enddo enddo moy = sum / float(ni*nj*nk) ! ! ** On calcule la variance ! sum = 0.0 do k=1,nk do j=1,nj do i=1,ni sum = sum + ((f(i,j,k) - moy)*(f(i,j,k) - moy)) enddo enddo enddo var = sqrt (sum / float(ni*nj*nk)) ! ! ** On identifie le minimum et le maximum. ! imin = 1 jmin = 1 kmin = 1 imax = 1 jmax = 1 kmax = 1 rmax = f(1,1,1) rmin = f(1,1,1) ! do k=1,nk do j=1,nj do i=1,ni if (f(i,j,k) .gt. rmax) then rmax = f(i,j,k) imax = i jmax = j kmax = k endif if (f(i,j,k) .lt. rmin) then rmin = f(i,j,k) imin = i jmin = j kmin = k endif enddo enddo enddo ! ! ** On imprime ! write(6,10) nomvar,typvar,ip1,ip2,ip3,date,etiket, moy,var,imin,jmin+(kmin-1)*nj,rmin,& imax,jmax+(kmax-1)*nj,rmax 10 format (' ',a2,1x,a1,1x,i5,1x,i4,1x,i3,1x,i9,1x,a8,1x,& ' Mean:',e12.6,' Var:',e12.6,& ' Min:[(',i3,',',i3,'):',& e10.4,']',' Max:[(',i3,',',i3,'):',& e10.4,']') ! !---------------------------------------------------------------- return end subroutine statfld