                  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   14-07-XX  KATSAFADOS - REDIRECTION OF WAVE OUTPUTS AND COMMUNICATION WITH WAVE MODEL
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"
      INCLUDE "wave.inc"
C--------------------------------------------------------------
      INCLUDE "PARA.comm"
      INCLUDE "BUFFER.comm"
                              P A R A M E T E R
     & (LB=2*IM+JM-3,LP1=LM+1)
C--Coupling
      PARAMETER (IMT=2*IM-1,JMT=JM/2+1,LM1=LM-1)
      INCLUDE "MAPOT.comm"
C--Coupling
C--------------------------------------------------------------
cioannis      INCLUDE "model2d_nl.nml"
C--------------------------------------------------------------
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),DUM8(IM,JM)
       REAL DUM9(IM,JM),DUM10(IM,JM)
       REAL DUMS(IM,JM,NSOIL)
CPK
      REAL U2WAM(IM,JM),V2WAM(IM,JM),USTAR2WAM(IM,JM),Z02WAM(IM,JM)
      REAL uwnd(ngx,ngy),vwnd(ngx,ngy),us_eta(ngx,ngy),z0_eta(ngx,ngy)
      INTEGER ISTAT(MPI_STATUS_SIZE)
CPK
       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
C--Coupling
      REAL, ALLOCATABLE ::
     & wavepar(:,:), z0gpar(:,:), swhgpar(:,:),
     & wdirpar(:,:), wmaskpar(:,:), agegpar(:,:),
     & Uneu(:,:), Vneu(:,:), HPBL2(:,:)
C--Coupling
C
      REAL, ALLOCATABLE ::
     & SI(:,:) ! ioannis 04/10/05
C
C--Coupling
!      REAL UL(2*LM), SPL(LSM), DFL(LP1), ETA(LP1)
      REAL UL(2*LM), DFL(LP1)
      CHARACTER*12 :: idtpro
C--Coupling
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
       REAL DT_WAVE_RATIO, ETANTSD, WAVENTSD   !cpk
C--------------------------------------------------------------
      INTEGER IDAT(3)
C
      INTEGER, ALLOCATABLE ::
     & IVGTYP(:,:),ISLTYP(:,:),LMH(:,:),LMV(:,:),
C--Coupling
     & LPBL2(:,:)
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,LABELW*32
C
       LOGICAL LME, PRINT_FIELDS, PRINT_GROUND, PRINT_INIT
       LOGICAL NEST  ! ioannis
       LOGICAL COUPLE_WAVE, USE_U10  ! cpk
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))
      ALLOCATE(z0gpar(MY_ISD:MY_IED,MY_JSD:MY_JED))
      ALLOCATE(swhgpar(MY_ISD:MY_IED,MY_JSD:MY_JED))
      ALLOCATE(wdirpar(MY_ISD:MY_IED,MY_JSD:MY_JED))
      ALLOCATE(wmaskpar(MY_ISD:MY_IED,MY_JSD:MY_JED))
      ALLOCATE(agegpar(MY_ISD:MY_IED,MY_JSD:MY_JED))
      ALLOCATE(Uneu(MY_ISD:MY_IED,MY_JSD:MY_JED))
      ALLOCATE(Vneu(MY_ISD:MY_IED,MY_JSD:MY_JED))
      ALLOCATE(LPBL2(MY_ISD:MY_IED,MY_JSD:MY_JED))
      ALLOCATE(HPBL2(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 ---- Coupling -------------------------------------------------------
      call decoal(LABELW,8)
      call decoal(TPH0D,1)
      call decoal(TLM0D,1)
      call decoal(DLMD,1)
      call decoal(DPHD,1)
      call decoal(WBD,1)
      call decoal(SBD,1)
      call decoal(idtpro,12)
      call decoal(COUPLE_WAVE,1)
      call decoal(DT_WAVE_RATIO,1)
      call decoal(USE_U10,1)
      call decoal(wavepar(is:ie,js:je),len_ch)
      call decoal(z0gpar(is:ie,js:je),len_ch)
      call decoal(swhgpar(is:ie,js:je),len_ch)
      call decoal(wdirpar(is:ie,js:je),len_ch)
      call decoal(wmaskpar(is:ie,js:je),len_ch)
      call decoal(agegpar(is:ie,js:je),len_ch)
      call decoal(Uneu(is:ie,js:je),len_ch)
      call decoal(Vneu(is:ie,js:je),len_ch)
      call decoal(HPBL2(is:ie,js:je),len_ch)
      call decoal(LPBL2(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,*) 'NEST flag, ME=',NEST,ME
cpk       write(0,*) '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 (mype.eq.inpes*jnpes) then
      print*,'QUILT NTSD, ACPREC, CUPREC ',
     &        NTSD, ACPREC(246,231),CUPREC (246,231)
     &        , DUM1(246,231)*1.E+3,DUM2 (246,231)*1.E+3
      end if
         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 -------coupling-----------------------------------------------------
      IF(COUPLE_WAVE) THEN
         IF ( LME ) WRITE(LRSTRT3) LABELW
         IF ( LME ) WRITE(LRSTRT3) IDTPRO
         IF ( LME ) WRITE(LRSTRT3) RWEST, REAST, RNORT, RSOUT
         IF ( LME ) WRITE(LRSTRT3) DELTAL, DELTAF, NXP, NYP
         CALL COLLECT(wavepar, DUM1)
         CALL COLLECT(z0gpar, DUM2)
         CALL COLLECT(swhgpar, DUM3)
         CALL COLLECT(wdirpar, DUM4)
         CALL COLLECT(wmaskpar, DUM5)
         CALL COLLECT(agegpar, DUM6)
         CALL COLLECT(Uneu, DUM7)
         CALL COLLECT(Vneu, DUM8)
         CALL COLLECT(HPBL2, DUM9)
         CALL COLLECT(LPBL2, DUM10)
         aminw1=100000.
         amaxw1=-100000.
         aminw2=100000.
         amaxw2=-100000.
         aminw3=100000.
         amaxw3=-100000.
         aminw4=100000.
         amaxw4=-100000.
         aminw5=100000.
         amaxw5=-100000.
         iminw6=100000
         imaxw6=-100000
         aminw7=100000.
         amaxw7=-100000.
         do i=1,im
         do j=1,jm
            if (DUM1(i,j).lt.aminw1) aminw1=DUM1(i,j)
            if (DUM1(i,j).gt.amaxw1) amaxw1=DUM1(i,j)
            if (DUM2(i,j).lt.aminw2) aminw2=DUM2(i,j)
            if (DUM2(i,j).gt.amaxw2) amaxw2=DUM2(i,j)
            if (DUM3(i,j).lt.aminw3) aminw3=DUM3(i,j)
            if (DUM3(i,j).gt.amaxw3) amaxw3=DUM3(i,j)
            if (DUM7(i,j).lt.aminw4) aminw4=DUM7(i,j)
            if (DUM7(i,j).gt.amaxw4) amaxw4=DUM7(i,j)
            if (DUM8(i,j).lt.aminw5) aminw5=DUM8(i,j)
            if (DUM8(i,j).gt.amaxw5) amaxw5=DUM8(i,j)
            if (DUM9(i,j).lt.aminw7) aminw7=DUM9(i,j)
            if (DUM9(i,j).gt.amaxw7) amaxw7=DUM9(i,j)
            if (DUM10(i,j).lt.iminw6) iminw6=DUM10(i,j)
            if (DUM10(i,j).gt.imaxw6) imaxw6=DUM10(i,j)
         enddo
         enddo
         if (mype.eq.inpes*jnpes) then    !5for2x3
            write(6,*)
     &      '====================================================='
            write(6,*)'SUBROUTINE QUILT diagnostics'
            write(6,*)'ntsd=',ntsd,' wam date/time=',idtpro
            write(6,*)
            write(6,*)'betag (wavepar) min-(im/2,jm/2)-max=',
     &                 aminw1,DUM1(im/2,jm/2),amaxw1
            write(6,*)
            write(6,*)'z0g (z0gpar) min-(im/2,jm/2)-max=',
     &                 aminw2,DUM2(im/2,jm/2),amaxw2
            write(6,*)
            write(6,*)'swhg (swhgpar) min-(im/2,jm/2)-max=',
     &                 aminw3,DUM3(im/2,jm/2),amaxw3
            write(6,*)
            write(6,*)'Uneu min-(im/2,jm/2)-max=',
     &                 aminw4,DUM7(im/2,jm/2),amaxw4
            write(6,*)
            write(6,*)'Vneu min-(im/2,jm/2)-max=',
     &                 aminw5,DUM8(im/2,jm/2),amaxw5
            write(6,*)
            write(6,*)'HPBL min-(im/2,jm/2)-max=',
     &                 aminw7,DUM9(im/2,jm/2),amaxw7
            write(6,*)
            write(6,*)'LPBL min-(im/2,jm/2)-max=',
     &                 iminw6,DUM10(im/2,jm/2),imaxw6
            write(6,*)
     &      '====================================================='
         endif
!         if (mype.eq.5)print*,'QUILT write-wavepar ntsd,idtpro,min,max '
!     &                 ,ntsd,idtpro,aminw,amaxw
         IF ( LME ) WRITE(LRSTRT3) DUM1, DUM2, DUM3, DUM4, DUM5, DUM6,
     &                             DUM7, DUM8, DUM10, DUM9
      ENDIF
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
CPK-----COUPLING WAM--------------------------
      IF(COUPLE_WAVE) THEN
!      IF(COUPLE_WAVE .AND. NTSD.NE.1 .AND. 
!     &   MOD(NTSD,INT(DT_WAVE_RATIO)).EQ.1) THEN
         call mpi_comm_size(MPI_COMM_WORLD,npesq,ierr)  !get the total processes in quilt
!      IF(NTSD.EQ.1 .AND. MOD(NTSD,INT(DT_WAVE_RATIO)).EQ.0) THEN
!      IF(NTSD.EQ.3 .OR. MOD(NTSD,INT(DT_WAVE_RATIO)).EQ.1) THEN
C-----------------------------------------------------------------
!      IF ( LME ) WRITE(LRSTRT3)IDAT,IHRST,IHR,LABEL3,PT2
      IF (USE_U10) THEN
         write(6,*)'USE OF WIND AT 10M'
         CALL COLLECT(U10,U2WAM)
         CALL COLLECT(V10,V2WAM)
      ELSE
         write(6,*)'USE OF NEUTRAL WIND'
         CALL COLLECT(Uneu,U2WAM)
         CALL COLLECT(Vneu,V2WAM)
      ENDIF
         CALL COLLECT(USTAR,USTAR2WAM)
         CALL COLLECT(Z0,Z02WAM)
         ETANTSD=NTSD
         WAVENTSD=ETANTSD/DT_WAVE_RATIO
Check min-max values
         aminu0=100000.
         amaxu0=-100000.
         aminv0=100000.
         amaxv0=-100000.
         amins0=100000.
         amaxs0=-100000.
         aminz0=100000.
         amaxz0=-100000.
         do i=1,im
         do j=1,jm
            if (U2WAM(i,j).lt.aminu0) aminu0=U2WAM(i,j)
            if (U2WAM(i,j).gt.amaxu0) amaxu0=U2WAM(i,j)
            if (V2WAM(i,j).lt.aminv0) aminv0=V2WAM(i,j)
            if (V2WAM(i,j).gt.amaxv0) amaxv0=V2WAM(i,j)
            if (USTAR2WAM(i,j).lt.amins0) amins0=USTAR2WAM(i,j)
            if (USTAR2WAM(i,j).gt.amaxs0) amaxs0=USTAR2WAM(i,j)
            if (Z02WAM(i,j).lt.aminz0) aminz0=Z02WAM(i,j)
            if (Z02WAM(i,j).gt.amaxz0) amaxz0=Z02WAM(i,j)
!            print*,i,j,U2WAM(i,j)
         enddo
         enddo
         IF(MYPE.EQ.inpes*jnpes)THEN  ! the first I/O server (4)
!            print*,"QUILT send min-max U2WAM ",aminu,amaxu,mype
!            print*,"QUILT send min-max V2WAM ",aminv,amaxv,mype
!
         CALL imjm2ll(U2WAM,V2WAM,uwnd,vwnd)
         CALL imjm2ll(USTAR2WAM,Z02WAM,us_eta,z0_eta)
!cpk         IF (.not.USE_U10) CALL imjm2ll_V(U2WAM,V2WAM,uwnd,vwnd)
Check min-max values
            aminu1=100000.
            amaxu1=-100000.
            aminv1=100000.
            amaxv1=-100000.
            amins1=100000.
            amaxs1=-100000.
            aminz1=100000.
            amaxz1=-100000.
            do i=1,ngx
            do j=1,ngy
               if (uwnd(i,j).lt.aminu1) aminu1=uwnd(i,j)
               if (uwnd(i,j).gt.amaxu1) amaxu1=uwnd(i,j)
               if (vwnd(i,j).lt.aminv1) aminv1=vwnd(i,j)
               if (vwnd(i,j).gt.amaxv1) amaxv1=vwnd(i,j)
               if (us_eta(i,j).lt.amins1) amins1=us_eta(i,j)
               if (us_eta(i,j).gt.amaxs1) amaxs1=us_eta(i,j)
               if (z0_eta(i,j).lt.aminz1) aminz1=z0_eta(i,j)
               if (z0_eta(i,j).gt.amaxz1) amaxz1=z0_eta(i,j)
            enddo
            enddo
C Write out diagnostics
            write(6,*)
     &      '====================================================='
            write(6,*)'SUBROUTINE QUILT send'
            write(6,*)'mype=',mype
            write(6,*)
            write(6,*)'U2WAM min-(im/2,jm/2)-max=',
     &                 aminu0,U2WAM(im/2,jm/2),amaxu0
            write(6,*)'uwnd min-(ngx/2,ngy/2)-max=',
     &                 aminu1,uwnd(ngx/2,ngy/2),amaxu1
            write(6,*)
            write(6,*)'V2WAM min-(im/2,jm/2)-max=',
     &                 aminv0,V2WAM(im/2,jm/2),amaxv0
            write(6,*)'vwnd min-(ngx/2,ngy/2)-max=',
     &                 aminv1,vwnd(ngx/2,ngy/2),amaxv1
            write(6,*)
            write(6,*)'USTAR2WAM min-(im/2,jm/2)-max=',
     &                 amins0,USTAR2WAM(im/2,jm/2),amaxs0
            write(6,*)'us_eta min-(ngx/2,ngy/2)-max=',
     &                 amins1,us_eta(ngx/2,ngy/2),amaxs1
            write(6,*)
            write(6,*)'Z02WAM min-(im/2,jm/2)-max=',
     &                 aminz0,Z02WAM(im/2,jm/2),amaxz0
            write(6,*)'z0_eta min-(ngx/2,ngy/2)-max=',
     &                 aminz1,z0_eta(ngx/2,ngy/2),amaxz1
            write(6,*)
     &      '====================================================='
!            print*,"QUILT send min-max uwnd ",aminu,amaxu
!            print*,"QUILT send min-max vwnd ",aminv,amaxv
C SEND U10,V10
!         IF(MYPE.EQ.4)THEN
            write(6,*)'QUILT mype,TIMESTEP,npesq ',mype,ntsd,npesq
            call mpi_send
     &      (IDAT,3,MPI_INTEGER,npesq-1,tag1,MPI_COMM_WORLD,status,ierr)
            call mpi_send
     &     (IHRST,1,MPI_INTEGER,npesq-1,tag2,MPI_COMM_WORLD,status,ierr)
            call mpi_send
     &      (IHR,1,MPI_INTEGER,npesq-1,tag3,MPI_COMM_WORLD,status,ierr)
            call mpi_send
     &      (ETANTSD,1,MPI_REAL,npesq-1,tag4,MPI_COMM_WORLD,status,ierr)
            call mpi_send
     &     (WAVENTSD,1,MPI_REAL,npesq-1,tag5,MPI_COMM_WORLD,status,ierr)
            call mpi_send
     &   (uwnd,ngx*ngy,MPI_REAL,npesq-1,tagu,MPI_COMM_WORLD,status,ierr)
            call mpi_send
     &   (vwnd,ngx*ngy,MPI_REAL,npesq-1,tagv,MPI_COMM_WORLD,status,ierr)
            call mpi_send
     & (us_eta,ngx*ngy,MPI_REAL,npesq-1,tagr,MPI_COMM_WORLD,status,ierr)
            call mpi_send
     & (z0_eta,ngx*ngy,MPI_REAL,npesq-1,tag0,MPI_COMM_WORLD,status,ierr)
!         ENDIF
         ENDIF
         ENDIF
!         CALL MPI_BARRIER(MPI_COMM_WORLD,ISTAT)
CPK-----END COUPLING WAM--------------------------
      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
C
      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

