      module fixio
!  FIXIO - routines adapted from 2001 MRF code to read and write
!  surface analysis files.
!
!  07/21/04 - First implementation by Eric
!  07/26/04 - Major rewrite by Istvan: elimination of all but two
!             subroutines and several unncesessary variables and
!             parameters 
!
!  SYNOPSIS: PARA_FIXO_R reads an NCEP surface file (unit number 
!            nread). The surface fields are first read into a
!            real*4 buffer (buffer1, buffer2, or buffer4) and then 
!            copied to the the appropriate real*8 arrays used in the 
!            model calculation
!            PARA_FIXIO_W writes an NCEP surface file. The real*8
!            fields are first copied into a real*4 buffer 
!
      use resolution
      use precision
      use grid_indexing,only:LONSPERLAT
      contains
!***********************************************************************
!
      SUBROUTINE PARA_FIXIO_R(LONF,LONF2,LATG,LATG2,TSEA,SMC,SHELEG, &
     &           STC,TG3,ZORL,CV, &
     &           CVB, &
     &           CVT,ALVSF,ALVWF,ALNSF,ALNWF,SLMSK,VFRAC,CANOPY,F10M, &
     &           VTYPE,STYPE,FACSF,FACWF,UUSTAR,FFMM,FFHH, &
     &           nread,xhour,idate)
!
!***********************************************************************
!
      implicit none
!
      integer LONF,LONF2,LATG,LATG2
      real(D) SMC(LONF,LATG,LSOIL),STC(LONF,LATG,LSOIL), &
     &     TSEA  (LONF,LATG),SHELEG(LONF,LATG),TG3     (LONF,LATG), &
     &     ZORL  (LONF,LATG),CV    (LONF,LATG),CVB   (LONF,LATG), &
     &     CVT   (LONF,LATG),ALVSF (LONF,LATG),ALVWF (LONF,LATG), &
     &     ALNSF (LONF,LATG),ALNWF (LONF,LATG),SLMSK (LONF,LATG), &
     &     VFRAC (LONF,LATG),CANOPY(LONF,LATG),F10M  (LONF,LATG), &
     &     VTYPE (LONF,LATG),STYPE (LONF,LATG),FACSF (LONF,LATG), &
     &     FACWF (LONF,LATG),UUSTAR(LONF,LATG),FFMM  (LONF,LATG), &
     &     FFHH  (LONF,LATG)

      integer jump

!      real(R) buff1(LONF2,LATG2),buff2(LONF2,LATG2,LSOIL), &
      real(R) buff1(LONF,LATG),buff2(LONF,LATG,LSOIL), &
         buff4(LONF,LATG,4),xhour
      integer nread,i,j,k,idate(4),lonsfc,latsfc,ivssfc
      CHARACTER(8) labfix(4)
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
      REWIND nread
      READ(nread)labfix
      READ(nread)xhour,IDATE,lonsfc,latsfc,ivssfc
      do k=3,12
        read(nread)
      enddo
      READ(NREAD) buff1
      rewind nread
      read(nread)
      read(nread)

      READ(NREAD) buff1
      DO J=1,LATG
         DO I=1,LONF
            TSEA(i,j)=buff1(i,j)
         ENDDO
      ENDDO

      READ(NREAD) buff2
      DO K=1,LSOIL
         DO J=1,LATG
            DO I=1,LONF
               SMC(i,j,k)=buff2(i,j,k)
            ENDDO
         ENDDO
      ENDDO

      READ(NREAD) buff1
      DO J=1,LATG
         DO I=1,LONF
            SHELEG(i,j)=buff1(i,j)
         ENDDO
      ENDDO

      READ(NREAD) buff2
      DO K = 1, LSOIL
         DO J=1,LATG
            DO I=1,LONF
               STC(i,j,k)=buff2(i,j,k)
            ENDDO
         ENDDO
      ENDDO

      READ(NREAD) buff1
      DO J=1,LATG
         DO I=1,LONF
            TG3(i,j)=buff1(i,j)
         ENDDO
      ENDDO

      READ(NREAD) buff1
      DO J=1,LATG
         DO I=1,LONF
            ZORL(i,j)=buff1(i,j)
         ENDDO
      ENDDO

      READ(NREAD) buff1
      DO J=1,LATG
         DO I=1,LONF
            CV(i,j)=buff1(i,j)
         ENDDO
      ENDDO

      READ(NREAD) buff1
      DO J=1,LATG
         DO I=1,LONF
            CVB(i,j)=buff1(i,j)
         ENDDO
      ENDDO
        
      READ(NREAD) buff1
      DO J=1,LATG
         DO I=1,LONF
            CVT(i,j)=buff1(i,j)
         ENDDO
      ENDDO

      READ(NREAD) buff4
      DO J=1,LATG
         DO I=1,LONF
            ALVSF(i,j)=buff4(i,j,1)
            ALVWF(i,j)=buff4(i,j,2)
            ALNSF(i,j)=buff4(i,j,3)
            ALNWF(i,j)=buff4(i,j,4)
         ENDDO
      ENDDO

      READ(NREAD) buff1
      DO J=1,LATG
         DO I=1,LONF
            SLMSK(i,j)=buff1(i,j)
         ENDDO
      ENDDO

      READ(NREAD) buff1
      DO J=1,LATG
         DO I=1,LONF
            VFRAC(i,j)=buff1(i,j)
         ENDDO
      ENDDO

      READ(NREAD) buff1
      DO J=1,LATG
         DO I=1,LONF
            CANOPY(i,j)=buff1(i,j)
         ENDDO
      ENDDO

      READ(NREAD) buff1
      DO J=1,LATG
         DO I=1,LONF
            F10M(i,j)=buff1(i,j)
         ENDDO
      ENDDO

      READ(NREAD) buff1
      VTYPE=buff1
      DO J=1,LATG
         DO I=1,LONF
            VTYPE(i,j)=buff1(i,j)
         ENDDO
      ENDDO

      READ(NREAD) buff1
      DO J=1,LATG
         DO I=1,LONF
            STYPE(i,j)=buff1(i,j)
         ENDDO
      ENDDO

      READ(NREAD) buff4(:,:,1:2)
      DO J=1,LATG
         DO I=1,LONF
            FACSF(i,j)=buff4(i,j,1)
            FACWF(i,j)=buff4(i,j,2)
         ENDDO
      ENDDO

      DO j=1,LATG
         DO i=1,LONF
            UUSTAR(i,j)=1.
            FFMM(i,j)=LOG(30.)
            FFHH(i,j)=LOG(30.)
         ENDDO
      ENDDO

!szunyogh 06/16/99
!     surface files written before 03/08/99 do not contain the records:
!     uustar, ffmm, ffhh
!     if uustar is not found the no attempt is made to read the two 
!     other records 
      JUMP=1
      READ(NREAD,END=200) buff1
      JUMP=0
200   continue
      IF (jump.eq.0) THEN
         UUSTAR=buff1
            
         READ(NREAD) buff1
         DO J=1,LATG
            DO I=1,LONF
               FFMM(i,j)=buff1(i,j)
            ENDDO
         ENDDO

         READ(NREAD) buff1
         DO J=1,LATG
            DO I=1,LONF
               FFHH(i,j)=buff1(i,j)
            ENDDO
         ENDDO
      ENDIF

      RETURN
      END SUBROUTINE PARA_FIXIO_R
!
!***********************************************************************
!
      SUBROUTINE PARA_FIXIO_W(LONF,LONF2,LATG,LATG2,TSEA,SMC,SHELEG, &
     &           STC,TG3,ZORL,CV, &
     &           CVB, &
     &           CVT,ALVSF,ALVWF,ALNSF,ALNWF,SLMSK,VFRAC,CANOPY,F10M, &
     &           VTYPE,STYPE,FACSF,FACWF,UUSTAR,FFMM,FFHH, &
     &           nw,yhour,idate)
!
!***********************************************************************
!
      implicit none
!
      integer LONF,LONF2,LATG,LATG2
      real (D) SMC(LONF,LATG,LSOIL),STC(LONF,LATG,LSOIL), &
     &     TSEA  (LONF,LATG),SHELEG(LONF,LATG),TG3   (LONF,LATG), &
     &     ZORL  (LONF,LATG),CV    (LONF,LATG),CVB   (LONF,LATG), &
     &     CVT   (LONF,LATG),ALVSF (LONF,LATG),ALVWF (LONF,LATG), &
     &     ALNSF (LONF,LATG),ALNWF (LONF,LATG),SLMSK (LONF,LATG), &
     &     VFRAC (LONF,LATG),CANOPY(LONF,LATG),F10M  (LONF,LATG), &
     &     VTYPE (LONF,LATG),STYPE (LONF,LATG),FACSF (LONF,LATG), &
     &     FACWF (LONF,LATG),UUSTAR(LONF,LATG),FFMM  (LONF,LATG), &
     &     FFHH  (LONF,LATG)

      real(R) buff1(LONF,LATG),buff2(LONF,LATG,LSOIL), &
         buff4(LONF,LATG,4),yhour
      integer nw,i,j,k,idate(4)
      CHARACTER(8) labfix(4)
      integer,save:: version
      data version/200004/
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!

      REWIND nw
      labfix=CHAR(0)//CHAR(0)//CHAR(0)//CHAR(0)// &
     &       CHAR(0)//CHAR(0)//CHAR(0)//CHAR(0)
      write(nw)labfix
      write(nw)yhour,IDATE,LONF,LATG,version,LONSPERLAT

      DO J=1,LATG
         DO I=1,LONF
            buff1(i,j)=real(TSEA(i,j),kind(buff1))
         ENDDO
      ENDDO
      write(nw) buff1

      DO k=1,LSOIL
         DO J=1,LATG
            DO I=1,LONF
               buff2(i,j,k)=real(SMC(i,j,k),kind(buff2))
            ENDDO
         ENDDO
      ENDDO
      write(nw) buff2

      DO J=1,LATG
         DO I=1,LONF
            buff1(i,j)=real(SHELEG(i,j),kind(buff1))
         ENDDO
      ENDDO
      write(nw) buff1

      DO K = 1, LSOIL
         DO J=1,LATG
            DO I=1,LONF
               buff2(i,j,k)=real(STC(i,j,k),kind(buff2))
            ENDDO
         ENDDO
      ENDDO
      write(nw) buff2

      DO J=1,LATG
         DO I=1,LONF
            buff1(i,j)=real(TG3(i,j),kind(buff1))
         ENDDO
      ENDDO
      write(nw) buff1

      DO J=1,LATG
         DO I=1,LONF
            buff1(i,j)=real(ZORL(i,j),kind(buff1))
         ENDDO
      ENDDO
      write(nw) buff1

      DO J=1,LATG
         DO I=1,LONF
            buff1(i,j)=real(CV(i,j),kind(buff1))
         ENDDO
      ENDDO
      write(nw) buff1

      DO J=1,LATG
         DO I=1,LONF
            buff1(i,j)=real(CVB(i,j),kind(buff1))
         ENDDO
      ENDDO
      write(nw) buff1

      DO J=1,LATG
         DO I=1,LONF
            buff1(i,j)=real(CVT(i,j),kind(buff1))
         ENDDO
      ENDDO
      write(nw) buff1

      DO J=1,LATG
         DO I=1,LONF
            buff4(i,j,1)=real(ALVSF(i,j),kind(buff4))
            buff4(i,j,2)=real(ALVWF(i,j),kind(buff4))
            buff4(i,j,3)=real(ALNSF(i,j),kind(buff4))
            buff4(i,j,4)=real(ALNWF(i,j),kind(buff4))
         ENDDO
      ENDDO
      write(nw) buff4

      DO J=1,LATG
         DO I=1,LONF
            buff1(i,j)=real(SLMSK(i,j),kind(buff1))
         ENDDO
      ENDDO
      write(nw) buff1

      DO J=1,LATG
         DO I=1,LONF
            buff1(i,j)=real(VFRAC(i,j),kind(buff1))
         ENDDO
      ENDDO
      write(nw) buff1

      DO J=1,LATG
         DO I=1,LONF
            buff1(i,j)=real(CANOPY(i,j),kind(buff1))
         ENDDO
      ENDDO
      write(nw) buff1

      DO J=1,LATG
         DO I=1,LONF
            buff1(i,j)=real(F10M(i,j),kind(buff1))
         ENDDO
      ENDDO
      write(nw) buff1

      DO J=1,LATG
         DO I=1,LONF
            buff1(i,j)=real(VTYPE(i,j),kind(buff1))
         ENDDO
      ENDDO
      write(nw) buff1

      DO J=1,LATG
         DO I=1,LONF
            buff1(i,j)=real(STYPE(i,j),kind(buff1))
         ENDDO
      ENDDO
      write(nw) buff1

      DO J=1,LATG
         DO I=1,LONF
            buff4(i,j,1)=real(FACSF(i,j),kind(buff4))
            buff4(i,j,2)=real(FACWF(i,j),kind(buff4))
         ENDDO
      ENDDO
      write(nw) buff4(:,:,1:2)

      DO J=1,LATG
         DO I=1,LONF
            buff1(i,j)=real(UUSTAR(i,j),kind(buff1))
         ENDDO
      ENDDO
      write(nw) buff1

      DO J=1,LATG
         DO I=1,LONF
            buff1(i,j)=real(FFMM(i,j),kind(buff1))
         ENDDO
      ENDDO
      write(nw) buff1

      DO J=1,LATG
         DO I=1,LONF
            buff1(i,j)=real(FFHH(i,j),kind(buff1))
         ENDDO
      ENDDO
      write(nw) buff1

      RETURN
      END SUBROUTINE PARA_FIXIO_W
!--------------------
      end module fixio
