!------------------------------------------------------------------------
! HISTORY:
!
!     Yunheng Wang (09/06/2001)
!     Update with the new version ext2arps changed by Gene Bassett.
!     In general, a variable soiltyp was added in soil initial 
!     file (xxxxxx.soilvar.000000) by Gene.
!
!     Deallocate all the allocated variables
!
!-----------------------------------------------------------------------


SUBROUTINE splitsoilini (fileheader,nx,ny,nstyps) 1,5

  IMPLICIT NONE

  INCLUDE 'mp.inc'

  INTEGER :: nx,ny,nstyps

  INTEGER :: nxlg, nylg

!
!-----------------------------------------------------------------------
!
!  Misc. local variables
!
!-----------------------------------------------------------------------
!
  CHARACTER (LEN=80) :: fileheader
  INTEGER :: lenstr
  CHARACTER (LEN=10) :: filetail
  CHARACTER (LEN=128) :: filename
  INTEGER :: fi, fj, i, j, k, is
  INTEGER :: nxin, nyin

  INTEGER :: mprojin,tsfcin,tsoilin,wsfcin,wdpin,wcanpin,stypin
  INTEGER :: snowcin,snowdin,nstypin
  INTEGER :: idummy
  REAL :: dxin,dyin,ctrlonin,ctrlatin,trlat1in,trlat2in,trlonin,sclin
  REAL :: rdummy
  CHARACTER (LEN=15) :: ctime

  REAL, ALLOCATABLE :: a2dlg(:,:), a2dsm(:,:)
  REAL, ALLOCATABLE :: a3dlg(:,:,:), a3dsm(:,:,:)
  INTEGER, ALLOCATABLE :: i2dlg(:,:), i2dsm(:,:)
  INTEGER, ALLOCATABLE :: ounit(:)
  INTEGER, ALLOCATABLE :: ffi(:), ffj(:)

  REAL, ALLOCATABLE :: soiltyp(:,:,:), soiltypsm(:,:,:)

  INTEGER :: ierr
  INTEGER :: nfields, fcnt
  INTEGER :: ii,jj,iiend
  INTEGER :: unit0, maxunit
  PARAMETER (unit0=110,maxunit=60)

!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
!  Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!

  if ( mp_opt > 0 ) then
	write(6,*) 'splitsoilini:  not MP ready'
	call arpsstop('splitsoilini:   not MP ready', 1)
	return
  endif

  nxlg = (nx-3)*nproc_x+3
  nylg = (ny-3)*nproc_y+3

  ALLOCATE(a2dlg(nxlg,nylg))
  ALLOCATE(i2dlg(nxlg,nylg))
  ALLOCATE(i2dsm(nx,ny))
  ALLOCATE(a2dsm(nx,ny))
  ALLOCATE(a3dlg(nxlg,nylg,0:nstyps))
  ALLOCATE(a3dsm(nx,ny,0:nstyps))
  ALLOCATE(soiltyp(nxlg,nylg,nstyps))
  ALLOCATE(soiltypsm(nx,ny,nstyps))
  ALLOCATE(ounit(nproc_x*nproc_y))
  ALLOCATE(ffi(nproc_x*nproc_y))
  ALLOCATE(ffj(nproc_x*nproc_y))

  lenstr = 0
  100   lenstr = lenstr + 1
  IF (fileheader(lenstr:lenstr) /= " ") GO TO 100
  lenstr = lenstr - 1

!
!-----------------------------------------------------------------------
!
!  Open the files.
!
!-----------------------------------------------------------------------
!
  CALL asnctl ('NEWLOCAL', 1, ierr)

  DO fj=1,nproc_y
    DO fi=1,nproc_x

      ii = fi+nproc_x*(fj-1)
      ffi(ii) = fi
      ffj(ii) = fj
      ounit(ii) = unit0 + ii

    END DO
  END DO

  DO jj = 1,1+(nproc_x*nproc_y-1)/maxunit

    iiend = MIN(jj*maxunit,nproc_x*nproc_y)

    DO ii=1+(jj-1)*maxunit,iiend

!
!-----------------------------------------------------------------------
!
!  Since T3D processors only support COS and IEEE double precision
!  format, we have to translate the files into COS format.
!
!-----------------------------------------------------------------------
!

      WRITE (filename, '(a,a,2i2.2)')                                   &
             fileheader(1:lenstr),'_',ffi(ii),ffj(ii)

      CALL asnfile(filename, '-F f77 -N ieee', ierr)

      OPEN (UNIT=ounit(ii), FILE=filename, FORM='unformatted')

    END DO

    CALL asnfile(fileheader(1:lenstr), '-F f77 -N ieee', ierr)
    OPEN (UNIT=10, FILE=fileheader(1:lenstr), FORM='unformatted')

!
!-----------------------------------------------------------------------
!
!  Read/write the dimensions of data in the file and check against
!  the dimensions passed to this subroutine.
!
!-----------------------------------------------------------------------
!
    READ (10) nxin,nyin
    IF ((nxin /= nxlg).OR.(nyin /= nylg)) THEN
      WRITE (*,*) "ERROR:  mismatch in sizes."
      WRITE (*,*) "nxin,nyin",nxin,nyin
      WRITE (*,*) "nxlg,nylg",nxlg,nylg
      call arpsstop("splitsoilini:  mismatch",1)
    END IF

    DO ii=1+(jj-1)*maxunit,iiend
      WRITE (ounit(ii)) nx,ny
    END DO

!
!-----------------------------------------------------------------------
!
!  Read/write header info
!
!-----------------------------------------------------------------------
!
    READ (10)                mprojin,tsfcin,tsoilin,wsfcin,wdpin,       &
                             wcanpin,snowcin,snowdin,stypin,idummy,     &
                             idummy,idummy,idummy,idummy,idummy,        &
                             idummy,idummy,idummy,idummy,nstypin
    DO ii=1+(jj-1)*maxunit,iiend

!Bug fix.  Eric Kemp, 22 March 2002.
      WRITE (ounit(ii))      mprojin,tsfcin,tsoilin,wsfcin,wdpin,       &
!                             wcanpin,snowcin,snowdin,idummy,idummy,     &
                             wcanpin,snowcin,snowdin,stypin,idummy,     &
                             idummy,idummy,idummy,idummy,idummy,        &
                             idummy,idummy,idummy,idummy,nstypin
    END DO

    nfields = 0
    IF (tsfcin  > 0) nfields = nfields + 1
    IF (tsoilin > 0) nfields = nfields + 1
    IF (wsfcin  > 0) nfields = nfields + 1
    IF (wdpin   > 0) nfields = nfields + 1
    IF (wcanpin > 0) nfields = nfields + 1


    READ (10)                dxin,dyin, ctrlonin,ctrlatin,trlat1in,     &
                             trlat2in,trlonin,sclin,rdummy,rdummy,      &
                             rdummy,rdummy,rdummy,rdummy,rdummy,        &
                             rdummy,rdummy,rdummy,rdummy,rdummy
    DO ii=1+(jj-1)*maxunit,iiend
      WRITE (ounit(ii)) dxin,dyin, ctrlonin,ctrlatin,trlat1in,          &
                             trlat2in,trlonin,sclin,rdummy,rdummy,      &
                             rdummy,rdummy,rdummy,rdummy,rdummy,        &
                             rdummy,rdummy,rdummy,rdummy,rdummy
    END DO

!
!-----------------------------------------------------------------------
!
!   Read in the global data, and write out appropriate sections into
!   each processors file.
!
!-----------------------------------------------------------------------
!
    DO fcnt = 1,nfields

      IF ( nstypin <= 1 ) THEN

        READ (10) a2dlg

        DO ii=1+(jj-1)*maxunit,iiend
          fi = ffi(ii)
          fj = ffj(ii)
          DO j = 1,ny
            DO i = 1,nx
              a2dsm(i,j) = a2dlg(i+(fi-1)*(nx-3),j+(fj-1)*(ny-3))
            END DO
          END DO
          WRITE (ounit(ii)) a2dsm
        END DO

      ELSE

        READ (10) a3dlg

          DO ii=1+(jj-1)*maxunit,iiend
            fi = ffi(ii)
            fj = ffj(ii)
            DO is=0,nstypin
              DO j = 1,ny
                DO i = 1,nx
                  a3dsm(i,j,is) = a3dlg(i+(fi-1)*(nx-3),j+(fj-1)*(ny-3),is)
                END DO
              END DO
            END DO
            WRITE (ounit(ii)) a3dsm
          END DO

      END IF

    END DO

    IF (snowcin /= 0) THEN

      READ (10) i2dlg

      DO ii=1+(jj-1)*maxunit,iiend
        fi = ffi(ii)
        fj = ffj(ii)
        DO j = 1,ny
          DO i = 1,nx
            i2dsm(i,j) = i2dlg(i+(fi-1)*(nx-3),j+(fj-1)*(ny-3))
          END DO
        END DO
        WRITE (ounit(ii)) i2dsm
      END DO

    END IF

    IF (snowdin /= 0) THEN

      READ (10) a2dlg

      DO ii=1+(jj-1)*maxunit,iiend
        fi = ffi(ii)
        fj = ffj(ii)
        DO j = 1,ny
          DO i = 1,nx
            a2dsm(i,j) = a2dlg(i+(fi-1)*(nx-3),j+(fj-1)*(ny-3))
          END DO
        END DO
        WRITE (ounit(ii)) a2dsm
      END DO

    END IF

    IF( stypin /=0 ) THEN

       READ (10) soiltyp

       DO ii=1+(jj-1)*maxunit,iiend
         fi = ffi(ii)
         fj = ffj(ii)
         DO is=1,nstypin
           DO j = 1,ny
             DO i = 1,nx
               soiltypsm(i,j,is) = soiltyp(i+(fi-1)*(nx-3),j+(fj-1)*(ny-3),is)
             END DO
           END DO
         END DO
         WRITE (ounit(ii)) soiltypsm
       END DO

    END IF

    CLOSE (10)
    DO ii=1+(jj-1)*maxunit,iiend
      CLOSE (ounit(ii))
    END DO

  END DO     ! jj

  DEALLOCATE(a2dlg)
  DEALLOCATE(i2dlg)
  DEALLOCATE(i2dsm)
  DEALLOCATE(a2dsm)
  DEALLOCATE(a3dlg)
  DEALLOCATE(a3dsm)
  DEALLOCATE(soiltyp)
  DEALLOCATE(soiltypsm)
  DEALLOCATE(ounit)
  DEALLOCATE(ffi)
  DEALLOCATE(ffj)

  RETURN

END SUBROUTINE splitsoilini