      SUBROUTINE TLODT1 (TREAL,TINT)
C
C     THERMAL LOAD VECTOR FOR TRPLT1 (HIGHER ORDER PLATE BENDING ELEMENT
C
C     ECPT ENTRIES
C     AS IN STIFFNESS ROUTINE KTRPL1
C
      LOGICAL         NOGO,NOTS,UNIBEN,UNITEM
      INTEGER         XPOWER(20),YPOWER(20),XTHK(10),YTHK(10),PT(3),
     1                QT(3),SIL(6),SIL1,TINT(6)
      REAL            IVECT,JVECT,KVECT
      DIMENSION       F(10,10),XC(6),YC(6),ZC(6),QQQ(20,20),QQINV(360),
     1                TS1(60),TS2(60),IEST(42),TREAL(6),TRAND(9),DD(3),
     2                ICS(6),GE1(9),NAM(2)
      CHARACTER       UFM*23
      COMMON /XMSSG / UFM
      COMMON /SSGWRK/ X,Y,Z,DISTA,DISTB,DISTC,A1,A2,A3,B1,B2,B3,G1(3),
     1                D(3),E(18),IVECT(3),JVECT(3),KVECT(3),CC(10),G(9),
     2                PTEM(20),PTELE(18),PTGLB(36),PSUB(3),PSUBT(6),
     3                PSUBT1(6),TS6(40),NAME(2),INDEX(20,3),NL(6),TL(3),
     4                BALOTR(36)
      COMMON /SYSTEM/ SYSBUF,IOUT
      COMMON /TRIMEX/ EST(100)
      COMMON /ZZZZZZ/ PG(1)
C
C     INPUT AND OUTPUT BLOCKS FOR SUBROUTINE MAT
C
      COMMON /MATIN / MATID,MATFLG,ELTEMP,PLA34,SINTH,COSTH
      COMMON /MATOUT/ EM(6),RHOY,ALF(3),TREF,GSUBE,SIGTY,SIGCY,SIGSY,
     1                RJ11,RJ12,RJ22
C
C     EQUIVALENCE IECPT WITH ECPT IN COMMON BLOCK /SMA1ET/ SINCE ECPT IS
C     A MIXED INTEGER AND REAL ARRAY
C
      EQUIVALENCE     (THK1,TMEM1),(THK2,TMEM3),(THK3,TMEM5),
     1                (A,DISTA),(B,DISTB),(C,DISTC),(IEST(1),EST(1)),
     2                (C1,CC(1)),(C2,CC(2)),(C3,CC(3)),(C4,CC(4)),
     3                (C5,CC(5)),(C6,CC(6)),(C7,CC(7)),(C8,CC(8)),
     4                (C9,CC(9)),(C10,CC(10)),(D(1),D1),(D(2),D2),
     5                (D(3),D3),(DD(1),D(1))
      DATA    BLANK , NAM  / 4H    , 4HTRPL, 4HT1    /
      DATA    XPOWER/ 0,1,0,2,1,0,3,2,1,0,4,3,2,1,0,5,3,2,1,0/
      DATA    YPOWER/ 0,0,1,0,1,2,0,1,2,3,0,1,2,3,4,0,2,3,4,5/
      DATA    XTHK  / 0,1,0,2,1,0,3,2,1,0 /
      DATA    YTHK  / 0,0,1,0,1,2,0,1,2,3 /
      DATA    PT    / 0,1,0 /,  QT / 0,0,1/
      DATA    DEGRA / 0.0174532925 /
C
C
      NOTS  = .FALSE.
      IDELE = IEST(1)
      DO 109 I = 1,6
      NL(I) = IEST(I+1)
  109 CONTINUE
      THETAM = EST(8)
      MATID1 = IEST(9)
      TMEM1  = (EST(10)*12.0)**0.333333333333
      TMEM3  = (EST(11)*12.0)**0.333333333333
      TMEM5  = (EST(12)*12.0)**0.333333333333
      TSHR1  = EST(14)
      TSHR3  = EST(15)
      TSHR5  = EST(16)
      J      = 0
      DO 120 I = 24,44,4
      J      = J + 1
      ICS(J) = IEST(I)
      XC(J)  = EST(I+1)
      YC(J)  = EST(I+2)
      ZC(J)  = EST(I+3)
  120 CONTINUE
      TEMP1  = TREAL(1)
      TEMP3  = TREAL(1)
      TEMP5  = TREAL(1)
      T1PRIM =-TREAL(2)
      T3PRIM =-TREAL(2)
      T5PRIM =-TREAL(2)
C
C     IF TMEM3 OR TMEM5 EQUAL TO ZERO OR BLANK,THEY WILL BE SET EQUAL TO
C     SO ALSO FOR TEMP3 AND TEMP5
C
      IF (TMEM3.EQ.0.0 .OR. TMEM3 .EQ.BLANK) TMEM3  = TMEM1
      IF (TMEM5.EQ.0.0 .OR. TMEM5 .EQ.BLANK) TMEM5  = TMEM1
      IF (TEMP3.EQ.0.0 .OR. TEMP3 .EQ.BLANK) TEMP3  = TEMP1
      IF (TEMP5.EQ.0.0 .OR. TEMP5 .EQ.BLANK) TEMP5  = TEMP1
      IF (T3PRIM.EQ..0 .OR. T3PRIM.EQ.BLANK) T3PRIM = T1PRIM
      IF (T5PRIM.EQ..0 .OR. T5PRIM.EQ.BLANK) T5PRIM = T1PRIM
      IF (TSHR3.EQ.0.0 .OR. TSHR3 .EQ.BLANK) TSHR3  = TSHR1
      IF (TSHR5.EQ.0.0 .OR. TSHR5 .EQ.BLANK) TSHR5  = TSHR1
      ELTEMP = EST(48)
      AVTHK  = (TMEM1+TMEM3+TMEM5)/3.0
      AVINER = AVTHK**3/12.0
      IF (TSHR1 .EQ. 0.0) NOTS = .TRUE.
      THETA1 = THETAM*DEGRA
      SINTH  = SIN(THETA1)
      COSTH  = COS(THETA1)
      IF (ABS(SINTH) .LE. 1.0E-06) SINTH = 0.0
C
C     EVALUATE MATERIAL PROPERTIES
C
      MATFLG = 2
      MATID = MATID1
      CALL MAT (IDELE)
C
      G(1) = EM(1)
      G(2) = EM(2)
      G(3) = EM(3)
      G(4) = EM(2)
      G(5) = EM(4)
      G(6) = EM(5)
      G(7) = EM(3)
      G(8) = EM(5)
      G(9) = EM(6)
C
C     IF TINT(6).NE.1,G1 IS G AND T1PRIME IS ALPHA TIMES T1PRIME
C     IF TINT(6).EQ.1,G1 IS G TIMES ALPHA AND T1PRIME IS T1PRIME
C
      IF (TINT(6) .NE. 1) GO TO 147
C
C     G1 IS G TIMES ALPHA
C
      CALL GMMATS (G,3,3,0, ALF,3,1,0, G1)
      GO TO 149
  147 CONTINUE
      DO 148 I = 1,9
  148 GE1(I) = G(I)*AVINER
C
C     NO NEED TO COMPUTE DETERMINANT SINCE IT IS NOT USED SUBSEQUENTLY.
C
      ISING = -1
      CALL INVERS (3,GE1(1),3,TS1(1),0,DETERM,ISING,INDEX)
      IF (ISING .EQ. 2) GO TO 901
      CALL GMMATS (GE1,3,3,0, TREAL(2),3,1,0, TL(1))
C
C     CALCULATIONS FOR THE TRIANGLE
C
  149 CALL TRIF (XC,YC,ZC,IVECT,JVECT,KVECT,A,B,C,IEST(1),NAM )
C
C     FILL E-MATRIX
C
      DO 177 I = 1,18
  177 E( I) = 0.0
      E( 1) = KVECT(1)
      E( 4) = KVECT(2)
      E( 7) = KVECT(3)
      E(11) = IVECT(1)
      E(14) = IVECT(2)
      E(17) = IVECT(3)
      E(12) = JVECT(1)
      E(15) = JVECT(2)
      E(18) = JVECT(3)
C
C     EVALUATE CONSTANTS D1,D2,D3 IN THE LINEAR EQUATION FOR TEMPERATURE
C     GRADIENT VARIATION OVER THE ELEMENT
C
      CALL AF (F,10,A,B,C,D1,D2,D3,THK1,THK2,THK3,1)
      UNITEM = .FALSE.
      IF (ABS(D2).LE.1.0E-06 .AND. ABS(D3).LE.1.0E-06) UNITEM =.TRUE.
C
      DISTAB = DISTA + DISTB
      A1   = (THK1*DISTA+THK2*DISTB)/DISTAB
      A2   = (THK2-THK1)/DISTAB
      A3   = (THK3-A1)/DISTC
      A1SQ = A1*A1
      A2SQ = A2*A2
      A3SQ = A3*A3
      C1   = A1SQ*A1
      C2   = 3.0*A1SQ*A2
      C3   = 3.0*A1SQ*A3
      C4   = 3.0*A1*A2SQ
      C5   = 6.0*A1*A2*A3
      C6   = 3.0*A3SQ*A1
      C7   = A2SQ*A2
      C8   = 3.0*A2SQ*A3
      C9   = 3.0*A2*A3SQ
      C10  = A3*A3SQ
      CALL AF (F,10,A,B,C,B1,B2,B3,TSHR1,TSHR3,TSHR5,1)
      UNIBEN =.FALSE.
      IF (ABS(A2).LE.1.0E-06 .AND. ABS(A3).LE.1.0E-06) UNIBEN =.TRUE.
C
C     COMPUTE THE AREA INTEGRATION FUNCTION F
C
      CALL AF (F,10,A,B,C,0,0,0,0,0,0,-1)
C
C     CALCULATIONS FOR QMATRIX (QQQ) AND ITS INVERSE
C
      DO 110 I = 1,400
  110 QQQ(I,1) = 0.0
      DO 115 I = 1,6
      I1 = (I-1)*3 + 1
      I2 = (I-1)*3 + 2
      I3 = (I-1)*3 + 3
      QQQ(I1, 1) = 1.0
      QQQ(I1, 2) = XC(I)
      QQQ(I1, 3) = YC(I)
      QQQ(I1, 4) = XC(I)*XC(I)
      QQQ(I1, 5) = XC(I)*YC(I)
      QQQ(I1, 6) = YC(I)*YC(I)
      QQQ(I1, 7) = QQQ(I1, 4)*XC(I)
      QQQ(I1, 8) = QQQ(I1, 4)*YC(I)
      QQQ(I1, 9) = QQQ(I1, 5)*YC(I)
      QQQ(I1,10) = QQQ(I1, 6)*YC(I)
      QQQ(I1,11) = QQQ(I1, 7)*XC(I)
      QQQ(I1,12) = QQQ(I1, 7)*YC(I)
      QQQ(I1,13) = QQQ(I1, 8)*YC(I)
      QQQ(I1,14) = QQQ(I1, 9)*YC(I)
      QQQ(I1,15) = QQQ(I1,10)*YC(I)
      QQQ(I1,16) = QQQ(I1,11)*XC(I)
      QQQ(I1,17) = QQQ(I1,12)*YC(I)
      QQQ(I1,18) = QQQ(I1,13)*YC(I)
      QQQ(I1,19) = QQQ(I1,14)*YC(I)
      QQQ(I1,20) = QQQ(I1,15)*YC(I)
      QQQ(I2, 3) = 1.0
      QQQ(I2, 5) = XC(I)
      QQQ(I2, 6) = YC(I)*2.0
      QQQ(I2, 8) = QQQ(I1, 4)
      QQQ(I2, 9) = QQQ(I1, 5)*2.0
      QQQ(I2,10) = QQQ(I1, 6)*3.0
      QQQ(I2,12) = QQQ(I1, 7)
      QQQ(I2,13) = QQQ(I1, 8)*2.0
      QQQ(I2,14) = QQQ(I1, 9)*3.0
      QQQ(I2,15) = QQQ(I1,10)*4.0
      QQQ(I2,17) = QQQ(I1,12)*2.0
      QQQ(I2,18) = QQQ(I1,13)*3.0
      QQQ(I2,19) = QQQ(I1,14)*4.0
      QQQ(I2,20) = QQQ(I1,15)*5.0
      QQQ(I3, 2) =-1.0
      QQQ(I3, 4) =-2.0*XC(I)
      QQQ(I3, 5) =-YC(I)
      QQQ(I3, 7) =-QQQ(I1, 4)*3.0
      QQQ(I3, 8) =-QQQ(I1, 5)*2.0
      QQQ(I3, 9) =-QQQ(I1, 6)
      QQQ(I3,11) =-QQQ(I1, 7)*4.0
      QQQ(I3,12) =-QQQ(I1, 8)*3.0
      QQQ(I3,13) =-QQQ(I1, 9)*2.0
      QQQ(I3,14) =-QQQ(I1,10)
      QQQ(I3,16) =-QQQ(I1,11)*5.0
      QQQ(I3,17) =-QQQ(I1,13)*3.0
      QQQ(I3,18) =-QQQ(I1,14)*2.0
      QQQ(I3,19) =-QQQ(I1,15)
C
C     IF NO TRANSVERSE SHEAR GO TO 113
C
      IF (NOTS) GO TO 115
      X = XC(I)
      Y = YC(I)
      CALL TLODT3 (TS6,NOTS)
      DO 113 JJ = 1,20
      QQQ(I2,JJ) = QQQ(I2,JJ) - TS6(20+JJ)
      QQQ(I3,JJ) = QQQ(I3,JJ) + TS6(   JJ)
  113 CONTINUE
  115 CONTINUE
C
      QQQ(19,16) = 5.0*A**4*C
      QQQ(19,17) = 3.0*A**2*C**3 - 2.0*A**4*C
      QQQ(19,18) =-2.0*A*C**4 + 3.0*A**3*C**2
      QQQ(19,19) = C**5 - 4.0*A**2*C**3
      QQQ(19,20) = 5.0*A*C**4
      QQQ(20,16) = 5.0*B**4*C
      QQQ(20,17) = 3.0*B**2*C**3 - 2.0*B**4*C
      QQQ(20,18) = 2.0*B*C**4 - 3.0*B**3*C**2
      QQQ(20,19) = C**5 - 4.0*B**2*C**3
      QQQ(20,20) =-5.0*B*C**4
C
C     FOURTH ARGUMENT IS A DUMMY LOCATION FOR INVERSE AND HENCE TS1(1)
C     IS U
C
C     AGAIN SET ISING = -1
C
      ISING = -1
      CALL  INVERS (20,QQQ,20,TS1(1),0,DETERM,ISING,INDEX)
C
C     ISING EQUAL TO 2 IMPLIES THAT QQQ IS SINGULAR
C
C     FIRST 18 COLUMNS OF QQQ INVERSE IS THE QQQINV FOR USE IN STIFFNESS
C     MATRIX CALCULATIONS
C
      DO 152 I = 1,20
      DO 152 J = 1,18
      IJ = (I-1)*18 + J
      QQINV (IJ) = QQQ(I,J)
  152 CONTINUE
C
      DO 220 I = 1,20
      MX   = XPOWER(I)
      RMX  = MX
      NX   = YPOWER(I)
      RNX  = NX
      RMNX = RMX*RNX
      RMX1 = RMX*(RMX-1.0D0)
      RNX1 = RNX*(RNX-1.0D0)
      PTEMP= 0.0
      MX01 = MX - 1
      MX1  = MX + 1
      NX01 = NX - 1
      NX1  = NX + 1
      DO 215 K = 1,10
      MX01X= MX01+ XTHK(K)
      NX1Y = NX1 + YTHK(K)
      MX1X = MX1 + XTHK(K)
      NX01Y= NX01+ YTHK(K)
      MXX  = MX  + XTHK(K)
      NXY  = NX  + YTHK(K)
      IF (TINT(6) .NE. 1) GO TO 213
      DO 212 L = 1,3
      MX01XP= MX01X+ PT(L)
      NX1YQ = NX1Y + QT(L)
      MX1XP = MX1X + PT(L)
      NX01YQ= NX01Y+ QT(L)
      MXXP  = MXX  + PT(L)
      NXYQ  = NXY  + QT(L)
      IF (MX01XP.GT.0 .AND. NX1YQ.GT.0)
     1    PTEMP = PTEMP+CC(K)*DD(L)*G1(1)*RMX1*F(MX01XP,NX1YQ)
      IF (MX1XP.GT.0 .AND. NX01YQ.GT.0)
     1    PTEMP = PTEMP+CC(K)*DD(L)*G1(2)*RNX1*F(MX1XP,NX01YQ)
      IF (MXXP.GT.0 .AND. NXYQ.GT.0)
     1    PTEMP = PTEMP+CC(K)*DD(L)*G1(3)*RMNX*F(MXXP,NXYQ)
      IF (UNITEM) GO TO 213
  212 CONTINUE
C
  213 IF (TINT(6) .EQ. 1) GO TO 214
      IF (MX01X .GT. 0) PTEMP = PTEMP + CC(K)*RMX1*(TL(1)*G(1)
     1                        + TL(2)*G(2) + TL(3)*G(3))*F(MX01X,NX1Y)
      IF (NX01Y .GT. 0) PTEMP = PTEMP + CC(K)*RNX1*(TL(1)*G(4)
     1                        + TL(2)*G(5) + TL(3)*G(6))*F(MX1X,NX01Y)
      IF (MXX.GT.0 .AND. NXY.GT.0) PTEMP = PTEMP + CC(K)*RMNX*
     1                   (TL(1)*G(7)+TL(2)*G(8)+TL(3)*G(9))*F(MXX,NXY)
  214 IF (UNIBEN) GO TO 216
  215 CONTINUE
C
  216 PTEM(I) = PTEMP/12.0
  220 CONTINUE
C
C     IF NO TRANSVERSE SHEAR GO TO 230
C
C     IF TSHR EQUAL TO ZERO OR MATID3 EQUAL TO ZERO, SKIP THESE
C     CALCULATIONS
C
      IF (NOTS) GO TO 230
C
      CALL TLODT2 (TS1,TS2)
      DO 226 I = 1,20
      PTEM(I) = PTEM(I) + TS2(I)
  226 CONTINUE
C
C     (QQQINV) TRANSPOSE (KTR3)  (QQQINV)
C
  230 CALL  GMMATS (QQINV,20,18,+1, PTEM,20,1,0, PTELE)
C
C     LOCATE THE TRANSFORMATION MATRICES FROM BASIC TO LOCAL (THAT IS
C     COORDINATE AT ANY GRID POINT IN WHICH DISPLACEMENT AND STRESSES
C     ARE R - NOT NEEDED IF FIELD 7 IN GRID CARD IS ZERO)
C
      DO 301 I = 1,36
      PTGLB(I) = 0.0
  301 CONTINUE
      DO 302 I = 1,6
      SIL(I) = I
  302 CONTINUE
      DO 380 I = 1,6
      DO 310 II = 1,36
      BALOTR(II) = 0.0D0
  310 CONTINUE
      SIL1 = SIL(I)
      DO 304 K = 1,3
      K1 = (SIL1-1)*3 + K
      PSUB(K) = PTELE(K1)
  304 CONTINUE
      CALL GMMATS (E,6,3,0, PSUB,3,1,0, PSUBT)
C
C     TRANSFORM THE PSUBT(6) FROM BASIC TO DISPLACEMENT COORDINATES
C
      IF (NL(I).EQ.0 .OR. ICS(I).EQ.0) GO TO 330
      JJ = 4*I + 20
      CALL TRANSS (IEST(JJ),TRAND)
      DO 320 JJ = 1,3
      L = 6*(JJ-1) + 1
      M = 3*(JJ-1) + 1
      BALOTR(L   ) = TRAND(M  )
      BALOTR(L+1 ) = TRAND(M+1)
      BALOTR(L+2 ) = TRAND(M+2)
      BALOTR(L+21) = TRAND(M  )
      BALOTR(L+22) = TRAND(M+1)
      BALOTR(L+23) = TRAND(M+2)
  320 CONTINUE
      CALL GMMATS (BALOTR(1),6,6,1, PSUBT,6,1,0, PSUBT1)
      DO 350 K = 1,6
      PSUBT(K) = PSUBT1(K)
  350 CONTINUE
C
C     INSERT PTGLB IN PG
C
  330 DO 370 II = 1,6
      I1 = (I-1)*6 + II
      I2 = IEST(I+1) + II - 1
      PTGLB(I1) = PSUBT(II)
      PG(I2) = PG(I2) + PSUBT(II)
  370 CONTINUE
  380 CONTINUE
      GO TO 999
C
  901 WRITE  (IOUT,905) UFM,IEST(1)
  905 FORMAT (A23,' 2412, A SINGULAR MATERIAL MATRIX FOR ELEMENT ID =',
     1       I9,' HAS BEEN DETECTED BY SUBROUTINE TLODT1', /26X,'WHILE',
     2       ' TRYING TO COMPUTE THERMAL LOADS WITH TEMPP2 CARD DATA.')
      NOGO=.TRUE.
  999 RETURN
      END


program make_starmask

  use fieldinfo_
  use sub_

  implicit none

!     idum: set arbitrary value for initial seed for ran2

  integer :: idum=-152103

!     inf: input file of shear distribution
!    outf: mask field [1:ni,1:nj](real)
!    outf2: flag data describing which data is masked or not [1:ntot] (logical*1)
!           if (flag(n)=.true.) n-th data is masked

  character(100) :: inf,outf,outf2

  integer :: i,j
  real, pointer :: mask(:,:),pos(:,:)
  logical*1, pointer :: flag(:)

  call getarg(1,inf)
  call getarg(2,outf)
  call getarg(3,outf2)

  call readdata(inf,pos)
  call maskdata(pos,flag,idum)
  call densassign(pos,flag,mask)
  call outmask(mask,outf)
  call outflag(outf2,flag)

contains

  subroutine readdata(inf,pos)

    use fieldinfo_
    implicit none

    integer :: n
    real, pointer :: pos(:,:)
    character :: inf*100

    write(*,*) 'read data from ',inf(1:len_trim(inf))
    allocate(pos(ntot,2))
    open(1,file=inf,status='old',form='unformatted')
    read(1) pos
    close(1)

  end subroutine readdata

  subroutine outflag(outf,flag)

    logical*1, pointer :: flag(:)
    character :: outf*100

    write(*,*) 'output flag:',outf(1:len_trim(outf))
    open(2,file=outf,status='unknown',form='unformatted')
    write(2) flag
    close(2)
    deallocate(flag)

  end subroutine outflag

  subroutine densassign(pos,flag,mask)

    use fieldinfo_
    use sub_
    implicit none

    integer :: i,j,i1,j1,idum,n
    real :: x,y,fx,fy
    real, pointer :: mask(:,:),pos(:,:)
    logical*1, pointer :: flag(:)

    allocate(mask(ni,nj))
    mask=0.
    do n=1,ntot
       if (flag(n)) cycle
       i=int(pos(n,1))+1
       j=int(pos(n,2))+1
       mask(i,j)=mask(i,j)+1.
    enddo
    close(1)
    deallocate(pos)

  end subroutine densassign

  subroutine maskdata(pos,flag,idum)

    use fieldinfo_
    use maskinfo_
    use sub_
    implicit none

    integer :: i,j,n,nmask,nm,next
    real :: hpos(2),hsize,ssize(2)  ! in unit of grid
    integer, intent(inout) :: idum
    real, pointer :: pos(:,:)
    integer, pointer :: num(:,:),pnum(:,:,:)
    logical*1, pointer :: flag(:)

    allocate(flag(ntot))
    flag=.false.
    call fieldassign(pos,num,pnum)
    next=0
    nmask=nint(ntot*fmask)
    write(*,*) nmask
    do while (next<nmask)
       hpos(1)=ran2(idum)*ni
       hpos(2)=ran2(idum)*nj
       hsize=(hmin+(hmax-hmin)*ran2(idum)**4)*amin2grid
       call starmask(hsize,hpos,pos,num,pnum,flag,next)
       if (hsize>rsmin*amin2grid) then
          ssize(1)=hsize*xrec
          ssize(2)=hsize*yrec
          call recmask(ssize,hpos,pos,num,pnum,flag,next)
       endif
    enddo
    call zpad(pos,num,pnum,flag,next,idum)
    deallocate(num,pnum)

    write(*,*) 'unmasked fraction:',1-float(next)/float(ntot)

  end subroutine maskdata

  subroutine outmask(mask,outf)

    implicit none
    real, pointer :: mask(:,:)
    character(100) :: outf

    write(*,*) 'output mask:',outf(1:len_trim(outf))
    open(2,file=outf,status='unknown',form='unformatted')
    write(2) mask
    close(2)
    deallocate(mask)

  end subroutine outmask

  subroutine fieldassign(pos,num,pnum)

    implicit none
    integer :: i,j,n,nmax
    real, pointer :: pos(:,:)
    integer, pointer :: num(:,:),pnum(:,:,:)

    allocate(num(ni,nj))
    num=0
    do n=1,ntot
       i=int(pos(n,1))+1
       j=int(pos(n,2))+1
       num(i,j)=num(i,j)+1
    enddo
    nmax=0
    do j=1,nj
       do i=1,ni
          if (num(i,j)>nmax) nmax=num(i,j)
       enddo
    enddo
    write(*,*) 'maximum number of galaxies per pixel',nmax
    allocate(pnum(ni,nj,nmax))
    num=0
    do n=1,ntot
       i=int(pos(n,1))+1
       j=int(pos(n,2))+1
       num(i,j)=num(i,j)+1
       pnum(i,j,num(i,j))=n
    enddo

  end subroutine fieldassign

  subroutine starmask(hsize,hpos,pos,num,pnum,flag,next)

    use fieldinfo_
    use sub_
    implicit none

    integer :: i,j,imin,imax,jmin,jmax,n
    integer, intent(inout) :: next
    real :: r
    real, intent(in) :: hsize,hpos(2)
    real, pointer :: pos(:,:)
    integer, pointer :: num(:,:),pnum(:,:,:)
    logical*1, pointer :: flag(:)

    imin=int(hpos(1)-hsize)
    imax=int(hpos(1)+hsize)+1
    jmin=int(hpos(2)-hsize)
    jmax=int(hpos(2)+hsize)+1
    do i=imin,imax
       do j=jmin,jmax
          if ((i<1).or.(i>ni)) cycle
          if ((j<1).or.(j>nj)) cycle
          do n=1,num(i,j)
             if (flag(pnum(i,j,n))) cycle
             r=dist(hpos,pos(pnum(i,j,n),:),2)
             if (r<hsize) then
                next=next+1
                flag(pnum(i,j,n))=.true.
             endif
          enddo
       enddo
    enddo

  end subroutine starmask

  subroutine recmask(ssize,hpos,pos,num,pnum,flag,next)

    use fieldinfo_
    implicit none

    integer :: i,j,imin,imax,jmin,jmax,n
    integer, intent(inout) :: next
    real, intent(in) :: ssize(2),hpos(2)
    real :: dx,dy
    real, pointer :: pos(:,:)
    integer, pointer :: num(:,:),pnum(:,:,:)
    logical*1, pointer :: flag(:)

    imin=int(hpos(1)-ssize(1))
    imax=int(hpos(1)+ssize(1))+1
    jmin=int(hpos(2)-ssize(2))
    jmax=int(hpos(2)+ssize(2))+1
    do i=imin,imax
       do j=jmin,jmax
          if ((i<1).or.(i>ni)) cycle
          if ((j<1).or.(j>nj)) cycle
          do n=1,num(i,j)
             if (flag(pnum(i,j,n))) cycle
             dx=abs(pos(pnum(i,j,n),1)-hpos(1))
             dy=abs(pos(pnum(i,j,n),2)-hpos(2))
             if ((dx<ssize(1)).and.(dy<ssize(2))) then
                next=next+1
                flag(pnum(i,j,n))=.true.
             endif
          enddo
       enddo
    enddo

  end subroutine recmask

  subroutine zpad(pos,num,pnum,flag,next,idum)

    use fieldinfo_
    use maskinfo_
    use sub_
    implicit none

    integer :: i,j,n,i2,i2max
    integer, intent(inout) :: idum,next
    integer, parameter :: nisim=2048,njsim=nisim
    real :: x
    real, pointer :: pos(:,:)
    integer, pointer :: num(:,:),pnum(:,:,:)
    logical*1, pointer :: flag(:)

    i2max=max(nint(1./(zwidth*ni)),1)
    do i=1,ni
       do i2=1,i2max
          if (ran2(idum)<=zfrac) then
             x=(i-1)+(i2-0.5)/float(i2max)
             do j=1,nj
                do n=1,num(i,j)
                   if (flag(pnum(i,j,n))) cycle
                   if (abs(pos(pnum(i,j,n),1)-x)<zwidth*ni/2.) then
                      flag(pnum(i,j,n))=.true.
                      next=next+1
                   endif
                enddo
             enddo
          endif
       enddo
    enddo

  end subroutine zpad

end program make_starmask


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

subroutine lin (p,flux)

!multilinear interpolation

use share, only: dp, ndim,indi,npix,n_p,ntot,ntimes,     &
                            f,ee,imap,                   &
			    f_format,f_access,fmtformat

implicit none

!input/output
real(dp),intent(in)	:: p(ndim)	!ndim vector of wanted pars [0-1]
real(dp),intent(out)	:: flux(npix)	!n vector of output fluxp

!local variables
integer			:: i,j,k,l	!dummy indices
real(dp)		:: t(ndim)	!input p's run 0-1, t's run 1-n_p(i)
real(dp)	 	:: wrk(npix,2**ndim) !(2**ndim) working matrix
real(dp)		:: delta	!t(indi(i))-int(t(indi(i)))
integer			:: findex(2**ndim)!indices of rows in f needed for
					  !the interpolation

!write(*,*)'in lin'

!	get t's from p's. The p's run between 0-1, while t's run
!	from the min to the max value of the indices of f (1<ti<n_pi)
t(1:ndim)=p(1:ndim)*(n_p(1:ndim)-1)+1.0_dp

do i=1,2**ndim
   findex(i)=dot_product(ntimes,int(t(1:ndim))+ee(1:ndim,i)-1)+1
enddo

!load wrk
if (f_access == 0) then
  do i=1,2**ndim
	wrk(1:npix,i)=f(1:npix,findex(imap(i)))
  enddo
else
  !$omp critical
  if (f_format == 0) then
  	do i=1,2**ndim
  		read(10,fmtformat,rec=findex(imap(i))) wrk(1:npix,i)
  	enddo
  else
  	do i=1,2**ndim
  		read(10,rec=findex(imap(i))) wrk(1:npix,i)
  	enddo
  endif
  !$omp end critical
endif

!interpolate
do i=1,ndim
	delta=t(indi(i))-int(t(indi(i)))
	do j=1,2**(ndim-i)
		wrk(1:npix,j)=wrk(1:npix,2*j-1) + (wrk(1:npix,2*j)-wrk(1:npix,2*j-1))* &
		!(t(ndim-i+1)-int(t(ndim-i+1)))   !original
		!(t(indi(i))-int(t(indi(i))))     !allow new interp. order
		delta				  !faster
	enddo
enddo
flux(1:npix)=wrk(1:npix,1)

!write(*,*)'exiting lin'

end subroutine lin


      program main_fft

c---------------------------------------------------------------------
c---------------------------------------------------------------------
      use global
      implicit none

      include 'mpif.h'
      integer i, ierr

c---------------------------------------------------------------------
c u0, u1, u2 are the main arrays in the problem.
c Depending on the decomposition, these arrays will have different
c dimensions. To accomodate all possibilities, we allocate them as
c one-dimensional arrays and pass them to subroutines for different
c views
c  - u0 contains the initial (transformed) initial condition
c  - u1 and u2 are working arrays
c---------------------------------------------------------------------

      double complex, allocatable ::  u0(:),u1(:),u2(:)
      double precision,allocatable :: twiddle(:)

      double complex pad1(3), pad2(3), pad3(3)
c      integer ::
      double complex :: dbg_dc_val
      double precision :: dbg_d_val

      integer iter
      double precision total_time, mflops
      logical verified
      character class
      call MPI_Init(ierr)

c---------------------------------------------------------------------
c Run the entire problem once to make sure all data is touched.
c This reduces variable startup costs, which is important for such a
c short benchmark.
c---------------------------------------------------------------------
      do i = 1, t_max
         call timer_clear(i)
      end do

      call timer_start(T_init)
      call setup()
      ntdivnp=((nx*ny)/np_min)*nz
      ntotal_f=1.d0*nx*ny*nz
      allocate(u(nx),u0(ntdivnp),u1(ntdivnp),u2(ntdivnp))
      allocate(sums(0:niter_default))
      allocate(twiddle(ntdivnp))
      call compute_indexmap(twiddle, dims(1,3), dims(2,3), dims(3,3))
      call compute_initial_conditions(u1, dims(1,1), dims(2,1),
     >                                dims(3,1))
      call fft_init (dims(1,1))
      call fft(1, u1, u0)
      call timer_stop(T_init)
      if (me .eq. 0) then
         print *,'Initialization time =',timer_read(T_init)
      endif

c---------------------------------------------------------------------
c Start over from the beginning. Note that all operations must
c be timed, in contrast to other benchmarks.
c---------------------------------------------------------------------

      do i = 1, t_max
         call timer_clear(i)
      end do
      call MPI_Barrier(MPI_COMM_WORLD, ierr)

      call timer_start(t_total)

      call compute_indexmap(twiddle, dims(1,3), dims(2,3), dims(3,3))
      call compute_initial_conditions(u1, dims(1,1), dims(2,1),
     >                                dims(3,1))
      call fft_init (dims(1,1))

      call fft(1, u1, u0)

      if(me .eq. 0) then
         print *, "<check> fortran"
         print *, niter, fftblockpad_default, maxdim
         print *, fftblock, layout_type, me
         print *, np1, np2, np
         print *, ntdivnp
         print *, transblockpad, transblock, fftblockpad
         print *, nx, ny, nz
         print *, "</check> fortran"
      endif
      call c_param_init(u0, u1, u2, twiddle, dims, niter,
     >         fftblockpad_default, fftblock, maxdim, layout_type,
     >         u, me, np1, np2, ntdivnp,
     >         np, transblockpad,
     >         transblock, fftblockpad,
     >         nx, ny, nz,
     >         xstart, ystart, zstart,
     >         xend, yend, zend, sums)

      if(me .eq. 0) then
         dbg_dc_val = (2.5, 22.1)
         dbg_d_val = -7.9
         print *, "<fortran dbg: "
         print *, dbg_d_val, real(dbg_dc_val), imag(dbg_dc_val)
         print *, dconjg(dbg_dc_val)
         print *, dbg_dc_val * dbg_d_val
         print *, dbg_dc_val * (-2.0, -2.0)
         print *, dbg_dc_val + (-2.0, -2.0)
         print *, dbg_dc_val - (-2.0, -2.0)
         print *, "</fortran dbg: "
         call fortran_c_dbg(dbg_dc_val, dbg_d_val)
      endif

      call c_fft_iter()

c      do iter = 1, niter
c         call evolve(u0, u1, twiddle, dims(1,1), dims(2,1), dims(3,1))
c!         if(mod(iter,100) .eq. 0) then
c         call fft(-1, u1, u2)
c!         if (timers_enabled) call synchup()
c            call checksum(iter, u2, dims(1,1), dims(2,1), dims(3,1))
c!         endif
c      end do

      call c_finalize()

      call timer_stop(t_total)
      total_time = timer_read(t_total)

      if( total_time .ne. 0. ) then
         mflops = 1.0d-6*ntotal_f *
     >             (14.8157+7.19641*log(ntotal_f)
     >          +  (5.23518+7.21113*log(ntotal_f))*niter)
     >                 /total_time
      else
         mflops = 0.0
      endif
      if (me .eq. 0) then
         call print_results('FT', class, nx, ny, nz, niter, np_min, np,
     >     total_time, mflops, '          floating point', verified,
     >     npbversion, compiletime, cs1, cs2, cs3, cs4, cs5, cs6, cs7)
      endif
C       if (me .eq. 0) print *, "total time = ", total_time
      if (timers_enabled) call print_timers()
      deallocate(u,u0,u1,u2)
      deallocate(sums)
      deallocate(twiddle)
      call MPI_Finalize(ierr)
      end

      subroutine mmpmmpmmp(i, allchk)
      use global
      implicit none
      integer :: i
      double complex allchk

      sums(i) = allchk

      print *, sums(i)

      end

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine evolve(u0, u1, twiddle, d1, d2, d3)

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c evolve u0 -> u1 (t time steps) in fourier space
c---------------------------------------------------------------------
      use global
      implicit none
c      include 'global.h'
      integer d1, d2, d3
      double precision exi
      double complex u0(d1,d2,d3)
      double complex u1(d1,d2,d3)
      double precision twiddle(d1,d2,d3)
      integer i, j, k

      do k = 1, d3
         do j = 1, d2
            do i = 1, d1
               u0(i,j,k) = u0(i,j,k)*(twiddle(i,j,k))
               u1(i,j,k) = u0(i,j,k)
            end do
         end do
      end do

      return
      end

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine compute_initial_conditions(u0, d1, d2, d3)

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c Fill in array u0 with initial conditions from
c random number generator
c---------------------------------------------------------------------
      use global
      implicit none
c      include 'global.h'
      integer d1, d2, d3
      double complex u0(d1, d2, d3)
      integer k
      double precision x0, start, an, dummy

c---------------------------------------------------------------------
c 0-D and 1-D layouts are easy because each processor gets a contiguous
c chunk of the array, in the Fortran ordering sense.
c For a 2-D layout, it's a bit more complicated. We always
c have entire x-lines (contiguous) in processor.
c We can do ny/np1 of them at a time since we have
c ny/np1 contiguous in y-direction. But then we jump
c by z-planes (nz/np2 of them, total).
c For the 0-D and 1-D layouts we could do larger chunks, but
c this turns out to have no measurable impact on performance.
c---------------------------------------------------------------------

      start = seed
c---------------------------------------------------------------------
c Jump to the starting element for our first plane.
c---------------------------------------------------------------------
      call ipow46(a, 2*nx, (zstart(1)-1)*ny + (ystart(1)-1), an)
      dummy = randlc(start, an)
      call ipow46(a, 2*nx, ny, an)

c---------------------------------------------------------------------
c Go through by z planes filling in one square at a time.
c---------------------------------------------------------------------
      do k = 1, dims(3, 1) ! nz/np2
         x0 = start
         call vranlc(2*nx*dims(2, 1), x0, a, u0(1, 1, k))
         if (k .ne. dims(3, 1)) dummy = randlc(start, an)
      end do

      return
      end

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine ipow46(a, exp_1, exp_2, result)

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c compute a^exponent mod 2^46
c---------------------------------------------------------------------

      implicit none
      double precision a, result, dummy, q, r
      integer exp_1, exp_2, n, n2, ierr
      external randlc
      double precision randlc
      logical  two_pow
c---------------------------------------------------------------------
c Use
c   a^n = a^(n/2)*a^(n/2) if n even else
c   a^n = a*a^(n-1)       if n odd
c---------------------------------------------------------------------
      result = 1
      if (exp_2 .eq. 0 .or. exp_1 .eq. 0) return
      q = a
      r = 1
      n = exp_1
      two_pow = .true.

      do while (two_pow)
         n2 = n/2
         if (n2 * 2 .eq. n) then
            dummy = randlc(q, q)
            n = n2
         else
            n = n * exp_2
            two_pow = .false.
         endif
      end do

      do while (n .gt. 1)
         n2 = n/2
         if (n2 * 2 .eq. n) then
            dummy = randlc(q, q)
            n = n2
         else
            dummy = randlc(r, q)
            n = n-1
         endif
      end do
      dummy = randlc(r, q)
      result = r
      return
      end

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine setup

c---------------------------------------------------------------------
c---------------------------------------------------------------------
      use global
      implicit none
      include 'mpinpb.h'
c      include 'global.h'

      integer ierr, i, j, fstatus
      debug = .FALSE.

      call MPI_Comm_size(MPI_COMM_WORLD, np, ierr)
      call MPI_Comm_rank(MPI_COMM_WORLD, me, ierr)

      if (.not. convertdouble) then
         dc_type = MPI_DOUBLE_COMPLEX
      else
         dc_type = MPI_COMPLEX
      endif

      if (me .eq. 0) then
         write(*, 1000)

         open (unit=2,file='timer.flag',status='old',iostat=fstatus)
         timers_enabled = .false.
         if (fstatus .eq. 0) then
            timers_enabled = .true.
            close(2)
         endif

         open (unit=2,file='inputft.data',status='old', iostat=fstatus)

         if (fstatus .eq. 0) then
            write(*,233)
 233        format(' Reading from input file inputft.data')
            read (2,*) nx,ny,nz,maxdim
            read (2,*) niter_default
            read (2,*) np_min
!            read (2,*) niter
            read (2,*) layout_type
            read (2,*) np1, np2
            close(2)
            niter=niter_default
c---------------------------------------------------------------------
c check to make sure input data is consistent
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c 1. product of processor grid dims must equal number of processors
c---------------------------------------------------------------------

            if (np1 * np2 .ne. np) then
               write(*, 238)
 238           format(' np1 and np2 given in input file are not valid.')
               write(*, 239) np1*np2, np
 239           format(' Product is ', i5, ' and should be ', i5)
               call MPI_Abort(MPI_COMM_WORLD, 1, ierr)
            endif

c---------------------------------------------------------------------
c 2. layout type must be valid
c---------------------------------------------------------------------

            if (layout_type .ne. layout_0D .and.
     >          layout_type .ne. layout_1D .and.
     >          layout_type .ne. layout_2D) then
               write(*, 240)
 240           format(' Layout type specified in inputft.data is
     >                  invalid ')
               call MPI_Abort(MPI_COMM_WORLD, 1, ierr)
            endif

c---------------------------------------------------------------------
c 3. 0D layout must be 1x1 grid
c---------------------------------------------------------------------

            if (layout_type .eq. layout_0D .and.
     >            (np1 .ne.1 .or. np2 .ne. 1)) then
               write(*, 241)
 241           format(' For 0D layout, both np1 and np2 must be 1 ')
               call MPI_Abort(MPI_COMM_WORLD, 1, ierr)
            endif
c---------------------------------------------------------------------
c 4. 1D layout must be 1xN grid
c---------------------------------------------------------------------

            if (layout_type .eq. layout_1D .and. np1 .ne. 1) then
               write(*, 242)
 242           format(' For 1D layout, np1 must be 1 ')
               call MPI_Abort(MPI_COMM_WORLD, 1, ierr)
            endif

         else
            write(*,234)
            if (np .eq. 1) then
               np1 = 1
               np2 = 1
               layout_type = layout_0D
            else if (np .le. nz) then
               np1 = 1
               np2 = np
               layout_type = layout_1D
            else
               np1 = nz
               np2 = np/nz
               layout_type = layout_2D
            endif
         endif

         if (np .lt. np_min) then
            write(*, 10) np_min
 10         format(' Error: Compiled for ', I5, ' processors. ')
            write(*, 11) np
 11         format(' Only ',  i5, ' processors found ')
            call MPI_Abort(MPI_COMM_WORLD, 1, ierr)
         endif

 234     format(' No input file inputft.data. Using compiled defaults')
         write(*, 1001) nx, ny, nz
         write(*, 1002) niter
         write(*, 1004) np
         write(*, 1005) np1, np2
!         if (np .ne. np_min) write(*, 1006) np_min

         if (layout_type .eq. layout_0D) then
            write(*, 1010) '0D'
         else if (layout_type .eq. layout_1D) then
            write(*, 1010) '1D'
         else
            write(*, 1010) '2D'
         endif

 1000 format(//,' CPC -- FFT Benchmark',/)
 1001    format(' Size                : ', i4, 'x', i4, 'x', i4)
 1002    format(' Iterations          : ', 7x, i7)
 1004    format(' Number of processes : ', 7x, i7)
 1005    format(' Processor array     : ', 5x, i4, 'x', i4)
 1006    format(' WARNING: compiled for ', i5, ' processes. ',
     >          ' Will not verify. ')
 1010    format(' Layout type         : ', 9x, A5)
      endif

c---------------------------------------------------------------------
c Broadcast parameters
c---------------------------------------------------------------------
      call MPI_BCAST(np1, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
      call MPI_BCAST(np2, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
      call MPI_BCAST(layout_type, 1, MPI_INTEGER, 0, MPI_COMM_WORLD,
     &               ierr)
      call MPI_BCAST(niter, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
      call MPI_BCAST(nx, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
      call MPI_BCAST(ny, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
      call MPI_BCAST(nz, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
      call MPI_BCAST(maxdim, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
      call MPI_BCAST(niter_default, 1, MPI_INTEGER, 0, MPI_COMM_WORLD,
     &              ierr)
      call MPI_BCAST(np_min, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
c      call MPI_BCAST(timers_enabled, 1, MPI_LOGICAL, 0, MPI_COMM_WORLD,
c     &               ierr)

      if (np1 .eq. 1 .and. np2 .eq. 1) then
        layout_type = layout_0D
      else if (np1 .eq. 1) then
         layout_type = layout_1D
      else
         layout_type = layout_2D
      endif

      if (layout_type .eq. layout_0D) then
         do i = 1, 3
            dims(1, i) = nx
            dims(2, i) = ny
            dims(3, i) = nz
         end do
      else if (layout_type .eq. layout_1D) then
         dims(1, 1) = nx
         dims(2, 1) = ny
         dims(3, 1) = nz

         dims(1, 2) = nx
         dims(2, 2) = ny
         dims(3, 2) = nz

         dims(1, 3) = nz
         dims(2, 3) = nx
         dims(3, 3) = ny
      else if (layout_type .eq. layout_2D) then
         dims(1, 1) = nx
         dims(2, 1) = ny
         dims(3, 1) = nz

         dims(1, 2) = ny
         dims(2, 2) = nx
         dims(3, 2) = nz

         dims(1, 3) = nz
         dims(2, 3) = nx
         dims(3, 3) = ny

      endif
      do i = 1, 3
         dims(2, i) = dims(2, i) / np1
         dims(3, i) = dims(3, i) / np2
      end do

c---------------------------------------------------------------------
c Determine processor coordinates of this processor
c Processor grid is np1xnp2.
c Arrays are always (n1, n2/np1, n3/np2)
c Processor coords are zero-based.
c---------------------------------------------------------------------
      me2 = mod(me, np2)  ! goes from 0...np2-1
      me1 = me/np2        ! goes from 0...np1-1
c---------------------------------------------------------------------
c Communicators for rows/columns of processor grid.
c commslice1 is communicator of all procs with same me1, ranked as me2
c commslice2 is communicator of all procs with same me2, ranked as me1
c mpi_comm_split(comm, color, key, ...)
c---------------------------------------------------------------------
      call MPI_Comm_split(MPI_COMM_WORLD, me1, me2, commslice1, ierr)
      call MPI_Comm_split(MPI_COMM_WORLD, me2, me1, commslice2, ierr)
!      if (timers_enabled) call synchup()

      if (debug) print *, 'proc coords: ', me, me1, me2

c---------------------------------------------------------------------
c Determine which section of the grid is owned by this
c processor.
c---------------------------------------------------------------------
      if (layout_type .eq. layout_0d) then

         do i = 1, 3
            xstart(i) = 1
            xend(i)   = nx
            ystart(i) = 1
            yend(i)   = ny
            zstart(i) = 1
            zend(i)   = nz
         end do

      else if (layout_type .eq. layout_1d) then

         xstart(1) = 1
         xend(1)   = nx
         ystart(1) = 1
         yend(1)   = ny
         zstart(1) = 1 + me2 * nz/np2
         zend(1)   = (me2+1) * nz/np2

         xstart(2) = 1
         xend(2)   = nx
         ystart(2) = 1
         yend(2)   = ny
         zstart(2) = 1 + me2 * nz/np2
         zend(2)   = (me2+1) * nz/np2

         xstart(3) = 1
         xend(3)   = nx
         ystart(3) = 1 + me2 * ny/np2
         yend(3)   = (me2+1) * ny/np2
         zstart(3) = 1
         zend(3)   = nz

      else if (layout_type .eq. layout_2d) then

         xstart(1) = 1
         xend(1)   = nx
         ystart(1) = 1 + me1 * ny/np1
         yend(1)   = (me1+1) * ny/np1
         zstart(1) = 1 + me2 * nz/np2
         zend(1)   = (me2+1) * nz/np2

         xstart(2) = 1 + me1 * nx/np1
         xend(2)   = (me1+1)*nx/np1
         ystart(2) = 1
         yend(2)   = ny
         zstart(2) = zstart(1)
         zend(2)   = zend(1)

         xstart(3) = xstart(2)
         xend(3)   = xend(2)
         ystart(3) = 1 + me2 *ny/np2
         yend(3)   = (me2+1)*ny/np2
         zstart(3) = 1
         zend(3)   = nz
      endif

c---------------------------------------------------------------------
c Set up info for blocking of ffts and transposes.  This improves
c performance on cache-based systems. Blocking involves
c working on a chunk of the problem at a time, taking chunks
c along the first, second, or third dimension.
c
c - In cffts1 blocking is on 2nd dimension (with fft on 1st dim)
c - In cffts2/3 blocking is on 1st dimension (with fft on 2nd and 3rd dims)

c Since 1st dim is always in processor, we'll assume it's long enough
c (default blocking factor is 16 so min size for 1st dim is 16)
c The only case we have to worry about is cffts1 in a 2d decomposition.
c so the blocking factor should not be larger than the 2nd dimension.
c---------------------------------------------------------------------

      fftblock = fftblock_default
      fftblockpad = fftblockpad_default

      if (layout_type .eq. layout_2d) then
         if (dims(2, 1) .lt. fftblock) fftblock = dims(2, 1)
         if (dims(2, 2) .lt. fftblock) fftblock = dims(2, 2)
         if (dims(2, 3) .lt. fftblock) fftblock = dims(2, 3)
      endif

      if (fftblock .ne. fftblock_default) fftblockpad = fftblock+3

      return
      end

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine compute_indexmap(twiddle, d1, d2, d3)

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c compute function from local (i,j,k) to ibar^2+jbar^2+kbar^2
c for time evolution exponent.
c---------------------------------------------------------------------
      use global
      implicit none
      include 'mpinpb.h'
c      include 'global.h'
      integer d1, d2, d3
      integer i, j, k, ii, ii2, jj, ij2, kk
      double precision ap, twiddle(d1, d2, d3)

c---------------------------------------------------------------------
c this function is very different depending on whether
c we are in the 0d, 1d or 2d layout. Compute separately.
c basically we want to convert the fortran indices
c   1 2 3 4 5 6 7 8
c to
c   0 1 2 3 -4 -3 -2 -1
c The following magic formula does the trick:
c mod(i-1+n/2, n) - n/2
c---------------------------------------------------------------------

      ap = - 4.d0 * alpha * pi *pi

      if (layout_type .eq. layout_0d) then ! xyz layout
         do i = 1, dims(1,3)
            ii =  mod(i+xstart(3)-2+nx/2, nx) - nx/2
            ii2 = ii*ii
            do j = 1, dims(2,3)
               jj = mod(j+ystart(3)-2+ny/2, ny) - ny/2
               ij2 = jj*jj+ii2
               do k = 1, dims(3,3)
                  kk = mod(k+zstart(3)-2+nz/2, nz) - nz/2
                  twiddle(i,j,k) = dexp(ap*dfloat(kk*kk+ij2))
               end do
            end do
         end do
      else if (layout_type .eq. layout_1d) then ! zxy layout
         do i = 1,dims(2,3)
            ii =  mod(i+xstart(3)-2+nx/2, nx) - nx/2
            ii2 = ii*ii
            do j = 1,dims(3,3)
               jj = mod(j+ystart(3)-2+ny/2, ny) - ny/2
               ij2 = jj*jj+ii2
               do k = 1,dims(1,3)
                  kk = mod(k+zstart(3)-2+nz/2, nz) - nz/2
                  twiddle(k,i,j) = dexp(ap*dfloat(kk*kk+ij2))
               end do
            end do
         end do
      else if (layout_type .eq. layout_2d) then ! zxy layout
         do i = 1,dims(2,3)
            ii =  mod(i+xstart(3)-2+nx/2, nx) - nx/2
            ii2 = ii*ii
            do j = 1, dims(3,3)
               jj = mod(j+ystart(3)-2+ny/2, ny) - ny/2
               ij2 = jj*jj+ii2
               do k =1,dims(1,3)
                  kk = mod(k+zstart(3)-2+nz/2, nz) - nz/2
                  twiddle(k,i,j) = dexp(ap*dfloat(kk*kk+ij2))
               end do
            end do
         end do
      else
         print *, ' Unknown layout type ', layout_type
         stop
      endif

      return
      end

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine print_timers()

c---------------------------------------------------------------------
c---------------------------------------------------------------------
      use global
      implicit none
      integer i, ierr
c      include 'global.h'
      include 'mpinpb.h'
      character*25 tstrings(T_max+2)
      double precision t1(T_max+2), tsum(T_max+2),
     >                 tming(T_max+2), tmaxg(T_max+2)
      data tstrings / '          total ',
     >                '          vnpsetup ',
     >                '            fft ',
     >                '         evolve ',
     >                '       checksum ',
     >                '         fftlow ',
     >                '        fftcopy ',
     >                '      transpose ',
     >                ' transpose1_loc ',
     >                ' transpose1_glo ',
     >                ' transpose1_fin ',
     >                ' transpose2_loc ',
     >                ' transpose2_glo ',
     >                ' transpose2_fin ',
     >                '           sync ',
     >                '           init ',
     >                '        totcomp ',
     >                '        totcomm ' /

      do i = 1, t_max
         t1(i) = timer_read(i)
      end do
      t1(t_max+2) = t1(t_transxzglo) + t1(t_transxyglo) + t1(t_synch)
      t1(t_max+1) = t1(t_total) - t1(t_max+2)

      call MPI_Reduce(t1, tsum,  t_max+2, MPI_DOUBLE_PRECISION,
     >                MPI_SUM, 0, MPI_COMM_WORLD, ierr)
      call MPI_Reduce(t1, tming, t_max+2, MPI_DOUBLE_PRECISION,
     >                MPI_MIN, 0, MPI_COMM_WORLD, ierr)
      call MPI_Reduce(t1, tmaxg, t_max+2, MPI_DOUBLE_PRECISION,
     >                MPI_MAX, 0, MPI_COMM_WORLD, ierr)

      if (me .ne. 0) return
      write(*, 800) np
      do i = 1, t_max+2
         if (tsum(i) .ne. 0.0d0) then
            write(*, 810) i, tstrings(i), tming(i), tmaxg(i), tsum(i)/np
         endif
      end do
 800  format(' nprocs =', i6, 19x, 'minimum', 5x, 'maximum',
     >       5x, 'average')
 810  format(' timer ', i2, '(', A16, ') :', 3(2X,F10.4))
      return
      end

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine fft(dir, x1, x2)

c---------------------------------------------------------------------
c---------------------------------------------------------------------
      use global
      implicit none
c      include 'global.h'
      integer dir
      double complex x1(ntdivnp), x2(ntdivnp)

      double complex scratch(fftblockpad_default*maxdim*2)

c---------------------------------------------------------------------
c note: args x1, x2 must be different arrays
c note: args for cfftsx are (direction, layout, xin, xout, scratch)
c       xin/xout may be the same and it can be somewhat faster
c       if they are
c note: args for transpose are (layout1, layout2, xin, xout)
c       xin/xout must be different
c---------------------------------------------------------------------

      if (dir .eq. 1) then
         if (layout_type .eq. layout_0d) then
c            print *, "dir .eq. 1, 0d"
            call cffts1(1, dims(1,1), dims(2,1), dims(3,1),
     >                  x1, x1, scratch)
            call cffts2(1, dims(1,2), dims(2,2), dims(3,2),
     >                  x1, x1, scratch)
            call cffts3(1, dims(1,3), dims(2,3), dims(3,3),
     >                  x1, x2, scratch)
         else if (layout_type .eq. layout_1d) then
c            print *, "dir .eq. 1, 1d"
            call cffts1(1, dims(1,1), dims(2,1), dims(3,1),
     >                  x1, x1, scratch)
            call cffts2(1, dims(1,2), dims(2,2), dims(3,2),
     >                  x1, x1, scratch)
            if (timers_enabled) call timer_start(T_transpose)
            call transpose_xy_z(2, 3, x1, x2)
            if (timers_enabled) call timer_stop(T_transpose)
            call cffts1(1, dims(1,3), dims(2,3), dims(3,3),
     >                  x2, x2, scratch)
         else if (layout_type .eq. layout_2d) then
c            print *, "dir .eq. 1, 2d"
            call cffts1(1, dims(1,1), dims(2,1), dims(3,1),
     >                  x1, x1, scratch)
            if (timers_enabled) call timer_start(T_transpose)
            call transpose_x_y(1, 2, x1, x2)
            if (timers_enabled) call timer_stop(T_transpose)
            call cffts1(1, dims(1,2), dims(2,2), dims(3,2),
     >                  x2, x2, scratch)
            if (timers_enabled) call timer_start(T_transpose)
            call transpose_x_z(2, 3, x2, x1)
            if (timers_enabled) call timer_stop(T_transpose)
            call cffts1(1, dims(1,3), dims(2,3), dims(3,3),
     >                  x1, x2, scratch)
         endif
      else
         if (layout_type .eq. layout_0d) then
c            print *, "dir .eq. -1, 0d"
            call cffts3(-1, dims(1,3), dims(2,3), dims(3,3),
     >                  x1, x1, scratch)
            call cffts2(-1, dims(1,2), dims(2,2), dims(3,2),
     >                  x1, x1, scratch)
            call cffts1(-1, dims(1,1), dims(2,1), dims(3,1),
     >                  x1, x2, scratch)
         else if (layout_type .eq. layout_1d) then
c            print *, "dir .eq. -1, 1d"
            call cffts1(-1, dims(1,3), dims(2,3), dims(3,3),
     >                  x1, x1, scratch)
            if (timers_enabled) call timer_start(T_transpose)
            call transpose_x_yz(3, 2, x1, x2)
            if (timers_enabled) call timer_stop(T_transpose)
            call cffts2(-1, dims(1,2), dims(2,2), dims(3,2),
     >                  x2, x2, scratch)
            call cffts1(-1, dims(1,1), dims(2,1), dims(3,1),
     >                  x2, x2, scratch)
         else if (layout_type .eq. layout_2d) then
c            print *, "dir .eq. -1, 2d"
            call cffts1(-1, dims(1,3), dims(2,3), dims(3,3),
     >                  x1, x1, scratch)
            if (timers_enabled) call timer_start(T_transpose)
            call transpose_x_z(3, 2, x1, x2)
            if (timers_enabled) call timer_stop(T_transpose)
            call cffts1(-1, dims(1,2), dims(2,2), dims(3,2),
     >                  x2, x2, scratch)
            if (timers_enabled) call timer_start(T_transpose)
            call transpose_x_y(2, 1, x2, x1)
            if (timers_enabled) call timer_stop(T_transpose)
            call cffts1(-1, dims(1,1), dims(2,1), dims(3,1),
     >                  x1, x2, scratch)
         endif
      endif
      return
      end

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine cffts1(is, d1, d2, d3, x, xout, y)

c---------------------------------------------------------------------
c---------------------------------------------------------------------
      use global
      implicit none

c      include 'global.h'
      integer is, d1, d2, d3, logd1
      double complex x(d1,d2,d3)
      double complex xout(d1,d2,d3)
      double complex y(fftblockpad, d1, 2)
      integer i, j, k, jj

      logd1 = ilog2(d1)

      do k = 1, d3
         do jj = 0, d2 - fftblock, fftblock
            if (timers_enabled) call timer_start(T_fftcopy)
            do j = 1, fftblock
               do i = 1, d1
                  y(j,i,1) = x(i,j+jj,k)
               enddo
            enddo
            if (timers_enabled) call timer_stop(T_fftcopy)

            if (timers_enabled) call timer_start(T_fftlow)
            call cfftz (is, logd1, d1, y, y(1,1,2))
            if (timers_enabled) call timer_stop(T_fftlow)

            if (timers_enabled) call timer_start(T_fftcopy)
            do j = 1, fftblock
               do i = 1, d1
                  xout(i,j+jj,k) = y(j,i,1)
               enddo
            enddo
            if (timers_enabled) call timer_stop(T_fftcopy)
         enddo
      enddo

      return
      end

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine cffts2(is, d1, d2, d3, x, xout, y)

c---------------------------------------------------------------------
c---------------------------------------------------------------------
      use global
      implicit none

c      include 'global.h'
      integer is, d1, d2, d3, logd2
      double complex x(d1,d2,d3)
      double complex xout(d1,d2,d3)
      double complex y(fftblockpad, d2, 2)
      integer i, j, k, ii

      logd2 = ilog2(d2)

      do k = 1, d3
        do ii = 0, d1 - fftblock, fftblock
           if (timers_enabled) call timer_start(T_fftcopy)
           do j = 1, d2
              do i = 1, fftblock
                 y(i,j,1) = x(i+ii,j,k)
              enddo
           enddo
           if (timers_enabled) call timer_stop(T_fftcopy)

           if (timers_enabled) call timer_start(T_fftlow)
           call cfftz (is, logd2, d2, y, y(1, 1, 2))
           if (timers_enabled) call timer_stop(T_fftlow)

           if (timers_enabled) call timer_start(T_fftcopy)
           do j = 1, d2
              do i = 1, fftblock
                 xout(i+ii,j,k) = y(i,j,1)
              enddo
           enddo
           if (timers_enabled) call timer_stop(T_fftcopy)
        enddo
      enddo

      return
      end

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine cffts3(is, d1, d2, d3, x, xout, y)

c---------------------------------------------------------------------
c---------------------------------------------------------------------
      use global
      implicit none

c      include 'global.h'
      integer is, d1, d2, d3, logd3
      double complex x(d1,d2,d3)
      double complex xout(d1,d2,d3)
      double complex y(fftblockpad, d3, 2)
      integer i, j, k, ii

      logd3 = ilog2(d3)

      do j = 1, d2
        do ii = 0, d1 - fftblock, fftblock
           if (timers_enabled) call timer_start(T_fftcopy)
           do k = 1, d3
              do i = 1, fftblock
                 y(i,k,1) = x(i+ii,j,k)
              enddo
           enddo
           if (timers_enabled) call timer_stop(T_fftcopy)

           if (timers_enabled) call timer_start(T_fftlow)
           call cfftz (is, logd3, d3, y, y(1, 1, 2))
           if (timers_enabled) call timer_stop(T_fftlow)

           if (timers_enabled) call timer_start(T_fftcopy)
           do k = 1, d3
              do i = 1, fftblock
                 xout(i+ii,j,k) = y(i,k,1)
              enddo
           enddo
           if (timers_enabled) call timer_stop(T_fftcopy)
        enddo
      enddo

      return
      end

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine fft_init (n)

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c compute the roots-of-unity array that will be used for subsequent FFTs.
c---------------------------------------------------------------------
      use global
      implicit none
c      include 'global.h'

      integer m,n,nu,ku,i,j,ln
      double precision t, ti

c---------------------------------------------------------------------
c   Initialize the U array with sines and cosines in a manner that permits
c   stride one access at each FFT iteration.
c---------------------------------------------------------------------
      nu = n
      m = ilog2(n)
      u(1) = m
      ku = 2
      ln = 1

      do j = 1, m
         t = pi / ln

         do i = 0, ln - 1
            ti = i * t
            u(i+ku) = dcmplx (cos (ti), sin(ti))
         enddo

         ku = ku + ln
         ln = 2 * ln
      enddo

      return
      end

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine cfftz (is, m, n, x, y)

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c   Computes NY N-point complex-to-complex FFTs of X using an algorithm due
c   to Swarztrauber.  X is both the input and the output array, while Y is a
c   scratch array.  It is assumed that N = 2^M.  Before calling CFFTZ to
c   perform FFTs, the array U must be initialized by calling CFFTZ with IS
c   set to 0 and M set to MX, where MX is the maximum value of M for any
c   subsequent call.
c---------------------------------------------------------------------
      use global
      implicit none
c      include 'global.h'

      integer is,m,n,i,j,l,mx
      double complex x, y

      dimension x(fftblockpad,n), y(fftblockpad,n)
c---------------------------------------------------------------------
c   Check if input parameters are invalid.
c---------------------------------------------------------------------
      mx = u(1)
      if ((is .ne. 1 .and. is .ne. -1) .or. m .lt. 1 .or. m .gt. mx)
     >  then
        write (*, 1)  is, m, mx
 1      format ('CFFTZ: Either U has not been initialized, or else'/
     >    'one of the input parameters is invalid', 3I5)
        stop
      endif

c---------------------------------------------------------------------
c   Perform one variant of the Stockham FFT.
c---------------------------------------------------------------------
      do l = 1, m, 2
        call fftz2 (is, l, m, n, fftblock, fftblockpad, u, x, y)
        if (l .eq. m) goto 160
        call fftz2 (is, l + 1, m, n, fftblock, fftblockpad, u, y, x)
      enddo

      goto 180

c---------------------------------------------------------------------
c   Copy Y to X.
c---------------------------------------------------------------------
 160  do j = 1, n
        do i = 1, fftblock
          x(i,j) = y(i,j)
        enddo
      enddo

 180  continue

      return
      end

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine fftz2 (is, l, m, n, ny, ny1, u, x, y)

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c   Performs the L-th iteration of the second variant of the Stockham FFT.
c---------------------------------------------------------------------
        use global, only:me
      implicit none

      integer is,k,l,m,n,ny,ny1,n1,li,lj,lk,ku,i,j,i11,i12,i21,i22
      double complex u,x,y,u1,x11,x21
      dimension u(n), x(ny1,n), y(ny1,n)

c      print *, real(u(1)), imag(u(1)), u(1)

c      print *, is, l, m, n, ny, ny1

c      y(1, 1) = (1.5, 2.1)
c      y(2, 2) = (21.5, 22.1)

c      print *, "f y(1, 1) = ", y(1, 1)
c      print *, "f y(2, 2) = ", y(2, 2)
c      call c_fftz2 (is, l, m, n, ny, ny1, u(1), x(1, 1), y(1, 1))
c      return

c---------------------------------------------------------------------
c   Set initial parameters.
c---------------------------------------------------------------------

      n1 = n / 2
      lk = 2 ** (l - 1)
      li = 2 ** (m - l)
      lj = 2 * lk
      ku = li + 1

      do i = 0, li - 1
        i11 = i * lk + 1
        i12 = i11 + n1
        i21 = i * lj + 1
        i22 = i21 + lk
        if (is .ge. 1) then
          u1 = u(ku+i)
        else
          u1 = dconjg (u(ku+i))
        endif

c---------------------------------------------------------------------
c   This loop is vectorizable.
c   ni zhe ge da pian zi!
c---------------------------------------------------------------------
        do k = 0, lk - 1
          do j = 1, ny
c            print *, "i, k, j", i, k, j
            x11 = x(j,i11+k)
            x21 = x(j,i12+k)
            y(j,i21+k) = x11 + x21
            y(j,i22+k) = u1 * (x11 - x21)
          enddo
        enddo
      enddo

c      print *, "</y(1, 1) = ", y(1, 1)

      return
      end

      subroutine fortran_starstar(left_val, right_val, ret)
      implicit none
      integer left_val, right_val, ret
      ret = left_val ** right_val
      return
      end

      subroutine fortran_starstar_m1(left_val, right_val, ret)
      implicit none
      integer left_val, right_val, ret
      ret = left_val ** (right_val - 1)
      return
      end

      subroutine fortran_two_starstar_m1(m, li)
      implicit none
      integer m, li
      li = 2 ** (m - 1)
      !print *, "(- w -) (m - 1) = ", (m - 1)
      !print *, "(- w -) 2 ** (m - l) = ", 2 ** (m - l)
      return
      end

      subroutine fftz2_dbg (is, l, m, n, ny, ny1, u, x, y)

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c   Performs the L-th iteration of the second variant of the Stockham FFT.
c---------------------------------------------------------------------
        use global, only:me
      implicit none

      integer is,k,l,m,n,ny,ny1,n1,li,lj,lk,ku,i,j,i11,i12,i21,i22
      double complex u,x,y,u1,x11,x21
      dimension u(n), x(ny1,n), y(ny1,n)

      integer ret

c---------------------------------------------------------------------
c   Set initial parameters.
c---------------------------------------------------------------------

      n1 = n / 2
      lk = 2 ** (l - 1)
      li = 2 ** (m - l)
      lj = 2 * lk
      ku = li + 1

      print *, is, l, m, n, ny, ny1
      print *, n1, lk, li, lj, ku

      do i = 0, li - 1
        i11 = i * lk + 1
        i12 = i11 + n1
        i21 = i * lj + 1
        i22 = i21 + lk
        if (is .ge. 1) then
          u1 = u(ku+i)
        else
          u1 = dconjg (u(ku+i))
        endif

c---------------------------------------------------------------------
c   This loop is vectorizable.
c   ni zhe ge da pian zi!
c---------------------------------------------------------------------
        do k = 0, lk - 1
          do j = 1, ny
            x11 = x(j,i11+k)
            x21 = x(j,i12+k)
            print *, i, k, j
            print *, "x11 = ", x11
            print *, "x11 = ", x21
            print *, "u1 = ", u1
            y(j,i21+k) = x11 + x21
            y(j,i22+k) = u1 * (x11 - x21)
            print *, "y21 = ", y(j,i21+k)
            print *, "y22 = ", y(j,i22+k)
          enddo
        enddo
      enddo

c      print *, "</y(1, 1) = ", y(1, 1)

      return
      end

c---------------------------------------------------------------------

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      integer function ilog2(n)

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      implicit none
      integer n, nn, lg
      if (n .eq. 1) then
         ilog2=0
         return
      endif
      lg = 1
      nn = 2
      do while (nn .lt. n)
         nn = nn*2
         lg = lg+1
      end do
      ilog2 = lg
      return
      end

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine transpose_x_yz(l1, l2, xin, xout)

c---------------------------------------------------------------------
c---------------------------------------------------------------------
      use global
      implicit none
      integer l1, l2
      double complex xin(ntdivnp), xout(ntdivnp)

      call transpose2_local(dims(1,l1),dims(2, l1)*dims(3, l1),
     >                          xin, xout)

      call transpose2_global(xout, xin)

      call transpose2_finish(dims(1,l1),dims(2, l1)*dims(3, l1),
     >                          xin, xout)

      return
      end

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine transpose_xy_z(l1, l2, xin, xout)

c---------------------------------------------------------------------
c---------------------------------------------------------------------
      use global
      implicit none
      integer l1, l2
      double complex xin(ntdivnp), xout(ntdivnp)

      call transpose2_local(dims(1,l1)*dims(2, l1),dims(3, l1),
     >                          xin, xout)
      call transpose2_global(xout, xin)
      call transpose2_finish(dims(1,l1)*dims(2, l1),dims(3, l1),
     >                          xin, xout)

      return
      end

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine transpose2_local(n1, n2, xin, xout)

c---------------------------------------------------------------------
c---------------------------------------------------------------------
      use global
      implicit none
      include 'mpinpb.h'
      integer n1, n2
      double complex xin(n1, n2), xout(n2, n1)

      double complex z(transblockpad, transblock)

      integer i, j, ii, jj

      if (timers_enabled) call timer_start(T_transxzloc)

c---------------------------------------------------------------------
c If possible, block the transpose for cache memory systems.
c How much does this help? Example: R8000 Power Challenge (90 MHz)
c Blocked version decreases time spend in this routine
c from 14 seconds to 5.2 seconds on 8 nodes class A.
c---------------------------------------------------------------------

      if (n1 .lt. transblock .or. n2 .lt. transblock) then
         if (n1 .ge. n2) then
            do j = 1, n2
               do i = 1, n1
                  xout(j, i) = xin(i, j)
               end do
            end do
         else
            do i = 1, n1
               do j = 1, n2
                  xout(j, i) = xin(i, j)
               end do
            end do
         endif
      else
         do j = 0, n2-1, transblock
            do i = 0, n1-1, transblock

c---------------------------------------------------------------------
c Note: compiler should be able to take j+jj out of inner loop
c---------------------------------------------------------------------
               do jj = 1, transblock
                  do ii = 1, transblock
                     z(jj,ii) = xin(i+ii, j+jj)
                  end do
               end do

               do ii = 1, transblock
                  do jj = 1, transblock
                     xout(j+jj, i+ii) = z(jj,ii)
                  end do
               end do

            end do
         end do
      endif
      if (timers_enabled) call timer_stop(T_transxzloc)

      return
      end

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine transpose2_global(xin, xout)

c---------------------------------------------------------------------
c---------------------------------------------------------------------
      use global
      implicit none
      include 'mpinpb.h'
      double complex xin(ntdivnp)
      double complex xout(ntdivnp)
      integer ierr

!      if (timers_enabled) call synchup()

      if (timers_enabled) call timer_start(T_transxzglo)
      call mpi_alltoall(xin, ntdivnp/np, dc_type,
     >                  xout, ntdivnp/np, dc_type,
     >                  commslice1, ierr)
      if (timers_enabled) call timer_stop(T_transxzglo)

      return
      end

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine transpose2_finish(n1, n2, xin, xout)

c---------------------------------------------------------------------
c---------------------------------------------------------------------
      use global
      implicit none
      integer n1, n2, ioff
      double complex xin(n2, n1/np2, 0:np2-1), xout(n2*np2, n1/np2)

      integer i, j, p

      if (timers_enabled) call timer_start(T_transxzfin)
      do p = 0, np2-1
         ioff = p*n2
         do j = 1, n1/np2
            do i = 1, n2
               xout(i+ioff, j) = xin(i, j, p)
            end do
         end do
      end do
      if (timers_enabled) call timer_stop(T_transxzfin)

      return
      end

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine transpose_x_z(l1, l2, xin, xout)

c---------------------------------------------------------------------
c---------------------------------------------------------------------
      use global
      implicit none
      integer l1, l2
      double complex xin(ntdivnp), xout(ntdivnp)

      call transpose_x_z_local(dims(1,l1),dims(2,l1),dims(3,l1),
     >                         xin, xout)
      call transpose_x_z_global(dims(1,l1),dims(2,l1),dims(3,l1),
     >                          xout, xin)
      call transpose_x_z_finish(dims(1,l2),dims(2,l2),dims(3,l2),
     >                          xin, xout)
      return
      end

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine transpose_x_z_local(d1, d2, d3, xin, xout)

c---------------------------------------------------------------------
c---------------------------------------------------------------------
      use global
      implicit none
      integer d1, d2, d3
      double complex xin(d1,d2,d3)
      double complex xout(d3,d2,d1)
      integer block1, block3
      integer i, j, k, kk, ii, i1, k1

      double complex buf(transblockpad, maxdim)
      if (timers_enabled) call timer_start(T_transxzloc)
      if (d1 .lt. 32) goto 100
      block3 = d3
      if (block3 .eq. 1)  goto 100
      if (block3 .gt. transblock) block3 = transblock
      block1 = d1
      if (block1*block3 .gt. transblock*transblock)
     >          block1 = transblock*transblock/block3
c---------------------------------------------------------------------
c blocked transpose
c---------------------------------------------------------------------
      do j = 1, d2
         do kk = 0, d3-block3, block3
            do ii = 0, d1-block1, block1

               do k = 1, block3
                  k1 = k + kk
                  do i = 1, block1
                     buf(k, i) = xin(i+ii, j, k1)
                  end do
               end do

               do i = 1, block1
                  i1 = i + ii
                  do k = 1, block3
                     xout(k+kk, j, i1) = buf(k, i)
                  end do
               end do

            end do
         end do
      end do
      goto 200

c---------------------------------------------------------------------
c basic transpose
c---------------------------------------------------------------------
 100  continue

      do j = 1, d2
         do k = 1, d3
            do i = 1, d1
               xout(k, j, i) = xin(i, j, k)
            end do
         end do
      end do

c---------------------------------------------------------------------
c all done
c---------------------------------------------------------------------
 200  continue

      if (timers_enabled) call timer_stop(T_transxzloc)
      return
      end

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine transpose_x_z_global(d1, d2, d3, xin, xout)

c---------------------------------------------------------------------
c---------------------------------------------------------------------
      use global
      implicit none
      include 'mpinpb.h'
      integer d1, d2, d3
      double complex xin(d3,d2,d1)
      double complex xout(d3,d2,d1) ! not real layout, but right size
      integer ierr

!      if (timers_enabled) call synchup()

c---------------------------------------------------------------------
c do transpose among all  processes with same 1-coord (me1)
c---------------------------------------------------------------------
      if (timers_enabled)call timer_start(T_transxzglo)
      call mpi_alltoall(xin, d1*d2*d3/np2, dc_type,
     >                  xout, d1*d2*d3/np2, dc_type,
     >                  commslice1, ierr)
      if (timers_enabled) call timer_stop(T_transxzglo)
      return
      end

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine transpose_x_z_finish(d1, d2, d3, xin, xout)

c---------------------------------------------------------------------
c---------------------------------------------------------------------
      use global
      implicit none
      integer d1, d2, d3
      double complex xin(d1/np2, d2, d3, 0:np2-1)
      double complex xout(d1,d2,d3)
      integer i, j, k, p, ioff
      if (timers_enabled) call timer_start(T_transxzfin)
c---------------------------------------------------------------------
c this is the most straightforward way of doing it. the
c calculation in the inner loop doesn't help.
c      do i = 1, d1/np2
c         do j = 1, d2
c            do k = 1, d3
c               do p = 0, np2-1
c                  ii = i + p*d1/np2
c                  xout(ii, j, k) = xin(i, j, k, p)
c               end do
c            end do
c         end do
c      end do
c---------------------------------------------------------------------

      do p = 0, np2-1
         ioff = p*d1/np2
         do k = 1, d3
            do j = 1, d2
               do i = 1, d1/np2
                  xout(i+ioff, j, k) = xin(i, j, k, p)
               end do
            end do
         end do
      end do
      if (timers_enabled) call timer_stop(T_transxzfin)
      return
      end

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine transpose_x_y(l1, l2, xin, xout)

c---------------------------------------------------------------------
c---------------------------------------------------------------------
      use global
      implicit none
      integer l1, l2
      double complex xin(ntdivnp), xout(ntdivnp)

c---------------------------------------------------------------------
c xy transpose is a little tricky, since we don't want
c to touch 3rd axis. But alltoall must involve 3rd axis (most
c slowly varying) to be efficient. So we do
c (nx, ny/np1, nz/np2) -> (ny/np1, nz/np2, nx) (local)
c (ny/np1, nz/np2, nx) -> ((ny/np1*nz/np2)*np1, nx/np1) (global)
c then local finish.
c---------------------------------------------------------------------

      call transpose_x_y_local(dims(1,l1),dims(2,l1),dims(3,l1),
     >                         xin, xout)
      call transpose_x_y_global(dims(1,l1),dims(2,l1),dims(3,l1),
     >                          xout, xin)
      call transpose_x_y_finish(dims(1,l2),dims(2,l2),dims(3,l2),
     >                          xin, xout)

      return
      end

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine transpose_x_y_local(d1, d2, d3, xin, xout)

c---------------------------------------------------------------------
c---------------------------------------------------------------------
      use global
      implicit none
      integer d1, d2, d3
      double complex xin(d1, d2, d3)
      double complex xout(d2, d3, d1)
      integer i, j, k
      if (timers_enabled) call timer_start(T_transxyloc)

      do k = 1, d3
         do i = 1, d1
            do j = 1, d2
               xout(j,k,i)=xin(i,j,k)
            end do
         end do
      end do
      if (timers_enabled) call timer_stop(T_transxyloc)
      return
      end

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine transpose_x_y_global(d1, d2, d3, xin, xout)

c---------------------------------------------------------------------
c---------------------------------------------------------------------
      use global
      implicit none
      include 'mpinpb.h'
      integer d1, d2, d3
c---------------------------------------------------------------------
c array is in form (ny/np1, nz/np2, nx)
c---------------------------------------------------------------------
      double complex xin(d2,d3,d1)
      double complex xout(d2,d3,d1) ! not real layout but right size
      integer ierr

!      if (timers_enabled) call synchup()

c---------------------------------------------------------------------
c do transpose among all processes with same 1-coord (me1)
c---------------------------------------------------------------------
      if (timers_enabled) call timer_start(T_transxyglo)
      call mpi_alltoall(xin, d1*d2*d3/np1, dc_type,
     >                  xout, d1*d2*d3/np1, dc_type,
     >                  commslice2, ierr)
      if (timers_enabled) call timer_stop(T_transxyglo)

      return
      end

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine transpose_x_y_finish(d1, d2, d3, xin, xout)

c---------------------------------------------------------------------
c---------------------------------------------------------------------
      use global
      implicit none
      integer d1, d2, d3
      double complex xin(d1/np1, d3, d2, 0:np1-1)
      double complex xout(d1,d2,d3)
      integer i, j, k, p, ioff
      if (timers_enabled) call timer_start(T_transxyfin)
c---------------------------------------------------------------------
c this is the most straightforward way of doing it. the
c calculation in the inner loop doesn't help.
c      do i = 1, d1/np1
c         do j = 1, d2
c            do k = 1, d3
c               do p = 0, np1-1
c                  ii = i + p*d1/np1
c note order is screwy bcz we have (ny/np1, nz/np2, nx) -> (ny, nx/np1, nz/np2)
c                  xout(ii, j, k) = xin(i, k, j, p)
c               end do
c            end do
c         end do
c      end do
c---------------------------------------------------------------------

      do p = 0, np1-1
         ioff = p*d1/np1
         do k = 1, d3
            do j = 1, d2
               do i = 1, d1/np1
                  xout(i+ioff, j, k) = xin(i, k, j, p)
               end do
            end do
         end do
      end do
      if (timers_enabled) call timer_stop(T_transxyfin)
      return
      end

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine checksum(i, u1, d1, d2, d3)

c---------------------------------------------------------------------
c---------------------------------------------------------------------
      use global
      implicit none
      include 'mpinpb.h'
      integer i, d1, d2, d3
      double complex u1(d1, d2, d3)
      integer j, q,r,s, ierr
      double complex chk,allchk
      chk = (0.0,0.0)
      do j=1,1024
         q = mod(j, nx)+1
         if (q .ge. xstart(1) .and. q .le. xend(1)) then
            r = mod(3*j,ny)+1
            if (r .ge. ystart(1) .and. r .le. yend(1)) then
               s = mod(5*j,nz)+1
               if (s .ge. zstart(1) .and. s .le. zend(1)) then
                  chk=chk+u1(q-xstart(1)+1,r-ystart(1)+1,s-zstart(1)+1)
               end if
            end if
         end if
      end do
      chk = chk/ntotal_f

      if (timers_enabled) call timer_start(T_synch)
      call MPI_Reduce(chk, allchk, 1, dc_type, MPI_SUM,
     >                0, MPI_COMM_WORLD, ierr)
      if (timers_enabled) call timer_stop(T_synch)
      if (me .eq. 0) then
            write (*, 30) i, allchk
 30         format (' T =',I5,5X,'Checksum =',1P2D22.12)
      endif

      sums(i) = allchk
      if(me .eq. 0)  write(*,*) sums(i)

      return
      end

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine synchup

c---------------------------------------------------------------------
c---------------------------------------------------------------------
      use global
      implicit none
      include 'mpinpb.h'
      integer ierr
      call timer_start(T_synch)
      call mpi_barrier(MPI_COMM_WORLD, ierr)
      call timer_stop(T_synch)
      return
      end


       subroutine brolin(k,xs1,ys1,xf1,yf1,s1,s2)
C***
C... to draw a character line  (a wroken line, one dot-chain line and to
C    chain line).
C    k        selective parameter of character line.
C    k=1      broken line
C    k=2      one dot chain line
C    k=3      two dot chain lines
C    xs1,ys1  x and y coordinates of a starting point of the char.line
C    xf1,yf1 x and y coordinates of an end point of the car. line
C    s1       length of the long segment.
C    s2       length of the short segment and the space.
        xss=xs1
        yss=ys1
        xff=xf1
        yff=yf1
        sleng=sqrt((xss-xff)**2+(yss-yff)**2)
C***
        if(xff.ne.xss)goto 20
        theta=3.14159265*0.5
        goto 50
   20   thett=abs((yff-yss)/(xff-xss))
        theta=atan(thett)
   50   continue
        xsign=xff-xss
        ysign=yff-yss
        xpitch=sign(s1,xsign)*cos(theta)
        ypitch=sign(s1,ysign)*sin(theta)
        xspace=sign(s2,xsign)*cos(theta)
        yspace=sign(s2,ysign)*sin(theta)
C***
        xs=xss
        ys=yss
        goto (100,200,300),k
C***  character line ***hasen
  100   xf=xs+xpitch
        yf=ys+ypitch
        cleng=sqrt((xss-xf)**2+(yss-yf)**2)
       if(cleng.ge.sleng)goto 130
       call move(xs,ys,0)
       call move(xf,yf,1)
       xs=xf+xspace
       ys=yf+yspace
       cleng=sqrt((xss-xs)**2+(yss-ys)**2)
       if(cleng.ge.sleng) goto 900
       goto 100
C ***  end
 130    call move(xs,ys,0)
       call move(xff,yff,1)
       goto 900
C ***character line ***1 ten basen
  200  kk=1
C***
  210 if(kk.gt.1)goto 240
  220 kk=2
      xf=xs+xpitch
      yf=ys+ypitch
      goto 250
 240  kk=1
      xf=xs+xspace
      yf=ys+yspace
 250  cleng=sqrt((xss-xf)**2+(yss-yf)**2)
       if(cleng.ge.sleng) goto 270
      call move(xs,ys,0)
      call move(xf,yf,1)
      xs=xf+xspace
      ys=yf+yspace
      cleng=sqrt((xss-xs)**2+(yss-ys)**2)
      if(cleng.ge.sleng) goto 900
      goto 210
C *** end
  270  call move(xs,ys,0)
      call move(xff,yff,1)
      goto 900
C***   character line ***2 ten sasen
  300 kk=3
C **
  305 goto (310,320,330),kk
  310 kk=2
      goto 340
  320 kk=3
  340 xf=xs+xspace
      yf=ys+yspace
      goto 350
  330 kk=1
      xf=xs+xpitch
      yf=ys+ypitch
 350  cleng=sqrt((xss-xf)**2+(yss-yf)**2)
      if(cleng.ge.sleng) goto 370
      call move(xs,ys,0)
      call move(xf,yf,1)
      xs=xf+xspace
      ys=yf+yspace
      cleng=sqrt((xss-xs)**2+(yss-ys)**2)
      if(cleng.ge.sleng)goto 900
      goto 305
C***  end
  370 call move(xs,ys,0)
      call move(xff,yff,1)
 900  return
      end


ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c      written by the UFO converter
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      SUBROUTINE MP_COUP3()

      IMPLICIT NONE
      REAL*16 MP__PI
      PARAMETER (MP__PI=3.1415926535897932384626433832795E0_16)
      INCLUDE 'mp_input.inc'
      INCLUDE 'mp_coupl.inc'

      INCLUDE 'model_functions.inc'
      MP__UV_3GG_1EPS = -(-((MP__MDL_G__EXP__2)/(2.000000E+00_16
     $ *4.800000E+01_16*MP__PI**2))*1.100000E+01_16*MP__MDL_CA)*MP__G
      MP__UV_3GB_1EPS = -(((MP__MDL_G__EXP__2)/(2.000000E+00_16
     $ *4.800000E+01_16*MP__PI**2))*4.000000E+00_16*MP__MDL_TF)*MP__G
      MP__UV_GQQG_1EPS = MP__MDL_COMPLEXI*(-((MP__MDL_G__EXP__2)
     $ /(2.000000E+00_16*4.800000E+01_16*MP__PI**2))*1.100000E
     $ +01_16*MP__MDL_CA)*MP__G
      MP__UV_GQQQ_1EPS = MP__MDL_COMPLEXI*(((MP__MDL_G__EXP__2)
     $ /(2.000000E+00_16*4.800000E+01_16*MP__PI**2))*4.000000E
     $ +00_16*MP__MDL_TF)*MP__G
      MP__UV_BMASS_1EPS = (MP_COND(CMPLX(MP__MDL_MB,KIND=16),CMPLX(0.00
     $ 0000E+00_16,KIND=16),CMPLX(MP__MDL_COMPLEXI*((MP__MDL_G__EXP__2
     $ )/(1.600000E+01_16*MP__PI**2))*(3.000000E+00_16*MP__MDL_CF)
     $ *MP__MDL_MB,KIND=16)))
      MP__UV_TMASS_1EPS = (MP_COND(CMPLX(MP__MDL_MT,KIND=16),CMPLX(0.00
     $ 0000E+00_16,KIND=16),CMPLX(MP__MDL_COMPLEXI*((MP__MDL_G__EXP__2
     $ )/(1.600000E+01_16*MP__PI**2))*3.000000E+00_16*MP__MDL_CF
     $ *MP__MDL_MT,KIND=16)))
      MP__UVWFCT_B_0_1EPS = MP_COND(CMPLX(MP__MDL_MB,KIND=16)
     $ ,CMPLX(0.000000E+00_16,KIND=16),CMPLX(-((MP__MDL_G__EXP__2)
     $ /(2.000000E+00_16*1.600000E+01_16*MP__PI**2))*3.000000E
     $ +00_16*MP__MDL_CF,KIND=16))
      MP__UVWFCT_G_2_1EPS = MP_COND(CMPLX(MP__MDL_MT,KIND=16)
     $ ,CMPLX(0.000000E+00_16,KIND=16),CMPLX(-((MP__MDL_G__EXP__2)
     $ /(2.000000E+00_16*4.800000E+01_16*MP__PI**2))*4.000000E
     $ +00_16*MP__MDL_TF,KIND=16))
      END


C
C**************************  CHMASPT ***********************************
C
C  calculate soil moisture characteristics needed for
C  mass balance calculations (general storage term)
C  in case of deformable peat soil
C
C***********************************************************************
C
      SUBROUTINE CHMASPT(NLKP,N,NNOD,NT,NTRI,IVGHU,TETRA,TP,
     1                   PNEW,SNODI,PNODI,PORE,INDE,Z,
     2                   SENODI,ETAI,SEELT,ETAE)
C
      IMPLICIT NONE
      INCLUDE 'CATHY.H'
      INTEGER  I,NS
      INTEGER  NLKP,N,NNOD,NT,NTRI,IVGHU
      INTEGER  TETRA(5,*),TP(*)
      REAL*8   FCDPORE,FVGSE,FVGDSE,FBCSE,FBCDSE
      REAL*8   PSI,SE,SWi,D
      REAL*8   PNEW(*),SNODI(*),PNODI(*),PORE(*),INDE(*),Z(*)
      REAL*8   SENODI(*),ETAI(*),SEELT(*),ETAE(*)
      INCLUDE 'SOILCHAR.H'
C
      IF (IVGHU .EQ. -1) THEN
         CALL MOISTABPT(NLKP,NT,NTRI,TETRA,PNEW,SEELT,ETAE)
         CALL ELTNOD(N,NT,TP,TETRA,ETAE,ETAI)
         CALL ELTNOD(N,NT,TP,TETRA,SEELT,SENODI)
         DO I=1,N
            NS       = I-(NNOD*INT((I-1)/NNOD))
            D        = Z(NS) - Z(I)
            PSI      = PNEW(I)
            SE       = SENODI(I)
            VGPNOT(I)= (PORE(I)-VGRMC(I))/PORE(I)
            SWi      = VGPNOT(I)*SE + VGRMC(I)/PORE(I)
            ETAI(I)  = SWi*SNODI(I) +
     1                 (SWi*FCDPORE(INDE(I),SWi,D,PNODI(I)) +
     2                  PORE(I)*VGPNOT(I)) * ETAI(I)
            IF (SWi .EQ. 1.0D0) ETAI(I) = ETAI(I) - SWi*SNODI(I)
         END DO
      ELSE IF (IVGHU .EQ. 0) THEN
         DO I=1,N
            NS       = I-(NNOD*INT((I-1)/NNOD))
            D        = Z(NS) - Z(I)
            PSI      = PNEW(I)
            SE       = FVGSE(PSI,I)
            VGPNOT(I)= (PORE(I)-VGRMC(I))/PORE(I)
            SWi      = VGPNOT(I)*SE + VGRMC(I)/PORE(I)
            ETAI(I)  = SWi*SNODI(I) +
     1                 (SWi*FCDPORE(INDE(I),SWi,D,PNODI(I)) +
     2                  PORE(I)*VGPNOT(I)) * FVGDSE(PSI,I)
            IF (SWi .EQ. 1.0D0) ETAI(I) = ETAI(I) - SWi*SNODI(I)
         END DO
      ELSE IF (IVGHU .EQ. 4) THEN
         DO I=1,N
            NS       = I-(NNOD*INT((I-1)/NNOD))
            D        = Z(NS) - Z(I)
            PSI      = PNEW(I)
            SE       = FBCSE(PSI)
            SWi      = BCPORM(I)*SE + BCRMC/PORE(I)
            ETAI(I)  = SWi*SNODI(I) +
     1                 (SWi*FCDPORE(INDE(I),SWi,D,PNODI(I)) +
     2                  PORE(I)*BCPORM(I)) * FBCDSE(PSI)
         END DO
      END IF
C
      RETURN
      END


!
!  energy_solid.f90
!
!
!  Created by Zhang on 9/3/08.
!  Copyright 2008 __MyCompanyName__. All rights reserved.
!

       subroutine energy_solid(x_solid,nsd,nen,ien,nn_solid,ne_solid,x_solid_init,v_solid)
! x_solid: the potision of the solid domain at current time step
! nsd: dimension of the problem
! nen: number of nodes per element of solid mesh
! ien: connectiviy of the solid mesh
! nn_solid: number of nodes of solid mesh
! ne_solid: number of elements of solid mesh
! e_area: the area of every element
! rhs: (det(F_{ij}))^{-1}-1 right hand side of the equations

use r_common, only: rc1,rc2,rk, density_solid, xmg, young_mod, Poisson
! constants for Mooney-Rivlin model
! gravity coefficients in all direction
      integer nsd
	  integer nn_solid
	  integer ne_solid
	  integer ien(ne_solid,nen)
      real(8) x_solid(nsd,nn_solid)
	  real(8) x_solid_init(nsd,nn_solid)
!=============================================================
! variable for E_int
      real(8) eint
! internal energy for whole solid domain
      real(8) eint_e(ne_solid)
! internal energy per element
	  real(8) j1
	  real(8) j2
	  real(8) j3
! tensor invariance variables for c_ij=F_im F_mj
	  integer isd
	  integer jsd
	  integer ksd
! loop variable for nsd
	  real(8) cij(3,3)
	  real(8) cij2(3,3)
          real(8) detcij
! C_ij= F_im F_mj
! C_ijj2= C_im C_mj
! detcij = det{c_ij}

!=============================================================

!============================================
! variable for EPt & EKt
	   real(8) delta_rho
	   ! density difference between fluid and solid: rho_solid - rho_fluid
	   real(8) x_gauss(nsd)
	   ! the coordinates of the integration point
	   real(8) ept_e(ne_solid)
	   ! the protential energy of solid (the artifical fluid has been substract) per element
	   real(8) ept
	   ! the prootential energy of the whole solid domain
	   real(8) v_solid(nsd,nn_solid)
	   ! grobal solid velocity
	   real(8) v(nsd,nen)
	   ! local solid velocity
	   real(8) v_gauss(nsd)
	   ! velocity at integration point
	   real(8) ekt_e(ne_solid)
	   ! kenectic energy per element (subcrabt the artificial fluid part) 1/2 \Delta \rho * v_s \dot v_s
	   real(8) ekt
	   ! sum of ekt_e
!==============================================

! shape funciton variable
	  integer iquad
	  integer nquad
	  real(8) xq(nsd,1)
	  real(8) wq
	  integer iq
	  real(8) sq(0:nsd,nen,1)
	  real(8) sh(0:nsd,nen)
	  real(8) xr(nsd,nsd)
	  real(8) cf(nsd,nsd)
	  real(8) sx(3,3)
	  real(8) det
! iquad: number of integration points always 1 here
! nquad: always 1
! sq: the same meaning of in the main program but only 1 in 3nd dimension here
! iq: always 1 here just for convenience
!===============================================================
! variables to calculate rhs & e_area
      real(8) e_area(ne_solid)
	  real(8) rhs(ne_solid)
	  real(8) y(nsd,nen)
	  real(8) rs(nsd)
	  real(8) xj(nsd,nsd)
	  real(8) xji(nsd,nsd)
	  real(8) detJ
	  real(8) toxj(nsd,nsd)
	  real(8) toxji(nsd,nsd)
	  real(8) todet
	  real(8) xto(nsd,nsd)
	  real(8) xot(nsd,nsd)
	  real(8) toc(nsd,nsd)
	  real(8) detf
!------------------------------------------------
          real(8) ge(nsd*2,ne_solid,1)
          real(8) cstr_element(nsd*2)
!------------------------------------------------

! det: determinant of Jacobian at current time step
! detf: det(F_{ij}
!=======================================
! Seting up left and right hand side variables
      integer ine
	  integer inen
	  integer index
	  integer jne
	  integer jnen
	  integer indey
	  integer inn
	  real(8) x(nsd,nen)
!	  real(8) y(nsd,nen)

! crrm: the whole matirx of the left hand side
! crra: the whole matrix of the right hand side
! s_area: the sum area of the elements sounding every point
!====================================================
! varialbe to solve the linear system
      integer np
      integer mp
      integer error
      real(8) crra_cg(nsd*nn_solid)
!=============================================================
! First step: calculate the shape funciton in the parent domain, based on nsd & nen
	  iquad=1
	  iq=1
          xq(:,:)=0.0d0
	  if (nsd==2) then
	     if (nen==3) then
 	!              write(*,*) 'I am here in volcorr 84', xq(:,:)
		     call quad2d3n(iquad,nquad,xq,wq,nsd,1)
         !             write(*,*) 'I am after call quad', xq(:,:)
		 else if (nen==4) then
		     call quad2d4n(iquad,nquad,xq,wq,nsd,1)
		 end if
		 if(nen==3) then
		  sq(0,1,iq) = xq(1,iq)
		  sq(0,2,iq) = xq(2,iq)
		  sq(0,3,iq) = 1 - xq(1,iq) - xq(2,iq)
        else if (nen==4) then
		  sq(0,1,iq) = (1 - xq(1,iq)) * (1 - xq(2,iq)) / 4
		  sq(0,2,iq) = (1 + xq(1,iq)) * (1 - xq(2,iq)) / 4
		  sq(0,3,iq) = (1 + xq(1,iq)) * (1 + xq(2,iq)) / 4
		  sq(0,4,iq) = (1 - xq(1,iq)) * (1 + xq(2,iq)) / 4

		  sq(1,1,iq) = - (1 - xq(2,iq)) / 4
		  sq(1,2,iq) = + (1 - xq(2,iq)) / 4
		  sq(1,3,iq) = + (1 + xq(2,iq)) / 4
		  sq(1,4,iq) = - (1 + xq(2,iq)) / 4

		  sq(2,1,iq) = - (1 - xq(1,iq)) / 4
		  sq(2,2,iq) = - (1 + xq(1,iq)) / 4
		  sq(2,3,iq) = + (1 + xq(1,iq)) / 4
		  sq(2,4,iq) = + (1 - xq(1,iq)) / 4

        endif
	  else if (nsd==3) then
	     if (nen==4) then
		     call quad3d4n(iquad,nquad,xq,wq,nsd,1)
		 else if  (nen==8) then
		     call quad3d8n(iquad,nquad,xq,wq,nsd,1)
		 end if

		 if(nen.eq.4) then
		  sq(0,1,iq) = xq(1,iq)
		  sq(0,2,iq) = xq(2,iq)
		  sq(0,3,iq) = xq(3,iq)
		  sq(0,4,iq) = 1 - xq(1,iq) - xq(2,iq) - xq(3,iq)
        else
		  sq(0,1,iq) = (1 - xq(1,iq))	&
			   * (1 - xq(2,iq)) * (1 - xq(3,iq)) / 8
		  sq(0,2,iq) = (1 + xq(1,iq))	&
			   * (1 - xq(2,iq)) * (1 - xq(3,iq)) / 8
		  sq(0,3,iq) = (1 + xq(1,iq))	&
			   * (1 + xq(2,iq)) * (1 - xq(3,iq)) / 8
		  sq(0,4,iq) = (1 - xq(1,iq))	&
			   * (1 + xq(2,iq)) * (1 - xq(3,iq)) / 8
		  sq(0,5,iq) = (1 - xq(1,iq))	&
			   * (1 - xq(2,iq)) * (1 + xq(3,iq)) / 8
		  sq(0,6,iq) = (1 + xq(1,iq))	&
			   * (1 - xq(2,iq)) * (1 + xq(3,iq)) / 8
		  sq(0,7,iq) = (1 + xq(1,iq))	&
			   * (1 + xq(2,iq)) * (1 + xq(3,iq)) / 8
		  sq(0,8,iq) = (1 - xq(1,iq))	&
			   * (1 + xq(2,iq)) * (1 + xq(3,iq)) / 8
		  sq(1,1,iq) = - (1 - xq(2,iq)) * (1 - xq(3,iq)) / 8
		  sq(1,2,iq) = + (1 - xq(2,iq)) * (1 - xq(3,iq)) / 8
		  sq(1,3,iq) = + (1 + xq(2,iq)) * (1 - xq(3,iq)) / 8
		  sq(1,4,iq) = - (1 + xq(2,iq)) * (1 - xq(3,iq)) / 8
		  sq(1,5,iq) = - (1 - xq(2,iq)) * (1 + xq(3,iq)) / 8
		  sq(1,6,iq) = + (1 - xq(2,iq)) * (1 + xq(3,iq)) / 8
		  sq(1,7,iq) = + (1 + xq(2,iq)) * (1 + xq(3,iq)) / 8
		  sq(1,8,iq) = - (1 + xq(2,iq)) * (1 + xq(3,iq)) / 8
		  sq(2,1,iq) = - (1 - xq(1,iq)) * (1 - xq(3,iq)) / 8
		  sq(2,2,iq) = - (1 + xq(1,iq)) * (1 - xq(3,iq)) / 8
		  sq(2,3,iq) = + (1 + xq(1,iq)) * (1 - xq(3,iq)) / 8
		  sq(2,4,iq) = + (1 - xq(1,iq)) * (1 - xq(3,iq)) / 8
		  sq(2,5,iq) = - (1 - xq(1,iq)) * (1 + xq(3,iq)) / 8
		  sq(2,6,iq) = - (1 + xq(1,iq)) * (1 + xq(3,iq)) / 8
		  sq(2,7,iq) = + (1 + xq(1,iq)) * (1 + xq(3,iq)) / 8
		  sq(2,8,iq) = + (1 - xq(1,iq)) * (1 + xq(3,iq)) / 8
		  sq(3,1,iq) = - (1 - xq(1,iq)) * (1 - xq(2,iq)) / 8
		  sq(3,2,iq) = - (1 + xq(1,iq)) * (1 - xq(2,iq)) / 8
		  sq(3,3,iq) = - (1 + xq(1,iq)) * (1 + xq(2,iq)) / 8
		  sq(3,4,iq) = - (1 - xq(1,iq)) * (1 + xq(2,iq)) / 8
		  sq(3,5,iq) = + (1 - xq(1,iq)) * (1 - xq(2,iq)) / 8
		  sq(3,6,iq) = + (1 + xq(1,iq)) * (1 - xq(2,iq)) / 8
		  sq(3,7,iq) = + (1 + xq(1,iq)) * (1 + xq(2,iq)) / 8
		  sq(3,8,iq) = + (1 - xq(1,iq)) * (1 + xq(2,iq)) / 8
        endif
	  end if

!==================================================================
! Second step: Internal energy due to the deformation

! eint_e: internal energy interal per element = c1*(J1-3)+c2*(J2-3)+\kappa /2 *(J3-1)^2
          eint_e(:)=0
          eint=0
          ge(:,:,:)=0
          cstr_element(:)=0
          do ine=1,ne_solid
	     do inen=1,nen
		    y(1:nsd,inen)=x_solid(1:nsd,ien(ine,inen)) ! current position
			x(1:nsd,inen)=x_solid_init(1:nsd,ien(ine,inen)) ! initial position
		 end do
		 rs(1:nsd)=xq(1:nsd,1)
		 call r_element(rs)
		 call r_jacob(y,xj,xji,detJ)
		 call r_jacob(x,toxj,toxji,todet)
		 call r_bdpd_curr(xji)
		 call r_bdpd_init(toxji)
		 call r_stoxc(xto,xot,xj,xji,toxj,toxji,toc,ine)
		 e_area(ine)=wq*detJ ! Jacobbi determinant times weight
		 call determinant(xto,nsd,nsd,detf)
                 call r_sstrain(toc,xto,iq,ine,ge)
               !  write(*,*) ge(:,:,:)
                 call r_spiola_elastic(det,xot,ge,iq,ine,cstr_element)
                 eint_e(ine)= (1.0d0/(2*young_mod))*((cstr_element(1)+cstr_element(2))**2)- &
                (2.0d0*(1+Poisson)/young_mod)*(cstr_element(1)*cstr_element(2)-cstr_element(3)**2)

                 eint_e(ine)=eint_e(ine)*e_area(ine)
!=======================================================================
            ! For hyperelastic model
             !    cij(:,:)=0
             !    cij2(:,:)=0
		! do isd=1,nsd
		! do jsd=1,nsd
		! do ksd=1,nsd
		!	cij(isd,jsd)=cij(isd,jsd)+xto(ksd,isd)*xto(ksd,jsd)
                  !      write(*,*) 'cij', cij(isd,jsd) ! C_ij
	       !  end do
		! end do
		! end do
		! if (nsd==2) then
                !    cij(1,3)=0
                !    cij(2,3)=0
                !    cij(3,1)=0
                !    cij(3,2)=0
                !    cij(3,3)=1
               ! end if
	    ! do isd=1,3
		! do jsd=1,3
		! do ksd=1,3
		!	cij2(isd,jsd)=cij2(isd,jsd)+cij(isd,ksd)*cij(ksd,jsd) ! C_ij ^2
	    ! end do
            ! end do
	    ! end do
		!call determinant(cij,3,3,detcij)
		! j3=detcij
		! j1=(cij(1,1)+cij(2,2)+cij(3,3))*(j3**(-0.3333))
		! j2=(j1*j1-cij2(1,1)-cij2(2,2)-cij2(3,3))*0.5d0*(j3**(-0.6666))
                ! j3=j3**(0.5)
           !      call determinant(cij,3,3,detcij)

		 ! get J1 J2 J3
		! eint_e(ine)=(rc1*(j1-3)+rc2*(j2-3)+rk*(j3-1)*(j3-1)*0.5d0)*e_area(ine)
		 ! W*weight*D
	  end do
	     eint=sum(eint_e)
             write(*,*) sum(e_area)
       continue

!loop over element

!============================================
!step 3: calculate the protential energy for solid

	  ept_e(:)=0
	  ekt_e(:)=0
	  delta_rho=density_solid
          ept=0
          ekt=0
	  do ine=1,ne_solid
      ! assembling from global to local for coordinates and velocity
         do inen=1,nen
		    x(:,inen)=x_solid(1:nsd,ien(ine,inen))
			v(:,inen)=v_solid(1:nsd,ien(ine,inen))
		 end do
	  ! get N_{j,i}
      !...  calculate the shape function and the weight at quad point
		if (nsd==2) then
		    if (nen.eq.3) then !calculate shape function at quad point
			   include "sh2d3n.h"
			elseif (nen.eq.4) then
				include "sh2d4n.h"
			endif
		elseif (nsd==3) then
		    if (nen.eq.4) then !calculate shape function at quad point
			   include "sh3d4n.h"
			elseif (nen.eq.8) then
				include "sh3d8n.h"
			endif
		endif
                x_gauss(:)=0
                v_gauss(:)=0
		do isd=1,nsd
                do inen=1,nen
		x_gauss(isd)=x_gauss(isd)+x(isd,inen)*sh(0,inen)
		v_gauss(isd)=v_gauss(isd)+v(isd,inen)*sh(0,inen)
		end do
                end do

       do isd=1,nsd
		  ept_e(ine)=ept_e(ine)+xmg(isd)*x_gauss(isd)*delta_rho*e_area(ine)
	   end do

	   do isd=1,nsd
	      ekt_e(ine)=ekt_e(ine)+v_gauss(isd)*v_gauss(isd)*delta_rho*e_area(ine)*0.5d0
	   end do

	  end do
	   ept=sum(ept_e)
	   ekt=sum(ekt_e)
	 open(unit=92, file='EPts.txt', status='unknown')
	 open(unit=93, file='EKts.txt', status='unknown')
	 open(unit=94, file='Eints.txt', status='unknown')
	 write(92,*) ept
	 write(93,*) ekt
	 write(94,*) eint
       return
       end