                  SUBROUTINE QUILT
C
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .
C   SUBROUTINE:  QUILT     I/O SERVERS
C   PRGRMMR: TUCCILLO        ORG:  IBM       DATE: 00-01-20
C
C ABSTRACT:  I/O SERVERS
C
C PROGRAM HISTORY LOG:
C   00-01-20  TUCCILLO - ORIGINATOR
C
C USAGE:  CALL QUILT
C
C   INPUT ARGUMENT LIST:
C     NONE
C
C   OUTPUT ARGUMENT LIST:
C     NONE
C
C   INPUT FILES:  NONE
C
C   OUTPUT FILES:  NONE
C
C   SUBPROGRAMS CALLED:
C     UNIQUE:
C            MPI_RECV
C            MPI_BCAST
C            COLLECT
C            SLP
C            DECOAL
C
C   EXIT STATES:
C     COND =   0 - NORMAL EXIT
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE : IBM SP
C
C$$$
C
C     THIS CODE ASSUMES THAT NSOIL IS GE TO 4. IF THIS IS NOT TRUE,
C     THE CODE WILL STOP. THE EQUIVALENCING IS THE PROBLEM.
C
C--------------------------------------------------------------
      INCLUDE "parmeta"
      INCLUDE "parmsoil"
      INCLUDE "mpif.h"
      INCLUDE "mpp.h"
C--------------------------------------------------------------
      INCLUDE "PARA.comm"
      INCLUDE "BUFFER.comm"
C--------------------------------------------------------------
cioannis      INCLUDE "model2d_nl.nml"
C--------------------------------------------------------------
                              P A R A M E T E R
     & (LB=2*IM+JM-3,LP1=LM+1)
cioannis      PARAMETER (NSOIL = NSOLD)
C--------------------------------------------------------------
C
       REAL DUM1(IM,JM),DUM2(IM,JM),DUM3(IM,JM),DUM4(IM,JM)
       REAL DUM5(IM,JM),DUM6(IM,JM),DUM7(IM,JM)
       REAL DUMS(IM,JM,NSOIL)
       REAL DUM1D1(12) ! ioannis used to store T at Alaiz
       REAL DUM1D2(12) ! ioannis used to store U at Alaiz
       REAL DUM1D3(12) ! ioannis used to store V at Alaiz
       INTEGER STATUS(MPI_STATUS_SIZE)
       EQUIVALENCE ( DUM1(1,1), DUMS(1,1,1) )
       EQUIVALENCE ( DUM2(1,1), DUMS(1,1,2) )
       EQUIVALENCE ( DUM3(1,1), DUMS(1,1,3) )
       EQUIVALENCE ( DUM4(1,1), DUMS(1,1,4) )
       EQUIVALENCE ( DUM5(1,1), DUMS(1,1,5) ) ! ioannis
       EQUIVALENCE ( DUM6(1,1), DUMS(1,1,6) ) ! ioannis
C
C--------------------------------------------------------------
      REAL, ALLOCATABLE ::
     & PD(:,:),RES(:,:),FIS(:,:)
     &,ACPREC(:,:),CUPREC(:,:),TSHLTR(:,:),U10(:,:),V10(:,:)
     &,ACSNOW(:,:),SM(:,:),SICE(:,:),SST(:,:),TG(:,:),SNO(:,:)
     &,VEGFRC(:,:),THS(:,:),QSHLTR(:,:),Q10(:,:)
     &,RSWIN(:,:),RSWOUT(:,:),RSWTOA(:,:),RLWIN(:,:)
     &,RLWOUT(:,:),RLWTOA(:,:),TWBS(:,:),QWBS(:,:),ALBEDO(:,:)
     &,Z0(:,:),USTAR(:,:),PSLP(:,:)
C
      REAL, ALLOCATABLE ::
     & CFRACL(:,:),CFRACM(:,:),CFRACH(:,:) ! ioannis 20/11/03
C
      REAL, ALLOCATABLE ::
     & wavepar(:,:)
C
      REAL, ALLOCATABLE ::
     & SI(:,:) ! ioannis 04/10/05
C
      REAL UL(2*LM), SPL(LSM), DFL(LP1), ETA(LP1)
C
      REAL, ALLOCATABLE ::
     & OMGALF(:,:,:),T(:,:,:),Q(:,:,:),U(:,:,:)
     &,V(:,:,:),HTM(:,:,:),VTM(:,:,:),CWM(:,:,:),Q2(:,:,:)
C
      REAL, ALLOCATABLE ::
     & SMC(:,:,:),STC(:,:,:),SH2O(:,:,:)
                              R E A L
     & PDB(LB,2),TB(LB,LM,2),QB(LB,LM,2),UB(LB,LM,2),VB(LB,LM,2)
C
C--------------------------------------------------------------
      INTEGER IDAT(3)
C
      INTEGER, ALLOCATABLE ::
     & IVGTYP(:,:),ISLTYP(:,:),LMH(:,:),LMV(:,:)
C--------------------------------------------------------------
                              L O G I C A L
     & RUN,FIRST
C--------------------------------------------------------------
                              C H A R A C T E R
     & RSTFIL1*50,RSTFIL2*50,RESTHR*4,LABEL*32
     &,FNAME*80,ENVAR*50,BLANK*4,FFNAME*256
      CHARACTER FINFIL*50,DONE*10,CDAT*3
      CHARACTER FN_VOUT*100 ! ioannis
                              C H A R A C T E R
     & LABEL1*32, LABEL2*32,LABEL3*32,LABEL4*32
C
       LOGICAL LME, PRINT_FIELDS, PRINT_GROUND, PRINT_INIT
       LOGICAL NEST  ! ioannis
C---------------------------------------------------------------
      DATA LRSTRT1/21/,LRSTRT2/51/,LRSTRT3/61/,NHB/12/,BLANK/'    '/
      DATA LRSTRT4/71/
C---------------------------------------------------------------
C
cpt      real*8 etime, ist, isp, rtc
      real*8 timef, ist, isp, rtc, ist2, isp2, icum

C---------------------------------------------------------------
C***
cioannis      OPEN (UNIT=11,FILE='../../namelists/name.list',FORM='FORMATTED')
cioannis      READ(11,MODEL2D_NL)
cioannis      CLOSE(11)
C---------------------------------------------------------------
      CALL MPI_FIRST
C
      IF(NSOIL.LT.4)THEN
        print *, ' NSOIL IS LESS THAN 4. CHANGE THE EQUIVALENCES'
        print *, ' STOPPING'
        stop
      ENDIF
C
      IF(ME.EQ.0)THEN
        LME=.TRUE.
      ELSE
        LME=.FALSE.
      ENDIF
C
cpt      btim=etime()
C
      ALLOCATE(PD(MY_ISD:MY_IED,MY_JSD:MY_JED))
      ALLOCATE(T(MY_ISD:MY_IED,MY_JSD:MY_JED,1:LM))
      ALLOCATE(Q(MY_ISD:MY_IED,MY_JSD:MY_JED,1:LM))
      ALLOCATE(U(MY_ISD:MY_IED,MY_JSD:MY_JED,1:LM))
      ALLOCATE(V(MY_ISD:MY_IED,MY_JSD:MY_JED,1:LM))
      ALLOCATE(CWM(MY_ISD:MY_IED,MY_JSD:MY_JED,1:LM))
      ALLOCATE(ACPREC(MY_ISD:MY_IED,MY_JSD:MY_JED))
      ALLOCATE(CUPREC(MY_ISD:MY_IED,MY_JSD:MY_JED))
      ALLOCATE(TSHLTR(MY_ISD:MY_IED,MY_JSD:MY_JED))
      ALLOCATE(U10(MY_ISD:MY_IED,MY_JSD:MY_JED))
      ALLOCATE(V10(MY_ISD:MY_IED,MY_JSD:MY_JED))
      ALLOCATE(OMGALF(MY_ISD:MY_IED,MY_JSD:MY_JED,1:LM))
      ALLOCATE(ACSNOW(MY_ISD:MY_IED,MY_JSD:MY_JED))
      ALLOCATE(SM(MY_ISD:MY_IED,MY_JSD:MY_JED))
      ALLOCATE(SNO(MY_ISD:MY_IED,MY_JSD:MY_JED))
      ALLOCATE(VEGFRC(MY_ISD:MY_IED,MY_JSD:MY_JED))
      ALLOCATE(Q2(MY_ISD:MY_IED,MY_JSD:MY_JED,1:LM))
C**********************************************************************
      ALLOCATE(RES(MY_ISD:MY_IED,MY_JSD:MY_JED))
      ALLOCATE(FIS(MY_ISD:MY_IED,MY_JSD:MY_JED))
      ALLOCATE(HTM(MY_ISD:MY_IED,MY_JSD:MY_JED,1:LM))
      ALLOCATE(VTM(MY_ISD:MY_IED,MY_JSD:MY_JED,1:LM))
      ALLOCATE(LMH(MY_ISD:MY_IED,MY_JSD:MY_JED))
      ALLOCATE(LMV(MY_ISD:MY_IED,MY_JSD:MY_JED))
      ALLOCATE(SICE(MY_ISD:MY_IED,MY_JSD:MY_JED))
      ALLOCATE(SST(MY_ISD:MY_IED,MY_JSD:MY_JED))
      ALLOCATE(IVGTYP(MY_ISD:MY_IED,MY_JSD:MY_JED))
      ALLOCATE(ISLTYP(MY_ISD:MY_IED,MY_JSD:MY_JED))
      ALLOCATE(TG(MY_ISD:MY_IED,MY_JSD:MY_JED))
C**********************************************************************
      ALLOCATE(THS(MY_ISD:MY_IED,MY_JSD:MY_JED))
      ALLOCATE(QSHLTR(MY_ISD:MY_IED,MY_JSD:MY_JED))
      ALLOCATE(Q10(MY_ISD:MY_IED,MY_JSD:MY_JED))
      ALLOCATE(RSWIN(MY_ISD:MY_IED,MY_JSD:MY_JED))
      ALLOCATE(RSWOUT(MY_ISD:MY_IED,MY_JSD:MY_JED))
      ALLOCATE(RSWTOA(MY_ISD:MY_IED,MY_JSD:MY_JED))
      ALLOCATE(RLWIN(MY_ISD:MY_IED,MY_JSD:MY_JED))
      ALLOCATE(RLWOUT(MY_ISD:MY_IED,MY_JSD:MY_JED))
      ALLOCATE(RLWTOA(MY_ISD:MY_IED,MY_JSD:MY_JED))
      ALLOCATE(TWBS(MY_ISD:MY_IED,MY_JSD:MY_JED))
      ALLOCATE(QWBS(MY_ISD:MY_IED,MY_JSD:MY_JED))
cioannis      ALLOCATE(ALB(MY_ISD:MY_IED,MY_JSD:MY_JED))
      ALLOCATE(ALBEDO(MY_ISD:MY_IED,MY_JSD:MY_JED))  ! ioannis
      ALLOCATE(Z0(MY_ISD:MY_IED,MY_JSD:MY_JED))
      ALLOCATE(USTAR(MY_ISD:MY_IED,MY_JSD:MY_JED))
      ALLOCATE(PSLP(MY_ISD:MY_IED,MY_JSD:MY_JED))
      ALLOCATE(CFRACL(MY_ISD:MY_IED,MY_JSD:MY_JED)) ! ioannis 20/11/03
      ALLOCATE(CFRACM(MY_ISD:MY_IED,MY_JSD:MY_JED)) ! ioannis 20/11/03
      ALLOCATE(CFRACH(MY_ISD:MY_IED,MY_JSD:MY_JED)) ! ioannis 20/11/03
      ALLOCATE(SMC(MY_ISD:MY_IED,MY_JSD:MY_JED,1:NSOIL))
      ALLOCATE(STC(MY_ISD:MY_IED,MY_JSD:MY_JED,1:NSOIL))
      ALLOCATE(SH2O(MY_ISD:MY_IED,MY_JSD:MY_JED,1:NSOIL))
      ALLOCATE(SI(MY_ISD:MY_IED,MY_JSD:MY_JED))  ! ioannis 04/10/05
C*****************************************************************
      ALLOCATE(wavepar(MY_ISD:MY_IED,MY_JSD:MY_JED))
C*****************************************************************
C-----------------------------------------------------------------
C-----------------------------------------------------------------
C***
C***  LOOP OVER ALL THE OUTPUT TIMES
C***
C-----------------------------------------------------------------
  666 continue
      if ( me .eq. 0 ) then
         print*,'IOANNIS *******',ihour ! ioannis
      call mpi_recv(ihour,1,MPI_INTEGER,0,0,mpi_comm_inter,status,ier)
      print *, ' ihour in quilt = ',ihour
      end if
      call mpi_bcast(ihour,1,MPI_INTEGER,0,mpi_comm_comp,ier)
      if ( ihour .eq. -999 ) goto 667
cpk      ist = rtc()
C------------------------------------------------------------------
      DO IXXX = 1, JEND(ME) - JSTA(ME) + 1
C------------------------------------------------------------------
C***
      call mpi_recv(buf,ibufmax,MPI_REAL,MPI_ANY_SOURCE,ihour,
     *              mpi_comm_inter, status,ier)
      IPE = status(MPI_SOURCE)
      if ( ier .ne. 0 ) then
         print *, ' error from mpi_rec = ',ier
      end if
      is = MY_IS_GLB_A(IPE)
      ie = MY_IE_GLB_A(IPE)
      js = MY_JS_GLB_A(IPE)
      je = MY_JE_GLB_A(IPE)
      len_ch = (ie-is+1) * (je-js+1)
C     EXTRACT RECORD LENGTH - LETS KEEP THIS IN BECAUSE IT IS POTENTIALLY HANDY
      call decoal(idum,-1)
C
      call decoal(IDAT,3)
      call decoal(IHRST,1)
      call decoal(IHR,1)               
      call decoal(NTSD,1)
      call decoal(NHOUT,1)
      call decoal(LABEL1,8)
      call decoal(PD(is:ie,js:je),len_ch)
      do l=1,lm
         call decoal(T(is:ie,js:je,l),len_ch)
         call decoal(Q(is:ie,js:je,l),len_ch)
         call decoal(U(is:ie,js:je,l),len_ch)
         call decoal(V(is:ie,js:je,l),len_ch)
         call decoal(CWM(is:ie,js:je,l),len_ch)
      enddo
      call decoal(ACPREC(is:ie,js:je),len_ch)
      call decoal(CUPREC(is:ie,js:je),len_ch)
      call decoal(SPL,lsm)
      call decoal(DFL,lp1)
CPK      call decoal(TSHLTR(is:ie,js:je),len_ch)
CPK      call decoal(U10(is:ie,js:je),len_ch)
CPK      call decoal(V10(is:ie,js:je),len_ch)
      do l=1,lm
         call decoal(OMGALF(is:ie,js:je,l),len_ch)
      enddo
      call decoal(ACSNOW(is:ie,js:je),len_ch)
      do l=1,lm
         call decoal(Q2(is:ie,js:je,l),len_ch)
      enddo
CPK      call decoal(SM(is:ie,js:je),len_ch)
CPK      call decoal(SNO(is:ie,js:je),len_ch)
C**********************************************************************
      call decoal(IDAT,3)
      call decoal(IHRST,1)
      call decoal(IHR,1)
      call decoal(PRINT_INIT,1)
      call decoal(LABEL2,8)
      call decoal(RES(is:ie,js:je),len_ch)
      call decoal(FIS(is:ie,js:je),len_ch)
      call decoal(PT,1)
      call decoal(DT,1)
      call decoal(ETA,lp1)
      do l=1,lm
         call decoal(HTM(is:ie,js:je,l),len_ch)
         call decoal(VTM(is:ie,js:je,l),len_ch)
      enddo
      call decoal(LMH(is:ie,js:je),len_ch)
      call decoal(LMV(is:ie,js:je),len_ch)
      call decoal(SM(is:ie,js:je),len_ch)
      call decoal(SICE(is:ie,js:je),len_ch)
      call decoal(SST(is:ie,js:je),len_ch)
      call decoal(IVGTYP(is:ie,js:je),len_ch)
      call decoal(ISLTYP(is:ie,js:je),len_ch)
      call decoal(TG(is:ie,js:je),len_ch)
C**********************************************************************
      call decoal(IDAT,3)
      call decoal(IHRST,1)
      call decoal(IHR,1)
      call decoal(PRINT_FIELDS,1)
      call decoal(NPFIELDS,1)
      call decoal(LABEL3,8)
      call decoal(PT2,1)                
      call decoal(THS(is:ie,js:je),len_ch)
      call decoal(TSHLTR(is:ie,js:je),len_ch)
      call decoal(U10(is:ie,js:je),len_ch)
      call decoal(V10(is:ie,js:je),len_ch)
      call decoal(QSHLTR(is:ie,js:je),len_ch)
      call decoal(Q10(is:ie,js:je),len_ch)
CPK      call decoal(ACPREC(is:ie,js:je),len_ch)
      call decoal(RSWIN(is:ie,js:je),len_ch)
      call decoal(RSWOUT(is:ie,js:je),len_ch)
      call decoal(RSWTOA(is:ie,js:je),len_ch)
      call decoal(RLWIN(is:ie,js:je),len_ch)
      call decoal(RLWOUT(is:ie,js:je),len_ch)
      call decoal(RLWTOA(is:ie,js:je),len_ch)
      call decoal(TWBS(is:ie,js:je),len_ch)
      call decoal(QWBS(is:ie,js:je),len_ch)
      call decoal(ALBEDO(is:ie,js:je),len_ch)  ! ioannis
cioannis      call decoal(ALB(is:ie,js:je),len_ch)
      call decoal(Z0(is:ie,js:je),len_ch)
      call decoal(USTAR(is:ie,js:je),len_ch)
      call decoal(PSLP(is:ie,js:je),len_ch)
CPK      call decoal(SMC(is:ie,js:je,1:nsoil),len_ch*nsoil)
CPK      call decoal(STC(is:ie,js:je,1:nsoil),len_ch*nsoil)
c ------ cloud fields added on 20/11/03 -------------------------------
      call decoal(CFRACL(is:ie,js:je),len_ch)
      call decoal(CFRACM(is:ie,js:je),len_ch)
      call decoal(CFRACH(is:ie,js:je),len_ch)
c ---------------------------------------------------------------------
      call decoal(wavepar(is:ie,js:je),len_ch)
c ---------------------------------------------------------------------
C**************************************************************
      call decoal(IDAT,3)
      call decoal(IHRST,1)
      call decoal(IHR,1)
      call decoal(PRINT_GROUND,1)
      call decoal(NPGROUND,1)
      call decoal(LABEL4,8)
      call decoal(SMC(is:ie,js:je,1:nsoil),len_ch*nsoil)
      call decoal(STC(is:ie,js:je,1:nsoil),len_ch*nsoil)
      call decoal(SH2O(is:ie,js:je,1:nsoil),len_ch*nsoil)
      call decoal(SNO(is:ie,js:je),len_ch)
      call decoal(VEGFRC(is:ie,js:je),len_ch)
      call decoal(SI(is:ie,js:je),len_ch)
      end do
C***************************************************************
cpk      isp = rtc()
cpk      print *, ' TIME FOR RECV/ASSEMBLY = ',isp-ist
C---------------------------------------------------------------
C***
C*** BEFORE WRITING OUT THE RESTRT FILE, COMPUTE THE MSLP
C***
C
cpk      ist = rtc()
cioannis      CALL SLP(NHB,PD,RES,FIS,T,Q,NTSD,PSLP)
        if (LME)    write(0,*) 'IOANNIS.....NEST =',NEST
       write(0,*) 'IOANNIS111111.....NEST =',NEST,ME
cioannis      NEST=.FALSE.  ! ioannis
      CALL SLP(NHB,PD,RES,FIS,T,Q,NTSD,NEST,PSLP) ! ioannis
cpk      isp = rtc()
cpk      print *, ' time for SLP = ',isp-ist
C
C----------------------------------------------------------------
C***  WRITE OUT THE GLOBAL FILE.
C----------------------------------------------------------------
C***
C***  GENERATE THE NAME OF THE GLOBAL OUTPUT RESTRT FILE
C***
      ENVAR=' '
      CALL GETENV("RSTFNL",ENVAR)
      CALL GETENV("tmmark",RESTHR)
      KPATH = INDEX(ENVAR,' ') -1
      IF(KPATH.LE.0) KPATH = LEN(ENVAR)
C
      IF(RESTHR.EQ.'    ')THEN
        WRITE(RSTFIL2,280)IHOUR
  280    FORMAT('restrt',I2.2)
      ELSE
        WRITE(RSTFIL2,285)IHOUR,RESTHR
  285    FORMAT('restrt',I2.2,'.',a4)
      ENDIF
C
      KRST = INDEX(RSTFIL2,' ') -1
      IF(KRST.LE.0) KRST = LEN(RSTFIL2)
C***
C***  OPEN UNIT TO THE GLOBAL RESTART FILE
C***
      CLOSE(LRSTRT1)
      CLOSE(LRSTRT2)
      CLOSE(LRSTRT3)
      CLOSE(LRSTRT4)
C
cpk      ist = rtc()
C *************************************
C
C     SET FORECAST HOUR.
C
C *************************************
      WRITE(CDAT(1:3),'(I3.3)') IHR
      IF (LME) write(0,*)'quilting Filenames at:',NTSD,CDAT,IHR
      IF (LME) then
         write(0,*)'quilting Filenames:',NHOUT,NPFIELDS,NPGROUND,LME
      ENDIF
C
      FN_VOUT='../../output/RUN/v_out.' ! ioannis
      IF(MOD(NTSD,NHOUT).EQ.0) THEN
         FFNAME=FN_VOUT(1:(INDEX(FN_VOUT,' '))-1)//CDAT//'.dat'
         OPEN(UNIT=LRSTRT1,FILE=FFNAME(1:INDEX(FFNAME,' ')-1) 
     &,       FORM='UNFORMATTED',IOSTAT=IER)
         write(6,*)'Writing in ',FFNAME(1:INDEX(FFNAME,' ')-1)
C----------------------------------------------------------------
         IF ( LME ) WRITE(LRSTRT1)IDAT,IHRST,IHR,LABEL1
         CALL COLLECT(PD,DUM1)
         IF ( LME ) WRITE(LRSTRT1) DUM1
         DO L=1,LM
           CALL COLLECT(T(:,:,L),DUM1)
           IF ( LME ) WRITE(LRSTRT1) DUM1
           CALL COLLECT(Q(:,:,L),DUM1)
           IF ( LME ) WRITE(LRSTRT1) DUM1
           CALL COLLECT(U(:,:,L),DUM1)
           IF ( LME ) WRITE(LRSTRT1) DUM1
           CALL COLLECT(V(:,:,L),DUM1)
           IF ( LME ) WRITE(LRSTRT1) DUM1
           CALL COLLECT(CWM(:,:,L),DUM1)
           IF ( LME ) WRITE(LRSTRT1) DUM1
         ENDDO
         CALL COLLECT(ACPREC,DUM1)
         CALL COLLECT(CUPREC,DUM2)
         IF ( LME ) WRITE(LRSTRT1) DUM1,DUM2,SPL,DFL
         CALL COLLECT(TSHLTR,DUM1)
         CALL COLLECT(U10,DUM2)
         CALL COLLECT(V10,DUM3)
         IF ( LME ) WRITE(LRSTRT1) DUM1,DUM2,DUM3
         DO L=1,LM
           CALL COLLECT(OMGALF(:,:,L),DUM1)
           IF ( LME ) WRITE(LRSTRT1) DUM1
         ENDDO
         CALL COLLECT(ACSNOW,DUM1)
         IF ( LME ) WRITE(LRSTRT1) DUM1
         CALL COLLECT(SM,DUM1)
         IF ( LME ) WRITE(LRSTRT1) DUM1
         CALL COLLECT(PSLP,DUM1)
         IF ( LME ) WRITE(LRSTRT1) DUM1
         CALL COLLECT(SNO,DUM1)
         IF ( LME ) WRITE(LRSTRT1) DUM1
         DO L=1,LM
           CALL COLLECT(Q2(:,:,L),DUM1)
           IF ( LME ) WRITE(LRSTRT1) DUM1
         ENDDO
      ENDIF
C
      IF (PRINT_INIT.AND.NTSD.EQ.0) then
         FFNAME=FN_VOUT(1:(INDEX(FN_VOUT,' '))-1)//CDAT//'.init'
         OPEN(UNIT=LRSTRT2,FILE=FFNAME(1:INDEX(FFNAME,' ')-1) 
     &,       FORM='UNFORMATTED',IOSTAT=IER)
         print*,'Writing in ',FFNAME(1:INDEX(FFNAME,' ')-1)
C---------------------------------------------------------------
         IF ( LME ) WRITE(LRSTRT2)IDAT,IHRST,IHR,LABEL2
         CALL COLLECT(RES,DUM1)
         CALL COLLECT(FIS,DUM2)
         IF ( LME ) WRITE(LRSTRT2)DUM1,DUM2,PT,DT,ETA
         DO L=1,LM
           CALL COLLECT(HTM(:,:,L),DUM1)
           IF ( LME ) WRITE(LRSTRT2) DUM1
           CALL COLLECT(VTM(:,:,L),DUM1)
           IF ( LME ) WRITE(LRSTRT2) DUM1
         ENDDO
         CALL COLLECT(LMH,DUM1)
         CALL COLLECT(LMV,DUM2)
         IF ( LME ) WRITE(LRSTRT2) DUM1,DUM2
         CALL COLLECT(SM,DUM1)
         CALL COLLECT(SICE,DUM2)
         CALL COLLECT(SST,DUM3)
         IF ( LME ) WRITE(LRSTRT2) DUM1,DUM2,DUM3
         CALL COLLECT(IVGTYP,DUM1)
         CALL COLLECT(ISLTYP,DUM2)
         IF ( LME ) WRITE(LRSTRT2) DUM1,DUM2
         CALL COLLECT(TG,DUM1)
         IF ( LME ) WRITE(LRSTRT2) DUM1
         CALL COLLECT(ALBEDO,DUM1)
         CALL COLLECT(Z0,DUM2)
         CALL COLLECT(USTAR,DUM3)
         IF ( LME ) WRITE(LRSTRT2) DUM1,DUM2,DUM3
      ENDIF
C
      IF (PRINT_FIELDS) then
         IF(MOD(NTSD,NPFIELDS).EQ.0) THEN
         FFNAME=FN_VOUT(1:(INDEX(FN_VOUT,' '))-1)//CDAT//'.datFIELDS'
         OPEN(UNIT=LRSTRT3,FILE=FFNAME(1:INDEX(FFNAME,' ')-1) 
     &,       FORM='UNFORMATTED',IOSTAT=IER)
         print*,'Writing in ',FFNAME(1:INDEX(FFNAME,' ')-1)
C-----------------------------------------------------------------
         IF ( LME ) WRITE(LRSTRT3)IDAT,IHRST,IHR,LABEL3,PT2
         CALL COLLECT(THS,DUM1)
         IF ( LME ) WRITE(LRSTRT3) DUM1
         CALL COLLECT(TSHLTR,DUM1)
         IF ( LME ) WRITE(LRSTRT3) DUM1
         CALL COLLECT(U10,DUM1)
         CALL COLLECT(V10,DUM2)
         IF ( LME ) WRITE(LRSTRT3) DUM1,DUM2
         CALL COLLECT(QSHLTR,DUM1)
         CALL COLLECT(Q10,DUM2)
         IF ( LME ) WRITE(LRSTRT3) DUM1,DUM2
         CALL COLLECT(ACPREC,DUM1)
         IF ( LME ) WRITE(LRSTRT3) DUM1
         CALL COLLECT(RSWIN,DUM1)
         CALL COLLECT(RSWOUT,DUM2)
         CALL COLLECT(RSWTOA,DUM3)
         CALL COLLECT(RLWIN,DUM4)
         CALL COLLECT(RLWOUT,DUM5)
         CALL COLLECT(RLWTOA,DUM6)
         IF ( LME ) WRITE(LRSTRT3) DUM1,DUM2,DUM3,DUM4,DUM5,DUM6
         CALL COLLECT(TWBS,DUM1)
         CALL COLLECT(QWBS,DUM2)
         IF ( LME ) WRITE(LRSTRT3) DUM1,DUM2
         CALL COLLECT(ALBEDO,DUM1)
         CALL COLLECT(Z0,DUM2)
         CALL COLLECT(USTAR,DUM3)
         CALL COLLECT(PSLP,DUM4)
         IF ( LME ) WRITE(LRSTRT3) DUM1,DUM2,DUM3,DUM4
         DO L = 1, NSOIL
            CALL COLLECT(SMC(:,:,L), DUMS(:,:,L))
         END DO
         IF ( LME ) WRITE(LRSTRT3) DUMS
         DO L = 1, NSOIL
            CALL COLLECT(STC(:,:,L), DUMS(:,:,L))
         END DO
         IF ( LME ) WRITE(LRSTRT3) DUMS
         CALL COLLECT(CFRACL,DUM1)   ! ioannis 20/11/03
         CALL COLLECT(CFRACM,DUM2)   ! ioannis 20/11/03
         CALL COLLECT(CFRACH,DUM3)   ! ioannis 20/11/03
         IF ( LME ) WRITE(LRSTRT3) DUM1,DUM2,DUM3 ! ioannis 20/11/03
C -------------------------------------------------------------
         CALL COLLECT(wavepar, DUM1)
         IF ( LME ) WRITE(LRSTRT3) DUM1
C -------------------------------------------------------------
C store U, V, T from level 20 to 31 over Alaiz (ANEMOS project) 
C -------------------------------------------------------------
c         DO L=1,LM
c           CALL COLLECT(T(:,:,L),DUM1)
c           CALL COLLECT(U(:,:,L),DUM2)
c           CALL COLLECT(V(:,:,L),DUM3)
c           IF (LME) THEN
c           IF ((L.LE.31).AND.(L.GE.20)) THEN
c              DUM1D1(L-20+1)=DUM1(63,159)  
c              DUM1D2(L-20+1)=DUM2(63,159)  
c              DUM1D3(L-20+1)=DUM3(63,159)  
c           ENDIF
c           ENDIF
c         ENDDO
c           IF ( LME ) WRITE(LRSTRT3) DUM1D1 ! ioannis 02/07/04
c           IF ( LME ) WRITE(LRSTRT3) DUM1D2 ! ioannis 02/07/04
c           IF ( LME ) WRITE(LRSTRT3) DUM1D3 ! ioannis 02/07/04
C -------------------------------------------------------------
         ENDIF
      ENDIF
C
      IF (PRINT_GROUND) then
         IF(MOD(NTSD,NPGROUND).EQ.0) THEN
         FFNAME=FN_VOUT(1:(INDEX(FN_VOUT,' '))-1)//CDAT//'.ground'
         OPEN(UNIT=LRSTRT4,FILE=FFNAME(1:INDEX(FFNAME,' ')-1)
     &,       FORM='UNFORMATTED',IOSTAT=IER)
         print*,'Writing in ',FFNAME(1:INDEX(FFNAME,' ')-1)
C--------------------------------------------------------------
         IF ( LME ) WRITE(LRSTRT4)IDAT,IHRST,IHR,LABEL4
         DO L = 1, NSOIL
            CALL COLLECT(SMC(:,:,L), DUMS(:,:,L))
         END DO
         IF ( LME ) WRITE(LRSTRT4) DUMS
         DO L = 1, NSOIL
            CALL COLLECT(STC(:,:,L), DUMS(:,:,L))
         END DO
         IF ( LME ) WRITE(LRSTRT4) DUMS
         CALL COLLECT(SNO,DUM1)
         IF ( LME ) WRITE(LRSTRT4) DUM1
         CALL COLLECT(VEGFRC,DUM1)
         IF ( LME ) WRITE(LRSTRT4) DUM1
         DO L = 1, NSOIL
            CALL COLLECT(SH2O(:,:,L), DUMS(:,:,L))
         END DO
         IF ( LME ) WRITE(LRSTRT4) DUMS
         CALL COLLECT(SI,DUM1)    ! ioannis 04/10/05
         IF ( LME ) WRITE(LRSTRT4) DUM1  ! ioannis 04/10/05
         ENDIF
      ENDIF
C
      CLOSE(LRSTRT1)
      CLOSE(LRSTRT2)
      CLOSE(LRSTRT3)
      CLOSE(LRSTRT4)
cpk      isp = rtc()
cpk      if ( LME ) THEN
cpk      print *, ' time for I/O = ',isp-ist
cpk      end if
C---------------------------------------------------------------
      IF(LME)THEN
        DONE='DONE'
        ITAG = ihour
        WRITE(FINFIL,1190)ITAG,RESTHR
 1190   FORMAT('fcstdone',I2.2,'.',A4)
        LFINFIL=91
        CLOSE(LFINFIL)
        OPEN(UNIT=LFINFIL,FILE=FINFIL,FORM='UNFORMATTED',IOSTAT=IER)
        WRITE(LFINFIL)DONE
        CLOSE(LFINFIL)
        IF(IER.NE.0)WRITE(LIST,*)' SIGNAL SENT TO FINFIL:  DONE'
      ENDIF
C
      GOTO 666
  667  continue
      print *, ' QUILT I/O SERVER SHUTTING DOWN NOW'
      END
      subroutine decoal(a,len_ch)
      include "BUFFER.comm"
      real a(*)
      if ( len_ch .lt. 0 ) then
         ip = 0
      end if
      do i = 1, abs(len_ch)
         ip = ip + 1
         a(i) = buf(ip)
      end do
      end

