      program hms2ncf 

c-----declarations

      implicit none

      include 'PARMS3.EXT'
      include 'IODECL3.EXT'
      include 'FDESC3.EXT'

      CHARACTER(LEN=16) :: progname
      CHARACTER(LEN=16) :: met
      CHARACTER(LEN=80) :: MESG
      CHARACTER(LEN=150) :: ename,fname,outfile
      CHARACTER(LEN=200) :: ifile,ipath
      CHARACTER :: method, sat

      CHARACTER(LEN=16), ALLOCATABLE :: vnames(:)
      REAL, ALLOCATABLE :: xlatx(:,:),xlonx(:,:),xx(:,:),conc(:,:)
      REAL :: reslat,reslon,lat1,lon1,xpos,ypos,dif1,dif2,rad

      INTEGER :: istatus,nlat,nlon,nx,ny,itmp,jtmp,syear,smon,sday
      INTEGER :: i,j, n, date, time, eco

      INTEGER :: TRIMLEN
      real       envreal

      EXTERNAL TRIMLEN, envreal

      integer icell,jcell,flag
      integer startday,endday,nxc,nyc,nzc,savei,savej
      real dxcamx,xorg,yorg,rlon0,rlat0,tlat1,tlat2,dx,other
      real flon,flat,rlon,rlat,xloc,yloc,xlon,ylat,std,lat,junk
      real*8 isop

      progname = 'HMS2NCF'

c-----Get user-supplied inputs
c

      read(*,'(20x,a)') fname
      write(*,*)fname
      read(fname,*) syear,smon,sday
      startday = syear*10000 + smon*100 + sday 
      call juldate(startday)
      write(*,'(a,t20,i10,i10,i10,i10)') 'Key date:',syear,smon,sday,startday


      read(*,'(20x,a)') fname
      read(fname,*) nxc,nyc,nzc
      write(*,'(a,t20,3i10)') 'Grid size',nxc,nyc,nzc

      read(*,'(20x,a)') fname
      read(fname,*) dxcamx,xorg,yorg
      write(*,'(a,t20,3f10.0)') 'Grid spacing',dxcamx,xorg,yorg

      read(*,'(20x,a)') fname
      read(fname,*) rlon0,rlat0,tlat1,tlat2
      write(*,'(a,t15,4f10.0)') 'Projection:',rlon0,rlat0,tlat1,tlat2

      read(*,'(20x,a)') outfile
c      open(19,file=fname,form='unformatted')
      write(*,*)'Opened netCDF/IOAPI output file: ',outfile

      read(*,'(20x,a)') fname
      open(11,file=fname,status='old',form='formatted')
      write(*,*)'Opened input HMS data file: ',fname

c-----Rename

       nx=nxc
       ny=nyc
       dx=dxcamx

c-----Allocate variables

      allocate (xx(nxc,nyc))
      allocate (conc(nxc,nyc))

c----Set up array

      do j = 1,ny
        do i = 1,nx
        xx(i,j) = 0.0
        conc(i,j) = 0.0
        enddo
      enddo

c-----Read file

        do n = 1,1  !read over header lines
          read(11,*)
        enddo

c        write(*,*)'Reading file'

        n = 0

 798    continue

c        write(*,*)'line number:',n                           
c        read(11,*,end=799) other,isop,flat,flon
        read(11,*,end=799) flat,flon,isop


        n = n + 1

          call lcpgeo(0,rlat0,rlon0,tlat1,tlat2,xpos,ypos,
     &                  flon,flat)

        i = int ( (xpos - xorg) / dxcamx ) + 1
        j = int ( (ypos - yorg) / dxcamx ) + 1
c       write(*,*) flon,flat,xpos,ypos,i,j,xorg,yorg,isop


        if(i.lt.nxc) then
        if(j.lt.nyc) then
        if(i.gt.0) then
        if(j.gt.0) then
         if(isop.gt.0) then
c         write(*,*)'!!!!',i,j,xx(i,j),conc(i,j),isop
         xx(i,j) = xx(i,j) + 1.0
         conc(i,j) = conc(i,j) + isop
         endif
        endif
        endif
        endif
        endif

        goto 798
 799    continue 

         do i = 1, nxc
          do j = 1, nyc
          if(xx(i,j).gt.0) then
          conc(i,j) = conc(i,j) / xx(i,j)
          else
          conc(i,j) = -9.
          endif
          enddo
         enddo

c-----Populate grid ioapi grid variables

      FTYPE3D = 1

      NCOLS3D = nxc
      NROWS3D = nyc
      XCELL3D = dx*1000.
      YCELL3D = dx*1000.
      NLAYS3D = 1
      NTHIK3D = 1
      XORIG3D = xorg*1000.
      YORIG3D = yorg*1000.

      SDATE3D = startday 
c      SDATE3D = 0
      STIME3D = 0
      MXREC3D = 1
      TSTEP3D = 240000
      write(*,*) MXREC3D, SDATE3D, STIME3D

      GDTYP3D = 2
      P_ALP3D = tlat1
      P_BET3D = tlat2
      P_GAM3D = rlon0
      XCENT3D = rlon0
      YCENT3D = rlat0


c ----------------------------- Write output file

      NVARS3D = 2 

      VNAME3D(1) = 'CONC'
      UNITS3D(1) = 'unk'
      VTYPE3D(1) = M3REAL
      VDESC3D(1) = 'griddeddata'

      VNAME3D(2) = 'NUMBER'
      UNITS3D(2) = 'unk'
      VTYPE3D(2) = M3REAL
      VDESC3D(2) = 'griddeddata'


      if ( .not. open3( OUTFILE, FSCREA3, progname ) ) THEN
          MESG = 'Could not open file "' //
     &     outfile( 1: TRIMLEN(OUTFILE))
     &     // '" for output'
c           CALL M3EXIT( progname, 0, 0, MESG, 2 )
      end if

      write(*,*)'KB',SDATE3D,STIME3D

      if ( .not.
     &        write3(OUTFILE,'CONC',SDATE3D,STIME3D,conc(1,1))
     &        ) then
              mesg = 'Error writing '//'FIREDETECT'//'from file '//
     &          outfile( 1: TRIMLEN( outfile ) )
              call m3exit( progname, 0, 0, MESG, 2 )
      end if


      if ( .not.
     &        write3(OUTFILE,'NUMBER',SDATE3D,STIME3D,xx(1,1))
     &        ) then
              mesg = 'Error writing '//'FIREDETECT'//'from file '//
     &          outfile( 1: TRIMLEN( outfile ) )
              call m3exit( progname, 0, 0, MESG, 2 )
      end if


 999  continue

      stop
      end

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      FUNCTION ARCOS(COSA)
      DATA PI/3.14159/                                                          
C$                                                                              
C NAME       ARCOS
C TYPE        FUNCTION                                                                 
C PURPOSE     RETURNS ARC COSINE IN DEGREES
C                                                                               
C CALLING     A = ARCOS(COSA)                                                   
C$                                                                              
      ARCOS = 90.                                                               
      IF(COSA .EQ. 0.) RETURN                                                   
      ARCOS = 0.                                                                
      IF(ABS(COSA) .GE. 1.) RETURN                                              
      ARCOS = (ATAN(SQRT(1. - COSA**2) / COSA) * 180. / PI)/57.29577951                       
      RETURN                                                                    
      END                



      subroutine lcpgeo(iway,phic,xlonc,truelat1,truelat2,xloc,yloc,
     &                  xlon,ylat)
c      write(*,*)'INCALL:',phic,xlonc,truelat1,truelat2
c
c     LCPGEO performs Lambert Conformal to geodetic (lat/lon) translation
c
c     Code based on the TERRAIN preprocessor for MM5 v2.0,
c     developed by Yong-Run Guo and Sue Chen, National Center for
c     Atmospheric Research, and Pennsylvania State University
c     10/21/1993
c
c     Input arguments:
c        iway                Conversion type
c                            0 = geodetic to Lambert Conformal
c                            1 = Lambert Conformal to geodetic
c        phic                Central latitude (deg, neg for southern hem)
c        xlonc               Central longitude (deg, neg for western hem)
c        truelat1            First true latitute (deg, neg for southern hem)
c        truelat2            Second true latitute (deg, neg for southern hem)
c        xloc/yloc           Projection coordinates (km)
c        xlon/ylat           Longitude/Latitude (deg)
c
c     Output arguments:
c        xloc/yloc           Projection coordinates (km)
c        xlon/ylat           Longitude/Latitude (deg)
c
 
      data conv/57.29578/, a/6370./
c
c-----Entry Point
c
      if (phic.lt.0) then
        sign = -1.
      else
        sign = 1.
      endif
      pole = 90.
      if (abs(truelat1).gt.90.) then
        truelat1 = 60.
        truelat2 = 30.
        truelat1 = sign*truelat1
        truelat2 = sign*truelat2
      endif
      xn = alog10(cos(truelat1/conv)) - alog10(cos(truelat2/conv))
      xn = xn/(alog10(tan((45. - sign*truelat1/2.)/conv)) -
     &         alog10(tan((45. - sign*truelat2/2.)/conv)))           
      psi1 = 90. - sign*truelat1
      psi1 = psi1/conv
      if (phic.lt.0.) then
        psi1 = -psi1
        pole = -pole
      endif
      psi0 = (pole - phic)/conv
      xc = 0.
      yc = -a/xn*sin(psi1)*(tan(psi0/2.)/tan(psi1/2.))**xn
c
c-----Calculate lat/lon of the point (xloc,yloc)
c
      if (iway.eq.1) then
        xloc = xloc + xc
        yloc = yloc + yc
        if (yloc.eq.0.) then
          if (xloc.ge.0.) flp = 90./conv
          if (xloc.lt.0.) flp = -90./conv
        else
          if (phic.lt.0.) then
            flp = atan2(xloc,yloc)
          else
            flp = atan2(xloc,-yloc)
          endif
        endif
        flpp = (flp/xn)*conv + xlonc
        if (flpp.lt.-180.) flpp = flpp + 360.
        if (flpp.gt. 180.) flpp = flpp - 360. 
        xlon = flpp 
c
        r = sqrt(xloc*xloc + yloc*yloc)
        if (phic.lt.0.) r = -r
        cell = (r*xn)/(a*sin(psi1))
        rxn  = 1.0/xn
        cel1 = tan(psi1/2.)*cell**rxn
        cel2 = atan(cel1)
        psx  = 2.*cel2*conv
        ylat = pole - psx
c
c-----Calculate x/y from lat/lon
c
      else
        ylon = xlon - xlonc
        if (ylon.gt. 180.) ylon = ylon - 360.
        if (ylon.lt.-180.) ylon = ylon + 360.
        flp = xn*ylon/conv
        psx = (pole - ylat)/conv
        r = -a/xn*sin(psi1)*(tan(psx/2.)/tan(psi1/2.))**xn
        if (phic.lt.0.) then
          xloc = r*sin(flp)
          yloc = r*cos(flp)
        else
          xloc = -r*sin(flp)
          yloc =  r*cos(flp)
        endif
      endif
c
c      write(*,*)xloc,xc,yloc,yc
      xloc = xloc - xc
      yloc = yloc - yc
c
      return
      end


      subroutine juldate(idate)
!
!-----JULDATE converts date from calender (YYMMDD) format to Julian
!     (YYJJJ) format
!
      implicit none
!
      integer idate
      integer nday(12),iyear,imonth,iday,mday,n,jday
!
      data nday/31,28,31,30,31,30,31,31,30,31,30,31/
!
!-----Entry point
!
      iyear = idate/10000
      imonth = (idate - iyear*10000)/100
      iday = idate - iyear*10000 - imonth*100
!
      nday(2) = 28
      if (mod(iyear,4).eq.0) nday(2) = 29
      mday = 0
      do 10 n = 1,imonth-1
        mday = mday + nday(n)
 10   continue
      jday = mday + iday
      idate = iyear*1000 + jday
!
      return
      end

