
!     NPROC = CommSize-1
!     IAM = myCommRank-1
! ---------------------------------------------------------

!!    subroutine TestCommon(iCallNum)
!!
!!    IMPLICIT DOUBLE PRECISION (A-H,O-Z)
!!    PARAMETER (MSGINP=8,MsgEnd=66)
!!    CHARACTER*80 REC80
!!
!!    PARAMETER (LIMPAR=50,LIMPRN=200,LIMFTN=100,LIMTOL=50,LIMINF=200)
!!    COMMON/PARINF/PAR(LIMPAR),LPRINT(LIMPRN),IUNIT(LIMFTN),
!!   *ITOL(LIMTOL),INF(LIMINF),ITIT(20),IIN,IOUT
!!
!!    COMMON/PARAL1/NPROC,NNPROC,IAM,MPOINT,ITASK
!!
!!    include 'mpif.h'
!!    integer Status(MPI_STATUS_SIZE)
!!
!!    write(6,*) 'TestCommon #',iCallNum,': Rank=',iam+1,
!!   .           ',IIN=',iin,',IOUT=',iout
!!
!!    end

! ---------------------------------------------------------

      subroutine SafeChDir( dir, icount )
      character*(*) dir
      COMMON/PARAL1/NPROC,NNPROC,IAM,MPOINT,ITASK

cc    write(6,*) 'Try chdir: rank=',iam+1,
cc   .           ', len=',icount,
cc   .           ', dir=(',dir(1:icount),')'
      call ftn_chdir( dir, icount, ierror )
     
      if ( ierror.lt.0 ) then
         write(6,*) 'ERROR: Jump to scratch dir failed, rank=',iam+1
         call MPI_Abort( MPI_COMM_WORLD, MPI_ERR_OTHER, ierror )
         stop
      endif
      if ( ierror.ne.1234 )
     .  write(6,*) '??? chdir is not called: ierror=',ierror

      end

! ---------------------------------------------------------

C***./ ADD NAME=MasterNode
      subroutine MasterNode

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER( MSGBGN=1, NXTVA=3, NXTVR=4, MSGDIR=33 )
      CHARACTER*72 LINE
      CHARACTER*1 NULL,COMMNT
      DATA NULL,COMMNT/' ','#'/
      COMMON/PARAL1/NPROC,NNPROC,IAM,MPOINT,ITASK

      include 'mpif.h'

      ios = 0

      icfg = 25
      if ( icfg.ne.5 )
     .   open(unit=icfg,file='paths.lst',form='FORMATTED',status='OLD')

      do linenum=0,nproc

C     // read line from file or (if EOF) set to default value

         if ( ios.eq.0 ) then
            Line(1:1) = Commnt
            do while( Line(1:1).eq.Commnt .and. ios.eq.0 )
               read( icfg, 1972, IOSTAT=ios ) Line
            enddo
         endif
         if ( ios.lt.0 ) then
            write(6,*) 'Paths list is too short, abort'
            call MPI_Abort( MPI_COMM_WORLD, MPI_ERR_OTHER, ierror )
            stop
C     //    Line = '/tmp'
         endif

 1972    Format(A)

C     // check file input status

         if ( ios.gt.0 ) then
            write(6,*) 'Cannot read config: error code ',ios
            call MPI_Abort( MPI_COMM_WORLD, MPI_ERR_OTHER, ierror )
            stop
         endif

C     // find start and end of text in line

         istart = 1
         do while( Line(istart:istart) .eq. null )
            istart = istart+1
         enddo
         iend = istart
         do while( Line(iend:iend) .ne.null )
             iend = iend+1
         enddo

C     // send name to temporary directory to node 'linenum'

         if ( linenum.ne.0 ) then
cc          write(6,*) 'Try Send: dest=',linenum,
cc   .                 ', dir=',Line(istart:iend),
cc   .                 ', istart=',istart,
cc   .                 ', iend=',iend
            call MPI_Send( Line(istart:iend),iend-istart,MPI_CHARACTER,
     .                     linenum, MsgDir, MPI_COMM_WORLD, ierror )
         else
            call SafeChDir( Line(istart:iend), iend-istart )
         endif
      enddo
      if ( icfg.ne.5 )
     .   close( icfg )
      end

! ---------------------------------------------------------

      subroutine NxtSrv

C  // Master runs as Next Value server

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER( MSGBGN=1, NXTVA=3, NXTVR=4, MSGDIR=33 )
      COMMON/PARAL1/NPROC,NNPROC,IAM,MPOINT,ITASK

      include 'mpif.h'
      integer Status(MPI_STATUS_SIZE)

      NTRMN=0
      NDONE=0
      NVAL=0

      do while( .TRUE. )
         call MPI_Recv( MProc, 1, MPI_INTEGER, MPI_ANY_SOURCE,
     .                  NxtVA, MPI_COMM_WORLD, Status, ierror )
!!       write(6,*) 'NXTSRV: RECEIVED MPROC = ',MProc,' FROM ',
!!   .              Status(MPI_SOURCE)

         if( MProc.eq.0 ) then
!!          write(6,*) 'NXTSRV: RECIEVED 0 NPROC = ',NPROC
            NTrmn = NTrmn + 1
            if ( NTrmn.eq.NProc ) then
               do ii=1, NProc
                  call MPI_Send( NVal, 1, MPI_INTEGER,
     .                 ii, NxtVR, MPI_COMM_WORLD, ierror )
               enddo
               call MPI_Barrier( MPI_COMM_WORLD, ierror )
cc             write(6,*) 'master: try finalize'
!!          // call sleep(10)
               call MPI_Finalize( ierror )
cc             write(6,*) 'master: end finalize'
               stop
            endif
         elseif ( MProc.gt.0 ) then
            call MPI_Send( NVal, 1, MPI_INTEGER,
     .           Status(MPI_SOURCE), NxtVR, MPI_COMM_WORLD, ierror )
            NVal = NVal + 1
         elseif ( MProc.lt.0 ) then
            NDone = NDone + 1
            if( NDone.eq.-MProc ) then
               NDone = 0
               NVal = 0
               do ii=1,NProc
                  call MPI_Send( NVal, 1, MPI_INTEGER,
     .                 ii, NxtVR, MPI_COMM_WORLD, ierror )
               enddo
            endif
         endif
      enddo

      end

! ---------------------------------------------------------

C***./ ADD NAME=GSUM
C PARALLEL UTILITY ROUTINES : PVM3.1  VERSION
      SUBROUTINE GSUM(X,NELEM)

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION X(*)
      PARAMETER(MDG=6,MDGBCK=7)
      COMMON/PARAL1/NPROC,NNPROC,IAM,MPOINT,ITASK

      PARAMETER (LIM001=300,LIM002=700,LIM003=60000,LIM004=60000,
     ,LIM005=1000,LIM007=500,LIM006=LIM007+LIM007-1,LIM008=2,
     ,LIM010=36000,LIM012=60000,LIM013=20000,LIM014=10,
     ,LIM015=300,LIM016=90,LIM018=48000,LIM019=200,
     ,LIM020=6,LIM021=700000,LIM024=16800,
     ,LIM025=3000,LIM026=8750,LIM027=410,LIM028=(LIM027+1)*LIM027/2,
     ,LIM030=70000,LIM031=2000,LIM033=8999,
     ,LIM039=25,LIM040=400,LIM041=15,LIM042=2000,LIM011=LIM016*LIM016,
     ,LIM045=LIM012+LIM012,
     ,NDFSQR=2*LIM002*LIM002,
     ,LIM022=LIM021*2,LIM049=50000,LIM050=LIM015*LIM015,
     *LIM071=8,LIM072=5,LIM073=17,LIM077=6000,
     *LIM079=500,LIM080=1600,LIM078=LIM080*3,LIM081=300,LIM082=450,
     *LIM083=LIM080*2,LIM088=20,LIM089=50000,
     *LIM090=16000,LIM091=96,LIM092=(LIM015+1)*LIM015/2,
     *LIM097=LIM021*3,LIM098=100,LIM099=250)

      COMMON /DGSUM/X1(LIM021)

      include 'mpif.h'
      integer Status(MPI_STATUS_SIZE)
cc    character*72 zzline

cc    write(6,*) 'Start Gsum'
      if (nproc.eq.1) return
      nup=(iam-1)/2
      nlft=iam+iam+1
      nrgt=iam+iam+2

cc    call FtnFormatArray(zzline,x,nelem,MPI_DOUBLE_PRECISION,iLen)
cc    write(6,*) '[',iam,'] Start GSUM: data=(',zzline(1:iLen),')'

      if (nlft.lt.nproc) then
         call MPI_Recv( x1(1), nelem, MPI_DOUBLE_PRECISION,
     .        nlft+1, Mdg, MPI_COMM_WORLD, status, ierror )
cc       call FtnFormatArray(zzline,x1,nelem,MPI_DOUBLE_PRECISION,iLen)
cc       write(6,*) '[',iam,'] GSUM.Recv1 ok: rank=',nlft+1,
cc   .              'data=(',zzline(1:iLen),')'
         do i=1,nelem
            x(i)=x(i)+x1(i)
         enddo
      endif

      if (nrgt.lt.nproc) then
         call MPI_Recv( x1(1), nelem, MPI_DOUBLE_PRECISION,
     .        nrgt+1, Mdg, MPI_COMM_WORLD, status, ierror )
cc       call FtnFormatArray(zzline,x1,nelem,MPI_DOUBLE_PRECISION,iLen)
cc       write(6,*) '[',iam,'] GSUM.Recv2 ok: rank=',nrgt+1,
cc   .              'data=(',zzline(1:iLen),')'
         do i=1,nelem
            x(i)=x(i)+x1(i)
         enddo
      endif

      if (iam.ne.0) then

         call MPI_Send( x(1), nelem, MPI_DOUBLE_PRECISION,
     .        NUP+1, Mdg, MPI_COMM_WORLD, ierror )

C        Receive final result from master ( node #1, iam=0 )

         call MPI_Recv( x(1), nelem, MPI_DOUBLE_PRECISION,
     .        1, MdgBck, MPI_COMM_WORLD, status, ierror )
      else

C        Multisend from master to n-1 slaves final result

         do i=2,NProc
            call MPI_Send( x(1), nelem, MPI_DOUBLE_PRECISION,
     .           i, MdgBck, MPI_COMM_WORLD, ierror )
         enddo

      endif
      return
      end

! ---------------------------------------------------------

C***./ ADD NAME=IGSUM
      SUBROUTINE IGSUM(IX,NELEM)

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION IX(*)
      PARAMETER(MDG=6,MDGBCK=7)
      COMMON/PARAL1/NPROC,NNPROC,IAM,MPOINT,ITASK

      PARAMETER (LIM001=300,LIM002=700,LIM003=60000,LIM004=60000,
     ,LIM005=1000,LIM007=500,LIM006=LIM007+LIM007-1,LIM008=2,
     ,LIM010=36000,LIM012=60000,LIM013=20000,LIM014=10,
     ,LIM015=300,LIM016=90,LIM018=48000,LIM019=200,
     ,LIM020=6,LIM021=700000,LIM024=16800,
     ,LIM025=3000,LIM026=8750,LIM027=410,LIM028=(LIM027+1)*LIM027/2,
     ,LIM030=70000,LIM031=2000,LIM033=8999,
     ,LIM039=25,LIM040=400,LIM041=15,LIM042=2000,LIM011=LIM016*LIM016,
     ,LIM045=LIM012+LIM012,
     ,NDFSQR=2*LIM002*LIM002,
     ,LIM022=LIM021*2,LIM049=50000,LIM050=LIM015*LIM015,
     *LIM071=8,LIM072=5,LIM073=17,LIM077=6000,
     *LIM079=500,LIM080=1600,LIM078=LIM080*3,LIM081=300,LIM082=450,
     *LIM083=LIM080*2,LIM088=20,LIM089=50000,
     *LIM090=16000,LIM091=96,LIM092=(LIM015+1)*LIM015/2,
     *LIM097=LIM021*3,LIM098=100,LIM099=250)

      COMMON /DGSUM/IX1(LIM021)

      include 'mpif.h'
      integer Status(MPI_STATUS_SIZE)

      if ( nproc.eq.1 )
     .   return
      nup=(iam-1)/2
      nlft=iam+iam+1
      nrgt=iam+iam+2

cc    write(6,*) 'Start Igsum'
      if (nlft.lt.nproc) then
         call MPI_Recv( ix1(1), nelem, MPI_INTEGER,
     .        nlft+1, Mdg, MPI_COMM_WORLD, status, ierror )
         do i=1,nelem
            ix(i)=ix(i)+ix1(i)
         enddo
      endif

      if (nrgt.lt.nproc) then
         call MPI_Recv( ix1(1), nelem, MPI_INTEGER,
     .        nrgt+1, Mdg, MPI_COMM_WORLD, status, ierror )
         do i=1,nelem
            ix(i)=ix(i)+ix1(i)
         enddo
      endif

      if (iam.ne.0) then

c        Send to upper node

         call MPI_Send( ix(1), nelem, MPI_INTEGER,
     .        nup+1, Mdg, MPI_COMM_WORLD, ierror )

c        Receive final result from master

         call MPI_Recv( ix(1), nelem, MPI_INTEGER,
     .        1, MdgBck, MPI_COMM_WORLD, status, ierror )

      else

c        Multisend from master to n-1 slaves final result

         do i=2,NProc
            call MPI_Send( ix(1), nelem, MPI_INTEGER,
     .           i, MdgBck, MPI_COMM_WORLD, ierror )
         enddo

      endif

      return
      end

! ---------------------------------------------------------

C***./ ADD NAME=INITPP
      SUBROUTINE INITPP
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      PARAMETER( MSGBGN=1, NXTVA=3, NXTVR=4, MSGDIR=33 )
      COMMON/PARAL1/NPROC,NNPROC,IAM,MPOINT,ITASK
      PARAMETER (LIMPAR=50,LIMPRN=200,LIMFTN=100,LIMTOL=50,LIMINF=200)
      COMMON/PARINF/PAR(LIMPAR),LPRINT(LIMPRN),IUNIT(LIMFTN),
     *ITOL(LIMTOL),INF(LIMINF),ITIT(20),IIN,IOUT

      include 'mpif.h'
      integer Status(MPI_STATUS_SIZE)
      character*72 TmpDir

      call MPI_Init( ierror )
      call MPI_Comm_size( MPI_COMM_WORLD, nproc, ierror )
      call MPI_Comm_rank( MPI_COMM_WORLD, iam, ierror )
cc    write(6,*) 'Start rank=',iam

      nproc = nproc-1
      iam = iam-1
      if ( nproc.eq.0 ) then
        write(6,*) 'Increase nodes count, 1 is invalid'
        stop
      endif

      if ( iam.lt.0 ) then
         call MasterNode
      else
         call second(ft)
      endif

      mpoint=0

      if ( iam.ge.0 ) then
         call MPI_Recv( TmpDir, 72, MPI_CHARACTER, 0, MsgDir,
     .                  MPI_COMM_WORLD, Status, ierror ) 
         call MPI_Get_count( Status, MPI_CHARACTER, icount, ierror )
         call SafeChDir( TmpDir, icount )
      endif

cc    write(6,*) 'Try GCopyF, rank=',iam+1
      call gcopyf

cc    write(6,*) 'Try Barrier, rank=',iam+1
      call MPI_Barrier( MPI_COMM_WORLD, ierror )
cc    write(6,*) 'After Barrier: rank=',iam+1

      if ( iam.lt.0 )
     .  call NxtSrv

      return
      end

! ---------------------------------------------------------

C***./ ADD NAME=STOPPE
      SUBROUTINE STOPPE
C... ERROR EXIT
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      include 'mpif.h'
      CALL TIMVRS('ERR     ')
      call MPI_Finalize( ierror )
      STOP
      END

! ---------------------------------------------------------

C***./ ADD NAME=STOPPP
      SUBROUTINE STOPPP
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      include 'mpif.h'
      character*24   fdate
      external       fdate
      common/paral1/nproc,nnproc,iam,mpoint,itask

      parameter (limpar=50,limprn=200,limftn=100,limtol=50,liminf=200)
      common/parinf/par(limpar),lprint(limprn),iunit(limftn),
     *itol(limtol),inf(liminf),itit(20),iin,iout

!!!   open(unit=100,file='LISTTIME',access='APPEND')
!!!   write(100,*)' Stoppp ended at ', fdate()
!!!   close(unit=100)

      CALL TIMVRS('END     ')
      CALL TREPOR
      JUNK=NXTVAL(0)
      close(unit=iout)
      call MPI_Barrier( MPI_COMM_WORLD, ierror )
cc    write(6,*) 'iam=',iam,': try finalize'
      call MPI_Finalize( ierror )
cc    write(6,*) 'iam=',iam,': end finalize'
      STOP
      END

! ---------------------------------------------------------

C***./ ADD NAME=GCOPYF
      SUBROUTINE GCOPYF
C **************************************************************
C COPY IIN ON NODE 0  TO IIN ON ALL NODES
C **************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MSGINP=8,MsgEnd=66)
      CHARACTER*80 REC80

      PARAMETER (LIMPAR=50,LIMPRN=200,LIMFTN=100,LIMTOL=50,LIMINF=200)
      COMMON/PARINF/PAR(LIMPAR),LPRINT(LIMPRN),IUNIT(LIMFTN),
     *ITOL(LIMTOL),INF(LIMINF),ITIT(20),IIN,IOUT

      COMMON/PARAL1/NPROC,NNPROC,IAM,MPOINT,ITASK

      include 'mpif.h'
      integer Status(MPI_STATUS_SIZE)

      if ( nproc.eq.1 )
     .   return

      IIN  = 88
      IOUT = 89
      ios  = 0

      open(unit=iout,file='OUTPUT',form='FORMATTED')

      if ( iam.lt.0 ) then

cc       write(6,*) 'Try open 1, rank=',iam+1
         open(unit=iin,file='INPUT',form='FORMATTED',status='OLD')
cc       write(6,*) 'End open 1, rank=',iam+1

         do while ( ios.eq.0 )
            read(iin,FMT=1000,IOSTAT=ios) rec80
            if ( ios.gt.0 ) then
               write(6,*) 'Cannot read file INPUT on Master node, stop'
               call MPI_Abort( MPI_COMM_WORLD, MPI_ERR_OTHER, ierror )
               stop
            else if ( ios.eq.0 ) then
!!             write(iout,FMT=1001) rec80
               do ii=1,NProc
!!                write(6,*) 'A. Try Send: rank=',iam+1,
!!   .                       ', to=',ii,', msg=',MsgInp
                  call MPI_Send( rec80, 80, MPI_CHARACTER,
     .                 ii, MsgInp, MPI_COMM_WORLD, ierror )
!!                write(6,*) 'A. End Send: rank=',iam+1,
!!   .                       ', to=',ii,', msg=',MsgInp
               enddo
            endif
         enddo

         do ii=1,NProc
!!          write(6,*) 'B. Try Send: rank=',iam+1,
!!   .                 ', to=',ii,', msg=',MsgEnd
            call MPI_Send( ' ', 1, MPI_CHARACTER,
     .           ii, MsgEnd, MPI_COMM_WORLD, ierror )
!!          write(6,*) 'B. End Send: rank=',iam+1,
!!   .                 ', to=',ii,', msg=',MsgEnd
         enddo

      else

         open(unit=iin,file='INPUT',form='FORMATTED')

         do while ( ios.eq.0 )

            call MPI_Recv( rec80, 80, MPI_CHARACTER,
     .           0, MPI_ANY_TAG, MPI_COMM_WORLD, status, ierror )
            if ( Status(MPI_TAG).eq.MsgEnd ) then
               ios = -1
            else if ( Status(MPI_TAG).ne.MsgInp ) then
               write(6,*) 'Error: rank=',iam+1,
     .           ': received msg with unknown tag ', Status(MPI_TAG)
               call MPI_Get_count( Status,MPI_CHARACTER,icount,ierror)
               write(6,*) 'Error: rank=',iam+1,'(',rec80(1:icount),')'
               call MPI_Abort( MPI_COMM_WORLD, MPI_ERR_OTHER, ierror )
               stop
            else
               write(iin,1000) rec80
            endif
         enddo

      endif

      close(unit=iin)
cc    write(6,*) 'Try open 2, rank=',iam+1
      open(unit=iin,file='INPUT',form='FORMATTED',status='OLD')
cc    write(6,*) 'End open 2, rank=',iam+1

 1000 format(a80)
 1001 format(1x,a80)

      return

      end

! ---------------------------------------------------------

C***./ ADD NAME=IGPVAL
      SUBROUTINE IGPVAL
C IMPLEMENTS A GLOBAL POINTER
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      include 'mpif.h'
      COMMON/PARAL1/NPROC,NNPROC,IAM,MPOINT,ITASK
      IF(NPROC.NE.1)MPOINT=NXTVAL(NPROC)
      MPOINT=MPOINT+1
      RETURN
      END

! ---------------------------------------------------------

C***./ ADD NAME=IGPRST
      SUBROUTINE IGPRST
C RESETS THE GLOBAL POINTER
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      include 'mpif.h'
      COMMON/PARAL1/NPROC,NNPROC,IAM,MPOINT,ITASK
      IF(NPROC.NE.1)THEN
         M=NXTVAL(-NPROC)
      ELSE
         MPOINT=0
      ENDIF
      RETURN
      END

! ---------------------------------------------------------

C***./ ADD NAME=NXTVAL
      FUNCTION NXTVAL(MPROC)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (NXTVA=3,NXTVR=4)

      include 'mpif.h'
      integer Status(MPI_STATUS_SIZE)
      common/paral1/nproc,nnproc,iam,mpoint,itask

cc    write(6,*) 'iam=',iam,' Try NxtVal(MPROC=',Mproc,')'
      call MPI_Send( MProc, 1, MPI_INTEGER, 0, NxtVA,
     .               MPI_COMM_WORLD, ierror )

C     Wait for reply from master

      call MPI_Recv( NVal, 1, MPI_INTEGER, 0, NxtVR,
     .               MPI_COMM_WORLD, status, ierror )
cc    write(6,*) 'iam=',iam,' End NxtVal()=',NVAL

      NXTVAL=NVAL
      RETURN
      END

! ---------------------------------------------------------

C***./ ADD NAME=TREPOR
      SUBROUTINE TREPOR
C COLLECT TOTAL CPU TIMES FROM ALL ACTIVE NODES
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MSGTIM=9)
      PARAMETER (LIMPAR=50,LIMPRN=200,LIMFTN=100,LIMTOL=50,LIMINF=200)
      COMMON/PARINF/PAR(LIMPAR),LPRINT(LIMPRN),IUNIT(LIMFTN),
     *ITOL(LIMTOL),INF(LIMINF),ITIT(20),IIN,IOUT
      COMMON/PARAL1/NPROC,NNPROC,IAM,MPOINT,ITASK

      include 'mpif.h'
      integer Status(MPI_STATUS_SIZE)

      call second(tend)
      if ( iam.ne.0 ) then
         call MPI_Send( tend, 1, MPI_DOUBLE_PRECISION,
     .        1, MsgTim, MPI_COMM_WORLD, ierror )
      else
         write(iout,100)iam,tend
         ttend=tend
         do i=2,NProc
            call MPI_Recv( tend, 1, MPI_DOUBLE_PRECISION,
     .           i, MsgTim, MPI_COMM_WORLD, status, ierror )
            write(iout,100)i,tend
            ttend=ttend+tend
         enddo
         write(iout,101)ttend
      endif
      return
100   format('node',i5,' cpu time =',f14.3)
101   format('    total cpu time =',f14.3)
      end

!<EOF>
