*=*=*=*= mkstat.html =*=*=*=*
PROGRAM mkstat

PROGRAM mkstat


      PROGRAM mkstat
c
c	modif 03/1997: stockage des stats dans cumul.dat et cumul.hdr
c	ecriture dans stats.dat et stats.ctl
c	au lieu d'une sauvegarde dans stats.bak
c
c  This program rewrites a stats.dat file from sums and sums of squares
c  to means and standard deviations and also writes a grads style .ctl
c  file so that the data can be viewed easily.  The data file is
c  overwritten in place.  Those of a nervous disposition can set
c  lcopy=.true. to get a backup copy of the stats data before anything
c  else is done.
c  SRL  21 May 1996
c
      implicit none
      integer npgmax            ! maximum number of grid points per level
      parameter (npgmax = 7010)
      integer nlmax             ! maximum number of levels
      parameter (nlmax = 50)
      integer nsmax             ! maximum number of time levels
      parameter (nsmax = 24)
c._.      real*8 rntape
          real*4 rntape
      integer kstart, ktotal, itspd, kphysic, refday
      integer cols, rows, npgrid, nl
      integer istats, istime, n2dvar, n3dvar, nltime
      integer nstore(nsmax)
      real*4 field(npgmax), field2(npgmax)
      real*4 sigma(nlmax), ftemp, rn
      integer i, j, k, l, n
      integer nls, irec
      integer dstart, dend, hstart, hint
      real*4 xstart, xint, ystart, yint
      integer isurf
      integer uin
      integer uout

C
c      logical lcopy /.false./
      logical lcopy
      data isurf,uin,uout/0,10,11/
      data lcopy/.true./

      CHARACTER*80  suff

      INTEGER   lnblnk
      EXTERNAL  lnblnk
      print*,'fichiers entree de type: cumula3m5.dat et cumula3m5.hdr'
      print*,'fichiers sortie de type: statsa3m5.dat et statsa3m5.ctl'
      print*,'entrer l\'anneeetlemoissouslaformea3m5'
      read(*,'(a)') suff

C
c  Read header file
      open(uin, file='cumul'//suff(1:lnblnk(suff))//'.hdr',
     .			form='unformatted', status='old')
      read(uin) rntape, kstart, ktotal, itspd, kphysic, refday
      read(uin) cols, rows, npgrid, nl
      if (nl.gt.nlmax) then
         print *, 'mkstat:  nlmax is too small for this data set'
         print *, '         recompile with nlmax >= ',nl
         stop
      endif
      read(uin) (sigma(k), k=1,nl)
      read(uin) istats, istime, n2dvar, n3dvar, nltime
      if (istime.gt.nsmax) then
         print *, 'mkstat:  nsmax is too small for this data set'
         print *, '         recompile with nsmax >= ',istime
         stop
      endif
      read(uin) (nstore(k), k=1,istime)
      close(uin)
      if (npgrid.gt.npgmax) then
         print *, 'mkstat:  npgmax is too small for this data set'
         print *, '         recompile with npgmax >= ',npgrid
         stop
      endif

c  Copy data file if required
      open(uin, file='cumul'//suff(1:lnblnk(suff))//'.dat',
     .			form='unformatted', status='old',
     :     access='direct', recl=4*npgrid)
      if (lcopy) then
         open(uout, file='stats'//suff(1:lnblnk(suff))//'.dat',
     .			form='unformatted', status='new',
     :        access='direct', recl=4*npgrid)
         nls = istime*nltime
         do l = 1, nls
            read(uin, rec=l) (field(k), k=1,npgrid)
            write(uout, rec=l) (field(k), k=1,npgrid)
         enddo
         close(uout)
         close(uin)
      endif

      open(uin, file='stats'//suff(1:lnblnk(suff))//'.dat',
     .			form='unformatted', status='old',
     :     access='direct', recl=4*npgrid)

c
c  Re-write stats.dat to contain the mean and standard deviation
      irec = 1
      do i = 1, istime
         rn = 1.0/float(nstore(i))
         do j = 1, n2dvar
            read(uin, rec=irec) (field(k), k=1,npgrid)
            do n = 1, npgrid
               field(n) = rn*field(n)
            enddo
            write(uin, rec=irec) (field(k), k=1,npgrid)
            irec = irec + 1
            read(uin, rec=irec) (field2(k), k=1,npgrid)
            do n = 1, npgrid
               ftemp = rn*field2(n) - field(n)**2
               field2(n) = sqrt(max(0.0,ftemp))
            enddo
            write(uin, rec=irec) (field2(k), k=1,npgrid)
            irec = irec + 1
         enddo
         do j = 1, n3dvar
            do l = 1, nl
               read(uin, rec=irec) (field(k), k=1,npgrid)
               do n = 1, npgrid
                  field(n) = rn*field(n)
               enddo
               write(uin, rec=irec) (field(k), k=1,npgrid)
               read(uin, rec=irec+nl) (field2(k), k=1,npgrid)
               do n = 1, npgrid
                  ftemp = rn*field2(n) - field(n)**2
                  field2(n) = sqrt(max(0.0,ftemp))
               enddo
               write(uin, rec=irec+nl) (field2(k), k=1,npgrid)
               irec = irec + 1
            enddo
            irec = irec + nl
         enddo
      enddo
      close(uin)
c
c  Write a grads header file
      dstart = kstart/itspd + refday
      dend = (ktotal - istats*kphysic)/itspd + refday
      hstart = 0
      hint = (24*istats*kphysic)/itspd
      xstart = -180.0
      xint = 360.0/float(cols)
      ystart = -90.0 + 90.0/float(rows)
      yint = 180.0/float(rows)
      open(uout, file='stats'//suff(1:lnblnk(suff))//'.ctl',
     .				status='new')
      write(uout,'(a)') '*'
      write(uout,'(a)') '* Grads header file written by mkstat'
      write(uout,'(a)') '* Seasonal means and standard deviations'
      write(uout,'(a)') '*'
      write(uout,'(a,a,a)') 'dset stats',suff(1:lnblnk(suff)),'.dat'
      write(uout,'(a,f8.3,a,i5,a,i5)')
     :     'title Run ',rntape,', day ',dstart,' to ',dend
      write(uout,'(a)') 'undef -9.99E33'
      write(uout,'(a)') 'options yrev'
      write(uout,'(a,i5,a,f9.4,f9.4)')
     :     'xdef ',cols,' linear ',xstart,xint
      write(uout,'(a,i5,a,f9.4,f9.4)')
     :     'ydef ',rows,' linear ',ystart,yint
      write(uout,'(a,i5,a)') 'zdef ',nl,' levels'
      write(uout,'(5f10.7)') (sigma(k), k=1,nl)
      write(uout,'(a,i5,a,i10,a,i2,a)')
     :     'tdef ',istime,' linear ',hstart,'z1jan0001 ',hint,'hr'
      write(uout,'(a,i10)')'vars ',2*(n2dvar+n3dvar)
c     co2ice  2d        co2 ice cover
c     emis    2d        surface emissivity
c     tsurf   2d        surface temperature
c     ps      2d        surface pressure
c     t       3d        temperature
c     u       3d        zonal wind
c     v       3d        meridional wind
c     rho     3d        density
c     q2      3d        b/layer eddy kinetic energy
      write(uout,'(a,i4,a)')
     :     'co2ice      ',isurf,' 99  mean CO2 ice cover (kg/m2)'
      write(uout,'(a,i4,a)')
     :     'sdco2ice    ',isurf,' 99  stdv CO2 ice cover (kg/m2)'
      write(uout,'(a,i4,a)')
     :     'emis        ',isurf,' 99  mean emissivity'
      write(uout,'(a,i4,a)')
     :     'sdemis      ',isurf,' 99  stdv emissivity'
      write(uout,'(a,i4,a)')
     :     'tsurf       ',isurf,' 99  mean surface temperature (K)'
      write(uout,'(a,i4,a)')
     :     'sdtsurf     ',isurf,' 99  stdv surface temperature (K)'
      write(uout,'(a,i4,a)')
     :     'ps          ',isurf,' 99  mean surface pressure (Pa)'
      write(uout,'(a,i4,a)')
     :     'sdps        ',isurf,' 99  stdv surface pressure (Pa)'
      write(uout,'(a,i4,a)')
     :     't           ',   nl,' 99  mean temperature (K)'
      write(uout,'(a,i4,a)')
     :     'sdt         ',   nl,' 99  stdv temperature (K)'
      write(uout,'(a,i4,a)')
     :     'u           ',   nl,' 99  mean zonal velocity (m/s)'
      write(uout,'(a,i4,a)')
     :     'sdu         ',   nl,' 99  stdv zonal velocity (m/s)'
      write(uout,'(a,i4,a)')
     :     'v           ',   nl,' 99  mean meridional velocity (m/s)'
      write(uout,'(a,i4,a)')
     :     'sdv         ',   nl,' 99  stdv meridional velocity (m/s)'
      write(uout,'(a,i4,a)')
     :     'rho         ',   nl,' 99  mean density (kg/m3)'
      write(uout,'(a,i4,a)')
     :     'sdrho       ',   nl,' 99  stdv density (kg/m3)'
      write(uout,'(a,i4,a)')
     :     'q2          ',   nl,' 99  mean b/layer eddy ke (m2/s2)'
      write(uout,'(a,i4,a)')
     :     'sdq2        ',   nl,' 99  stdv b/layer eddy ke (m2/s2)'
      write(uout,'(a)') 'endvars'
      close(uout)
c
      stop
      end