Subversion Repositories lagranto.um

      program pp2cdf

      implicit none

C

C     Purpose.

C     --------

C

C       Reads UKMO MM pressure data and writes the data to a NetCDF-file.

C       It works on 20 pressure levels, and uses stashcodes 90003 and 90004 

C       (u and v wrt model grid).

C

C     Interface.

C     ----------

C

C       File with MM data attached as unit 8.

C       File with NetCDF filename and missing data flag is unit 15.

C       Varfile (variable informations) attached as unit 12.

C

C     Reference.

C     ----------

C

C       None.

C

C     Author.

C     -------

C

C

C     Modifications.

C     --------------

C

C       None.

C

C     -----------------------------------------------------------------

C

CCC   Include your netcdf.inc

      include 'netcdf.inc'

C     ===  definitions of routinespecific variables  =======================

CCC   maximum array dimensions (change them for your purpose)

      integer   nxmax,nymax,nxi,nyi,nlevmax,nwet

      real      pmin,pmax,pdiff

      parameter(nxmax=270,nymax=270,nlevmax=20,nwet=20)

      parameter(nxi=nxmax-2,nyi=nymax-2)

      real      fld(nxmax,nymax)

      real	field(nxi*nyi)

      real	pstar(nxmax,nymax)

      real	data(nxi,nyi)

      real      varmin(3), varmax(3), stag(3)

      integer   vardim(4)

      real      mdv

      integer	datar(14),idate(5),stdate(5),cstid

      integer	lev,cdfid

      real	tstep

      real	aklev(nlevmax),bklev(nlevmax),aklay(nlevmax),bklay(nlevmax)

      real	latn,lats,lonw,lone,dx,dy,pole_lon,pole_lat

      real      p1,p2,pex1,pex2,exner,pres,plevs(nlevmax)

      integer	nx,ny,nlev,nvars,ntimes,tcode,qcode,pcode

      integer	i,j,ierr,iform,ieee,stash_code,iend,ilev

      integer	dyear,dmonth,dday,dhour,dmins

      logical	opnfile

      integer	strend,saveplevs,tind,irec

      integer	done_u,done_v,done_t,done_q,done_o,done_p

      character*80 cfn,wrcstflag,cdfname,varname

      logical    NewDyn

c     include 'ABmeso31.f'     ! define Hybrid coord. coefficients

C R IS GAS CONSTANT FOR DRY AIR

C CP IS SPECIFIC HEAT OF DRY AIR AT CONSTANT PRESSURE

C PREF IS REFERENCE SURFACE PRESSURE

      REAL R,CP,KAPPA,PREF  ! PREFTOKI

      PARAMETER(R=287.05,CP=1005.0,KAPPA=R/CP,PREF=100000.0)

!     PARAMETER(pmin=1000.0,pmax=200.0,pdiff=25.0,pcode=409)

      character*100 infile

      character*60 cdf_file,ctime*2,char1*1,ext1*2,ext2*2,date_str*2

      write(*,*)'===  start of program pp2cdf_p20 ===  (+++)'

      write(*,*)'===  This Program works on UKMM pressure level data'

C     Read parameters from input-file fort.15

      read(15,'(a)') infile		! name of PP Format input file

      read(15,'(a)') cdfname	! name of NetCDF file

      read(15,'(a)') wrcstflag	! write-cst-file flag

      read(15,'(a)') cfn           ! name of constants file

      read(15,*) mdv			! missing data value

      read(15,*) tcode             ! stash code of T/Theta field

      read(15,*) qcode             ! stash code of Q field

      read(15,*) pcode             ! stash code of PS field

      read(15,*) pmin              ! min value of PS field

      read(15,*) pmax              ! max. value of PS field

      read(15,*) pdiff             ! level difference of PS field

      read(15,*) NewDyn            ! New Dynamics (version 5 onwards)

C      write(*,*) NewDyn

C     write(*,*)pmin, pmax, pdiff 

C     Define constants file name

      if (cfn.eq.'default') then

        cfn=cdfname(1:strend(cdfname))//'_cst'

      endif

      opnfile=.false.

      nvars=0

      ntimes=1

C     ======================================================

C     Start of loop to write specified fields on NetCDF file

C     loop 30 --> goto 30

C     ======================================================

      iform=0

      ieee=1

      irec=0

      done_u=0

      done_v=0

      done_t=0

      done_q=0

      done_o=0

      done_p=0

      saveplevs=0

      nlev=pmax  !50.0

      call open_ppf(infile,iform,ieee)  ! open PP Format input file

   30 continue

CCC   call here a subroutine that reads 1 variable on 1 level from

CCC   a data file

CCC   call another subroutine or do everything in one, as you like,

CCC   that gets some general information about the data

CCC   anyhow, what you do here should define the following parameters:

C     dyear	integer		year of date valid for current field

C     dmonth	integer		month of date valid for current field

C     dday	integer		day of date valid for current field

C     dhour	integer		hour of date valid for current field

C     dmins	integer		minute of date valid for current field

C     lonw	real		coordinates of data domain (in deg):

C     lone	real		      latn

C     lats	real       	 lonw --|-- lone

C     late	real		      lats

C     dx	real		grid size in W-E direction (in deg)

C     dy	real		grid size in S-N direction (in deg)

C     nx	integer	number of data points in W-E direction

C     ny	integer	number of data points in S-N direction

C     nlev	integer	number of data levels

C     stash_code	integer	your field code

C     lev	integer	number of the level for the current field

C     fld 	real		2-dim array with dimensions (nx,ny),

C				contains the field values

CCC   ... call here your subroutine(s)...

      call read_field(iform,nx,ny,fld,stash_code,lev,

     &     dx,dy,dyear,dmonth,dday,dhour,dmins,iend,

     &     lonw,lone,latn,lats,pole_lon,pole_lat,pres,nxmax,nymax,

     &     NewDyn)

c      write(*,*)'stash and level',stash_code,lev,iend,pres

      if(iend.eq.1) goto 999

CCC   Determine the name of the variable from the field code 'num'

CCC   If a variable is not in the list, it is not written to the NetCDF file

      if (stash_code.eq.90003) then

        varname='U'			! zonal velocity

        if(lev.eq.nlev) done_u=1

c       if(saveplevs.lt.nlevmax+1) then

c         if(saveplevs.eq.0) tind=1

c         plevs(tind)=pres

c         tind=tind+1

c       endif

      else if (stash_code.eq.90004) then

        varname='V'			! meridional velocity

        if(lev.eq.nlev) done_v=1

      else if (stash_code.eq.90087) then

        varname='OMEGA'			! vertical velocity

        if(lev.eq.nlev) done_o=1

      else if (stash_code.eq.tcode) then

        varname='T'			! temperature

        if(lev.eq.nlev) done_t=1

c if Theta supplied then convert to Temp

        if(tcode.eq.90006) then

          do j = 1,ny

            do i = 1,nx

c     form Temp. at full levels from Theta

              exner=(pres/pref)**kappa

              fld(i,j)=fld(i,j)*exner

            enddo

          enddo

        endif

      else if (stash_code.eq.pcode ) then

        varname='PS'			! surface pressure

cwang   nlev=1

cwang   lev=1        ! reset lev to 1 from 9999

        done_p=1

        do j = 1,ny

          do i = 1,nx

            pstar(i,j)=fld(i,j)

            fld(i,j)=fld(i,j)/100.0    ! Pstar needed in hPa

          enddo

        enddo

      else if (stash_code.eq.qcode) then

        varname='Q'			! specific humidity

        if(lev.eq.nlev) done_q=1

      else

        goto 30				! don't put fld on NetCDF file

      endif

      irec=irec+1

c     N.B. U, V and Omega are all on P-Grid

        do i=1,nxi

          do j=1,nyi

            data(i,j)=fld(i+1,j+1)

          enddo

        enddo

C     Define staggering coefficients

CCC   change the ??? to your num-value for vertical velocity

      stag(1)=0.0

      stag(2)=0.0

      stag(3)=0.0

c     if (stash_code.eq.???) then	! no staggering for vertical velocity

c       stag(3)=0.0

c     else

c       stag(3)=-0.5		! vertical staggering for all other variables

c     endif

C     Define data region

      varmin(1)=lonw

      varmin(2)=lats

      varmax(1)=lone

      varmax(2)=latn

C     varmin/max(3) changed to take into account reverse order of data

      varmin(3)=pmin   ! Not used

      varmax(3)=pmax  !50.0

      write(*,*) 'lonw,lats,lone,latn',lonw,lats,lone,latn

      write(*,*) 'pmax, pmin',pmax, pmin 

C     Define dimensions

      vardim(1)=nxi

      vardim(2)=nyi

CCC   Distinction between 2dim and 3dim fields

CCC   Insert num-values for 2dim fields

      if (stash_code.eq.pcode) then

        vardim(3)=1

      else

        vardim(3)=nlevmax

      endif

      vardim(4)=1

C     Define the date array

      idate(1)=dyear

      idate(2)=dmonth

      idate(3)=dday

      idate(4)=dhour

      idate(5)=dmins

C     set stdate on first read of PP record from file

c     if (irec.eq.1) then

c     endif

      if (wrcstflag.eq.'yes') then

C       stdate is the simulation start time

        stdate(1)=dyear

        stdate(2)=dmonth

        stdate(3)=dday

        stdate(4)=dhour

        stdate(5)=dmins

C       Define the datar array (used to define constants file)

        datar(1)=nxi

        datar(2)=nyi

        datar(3)=nint(1000.0*latn) ! I agree this is not nice

        datar(4)=nint(1000.0*lonw) ! but for historical reasons

        datar(5)=nint(1000.0*lats) ! subroutine wricst contains

        datar(6)=nint(1000.0*lone) ! this factor 1000. things

        datar(7)=nint(1000.0*dx)

        datar(8)=nint(1000.0*dy)

        datar(9)=nlevmax  ! just in case Pstar first in file

        datar(10)=0         ! not used

        datar(11)=0         ! not used

        datar(12)=0         ! not used

        datar(13)=nint(1000.0*pole_lon)

        datar(14)=nint(1000.0*pole_lat)

C       Get the 4 levels/layers arrays

        call modlevs(aklev,bklev,aklay,bklay,plevs,nlevmax,pmin,pdiff)

C       Write the constants file

        call wricst(cfn,datar,aklev,bklev,aklay,bklay,stdate)

        write(*,*)

        write(*,*)'*** constants-file ',cfn(1:strend(cfn)),' created'

        wrcstflag='no'

      else           ! assume that the constants-file already exists

C       Inquire start time

        call cdfopn(cfn,cstid,ierr)              ! open constants file

        call getstart(cstid,stdate,ierr)

        call ncclos(cstid,ierr)                  ! close constants file

      endif

C     Create the NetCDF file (only once)

      if (.not.opnfile) then

c    Code to derive Index No. for filenames

c       if(ntimes.lt.10) then

c         write(char1,'(i1)') ntimes

c         ctime='0'//char1

c       else

c         write(ctime,'(i2)') ntimes

c       endif

c       cdf_file=cdfname(1:strend(cdfname))//ctime

c    Code to derive timestamp for filenames

c       dhour=dhour-stdate(4)  ! subtract start time so always atart at 0

        if(dhour.eq.0) then

          ext1='00'

        elseif(dhour.lt.10) then

          write(char1,'(i1)') dhour

          ext1='0'//char1

        else

          write(ext1,'(i2)') dhour

        endif

        if(dmins.eq.0) then

          ext2='00'

        else

          write(ext2,'(i2)') dmins

        endif

c       n.b if data runs into next day then can't use root of first

c       filename for rest, so form filename manually

c       cdf_file=cdfname(1:strend(cdfname))//ext1//ext2

c       below assumes year and month are constant

        if(dday.lt.10) then

          write(char1,'(i1)') dday

          date_str='0'//char1

        else

          write(date_str,'(i2)') dday

        endif

        cdf_file=cdfname(1:5)//date_str//'_'//ext1//ext2

        call crecdf(cdf_file,cdfid,varmin,varmax,

     &              3,cfn(1:strend(cfn)),ierr)

        if (ierr.ne.0) goto 996

        write(*,*)

c       write(*,*)'*** NetCDF file ',cdfname(1:strend(cdfname)),' create

        write(*,*)'*** NetCDF file ',cdf_file,' created'

        opnfile=.true.

      endif

C     Put 2dim array in 1dim array

      do i=1,nxi

        do j=1,nyi

          field(i+(j-1)*nxi)=data(i,j)

        enddo

      enddo

C     Calculate tstep for actual date (relative to first time of

c     simulation) and convert to minutes

      call timediff(idate,stdate,tstep)

c     tstep=tstep*100.0

c     tstep=float(nint(tstep*100.0))

      write(6,*)"idate,stdate,tstep:",idate,stdate,tstep

      i=ifix(tstep)  ! round down to nearest hour

      tstep=float(i*60+nint(100.0*tstep)-100*i)

cwang     ilev=1+((1000-lev)/50) this should be changed to /25     

cwang     change ilev=1+((1000-lev)/50) statement when pdiff read in

      write(6,*)"tstep:",tstep

      ilev=1+((pmin-lev)/pdiff)

      if(stash_code.eq.pcode) ilev=1

      if (ilev.eq.1) then

        call putdef(cdfid,varname(1:strend(varname)),4,mdv,vardim,

     &              varmin,varmax,stag,ierr)

        if (ierr.ne.0) goto 996

        write(*,*)

        write(*,*)'*** variable ',varname(1:strend(varname)),' created'

        nvars=nvars+1

      endif

C     Put data on file

c     Convert units of Temp to Degrees C

      if (stash_code.eq.90002.or.stash_code.eq.90006) then

        do i=1,nxi*nyi

          field(i)=field(i)-273.15

        enddo

      endif

      write(*,*)

      write(*,'(a,a,a,f7.1,a,i4,a)')'*** var ',

     &  varname(1:strend(varname)),' at time ',

     &  tstep,' on level ',lev,' written on cdffile'

      call putdat(cdfid,varname(1:strend(varname)),tstep,ilev,

     &  field,ierr)

      if (ierr.ne.0) goto 996

      write(*,*)'cdfid',cdfid

c     if(nvars.eq.6.and.lev.eq.nlev) then   ! required variables written

      write(*,*)done_u,done_v,done_t,done_q,done_o,done_p

      if(done_u+done_v+done_t+done_q+done_o+done_p.eq.6) then

        opnfile=.false.

        ntimes=ntimes+1

        nvars=0

C     Close NetCDF file

        call ncclos(cdfid,ierr)

        if (ierr.ne.0) stop 'error when closing NetCDF file'

c       if(ntimes.eq.2) stop

        done_u=0

        done_v=0

        done_t=0

        done_q=0

        done_o=0

        done_p=0

      endif

      goto 30

  996 stop 'error: could not create NetCDF file'

  999 continue

      write(*,*)lev,nlev,ierr

      if(lev.gt.nlev.or.ierr.ne.0) then

        write(*,*)'===  Error: NetCDF file: ',cdf_file,' incomplete'

        write(*,*)'See fort.12 for list of data processed'

        stop

      endif

      write(*,*)'===  end of program pp2cdf_p20: status normal  ==='

      stop

      end

      subroutine open_ppf(infile,iform,ieee)

C    I/O STREAMS ARE AS FOLLOWS

C     1) 6   STANDARD OUTPUT

C     2) 8   PPUNIT - READ UNIT FOR PP FILE

      IMPLICIT NONE

      INTEGER ierr,IFORM,IEEE

      CHARACTER INFILE*100

c

      IF(IFORM.EQ.1) THEN

        OPEN(UNIT=8,FILE=INFILE,FORM='FORMATTED')

      ELSE

        IF(IEEE.EQ.1) THEN

c     2 lines below are Cray specific calls to identify IEEE file

c     n.b 'newlocal' refers to assign environment, not file

c         call asnctl('newlocal',1,ierr)

c         write(*,*) 'ierr from asnctl ',ierr

c         call asnunit(8,'-F f77 -N ieee',ierr)

c         write(*,*) 'ierr from asnunit ',ierr

        ENDIF

        OPEN(UNIT=8,FILE=INFILE,FORM='UNFORMATTED')

      ENDIF

      return

      END

c********************************************************

      subroutine read_field(iform,nx,ny,data,stash_code,level,

     &     dxdeg,dydeg,dyear,dmonth,dday,dhour,dmins,iend,

     &     lonw,lone,latn,lats,pole_lon,pole_lat,pres,nxmax,nymax,

     &      NewDyn)

C    I/O STREAMS ARE AS FOLLOWS

C     1) 6   STANDARD OUTPUT

C     2) 8   PPUNIT - READ UNIT FOR PP FILE

C     3) 12  HEADER INFORMATION STREAM

      IMPLICIT NONE

c     

      REAL ROOK(19), FIELD(72900),data(270,270)

      INTEGER LOOK(45),I,J,K,N,NUM_VALUES,NX,NY,IFORM,nxmax,nymax,

     &     nf,stash_code,level,dyear,dmonth,dday,dhour,dmins,iend

      real LONG1,LAT1,dxdeg,dydeg,long_nw,lat_nw,

     &     fac,lonw,lone,latn,lats,pole_lon,pole_lat,pres

      logical NewDyn

      data nf/0/

      save nf

      nf=nf+1

c

      IF(IFORM.EQ.1) THEN

        READ(8,12,END=99) LOOK

        READ(8,13) ROOK

      ELSE

        READ(8,END=99) LOOK,ROOK

      ENDIF

      NX=LOOK(19)

      NY=LOOK(18)

      NUM_VALUES=NX*NY

C     WRITE OUT CONTENTS OF INFILE FOR INFORMATION

      WRITE(12,106) LOOK(33),LOOK(14),nf,

     &      NUM_VALUES,LOOK(42),LOOK(18),LOOK(19)

      IF(IFORM.EQ.1) THEN

        READ(8,13) (FIELD(I),I=1,NUM_VALUES)

      ELSE

      write(*,*) '1'

        READ(8) (FIELD(I),I=1,NUM_VALUES)

      ENDIF

      write(*,*) '2'

      LEVEL=LOOK(33)

      stash_code=LOOK(42)

c     Assign exact time of field from "Validity time"

      dyear=look(1)

      if(dyear.gt.1900) dyear=dyear-1900   ! wants only year as 9?

      dmonth=look(2)

      dday=look(3)

      dhour=look(4)

      dmins=look(5)

      LONG1=ROOK(61-45)

      if(LONG1 .lt. 0.0 ) then 

        LONG1=LONG1+360.0

      endif

      LAT1=ROOK(59-45)

      dxdeg=abs(ROOK(62-45))

      dydeg=abs(ROOK(60-45))

cwang      write(*,*)'dxdy',ROOK(62-45),ROOK(60-45)

cwang      write(*,*)'LONG1Lat1',ROOK(61-45),ROOK(59-45)

      fac=0.0

c     if(stash_code.eq.2.or.stash_code.eq.3.or.stash_code.eq.12201)

c    &      fac=0.5

C PAC Verified 

      long_nw=LONG1+dxdeg-fac*dxdeg

cwang      lat_nw=Lat1-dydeg+fac*dydeg

c     define limits of inner 2:nxmax-1 X 2:nymax-1 grid

      lonw=long_nw+dxdeg

      lone=lonw+float(nxmax-3)*dxdeg

cwang change statements to calculate latn and lats

cwang to next if loop so that it counts for dy for positive condition

      if (NewDyn .eq. .false.) then 

        lat_nw=Lat1-dydeg+fac*dydeg

        latn=lat_nw-dydeg

        lats=latn-float(nymax-3)*dydeg

      else

C PAC Verified

        lat_nw=Lat1+dydeg-fac*dydeg

        lats=lat_nw+dydeg

        latn=lats+float(nymax-3)*dydeg

      endif

      pole_lon=ROOK(57-45)

      pole_lat=ROOK(56-45)

      pres=100.0*rook(52-45)  ! in Pa

C-------------------------------------------------------------------

 12   FORMAT(12I10)

 13   FORMAT(10E12.5)

  106 FORMAT(' LEVEL=',I5,' FCST=',I6,' FIELD NO',I4,' NVALS='

     &    ,I5,' STASH CODE=',I5,' NO.ROWS=',I3,' NO.COLUMNS=',I3)

  100 FORMAT('  THE NUMBER OF FIELDS IN THE INPUT FILE IS   ',I8)

C-----------------------Process Data--------------------------------

C     Data WRITTEN STARTING AT N-W CORNER, FOLLOWING LOOPS

C     ASSIGN DATA FROM S-W CORNER AND THEN WRITE OUT

      if (NewDyn .eq. .false.) then 

        write(*,*)'data read starting at N-W'

        DO J=NY-1,0,-1 !LOOP SOUTH-NORTH (ROWS)

          I=J*NX       !FIELD RUNS OPPOSITE

          DO N=1,NX

            DATA(N,NY-J)=FIELD(N+I)

          END DO

        END DO

      else

C PAC Verified

         write(*,*)'data read dstarting at S-W'

        DO J=1,NY

          DO N=1,NX

            DATA(N,J)=FIELD((J-1)*NX+N)

          END DO

        END DO

      endif

C     CODE TO PREVENT UNDERFLOWS ON CONVERSION TO IEEE

      DO J = 1,NY

        DO I = 1,NX

           IF(ABS(DATA(I,J)).LT.1.0E-30.AND.DATA(I,J).NE.0.0) THEN

c            WRITE(6,*) 'UNDERFLOW AT: ',I,J,DATA(I,J)

             DATA(I,J) = 0.0

           ENDIF

        END DO

      END DO

      iend=0

      return

 99   continue

      iend=1

      write(*,*) 'End of file reached'

      return

      END

      subroutine modlevs(aklev,bklev,aklay,bklay,plevs,nlevmax,pm,pd)

C------------------------------------------------------------------------

C

C     Defines the level- and layer-arrays given the number of levels nlev.

C

C     nlev    int    input  number of levels/layers

C     aklev   real   output array contains ak values for levels

C     bklev     real    output  array contains bk values for levels

C     aklay     real    output  array contains ak values for layers

C     bklay     real    output  array contains bk values for layers

C------------------------------------------------------------------------

      integer   nlev,k

      real      aklev(nlevmax),bklev(nlevmax),    ! level coefficients

     &          aklay(nlevmax),bklay(nlevmax)     ! layer coefficients

     &         ,plevs(nlevmax)

      do k=1,nlevmax

        aklay(k)=0.0

        bklay(k)=0.0

c       aklev(k)=plevs(k)/100.0    ! P needed in hPa

        aklev(k)=(pm-(k-1)*pd)    ! P needed in hPa

        bklev(k)=0.0

      enddo

      return

      end