      subroutine tbendi(np,x,px,y,py,z,g,dv,sx,sy,sz,al,phib,phi0,
     1     cosp1,sinp1,cosp2,sinp2,
     1     ak,dx,dy,theta,dtheta,cost,sint,
     1     fb1,fb2,mfring,enarad,fringe,eps0)
      use tbendcom, only:tbrot,tbshift
      use bendib
      use tfstk
      use ffs_flag
      use tmacro
      use ffs_pointer, only:inext,iprev
      use kradlib
      use tspin, only:cphi0,sphi0
      use photontable
      implicit none
      integer*4 , parameter :: ndivmax=1000
      integer*4 np,mfring,i,ndiv,n,n1,n2
      real*8 x(np),px(np),y(np),py(np),z(np),dv(np),g(np),
     $     sx(np),sy(np),sz(np),
     $     alx(-1:ndivmax+2),alr(-1:ndivmax+2),
     $     akxn(-1:ndivmax+2),phixn(-1:ndivmax+2),
     $     cphixn(-1:ndivmax+2),sphixn(-1:ndivmax+2),
     $     al,phib,phi0,cosp1,sinp1,cosp2,sinp2,
     1     ak,dx,dy,theta,cost,sint,fb1,fb2,eps0,
     $     tanp1,tanp2,aind,b,dxfr1,dyfr1,dyfra1,pr,eps,
     $     af,f,fpx,ff,aln,f1r,f2r,akx0,alx0,
     $     phix0,alc,
     $     dxfr2,dyfr2,dyfra2,dtheta
      logical*4 enarad,fringe,krad
      call tbshift(np,x,px,y,py,z,dx,dy,phi0,cost,sint,.true.)
      if(dtheta .ne. 0.d0)then
        call tbrot(np,x,px,y,py,z,sx,sy,sz,phi0,dtheta)
      endif
      tanp1=sinp1/cosp1
      tanp2=sinp2/cosp2
      rhob=al/phib
      rho0=al/phi0
      aind=rho0/phi0*ak
      eps=merge(epsbend,epsbend*eps0,eps0 .eq. 0.d0)
      ndiv=1+int(abs(phi0/eps))
      krad=rad .and. enarad .and. al .ne. 0.d0
      f1r=0.d0
      f2r=0.d0
      n1=1
      n2=0
      alc=al
      if(krad)then
        pxr0=px
        pyr0=py
        zr0=z
        if(calpol)then
          bsi=0.d0
        endif
        if(iprev(l_track) .eq. 0 .and. fb1 .ne. 0.d0)then
          f1r=.5d0*fb1
          n1=-1
        endif
        if(inext(l_track) .eq. 0 .and. fb2 .ne. 0.d0)then
          f2r=.5d0*fb2
          n2=2
        endif
        b=brhoz/rhob
        alc=al-f1r-f2r
        ndiv=max(ndiv,ndivrad(phib*alc/al,ak*alc/al,0.d0,eps0))
      endif
      ndiv=min(ndivmax,ndiv)
      n2=ndiv+n2
      if(fringe .and. mfring .gt. -4 .and. mfring .ne. 2)then
        call ttfrin(np,x,px,y,py,z,g,4,ak,al,0.d0)
      endif
      if(fb1 .ne. 0.d0)then
        dxfr1=fb1**2/rhob/24.d0
        dyfr1=fb1/rhob**2/6.d0
        dyfra1=4.d0*dyfr1/fb1**2
        do i=1,np
c     dp=g(i)*(2.d0+g(i))
          dp=g(i)
          pr=1.d0+dp
          x(i)=x(i)+dxfr1*dp/pr
          py(i)=py(i)+(dyfr1-dyfra1*y(i)**2)*y(i)/pr**2
          z(i)=z(i)+(dxfr1*px(i)+
     $         (.5d0*dyfr1-.25d0*dyfra1*y(i)**2)*y(i)**2/pr)/pr
        enddo
      endif
      af=merge(1.d0,0.d0,fringe)
      aln=alc/ndiv
      do n=n1,n2
        call tbendal(n,ndiv,f1r,f2r,aln,alx(n),alr(n))
        akxn(n)=ak*alx(n)/al
        phixn(n)=phi0*alx(n)/al
        cphixn(n)=cos(phixn(n))
        sphixn(n)=sin(phixn(n))
      enddo
      do i=1,np
        dp=g(i)
        p=1.d0+dp
        rhoe=rhob*p
        yi=y(i)
        f=yi/rhoe
        fpx=af*px(i)
        pyi=py(i)-(tanp1+fpx)*f
        ff  =af*yi*f*.5d0
        xi=x(i)+ff
        zi=z(i)-ff*fpx
        pxi=px(i)+tanp1*xi/rhoe
        akx0=0.d0
        alx0=0.d0
        phix0=0.d0
        if(photons .and. krad)then
          call tsetpcvt(l_track,dx,dy,theta,dtheta,phi0,al)
        endif
        do n=n1,n2
          call tbendiinit(akxn(n),alx(n),n .eq. n1)
          call tbendicorr((akxn(n)+akx0)*.5d0,(alx(n)+alx0)*.5d0,
     $         (phixn(n)+phix0)*.5d0)
          akx0=akxn(n)
          alx0=alx(n)
          phix0=phixn(n)
          call tbendibody(alx0)
          if(krad)then
            bsi(i)=bsi(i)+akxn(n)/alx(n)*xi*yi
            if(n .ne. n2)then
              cphi0=cphixn(n)
              sphi0=sphixn(n)
              if(rfluct)then
                call tradkf1(xi,pxi,yi,pyi,zi,dp,dv(i),
     $               sx(i),sy(i),sz(i),
     $               pxr0(i),pyr0(i),zr0(i),bsi(i),alr(n),i)
              else
                call tradk1(xi,pxi,yi,pyi,zi,dp,dv(i),
     $               sx(i),sy(i),sz(i),
     $               pxr0(i),pyr0(i),zr0(i),bsi(i),alr(n))
              endif
              pxr0(i)=pxi
              pyr0(i)=pyi
              zr0(i)=zi
              bsi(i)=0.d0
              if(photons)then
                pcvt%fr0=pcvt%fr0+alx(n)/al
c                call tsetphotongeo(alx(n),phixn(n),theta,.false.)
              endif
            endif
          endif
        enddo
        call tbendicorr(akx0*.5d0,alx0*.5d0,phix0*.5d0)
        zi=zi-dv(i)*al
        px(i)=pxi+tanp2*xi/rhoe
        y(i)=yi
        f=yi/rhoe
        fpx=af*px(i)
        py(i)=pyi-(tanp2-fpx)*f
        ff  =af*yi*f*.5d0
        x(i)=xi-ff
        z(i)=zi+ff*fpx
        g(i)=dp
      enddo
      if(fb2 .ne. 0.d0)then
        dxfr2=fb2**2/rhob/24.d0
        dyfr2=fb2/rhob**2/6.d0
        dyfra2=4.d0*dyfr2/fb2**2
        do i=1,np
          dp=g(i)
          pr=1.d0+dp
          x(i)=x(i)-dxfr2*dp/pr
          py(i)=py(i)+(dyfr2-dyfra2*y(i)**2)*y(i)/pr**2
          z(i)=z(i)-(dxfr2*px(i)-
     $         (.5d0*dyfr2-.25d0*dyfra2*y(i)**2)*y(i)**2/pr)/pr
        enddo
      endif
      if(fringe .and. mfring .gt. -4 .and. mfring .ne. 1)then
        call ttfrin(np,x,px,y,py,z,g,4,-ak,al,0.d0)
      endif
      if(krad)then
        if(photons)then
          call tsetpcvt(l_track,dx,dy,theta,dtheta,phi0,al)
          pcvt%fr0=1.d0-alr(n2)/al
        endif
        call tradk(np,x,px,y,py,z,g,dv,sx,sy,sz,alr(n2),phixn(n2))
      endif
      if(dtheta .ne. 0.d0)then
        call tbrot(np,x,px,y,py,z,sx,sy,sz,-phi0,-dtheta)
      endif
      call tbshift(np,x,px,y,py,z,-dx,-dy,-phi0,cost,-sint,.false.)
      return
      end


      SUBROUTINE CONSTS (COORD)
C THIS ROUTINE CONSTRUCTS OR UPDATES THE SOLVENT-ACCESSIBLE
C SURFACE (SAS)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INCLUDE 'SIZES'
      DIMENSION XX(3),XA(3),XI(3),XJ(3),XSP(3,LENABC),COORD(3,*)
      DIMENSION NSET(NPPA*NUMATM/2),NSETF(LENABC), N0(2)
      LOGICAL DIN(NPPA),ISUP
      COMMON / SOLV / FEPSI,RDS,DISEX2,NSPA,NPS,NPS2,NDEN,
     1                COSURF(3,LENABC), SRAD(NUMATM),ABCMAT(LENAB2),
     2                TM(3,3,NUMATM),QDEN(MAXDEN),DIRTM(3,NPPA),
     3                BH(LENABC)
     4       /SOLVI/  IATSP(LENABC+1),NAR(LENABC)
      COMMON /DIRVEC/ DIRVEC(3,NPPA), NN(3,NUMATM)
      COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM),
     1                NLAST(NUMATM), NORBS, NELECS,NALPHA,NBETA,
     2                NCLOSE,NOPEN,NDUMY,FRACT
      DIMENSION IPIV(LENABC)
      COMMON /AREAVD/ AREA
      COMMON /CHANEL/ IFILES(30)
      EQUIVALENCE(IW,IFILES(6))
      EQUIVALENCE (ABCMAT(LENABC*LENABC+1),XSP)
      ISUP=(NPS.GT.0)
      N0(1)=NPS2
      N0(2)=-NPS
      MAXNPS=SQRT(2*LENAB2+.251)-NDEN-.5
      MAXNPS=MIN(MAXNPS,LENABC)
      IF (MAXNPS .LT. 3*NUMAT) THEN
         WRITE(IW,*)' PARAMETER LENABC MUST BE INCREASED FOR THIS SYSTEM
     1'
         STOP       ' PARAMETER LENABC MUST BE INCREASED FOR THIS SYSTEM
     1'
      ENDIF
      IF (ISUP) THEN
         NPS3=LENABC-NPS
         DO 10 I=NPS,1,-1
            IATSP(NPS3+I)=IATSP(I)
            DO 10 IX=1,3
               COSURF(IX,NPS3+I)=COSURF(IX,I)
   10    CONTINUE
         NPS3=NPS3+1
      END IF
      SDIS=0.D0
      FDIAG=1.05D0*SQRT(NPPA+0.D0)
      INSET=1
      IATSP(LENABC+1)=0
      NPS = 0
      DO 340 I=1,NUMAT
         DS=SQRT(4.D0/NSPA)
         IF (NAT(I) .EQ. 1) DS=2*DS
         C2DS=COS(2.D0*DS)
         AREA=0.D0
         R=SRAD(I)
         RI=R-RDS
         DO 20 IX=1,3
   20    XA(IX)=COORD(IX,I)
         NPS0=NPS+1
         IF(ISUP) THEN
            IF (NPS .GE. NPS3) STOP 'NPS .GT. NPS3'
            NPS2=NPS3
            IF (IATSP(NPS0) .NE. I) GO TO 340
            DO 30 IPS=NPS2,LENABC+1
   30       IF(IATSP(IPS) .NE. I) GO TO 40
   40       NPS3=IPS
C TRANSFORM COSURF ACCORDING TO TM(INV)
            DO 50 J=NPS2,NPS3-1
               XX(1)=COSURF(1,J)
               XX(2)=COSURF(2,J)
               XX(3)=COSURF(3,J)
               COSURF(1,J)=XX(1)*TM(1,1,I)+XX(2)*TM(1,2,I)+XX(3)*TM(1,3,
     1I)
               COSURF(2,J)=XX(1)*TM(2,1,I)+XX(2)*TM(2,2,I)+XX(3)*TM(2,3,
     1I)
               COSURF(3,J)=XX(1)*TM(3,1,I)+XX(2)*TM(3,2,I)+XX(3)*TM(3,3,
     1I)
   50       CONTINUE
            NN1=NN(1,I)
            NN2=NN(2,I)
            NN3=NN(3,I)
         ELSE
C SEARCH FOR 3 NEAREST NEIGHBOR ATOMS
            DIST1=1.D20
            DIST2=1.D20
            DIST3=1.D20
            NN1=0
            NN2=0
            NN3=0
            DO 70 J=1,NUMAT
               IF (J.EQ. I) GO TO 70
               DIST=0.D0
               DO 60 IX=1,3
   60          DIST=DIST+(XA(IX)-COORD(IX,J))**2
               IF (DIST+0.05D0 .LT. DIST3) THEN
                  DIST3=DIST
                  NN3=J
               END IF
               IF (DIST3+0.05D0 .LT. DIST2) THEN
                  DIST=DIST2
                  DIST2=DIST3
                  DIST3=DIST
                  NN3=NN2
                  NN2=J
               END IF
               IF (DIST2+0.05D0 .LT. DIST1) THEN
                  DIST=DIST1
                  DIST1=DIST2
                  DIST2=DIST
                  NN2=NN1
                  NN1=J
               END IF
   70       CONTINUE
            NN(1,I)=NN1
            NN(2,I)=NN2
            NN(3,I)=NN3
         ENDIF
C BUILD NEW TRANSFORMATION MATRIX
         IF (NN1 .EQ. 0) THEN
            TM(1,1,I)=1.D0
            TM(1,2,I)=0.D0
            TM(1,3,I)=0.D0
         ELSE
            DIST1=0.D0
            DO 80 IX=1,3
   80       DIST1=DIST1+(XA(IX)-COORD(IX,NN1))**2
            DIST=1./SQRT(DIST1)
            TM(1,1,I)=(COORD(1,NN1)-XA(1))*DIST
            TM(1,2,I)=(COORD(2,NN1)-XA(2))*DIST
            TM(1,3,I)=(COORD(3,NN1)-XA(3))*DIST
         END IF
   90    IF (NN2 .EQ. 0) THEN
            TM(2,1,I)=-TM(1,2,I)
            TM(2,2,I)=TM(1,1,I)
            TM(2,3,I)=0.D0
         ELSE
            DIST2=0.D0
            DO 100 IX=1,3
  100       DIST2=DIST2+(XA(IX)-COORD(IX,NN2))**2
            DIST=1./SQRT(DIST2)
            XX(1)=(COORD(1,NN2)-XA(1))*DIST
            XX(2)=(COORD(2,NN2)-XA(2))*DIST
            XX(3)=(COORD(3,NN2)-XA(3))*DIST
            SP=XX(1)*TM(1,1,I)+XX(2)*TM(1,2,I)+XX(3)*TM(1,3,I)
            IF (SP*SP .GT. 0.99D0) THEN
               NN2=NN3
               NN3=0
               DIST2=DIST3
               GO TO 90
            END IF
            SININV=1.D0/SQRT(1.D0-SP*SP)
            TM(2,1,I)=(XX(1)-SP*TM(1,1,I))*SININV
            TM(2,2,I)=(XX(2)-SP*TM(1,2,I))*SININV
            TM(2,3,I)=(XX(3)-SP*TM(1,3,I))*SININV
         END IF
         TM(3,1,I)=TM(1,2,I)*TM(2,3,I)-TM(2,2,I)*TM(1,3,I)
         TM(3,2,I)=TM(1,3,I)*TM(2,1,I)-TM(2,3,I)*TM(1,1,I)
         TM(3,3,I)=TM(1,1,I)*TM(2,2,I)-TM(2,1,I)*TM(1,2,I)
C TRANSFORM DIRVEC ACCORDING TO TM
         DO 110 J=1,NPPA
            XX(1)=DIRVEC(1,J)
            XX(2)=DIRVEC(2,J)
            XX(3)=DIRVEC(3,J)
            DO 110 IX=1,3
               X=XX(1)*TM(1,IX,I)+XX(2)*TM(2,IX,I)+XX(3)*TM(3,IX,I)
               DIRTM(IX,J)=X
  110    CONTINUE
         IF (ISUP) THEN
            DO 120 J=NPS2,NPS3-1
               NPS=NPS+1
               IATSP(NPS)=I
               XX(1)=COSURF(1,J)
               XX(2)=COSURF(2,J)
               XX(3)=COSURF(3,J)
               COSURF(1,NPS)=XX(1)*TM(1,1,I)+XX(2)*TM(2,1,I)+XX(3)*TM(3,
     11,I)
               COSURF(2,NPS)=XX(1)*TM(1,2,I)+XX(2)*TM(2,2,I)+XX(3)*TM(3,
     12,I)
               COSURF(3,NPS)=XX(1)*TM(1,3,I)+XX(2)*TM(2,3,I)+XX(3)*TM(3,
     13,I)
  120       CONTINUE
         ELSE
         I0=2-1/NAT(I)
         JMAX=N0(I0)
         I0=3*(I0-1)*NPPA-3
         DO 45 J=1,JMAX
         NPS=NPS+1
         IATSP(NPS)=I
         XX(1)=ABCMAT(I0+J*3+1)
         XX(2)=ABCMAT(I0+J*3+2)
         XX(3)=ABCMAT(I0+J*3+3)
         COSURF(1,NPS)=XX(1)*TM(1,1,I)+XX(2)*TM(2,1,I)+XX(3)*TM(3,1,I)
         COSURF(2,NPS)=XX(1)*TM(1,2,I)+XX(2)*TM(2,2,I)+XX(3)*TM(3,2,I)
         COSURF(3,NPS)=XX(1)*TM(1,3,I)+XX(2)*TM(2,3,I)+XX(3)*TM(3,3,I)
  45     CONTINUE
         ENDIF
C FIND THE POINTS OF THE BASIC GRID ON THE SAS
         NAREA=0
         DO 160 J = 1,NPPA
            DIN(J)=.FALSE.
            DO 130 IX=1,3
               XX(IX) = XA(IX) + DIRTM(IX,J)* R
  130       CONTINUE
            DO 150 K = 1, NUMAT
               IF (K . EQ. I) GO TO 150
               DIST=0.
               DO 140 IX=1,3
                  DIST = DIST + (XX(IX) - COORD(IX,K))**2
  140          CONTINUE
               DIST=SQRT(DIST)-SRAD(K)
               IF (DIST .LT. 0) GO TO 160
  150       CONTINUE
            NAREA=NAREA+1
            DIN(J)=.TRUE.
  160    CONTINUE
         AREA=AREA+NAREA*RI*RI
  200    SDIS0=SDIS
         DO 210 IPS=NPS0,NPS
            NAR(IPS)=0
            XSP(1,IPS)=0.D0
            XSP(2,IPS)=0.D0
            XSP(3,IPS)=0.D0
  210    CONTINUE
         DO 250 J=1,NPPA
            IF (.NOT. DIN(J)) GO TO 250
            SPM=-1.D0
            X1=DIRTM(1,J)
            X2=DIRTM(2,J)
            X3=DIRTM(3,J)
            DO 220 IPS=NPS0,NPS
               SP=X1*COSURF(1,IPS)+X2*COSURF(2,IPS)+X3*COSURF(3,IPS)
               IF (SP .LT. SPM) GO TO 220
               SPM=SP
               IPM=IPS
  220       CONTINUE
            IF (SPM .LT. C2DS) THEN
               NPS=NPS+1
               IF (NPS .GT. MAXNPS) THEN
                  WRITE(IW,*) 'NPS IS GREATER THAN MAXNPS-USE SMALLER NS
     1PA'
                  STOP 'NPS GREATER THAN MAXNPS'
               END IF
               DO 230 IX=1,3
  230          COSURF(IX,NPS)=DIRTM(IX,J)
               IATSP(NPS)=I
               GO TO 200
            END IF
            NAR(IPM)=NAR(IPM)+1
            DO 240 IX=1,3
  240       XSP(IX,IPM)=XSP(IX,IPM)+DIRTM(IX,J)
  250    CONTINUE
         SDIS=0.D0
         IPS=NPS0-1
         IF(NPS.LT.IPS) GOTO 200
  260    IPS=IPS+1
  352  IF(NAR(IPS).EQ.0)THEN
       NPS=NPS-1
       IF(NPS.LT.IPS) GOTO 200
       DO 369 JPS=IPS,NPS
       NAR(JPS)=NAR(JPS+1)
       XSP(1,JPS)=XSP(1,JPS+1)
       XSP(2,JPS)=XSP(2,JPS+1)
  369  XSP(3,JPS)=XSP(3,JPS+1)
       GOTO 352
       ENDIF
         DIST=0.D0
         DO 280 IX=1,3
            X=XSP(IX,IPS)
            DIST=DIST+X*X
  280    CONTINUE
         SDIS=SDIS+DIST
         DIST=1.D0/SQRT(DIST)
         DO 290 IX=1,3
  290    COSURF(IX,IPS)=XSP(IX,IPS)*DIST
         IF(IPS.LT.NPS) GOTO 260
         IF (ABS(SDIS-SDIS0) .GT. 1.D-5) GO TO 200
         DO 310 IPS=NPS0,NPS
            NSETF(IPS)=INSET
            INSET=INSET+NAR(IPS)
            NAR(IPS)=0
            DO 300 IX=1,3
  300       XSP(IX,IPS)=XA(IX)+COSURF(IX,IPS)*RI
  310    CONTINUE
         DO 330 J=1,NPPA
            IF (.NOT. DIN(J)) GO TO 330
            SPM=-1.D0
            X1=DIRTM(1,J)
            X2=DIRTM(2,J)
            X3=DIRTM(3,J)
            DO 320 IPS=NPS0,NPS
               SP=X1*COSURF(1,IPS)+X2*COSURF(2,IPS)+X3*COSURF(3,IPS)
               IF (SP .LT. SPM) GO TO 320
               SPM=SP
               IPM=IPS
  320       CONTINUE
            IF (SPM .LT. C2DS) GO TO 330
            NARA=NAR(IPM)
            NSET(NSETF(IPM)+NARA)=J
            NAR(IPM)=NARA+1
  330    CONTINUE
  340 CONTINUE
      AREA=AREA*4.D0*3.14159D0/NPPA
C FILLING AAMAT
      DO 450 IPS=1,NPS
         I=IATSP(IPS)
         RI=SRAD(I)-RDS
         NARI=NAR(IPS)
         NSETFI=NSETF(IPS)
         AA=0.D0
         DO 350 K=NSETFI,NSETFI+NARI-1
            J1=NSET(K)
            AA=AA+FDIAG
            X1=DIRVEC(1,J1)
            X2=DIRVEC(2,J1)
            X3=DIRVEC(3,J1)
            DO 350 L=NSETFI,K-1
               J2=NSET(L)
               AA=AA+2.D0/SQRT((X1-DIRVEC(1,J2))**2+
     1             (X2-DIRVEC(2,J2))**2+(X3-DIRVEC(3,J2))**2)
  350    CONTINUE
         AA=AA/RI/NARI**2
         ABCMAT(IPS+(IPS-1)*NPS)=AA
         DO 360 IX=1,3
            XI(IX)=COORD(IX,I)
  360    XA(IX)=XSP(IX,IPS)
         DO 440 JPS=IPS+1,NPS
            NARJ=NAR(JPS)
            NSETFJ=NSETF(JPS)
            J=IATSP(JPS)
            DIST=0.
            DO 370 IX=1,3
               XJ(IX)=COORD(IX,J)-XI(IX)
  370       DIST=DIST+(XSP(IX,JPS)-XA(IX))**2
            IF (DIST .LT. DISEX2) THEN
               RJ=SRAD(J)-RDS
               AIJ=0.D0
               DO 430 K=NSETFI,NSETFI+NARI-1
                  J1=NSET(K)
                  DO 380 IX=1,3
  380             XX(IX)=DIRVEC(IX,J1)*RI
                  IF (I .NE. J) THEN
                     X1=XX(1)*TM(1,1,I)+XX(2)*TM(2,1,I)+XX(3)*TM(3,1,I)-
     1XJ(1)
                     X2=XX(1)*TM(1,2,I)+XX(2)*TM(2,2,I)+XX(3)*TM(3,2,I)-
     1XJ(2)
                     X3=XX(1)*TM(1,3,I)+XX(2)*TM(2,3,I)+XX(3)*TM(3,3,I)-
     1XJ(3)
                     DO 400 L=NSETFJ,NSETFJ+NARJ-1
                        J2=NSET(L)
                        DO 390 IX=1,3
  390                   XX(IX)=DIRVEC(IX,J2)*RJ
                        Y1=XX(1)*TM(1,1,J)+XX(2)*TM(2,1,J)+XX(3)*TM(3,1,
     1J)-X1
                        Y2=XX(1)*TM(1,2,J)+XX(2)*TM(2,2,J)+XX(3)*TM(3,2,
     1J)-X2
                        Y3=XX(1)*TM(1,3,J)+XX(2)*TM(2,3,J)+XX(3)*TM(3,3,
     1J)-X3
                        AIJ=AIJ+1.D0/SQRT(Y1*Y1+Y2*Y2+Y3*Y3)
  400                CONTINUE
                  ELSE
  410                DO 420 L=NSETFJ,NSETFJ+NARJ-1
                        J2=NSET(L)
C                  AA=((DIRVEC(1,J2)*RJ-XX(1))**2+(DIRVEC(2,J2)*RJ
C     &                   -XX(2))**2+(DIRVEC(3,J2)*RJ-XX(3))**2)
                        AIJ=AIJ+((DIRVEC(1,J2)*RJ-XX(1))**2+(DIRVEC(2,J2
     1)*RJ                   -XX(2))**2+(DIRVEC(3,J2)*RJ-XX(3))**2)**-.5
     2D0
  420                CONTINUE
                  END IF
  430          CONTINUE
               AIJ=AIJ/NARI/NARJ
            ELSE
               AIJ=1.D0/SQRT(DIST)
            END IF
            ABCMAT(IPS+(JPS-1)*NPS)=AIJ
            ABCMAT(JPS+(IPS-1)*NPS)=AIJ
  440    CONTINUE
  450 CONTINUE
C INVERT A-MATRIX
      CALL DGETRF(NPS,NPS,ABCMAT,NPS,IPIV,INFO)
      CALL DGETRI(NPS,ABCMAT,NPS,IPIV,XSP, 3*LENABC,INFO)
C  STORE INV. A-MATRIX AS LOWER TRIANGLE
      II=0
      DO 460 I=1,NPS
         DO 460 J=1,I
            II=II+1
            ABCMAT(II)=ABCMAT(J+(I-1)*NPS)
  460 CONTINUE
      NPS2=II
      RETURN
      END


module negf_output_module
  implicit none

  contains

     subroutine write_mat(matA,Arange,maxijk,fname,ladd)
  ! ----------------------------------------------------------------------
  !
  !   Write out matrix values with indeces
  !   (primary atom, neighbour atom, sf1 in primary atom, sf2 in neighbour atom,
  !    which are all in global numbers).
  !

  ! ----------------------------------------------------------------------
  ! (modfied version based on Nakata-san's source)
  ! Dump matricies into PETSc format (AIJ storage) to load them with MatLoad
  ! http://www.mcs.anl.gov/petsc/petsc-current/docs/manualpages/Mat/MatLoad.html
  !
  ! 1. First run: get non-zero structure
  ! 2. Second run: Write matrix to disk, seperate file for different cells
  ! ----------------------------------------------------------------------

      use datatypes
      use numbers,             ONLY: zero
      use global_module,       ONLY: id_glob, species_glob, numprocs, ni_in_cell, &
                                     x_atom_cell,y_atom_cell,z_atom_cell,io_lun,sf
      use species_module,      ONLY: species, nsf_species, npao_species
      use GenComms,            ONLY: myid, cq_abort, gsum, my_barrier, inode, ionode,numprocs,gmax,gsum,int_copy
  !    use ScalapackFormat,     ONLY: pgid, pg_kpoints
      use matrix_module,       ONLY: matrix, matrix_halo
      use group_module,        ONLY: parts
      use primary_module,      ONLY: bundle
      use cover_module,        ONLY: BCS_parts
      use support_spec_format, ONLY: flag_paos_atoms_in_cell, flag_one_to_one
      use matrix_data,         ONLY: mat, halo,mat_name
      use mult_module,         ONLY: matrix_pos, mat_p
      use input_module,        ONLY: io_assign, io_close
      use timer_module
      use dimens,         only: r_super_x, r_super_y, r_super_z
      use functions_on_grid,           only: atomfns

      use MPI

      implicit none

      type mat_aij
        integer, allocatable :: cols(:), offsets(:)
      end type mat_aij

      ! Passned variables
      integer, intent(in) :: matA, Arange
      integer, intent(out) :: maxijk(3)
      character(*) :: fname
      logical, optional :: ladd

      ! Local variables

      type(mat_aij), allocatable :: mat_info(:,:,:,:)

      integer :: iprim, np, i, j, ist, atom_num, atom_i, atom_spec, nprim
      integer :: neigh_global_part, atom_j, neigh_species, j_in_halo
      integer :: nsf1, nsf2, nsf, nsf0, max_nab, last_m, &
                 k, l, kl, kg, lg, kstart, lstart, jj,ip,itmp
      integer :: gcspart, matrix_size
      integer :: wheremat
      integer, parameter :: Ilast=9999999
      real(double) :: dx, dy, dz, r2
      real(double) :: rval, phase, rfac, ifac
      real(double), allocatable :: values_local(:), values_global(:)

      integer, allocatable ::  cols_global(:), cols_offset(:), cols_global_idx(:)

      integer, allocatable :: label_nsf_g(:)
      integer, allocatable :: label(:,:), start_m(:,:)
      complex(double_cplx) :: cval
      complex(double_cplx), allocatable :: buf_out(:), buf_in(:)
      integer, allocatable :: iunit(:,:,:), IamMat(:,:), displ(:), nz_receive(:), at_npaos(:)
      integer, allocatable :: nzrow(:,:,:,:), nzcount(:,:,:), nzrow_local(:,:,:,:), pos_out(:), &
        pos_col_out(:), buf_col_out(:)
      integer :: i1,i2,i3,irun,irow,icol,nbatch,ii,ierr, nz_l, nz_g, nzoff, max_nsf
      integer :: lun
      integer :: FSCpart,iii(1)
      integer :: maxi,iheaderoff,ipos, kkl, ipos_col, ipos_val, nzrow_i, row_offset, header_offset
      character(256),allocatable :: petscfile(:,:,:)
      character(256) :: si1,si2,si3
      complex(double_cplx) :: zout,zin
      integer :: isize, zsize
      logical :: lreadandadd, ldebug
      integer(8) :: counti, count_rate, countf, i_offset

      ldebug = .false.
      lreadandadd=.false.
      if (present(ladd)) lreadandadd=ladd

      isize=kind(ierr)
      zsize=kind(cval)*2

      matrix_size = 0 !ni_in_cell*nsf
      do i = 1, ni_in_cell
        matrix_size = matrix_size + nsf_species(species(i))
      end do
      max_nsf = maxval(nsf_species)

      write(io_lun,fmt='(A,A,A,i8)') "start writing ",trim(fname)," matrix size ",matrix_size

      allocate(buf_out(max_nsf), buf_in(max_nsf), buf_col_out(max_nsf), &
        pos_out(max_nsf), pos_col_out(max_nsf), stat=ierr)

      allocate(at_npaos(ni_in_cell), displ(numprocs), nz_receive(numprocs), &
        stat=ierr)

      iprim = 0
      maxijk=0
      at_npaos=0d0

      do i = 1, ni_in_cell
        at_npaos(i)=nsf_species(species_glob(i))
      end do

      do irun = 0, 3
        call system_clock(counti, count_rate)
        write(io_lun,fmt='(i3," / 3 ")', advance="no") irun
        iprim = 0
        do np = 1,bundle%groups_on_node ! Loop over primary set partitions
          do i = 1,bundle%nm_nodgroup(np) ! Loop over atoms
            atom_num = bundle%nm_nodbeg(np) + i - 1
            iprim = iprim + 1
            atom_i = bundle%ig_prim(iprim)         ! global number of i
            atom_spec = bundle%species(atom_num)   ! atomic species of i
            nsf1 = nsf_species(atom_spec)          ! number of SFs on i

            ii = 0 ! column index
            do j = 1, mat(np,Arange)%n_nab(i) ! Loop over neighbours
              ist = mat(np,Arange)%i_acc(i) + j - 1
              gcspart = BCS_parts%icover_ibeg(mat(np,Arange)%i_part(ist))+mat(np,Arange)%i_seq(ist)-1
              neigh_global_part = BCS_parts%lab_cell(mat(np,Arange)%i_part(ist))
              atom_j = id_glob(parts%icell_beg(neigh_global_part)+mat(np,Arange)%i_seq(ist)-1)   ! global number of j
              neigh_species = species_glob(atom_j)                                               ! atomic species of j
              nsf2 = nsf_species(neigh_species)                                                  ! number of SFs on j
              FSCpart = BCS_parts%lab_cell(mat(np,Arange)%i_part(ist))!gcspart)
! - this is the original definition used during the SCF. The phase depends on the actual atomic position
!                    dx = BCS_parts%xcover(gcspart)-bundle%xprim(atom_num)
!                    dy = BCS_parts%ycover(gcspart)-bundle%yprim(atom_num)
!                    dz = BCS_parts%zcover(gcspart)-bundle%zprim(atom_num)
!--------------------------------------------------------------------------------------------------------
! - this is the usual definition of real-space vs. k-space, that is in terms of real-space units cells.
              dx = BCS_parts%xcover(gcspart)-x_atom_cell(parts%icell_beg(FSCpart)+mat(np,Arange)%i_seq(ist)-1)
              dy = BCS_parts%ycover(gcspart)-y_atom_cell(parts%icell_beg(FSCpart)+mat(np,Arange)%i_seq(ist)-1)
              dz = BCS_parts%zcover(gcspart)-z_atom_cell(parts%icell_beg(FSCpart)+mat(np,Arange)%i_seq(ist)-1)
!------------------------------------------------------------------------------------------------------------
!~                   write(0,fmt='(A,2i8,e24.12)') "atoms ",atom_i,atom_j,dz
              i1=nint(dx/r_super_x)
              i2=nint(dy/r_super_y)
              i3=nint(dz/r_super_z)

              if (irun.eq.0) then
                maxijk(1)=max(maxijk(1),abs(i1))
                maxijk(2)=max(maxijk(2),abs(i2))
                maxijk(3)=max(maxijk(3),abs(i3))
                cycle
              end if

              j_in_halo = halo(Arange)%i_halo(gcspart)                                         ! halo-ID of j
              neigh_species = species_glob(atom_j)                                             ! atomic species of j
              nsf2 = nsf_species(neigh_species)                                                ! number of SFs on j

              do k = 1, nsf1
                irow = k+sum(at_npaos(1:atom_i-1))
                do l = 1, nsf2
                  icol = l+sum(at_npaos(1:atom_j-1))

                  if (irun.eq.1) then

                    nzrow_local(irow,i1,i2,i3) = nzrow_local(irow,i1,i2,i3) + 1

                  else if (irun .eq. 2) then

                    nzrow_local(irow,i1,i2,i3) = nzrow_local(irow,i1,i2,i3) + 1
                    mat_info(irow,i1,i2,i3)%cols(nzrow_local(irow,i1,i2,i3)) = icol

                  else if (irun .eq. 3) then

                    nzrow_local(irow,i1,i2,i3) = nzrow_local(irow,i1,i2,i3) + 1

                    wheremat = matrix_pos(matA,iprim,j_in_halo,k,l)
                    rval = mat_p(matA)%matrix(wheremat)
                    cval = cmplx(rval,0d0,double_cplx)

                    row_offset = sum(nzrow(1:irow-1,i1,i2,i3))
                    ipos = header_offset + row_offset * isize + mat_info(irow,i1,i2,i3)%offsets(nzrow_local(irow,i1,i2,i3)) * isize
                    pos_col_out(l) = ipos
                    buf_col_out(l) = icol -1
!~                     write(unit=iunit(i1,i2,i3),pos=ipos) icol - 1

                    ipos = header_offset + nzcount(i1,i2,i3) * isize + row_offset * zsize + mat_info(irow,i1,i2,i3)%offsets(nzrow_local(irow,i1,i2,i3)) * zsize
                    pos_out(l) = ipos
                    buf_out(l) = cval
!~                     write(unit=iunit(i1,i2,i3),pos=ipos) cval

!~ debug needs offset for all i1,i2,i3 or we also create seperate files
!~                     write(si1,fmt='(5i7,es45.24e5,2i8,X,A,X,i8)')  i1,i2,i3,irow,icol,rval,atom_i,atom_j,trim(fname),inode
!~                     si1=adjustl(si1)
!~                     ipos = ( sum(nzrow(1:irow-1,i1,i2,i3)) + mat_info(irow,i1,i2,i3)%offsets(nzrow_local(irow,i1,i2,i3))  ) * (len(trim(si1))+1) +1
!~                     write(lun,fmt='(A)', pos=ipos)  trim(si1)
!~                     write(0,fmt='(5i7,es45.24e5,2i8,X,A,X,i8)')  i1,i2,i3,irow,icol,rval,ipos,len(trim(si1)),trim(fname),inode

                  end if
                end do
                if (irun .eq. 3) then
                  do l = 1, nsf2-1
                    if ((pos_col_out(l+1)-pos_col_out(l)).ne.4) then
                      write(0,*) "buf_col allignment error ",pos_col_out(1:nsf2)
                      stop
                    end if
                    if ((pos_out(l+1)-pos_out(l)).ne.16) then
                      write(0,*) "buf allignment error ",pos_out(1:nsf2)
                      stop
                    end if
                  end do
                  if (lreadandadd) then
                    i_offset = pos_out(1) - 1
                    call MPI_FILE_READ_AT(iunit(i1,i2,i3), i_offset, buf_col_out(1:nsf2), &
                     nsf2, MPI_INTEGER, MPI_STATUS_IGNORE, ierr)
!~                     read(unit = iunit(i1,i2,i3), pos = pos_out(1)) buf_in(1:nsf2)
                    buf_in(1:nsf2) = swap_endian_z(buf_in(1:nsf2))
                    buf_out(1:nsf2) = buf_in(1:nsf2) + buf_out(1:nsf2)
                  end if
                  i_offset = pos_col_out(1) - 1
                  buf_col_out(1:nsf2) = swap_endian_i4(buf_col_out(1:nsf2))
                  call MPI_FILE_WRITE_AT(iunit(i1,i2,i3), i_offset, buf_col_out(1:nsf2), nsf2, &
                  MPI_INTEGER, MPI_STATUS_IGNORE, ierr)
                  i_offset = pos_out(1) - 1
                  buf_out(1:nsf2) = swap_endian_z(buf_out(1:nsf2))
                  call MPI_FILE_WRITE_AT(iunit(i1,i2,i3), i_offset, buf_out(1:nsf2), nsf2, &
                  MPI_DOUBLE_COMPLEX, MPI_STATUS_IGNORE, ierr)
!~                   write(unit=iunit(i1,i2,i3),pos=pos_col_out(1)) swap_endian_i4(buf_col_out(1:nsf2))
!~                   write(unit=iunit(i1,i2,i3),pos=pos_out(1)) swap_endian_z(buf_out(1:nsf2))
                end if
              end do

            end do ! j
          end do ! i
        end do ! np

        if (irun .eq. 0) then

          call gmax(maxijk(1))
          call gmax(maxijk(2))
          call gmax(maxijk(3))

          allocate(nzrow(matrix_size,-maxijk(1):maxijk(1),-maxijk(2):maxijk(2),-maxijk(3):maxijk(3)),&
            nzrow_local(matrix_size,-maxijk(1):maxijk(1),-maxijk(2):maxijk(2),-maxijk(3):maxijk(3)),&
            nzcount(-maxijk(1):maxijk(1),-maxijk(2):maxijk(2),-maxijk(3):maxijk(3)),&
            mat_info(matrix_size,-maxijk(1):maxijk(1),-maxijk(2):maxijk(2),-maxijk(3):maxijk(3)),&
            petscfile(-maxijk(1):maxijk(1),-maxijk(2):maxijk(2),-maxijk(3):maxijk(3)),&
            iunit(-maxijk(1):maxijk(1),-maxijk(2):maxijk(2),-maxijk(3):maxijk(3)), stat=ierr)
          nzrow=0
          nzrow_local=0
        else if (irun .eq. 1) then

          nzrow = nzrow_local
          do i3=-maxijk(3),maxijk(3)
            do i2=-maxijk(2),maxijk(2)
              do i1=-maxijk(1),maxijk(1)
                do irow=1,matrix_size
                  call gsum(nzrow(irow,i1,i2,i3))
                  nz_l=nzrow_local(irow,i1,i2,i3)
                  allocate(mat_info(irow,i1,i2,i3)%cols(nz_l),&
                    mat_info(irow,i1,i2,i3)%offsets(nz_l), stat=ierr)
                  if (ierr.ne.0) then
                    write(0,fmt='(i8,A,i8)') inode," allocation error mat_info ",ierr
                  end if
                end do
                nzcount(i1,i2,i3) = sum(nzrow(:,i1,i2,i3))
              end do
            end do
          end do

          nzrow_local = 0

        else if (irun .eq. 2) then
          nz_g = maxval(nzrow)
          allocate(cols_global(nz_g), cols_offset(nz_g), cols_global_idx(nz_g), &
            stat=ierr)
          do i3=-maxijk(3),maxijk(3)
            do i2=-maxijk(2),maxijk(2)
              do i1=-maxijk(1),maxijk(1)
                do irow=1,matrix_size
                  nz_l=nzrow_local(irow,i1,i2,i3)
                  nz_g=nzrow(irow,i1,i2,i3)
                  if (nz_g.eq.0) cycle
                  nz_receive=-1
                  call MPI_Gather(nz_l, 1, MPI_INTEGER, nz_receive, 1, MPI_INTEGER, ionode-1, MPI_COMM_WORLD,ierr)
                  if (ierr.ne.0) then
                    write(0,fmt='(i8,A,i8)') inode," MPI_Gather nz_l failed ",ierr
                    stop
                  end if
                  displ=cshift(nz_receive,-1)
                  displ(1)=0

                  cols_global=-1
                  if ((nz_g.ne.sum(nz_receive)).and.(inode.eq.ionode)) then
                    write(io_lun,fmt='(i4,A,6i12,A)') "nz_g .ne. sum nz_receive ",nz_g,sum(nz_receive),i1,i2,i3,irow
                    stop
                  end if
                  call MPI_Gatherv(mat_info(irow,i1,i2,i3)%cols(1:nz_l), nz_l, MPI_INTEGER, &
                    cols_global(1:nz_g), nz_receive, displ, MPI_INTEGER, ionode-1, MPI_COMM_WORLD, ierr)
                  if (ierr.ne.0) then
                    write(0,fmt='(i8,A,i8)') inode," MPI_Gatherv cols_local -> cols_global failed ",ierr
                    stop
                  end if
!~                   write(io_lun,fmt='(A,6i6," XX ",999i6)') "cols ",i1,i2,i3,irow,matrix_size,nz_g,cols_global(1:nz_g)

                  if (ionode .eq. inode) then
                    cols_offset(1:nz_g) = 0

                    do icol = 1, nz_g
                      cols_global_idx(icol) = icol
                    end do
                    call sort_ab(cols_global(1:nz_g), cols_global_idx(1:nz_g))

                    do i = 1, nz_g
                      cols_offset(cols_global_idx(i)) = i - 1
                    end do

!~                     do icol = 1, nz_g
!~                       do k = 1, nz_g
!~                         if (cols_global(k).lt.cols_global(icol)) cols_offset(icol)=cols_offset(icol) + 1
!~                       end do
!~                     end do

                  end if

                  call MPI_SCATTERV(cols_offset(1:nz_g), nz_receive, displ, MPI_INTEGER,&
                   mat_info(irow,i1,i2,i3)%offsets(1:nz_l), nz_l, MPI_INTEGER, ionode-1, MPI_COMM_WORLD, ierr)
                  if (ierr.ne.0) then
                    write(0,fmt='(i8,A,i8)') inode," MPI_Scatterv cols_offset -> local offsets ",ierr
                    stop
                  end if
!~                   write(io_lun,fmt='(A,6i6," XX ",999i6)') "offs ",i1,i2,i3,irow,matrix_size,nz_g,cols_offset(1:nz_g)

                end do ! irow

! prepare filenames

                write(si3,*) i3
                si3=adjustl(si3)
                write(si2,*) i2
                si2=adjustl(si2)
                write(si1,*) i1
                si1=adjustl(si1)
                petscfile(i1,i2,i3)=trim(fname)//"_"//trim(si1)//"_"//trim(si2)//&
                  "_"//trim(si3)//"_petsc.dat"

! using fortran 2003 standard: access="stream", read/write controlled by pos=x where pos is here given in byte
! -> integer(4) -> 4 byte, double precision -> 8 byte, double complex -> 16 byte
! PETSc MAT_LOAD need ordered nonzero columns, that is very cumbersome to work out here. -> Use MPI_READs in transport code
! to load matrices and work out process partition. No BIG_ENDIAN necessary as for MAT_LOAD
                if (ionode.eq.ionode) then
                  if (.not.lreadandadd) then

                    open(newunit=iunit(i1,i2,i3),file=trim(petscfile(i1,i2,i3)),access="stream",&
                      status="replace", BUFFERED='YES' )
!~                       status="replace",CONVERT='BIG_ENDIAN', BUFFERED='YES' )
! header ---- start
                      ipos = 1 ! 1
                      write(iunit(i1,i2,i3),pos=ipos) swap_endian_i4(1211216)
                      ipos = ipos + isize ! 5
                      write(iunit(i1,i2,i3),pos=ipos) swap_endian_i4(matrix_size)
                      ipos = ipos + isize ! 9
                      write(iunit(i1,i2,i3),pos=ipos) swap_endian_i4(matrix_size)
                      ipos = ipos + isize ! 13
                      write(iunit(i1,i2,i3),pos=ipos) swap_endian_i4(nzcount(i1,i2,i3))
                      ipos = ipos + isize ! 17
                      write(iunit(i1,i2,i3),pos=ipos) swap_endian_i4(nzrow(1:matrix_size,i1,i2,i3))
                      ipos = ipos + isize * matrix_size
! header ---- start
                      close(iunit(i1,i2,i3))
                      if (ldebug) then
                        open(newunit=lun, file=trim(fname)//".dat", status="replace", access="stream", &
                          form="formatted")
                        close(lun)
                      end if
                  end if

                end if ! ionode

                header_offset = 1 + 4 * isize + matrix_size * isize

                call MPI_BARRIER(MPI_COMM_WORLD,ierr)

                call MPI_FILE_OPEN(MPI_COMM_WORLD, trim(petscfile(i1,i2,i3)), &
                  MPI_MODE_WRONLY + MPI_MODE_CREATE, MPI_INFO_NULL, iunit(i1,i2,i3), ierr)

!~                 open(newunit=iunit(i1,i2,i3),file=trim(petscfile(i1,i2,i3)),access="stream",&
!~                   status="old", BUFFERED='YES')
!~                   status="old",CONVERT='BIG_ENDIAN', BUFFERED='YES')

              end do ! i1
            end do ! i2
          end do !i3

          if (ldebug) open(newunit=lun, file=trim(fname)//".dat", status="old", &
            access="stream", form="formatted")
          nzrow_local = 0

          deallocate(cols_global, cols_offset, cols_global_idx, stat=ierr)

        end if  ! irun = 2
        call system_clock(countf)
        write (io_lun, fmt='(X,e24.12)') real(countf - counti, 8)/real(count_rate, 8)
      end do ! irun

      if (ldebug) close(lun)
      do i3=-maxijk(3),maxijk(3)
        do i2=-maxijk(2),maxijk(2)
          do i1=-maxijk(1),maxijk(1)
            call MPI_File_Close(iunit(i1,i2,i3), ierr)
!~             close(iunit(i1,i2,i3))
          end do
        end do
      end do

    end subroutine write_mat

    subroutine sort_ab(A, B)
      implicit none

        integer :: A(:), B(:)
        integer :: i, j, n, l ,ir, a_save, b_save

        n = size(A)

        l = n/2+1
        ir = n

        do
          if(l .gt. 1) then
            L = l - 1
            a_save = A(l)
            b_save = B(l)
          else
            a_save = A(ir)
            b_save = B(ir)
            A(ir) = A(1)
            B(ir) = B(1)
            ir = ir - 1
            if(ir .eq. 1) then
              A(1)=a_save
              B(1)=b_save
              return
            end if
          end if
          i = l
          j = l + l
          do
            if(j .le. ir) then
              if(j .lt. ir) then
                if(A(j) .le. A(j+1)) j = j + 1
              end if
              if(a_save .lt. A(j)) then
                A(i) = A(j)
                B(i) = B(j)
                i = j
                j = j + j
              else
                j = ir + 1
              end if
            else
              exit
            end if
          end do
          A(i) = a_save
          B(i) = b_save
        end do

    end subroutine sort_ab

    elemental function swap_endian_z(x) result(res)
      complex(8) :: res
      double complex,intent(in)::x
      integer(1),dimension(8):: bytes_r, bytes_i
      real(8) :: r_r, r_i

      bytes_r = transfer(real(x,8),bytes_r,8)
      bytes_i = transfer(aimag(x),bytes_i,8)
      bytes_r(1:8) = bytes_r(8:1:-1)
      bytes_i(1:8) = bytes_i(8:1:-1)
      r_r = transfer(bytes_r,r_r)
      r_i = transfer(bytes_i,r_i)
      res = cmplx(r_r, r_i, 8)

    end function swap_endian_z

    elemental function swap_endian_i4(x) result(res)
      integer(4) :: res
      integer(4), intent(in)::x
      integer(1),dimension(4):: bytes

      bytes = transfer(x,bytes,4)
      bytes(1:4) = bytes(4:1:-1)
      res = transfer(bytes,res)

    end function swap_endian_i4

end module negf_output_module


\ Fruitflies.f
\ Based on 10+ year old code written for Win32Forth

empty
include le/le
import le/oe/task
le: role fruitflies:

\ This program was inspired by the motion of flies.
\ Usually the flies die out before things get interesting or they
\ overpopulate and prosper indefinitely.
200 constant lifespan
defer fly
var life  var r  var g  var b  var a   var s  \ s=size

: oranges  0 0 vx 2!  yellow @color r 4!  20 rnd 0 ?do  i s !  pause  loop ;     \ temporary; these should draw extra stuff under the green center
: apples   0 0 vx 2!  red @color r 4!    50 rnd 0 ?do  i s !  pause  4 +loop ;  \ temporary; these should draw extra stuff under the green center
: randmove  green @color r 4!  8 s !  5 rnd 2.5 -  5 rnd 2.5 -  vx 2!  8 pauses ;
: ?bore  7 rnd pfloor 0= if { 0 0 from one fly } then ;
: live  100 rnd lifespan + life ! ;
: darker  0.99 * ; \  0.95 0.95 2*  2>r  0.95 0.95 2*  2r> ;
: fadeout  300 0 do  r 4@ darker r 4!  pause  loop ;
: die  0 0 vx 2!   50 pauses  0.5 0.5 0.5 1 r 4!  2 secs  fadeout  me delete ;
: ?die  life @ 0 <= -exit  die ;
: mortal  live  act>  life -- ;
: twitch  0 perform>  begin  apples randmove oranges randmove ?bore ?die  again ;
:noname  [ is fly ]  mortal  twitch  green @color r 4!  draw>  r 4@ color  s @ circlef ;

scene
displaywh 0.5 0.5 2* at  one fly  named og
:noname  black backdrop ; is prerender


c
c   Dint – version 2.0  is licensed under the Apache License, Version 2.0 (the "License");
c   you may not use Dint – version 2.0 except in compliance with the License.
c   You may obtain a copy of the License at
c       http://www.apache.org/licenses/LICENSE-2.0
c   The license is also given in the LICENSE file.
c   Unless required by applicable law or agreed to in writing, software
c   distributed under the License is distributed on an "AS IS" BASIS,
c   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
c   See the License for the specific language governing permissions and limitations under the License.
c
c -------------------------------------------------------------------------------------------
c  Dint : Direct Nonadiabatic Trajectories A code for non-Born–Oppenheimer molecular dynamics
c
c  version 2.0
c
c  A. W. Jasper
c  Argonne National Laboratory
c
c  Rui Ming Zhang
c  Tsinghua University
c
c  and
c
c  D. G. Truhlar
c  University of Minnesota
c
c  copyright  2020
c  Donald G. Truhlar and Regents of the University of Minnesota
c----------------------------------------------------------------------------------------------

      subroutine ewkb(ji,vi,arri,mm,erotvib,rin,rout,nsurf)

c This subroutine is specialized for the atom-diatom initial conditions.
c It computes the WKB energy for the rovibrational state (vi,ji).
c INPUT
c ji = initial rot state of diatom
c vi = initial vib state of the diatom
c arri = initial arrangement
c mm = masses of the atoms
c OUTPUT
c erotvib = rivibrational energy for (vi,ji) state

      implicit none
      include 'param.f'

      integer ji,vi,arri,nsurf
      double precision mm(mnat),erotvib,xj

c     local
      integer i,j,JMAX
      double precision rmin,emin,emax,xv,f,fmid,dx,rtbis_vib,etry,
     & rin,rout

      xj = dble(ji)

c Need to bracket energy for (vi,ji) state
c     find minimum of diatom (no rotation)
      call diamin(rmin,emin,xj,arri,mm,nsurf)
c     get asymptotic energy
      call diapot(1000.d0,arri,emax,0.d0,mm,nsurf)
c      write(6,*)"Minimum energy for diatom in arr ",arri,
c     &  " is ",emin*autoev," eV at ",rmin," bohr"
c      write(6,*)"Asym energy is ",emax*autoev," eV"

c Now determine energy of (vi,ji) state
c     compute vibrational action at E = emax
      call vwkb(arri,mm,emin,xj,xv,rin,rout,nsurf)
      f = xv - dble(vi)
c      write(6,*)"vibrational action at emin = ",xv
c     compute vibrational action at E = emin
      call vwkb(arri,mm,emax,xj,xv,rin,rout,nsurf)
      fmid = xv - dble(vi)
c      write(6,*)"vibrational action at emax = ",xv

      if (f*fmid.ge.0.d0) then
          write(6,1000)
          stop
      end if
      if (f.lt.0.d0) then
          rtbis_vib=emin
          dx=emax-emin
      else
          rtbis_vib=emax
          dx=emin-emax
      end if

      JMAX=100
      do 11 j = 1, JMAX
          dx=dx*0.5d0
          etry=rtbis_vib+dx
          call vwkb(arri,mm,etry,xj,xv,rin,rout,nsurf)
c          write(6,*)"trying...",etry*27.211d0
c          write(6,*)"vibrational action at etry = ",xv
          fmid = xv - dble(vi)
          if (fmid.le.0.d0) rtbis_vib=etry
          if (abs(dx).lt.1.d-10.or.fmid.eq.0.d0) go to 12
   11 continue
      write(6,1010)
      stop
 1000 format(2x,'root must be bracketed in rtbis_vib')
 1010 format(2x,'Too many bisections in rtbis_vib')

   12 continue

      erotvib = rtbis_vib

      return

      end


! <cstatm.f90 - A component of the City-scale
!                 Chemistry Transport Model EPISODE-CityChem>
!*****************************************************************************!
!*
!* EPISODE - An urban-scale air quality model
!* ==========================================
!* Copyright (C) 2018  NILU - Norwegian Institute for Air Research
!*                     Instituttveien 18
!*                     PO Box 100
!*                     NO-2027 Kjeller
!*                     Norway
!*
!*                     Contact persons: Gabriela Sousa Santos - gss@nilu.no
!*                                      Paul Hamer - pdh@nilu.no
!*
!* Unless explicitly acquired and licensed from Licensor under another license,
!* the contents of this file are subject to the Reciprocal Public License ("RPL")
!* Version 1.5, https://opensource.org/licenses/RPL-1.5 or subsequent versions as
!* allowed by the RPL, and You may not copy or use this file in either source code
!* or executable form, except in compliance with the terms and conditions of the RPL.
!*
!* All software distributed under the RPL is provided strictly on an "AS IS" basis,
!* WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESS OR IMPLIED, AND LICENSOR HEREBY
!* DISCLAIMS ALL SUCH WARRANTIES, INCLUDING WITHOUT LIMITATION, ANY WARRANTIES OF
!* MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, QUIET ENJOYMENT, OR NON-INFRINGEMENT.
!* See the RPL for specific language governing rights and limitations under the RPL.
!*
!* ==========================================
!* The dispersion model EPISODE (Grønskei et. al., 1993; Larssen et al., 1994;
!* Walker et al., 1992, 1999; Slørdal et al., 2003, 2008) is an Eulerian grid model
!* with embedded subgrid models for calculations of pollutant concentrations resulting
!* from different types of sources (area-, line- and point sources). EPISODE solves the
!* time dependent advection/-diffusion equation on a 3 dimensional grid.
!* Finite difference numerical methods are applied to integrate the solution forward in time.
!* It also includes extensions as the implementation of a simplified EMEP photochemistry
!* scheme for urban areas (Walker et al. 2004) and a scheme for Secondary Organic Aerosol
!* implemented by Håvard Slørdal
!*
!* Grønskei, K.E., Walker, S.E., Gram, F. (1993) Evaluation of a model for hourly spatial
!*    concentrations distributions. Atmos. Environ., 27B, 105-120.
!* Larssen, S., Grønskei, K.E., Gram, F., Hagen, L.O., Walker, S.E. (1994) Verification of
!*    urban scale time-dependent dispersion model with sub-grid elements in Oslo, Norway.
!*    In: Air poll. modelling and its appl. X. New York, Plenum Press.
!* Slørdal, L.H., McInnes, H., Krognes, T. (2008): The Air Quality Information System AirQUIS.
!*    Info. Techn. Environ. Eng., 1, 40-47, 2008.
!* Slørdal, L.H., Walker, S.-E., Solberg, S. (2003) The Urban Air Dispersion Model EPISODE
!*    applied in AirQUIS. Technical Description. NILU TR 12/2003. ISBN 82-425-1522-0.
!* Walker, S.E., Grønskei, K.E. (1992) Spredningsberegninger for on-line overvåking i Grenland.
!*    Programbeskrivelse og brukerveiledning. Lillestrøm,
!*    Norwegian Institute for Air Research (NILU OR 55/92).
!* Walker, S.E., Slørdal, L.H., Guerreiro, C., Gram, F., Grønskei, K.E. (1999) Air pollution
!*    exposure monitoring and estimation. Part II. Model evaluation and population exposure.
!*    J. Environ. Monit, 1, 321-326.
!* Walker, S.-E., Solberg, S., Denby, B. (2003) Development and implementation of a
!*    simplified EMEP photochemistry scheme for urban areas in EPISODE. NILU TR 13/2013.
!*    ISBN 82-425-1524-7
!*****************************************************************************!

      subroutine CSTATM

! The subroutine updates main grid concentration statistics.
! Changed this routine so that averages (only) are calculated for all compounds 1:NC
! Should be further updated for the other statistics
! ----------------------------------------------------------------------------------
! Based on:
! Version Episode 5.5 (May29, 2012) prepared for BB-Stand-Alone
! Original source code of EPISODE by Sam-Erik Walker (NILU)
!
! Sam-Erik Walker
! Norwegian Institute for Air Research (NILU)
! Instituttveien 18 P.O. Box 100
! N-2027 Kjeller, NORWAY
! Tel: +47 63898000 Fax: +47 63898050
! E-mail: sam-erik.walker@nilu.no
!
! ----------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------
! REVISION HISTORY
!
!           2017  M. Karl: Calculation of CMAVED is now inside tsstat.for
!
! ----------------------------------------------------------------------------------

      use mod_util
      use mod_main
      use mod_site
      use mod_time
      use mod_mete
      use mod_conc
      use mod_depo
      use mod_stat

      implicit none

! *** Local variables

      real    :: CMHIGHDMAX
      real    :: CMHIGHHMAX
      real    :: CMHIGHDMIN
      real    :: CMHIGHHMIN
      real    :: TMPV

      integer :: IC
      integer :: IHIGHH
      integer :: IHIGHD
      integer :: IV
      integer :: IVMAX
      integer :: IX
      integer :: IY

! CMHIGHDMAX - Maximum of highest daily  concentration values
! CMHIGHDMIN - Minimum of highest daily  concentration values
! CMHIGHHMAX - Maximum of highest daily  concentration values
! CMHIGHHMIN - Minimum of highest hourly concentration values
! TMPV       - Temporary swap value
! IC         - Compound index
! IHIGHH     - Highest hourly concentrations index
! IHIGHD     - Highest daily  concentrations index
! IV         - Index value
! IVMAX      - Index value
! IX         - Main grid index in x-direction
! IY         - Main grid index in y-direction

! *** External functions:

!MSK      LOGICAL ATDATE

! *** If no grid cells then return

      IF (NX .EQ. 0 .OR. NY .EQ. 0) RETURN

! *** UPDATE HIGHEST HOURLY CONCENTRATIONS:

! *** Number of highest hourly values set to zero or missing?
! *** Then skip the treatment of the NHIGHH highest conc.

      IF (NHIGHH .LE. 0) GOTO 199

! *** Go through all compounds

      DO 100 IC = 1,NC

! ***   Only calculate statistics for compound nr. 1:
!        IF (IC .GT. 1) GOTO 100
!MSK        IF (IC /= ICSTAT) GOTO 100
!MSK start
!           if ( cmpnd(ic) .ne. cpnstat(1) )  goto 100
!MSK end

! ***   Check if missing data for current compound, then go to next compund.
        IF (CM(1,1,IC) .EQ. MISS) GOTO 100

! ***   Go through all main grid cells:
        DO 110 IY = 1,NY
          DO 120 IX = 1,NX

! ***       Check if current main grid value is .LE. than the smallest of
! ***       the NHIGHH values collected so far, if so go to next grid cell:

            IV = IMHIGHHMIN(IX,IY)
            IF (CM(IX,IY,IC) .LE. CMHIGHH(IV,IX,IY)) GOTO 120

! ***       No!

! ***       Collect the current main grid value

            CMHIGHH(IV,IX,IY) = CM(IX,IY,IC)

! ***       Find lowest concentration value collected so far

            CMHIGHHMIN = 1.E+30
            DO 130 IHIGHH = 1,NHIGHH
              IF (CMHIGHH(IHIGHH,IX,IY) .LT. CMHIGHHMIN) THEN
                CMHIGHHMIN = CMHIGHH(IHIGHH,IX,IY)
                IV = IHIGHH
              ENDIF
  130       CONTINUE

! ***       Update the minimum value index

            IMHIGHHMIN(IX,IY) = IV

! ***       Next main grid cell

  120     CONTINUE
  110   CONTINUE

! ***   Next compound

  100 CONTINUE

  199 CONTINUE

! *** UPDATE DAILY MEAN CONCENTRATIONS

! *** Calculate daily mean indicator set to zero or missing?

      IF (IAVED .LE. 0) GOTO 299

      DO 200 IC = 1,NC

!MSK start
!MSK For all compounds
!MSK Receptor concentration CMAVED is hourly mean
!MSK Therefore calculation of CMAVED is now inside tsstat.for
!MSK Below is commented
!MSK
!MSK          DO IY = 1,NY
!MSK            DO IX = 1,NX
!MSK             IF (CM(IX,IY,IC) .lt. 0.0) THEN
!MSK               print *,'cstatm: CM(IX,IY,IC)', CM(IX,IY,IC)
!MSK               print *,'cstatm: STOPPED'
!MSK               STOP
!MSK             ENDIF
!MSK            ENDDO
!MSK          ENDDO
!MSK
!MSK ! Add to daily mean arrays
!MSK
!MSK          DO 210 IY = 1,NY
!MSK            DO 220 IX = 1,NX
!MSK              CMAVED(IX,IY,IC) = CMAVED(IX,IY,IC) + CM(IX,IY,IC)
!MSK  220       CONTINUE
!MSK  210     CONTINUE
!MSK end

!MSK start
! *** Set the NAVED counter for the daily mean here
          IF (IC .eq. 1)  NAVED = NAVED + 1
!MSK end

! Next compound

  200 CONTINUE

      IF (HOUR .NE. 23) GOTO 299

!MSK Below is commented
!MSK ! Calculate daily mean value?
!MSK  ! Yes!
!MSK  ! Calculate daily mean
!MSK
!MSK      IF (NAVED .GE. 20) THEN
!MSK
!MSK          DO IC = 1,NC
!MSK          DO 230 IY = 1,NY
!MSK          DO 240 IX = 1,NX
!MSK              CMAVED(IX,IY,IC) = CMAVED(IX,IY,IC)/NAVED
!MSK                IF ( CMAVED(IX,IY,IC) .lt. 0.0 ) THEN
!MSK                  print *,'CSTATM: CMAVED < 0', IC,IX,IY,CMAVED(IX,IY,IC)
!MSK                  print *,'CSTATM: stopped'
!MSK                  STOP
!MSK                ENDIF
!MSK  240     CONTINUE
!MSK  230     CONTINUE
!MSK
!MSK          ENDDO
!MSK
!MSK
!MSK      ELSE
!MSK               print *,'cstatm: NAVED .lt. 20', NAVED
!MSK               print *,'cstatm: STOPPED'
!MSK               STOP
!MSK
!MSK      ENDIF

  299 CONTINUE

! UPDATE OVERALL MEAN CONCENTRATIONS

! Calculate overall mean indicator set to zero or missing?

      IF (IAVEA .LE. 0) GOTO 399

! Add to overall mean value

      DO 300 IC = 1,NC

! Only add for compound nr. 1

!          IF (IC .GT. 1) GOTO 300
!          IF (IC /= ICSTAT) GOTO 300

! Check if missing data for current compound

!MSK start
!MSK          IF (CM(1,1,IC) .EQ. MISS) GOTO 300
          DO IY = 1,NY
            DO IX = 1,NX
             IF (CM(IX,IY,IC) .lt. 0.0) THEN
               print *,'cstatm: overall mean CM(IX,IY,IC)', CM(IX,IY,IC)
               print *,'cstatm: STOPPED'
               STOP
             ENDIF
            ENDDO
          ENDDO
!MSK end

! Add to overall mean arrays

          DO 310 IY = 1,NY
          DO 320 IX = 1,NX
              CMAVEA(IX,IY,IC) = CMAVEA(IX,IY,IC) + CM(IX,IY,IC)
  320     CONTINUE
  310     CONTINUE

!MSK start
!      NAVEA = NAVEA + 1
          IF (IC .eq. 1)  NAVEA = NAVEA + 1
!MSK end

! Next compound

  300 CONTINUE

! Calculate overall mean value?

      IF (.NOT. (ATDATE(EDAT) .AND.     &
       ISH .EQ. NSH .AND. ITS .EQ. NTS)) GOTO 399

! Yes!

! Calculate overall mean

      IF (NAVEA .GT. 0) THEN

          DO IC = 1,NC
          DO 350 IY = 1,NY
          DO 360 IX = 1,NX
              CMAVEA(IX,IY,IC) = CMAVEA(IX,IY,IC)/NAVEA
  360     CONTINUE
  350     CONTINUE
          ENDDO

      ELSE

          DO IC = 1,NC
           DO 355 IY = 1,NY
            DO 365 IX = 1,NX
              CMAVEA(IX,IY,IC) = MISS
  365     CONTINUE
  355     CONTINUE
          ENDDO

      ENDIF

  399 CONTINUE

! UPDATE HIGHEST DAILY CONCENTRATIONS

! Number of highest daily values set to zero or missing?

      IF (NHIGHD .LE. 0) GOTO 499

! Go through all compounds

      DO 400 IC = 1,NC

! Only calculate statistics for compound nr. 1

!          IF (IC .GT. 1) GOTO 400
!MSK          IF (IC /= ICSTAT) GOTO 400
!MSK start
!           if ( cmpnd(ic) .ne. cpnstat(1) )  goto 400
!MSK end

! Calculate statistics?

          IF (HOUR .NE. 23) GOTO 400

! Yes!

! Check if missing data

          IF (CMAVED(1,1,IC) .EQ. MISS) GOTO 400

! No!

! Go through all main grid cells

          DO 410 IY = 1,NY
          DO 420 IX = 1,NX

! Check if current main grid value is smaller than the smallest
! of the NHIGHD values collected so far

!MSK: ATTENTION CMHIGHD has to be changed to index IX,IY,IC

              IV = IMHIGHDMIN(IX,IY)
              IF (CMAVED(IX,IY,IC) .LE. CMHIGHD(IV,IX,IY)) GOTO 420

! No!

! Collect the current main grid value and update the minimum
! value index

              CMHIGHD(IV,IX,IY) = CMAVED(IX,IY,IC)

! Find lowest concentration value collected so far

              CMHIGHDMIN = 1.E+30
              DO 430 IHIGHD = 1,NHIGHD
                  IF (CMHIGHD(IHIGHD,IX,IY) .LT. CMHIGHDMIN) THEN
                      CMHIGHDMIN = CMHIGHD(IHIGHD,IX,IY)
                      IV = IHIGHD
                  ENDIF
  430         CONTINUE

! Update lowest value index

              IMHIGHDMIN(IX,IY) = IV

! Next main grid cell

  420     CONTINUE
  410     CONTINUE

! Next compound

  400 CONTINUE

  499 CONTINUE

! SORT HIGHEST HOURLY AND DAILY CONCENTRATIONS

! Check if at end of simulations or daily statistics of highest
! hourly concentrations wanted

         IF (.NOT. ((ATDATE(EDAT) .AND.     &
             ISH .EQ. NSH .AND. ITS .EQ. NTS) .OR.     &
            (HOUR .EQ. 23 .AND. IDSTA .EQ. 1))) RETURN

! Yes!

! Number of highest hourly values set to zero or missing?

      IF (NHIGHH .LE. 0) GOTO 599

! Sort the main grid highest hourly concentration values

      DO 500 IY = 1,NY
        DO 510 IX = 1,NX

! Sort the values in descending order

          IHIGHH = 0
  520     CONTINUE

! Initialize current value

          IHIGHH = IHIGHH + 1
          CMHIGHHMAX = CMHIGHH(IHIGHH,IX,IY)
          IVMAX = IHIGHH

! Find highest value in the rest of the array

          DO 530 IV = IHIGHH+1,NHIGHH
              IF (CMHIGHH(IV,IX,IY) .GT. CMHIGHHMAX) THEN
                  CMHIGHHMAX = CMHIGHH(IV,IX,IY)
                  IVMAX = IV
              ENDIF
  530     CONTINUE

! Swap current value with highest value

          IF (CMHIGHHMAX .GT. CMHIGHH(IHIGHH,IX,IY)) THEN
              TMPV = CMHIGHH(IHIGHH,IX,IY)
              CMHIGHH(IHIGHH,IX,IY) = CMHIGHHMAX
              CMHIGHH(IVMAX,IX,IY) = TMPV
          ENDIF

! Finished with array?

          IF (IHIGHH .LT. NHIGHH) GOTO 520

! Yes! Array sorted in descending order

           IMHIGHHMIN(IX,IY) = NHIGHH

  510 CONTINUE
  500 CONTINUE

  599 CONTINUE

! Number of highest daily values set to zero or missing?

      IF (NHIGHD .LE. 0) GOTO 699

! Sort the main grid highest daily concentration values

      DO 600 IY = 1,NY
        DO 610 IX = 1,NX

! Sort the values in descending order

          IHIGHD = 0
  620     CONTINUE

! Initialize current value

          IHIGHD = IHIGHD + 1
          CMHIGHDMAX = CMHIGHD(IHIGHD,IX,IY)
          IVMAX = IHIGHD

! Find highest value in the rest of the array

          DO 630 IV = IHIGHD+1,NHIGHD
              IF (CMHIGHD(IV,IX,IY) .GT. CMHIGHDMAX) THEN
                  CMHIGHDMAX = CMHIGHD(IV,IX,IY)
                  IVMAX = IV
              ENDIF
  630     CONTINUE

! Swap current value with highest value

          IF (CMHIGHDMAX .GT. CMHIGHD(IHIGHD,IX,IY)) THEN
              TMPV = CMHIGHD(IHIGHD,IX,IY)
              CMHIGHD(IHIGHD,IX,IY) = CMHIGHDMAX
              CMHIGHD(IVMAX,IX,IY) = TMPV
          ENDIF

! Finished with array?

          IF (IHIGHD .LT. NHIGHD) GOTO 620

! Yes! Array sorted in descending order

           IMHIGHDMIN(IX,IY) = NHIGHD

  610 CONTINUE
  600 CONTINUE

  699 CONTINUE

! UPDATE TOTAL WET DEPOSITIONS

! Add to overall total value

      DO 700 IC = 1,NC

! Check if missing data for current compound

          IF (WDEPM(1,1,IC) .EQ. MISS) GOTO 700

! Add to total overall arrays

          DO 710 IY = 1,NY
          DO 720 IX = 1,NX
              WMTOTA(IX,IY,IC) = WMTOTA(IX,IY,IC) + WDEPM(IX,IY,IC)
  720     CONTINUE
  710     CONTINUE

! Next compound

  700 CONTINUE

      RETURN

! End of subroutine CSTATM

      end subroutine cstatm


SUBROUTINE WQBENTHIC (TIMTMP)

  ! *** RWQBEN2

  ! READ IN SPATIALLY AND/OR TEMPORALLY VARYING PARAMETERS FOR BENTHIC
  ! FLUXES OF PO4D, NH4, NO3, SAD, COD, O2
  ! FORMAT OF BENFN FILE IS:
  !    TITLE 1
  !    TITLE 2
  !    TITLE 3
  !  270.00000  <-- DAY AT WHICH FOLLOWING FLUXES BECOME ACTIVE
  !  350.00000  <-- DAY AT WHICH FOLLOWING FLUXES BECOME ACTIVE
  ! 9999.99999 <-- ENTER LARGE DAY AT END OF FILE

  USE GLOBAL
  USE INFOMOD,ONLY:SKIPCOM
  IMPLICIT NONE

  REAL,INTENT(IN) :: TIMTMP
  INTEGER :: M,MM,IBENZ,I,L,IZM,IZS
  REAL    :: XBSFAD,BDAY,XM

  CHARACTER TITLE(3)*79, CCMRM*1
  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: IZONE
  REAL,SAVE,ALLOCATABLE,DIMENSION(:) :: XBFCOD
  REAL,SAVE,ALLOCATABLE,DIMENSION(:) :: XBFNH4
  REAL,SAVE,ALLOCATABLE,DIMENSION(:) :: XBFNO3
  REAL,SAVE,ALLOCATABLE,DIMENSION(:) :: XBFO2
  REAL,SAVE,ALLOCATABLE,DIMENSION(:) :: XBFPO4D
  REAL,SAVE,ALLOCATABLE,DIMENSION(:) :: XBFSAD

  IF(  .NOT. ALLOCATED(IZONE  ) )THEN
    ALLOCATE(IZONE(NSMZM))
    ALLOCATE(XBFCOD(NSMZM))
    ALLOCATE(XBFNH4(NSMZM))
    ALLOCATE(XBFNO3(NSMZM))
    ALLOCATE(XBFO2(NSMZM))
    ALLOCATE(XBFPO4D(NSMZM))
    ALLOCATE(XBFSAD(NSMZM))
    IZONE=0
    XBFCOD=0.0
    XBFNH4=0.0
    XBFNO3=0.0
    XBFO2=0.0
    XBFPO4D=0.0
    XBSFAD=0.0
  ENDIF

  WRITE(*,'(A)')' WQ: '//BENFN
  OPEN(1,FILE=BENFN,STATUS='UNKNOWN')
  OPEN(2,FILE=OUTDIR//'WQ3D.OUT',STATUS='UNKNOWN',POSITION='APPEND')

  ! SKIP OVER THREE HEADER RECORDS:
  READ(1,50) (TITLE(M),M=1,3)
  WRITE(2,999)
  WRITE(2,50) (TITLE(M),M=1,3)

  ! SKIP OVER ALL COMMENT CARDS AT BEGINNING OF FILE:
  REWIND(1)
  CCMRM = '#'
  CALL SKIPCOM(1, CCMRM,2)
  READ(1, *) IBENZ
  WRITE(2, 65) TIMTMP, IBENZ
  65 FORMAT(' * BENTHIC FLUXES AT     ', F10.5,' DAYS OF MODEL RUN',/, &
            '   NUMBER OF BENTHIC FLUX ZONES = ', I4)

  ! SEQUENTIALLY READ THROUGH BENTHIC FLUX FILE UNTIL THE APPROPRIATE
  ! TIME IS FOUND:
  !   BDAY   = CURRENT DAY AT WHICH BENTHIC FLUX IS IN EFFECT
  !   BENDAY = NEXT DAY AT WHICH BENTHIC FLUX CHANGES (PASSED TO MAIN PROG

  10 READ(1, *, END=15) BENDAY

  IF( BENDAY  >  TIMTMP) GOTO 20
  BDAY = BENDAY
  DO I=1,IBENZ
    READ(1,*,END=15) MM, XBFPO4D(MM), XBFNH4(MM), XBFNO3(MM),XBFSAD(MM), XBFCOD(MM), XBFO2(MM)
    IZONE(I) = MM
  ENDDO
  GOTO 10

  ! UNEXPECTED END-OF-FILE ENCOUNTERED:
  15 WRITE(2,16) BENFN
  16 FORMAT(//,' ************* WARNING *************',/, &
               ' END-OF-FILE ENCOUNTERED IN FILE: ', A20,/,/ &
               ' BENTHIC FLUXES SET TO VALUES CORRESPONDING TO LAST DAY IN FILE.',/)
  BENDAY=(TCON*TBEGIN + NTC*TIDALP)/86400.0  ! *** PMC SINGLE LINE

  20 CONTINUE
  WRITE(2, 48) BDAY
  48 FORMAT(/,' DAY IN BENTHIC FLUX FILE: ',F10.5,/, &
              '    ZONE    FPO4    FNH4    FNO3    FSAD    FCOD    FSOD')
  DO I=1,IBENZ
    MM = IZONE(I)
    WRITE(2,51) MM,XBFPO4D(MM),XBFNH4(MM),XBFNO3(MM),XBFSAD(MM),XBFCOD(MM),XBFO2(MM)
  ENDDO

  ! DETERMINE BENTHIC FLUX FOR EACH CELL (L) BY INTERPOLATING BETWEEN
  ! THE MUD AND SAND FLUXES.  XBENMUD(L) IS THE PERCENT MUD FOR EACH CELL.
  DO L=2,LA
    IZM = IBENMAP(L,1)
    IZS = IBENMAP(L,2)
    XM = XBENMUD(L)
    WQBFPO4D(L) = XM*XBFPO4D(IZM) + (1.0-XM)*XBFPO4D(IZS)
    WQBFNH4(L)  = XM*XBFNH4(IZM)  + (1.0-XM)*XBFNH4(IZS)
    WQBFNO3(L)  = XM*XBFNO3(IZM)  + (1.0-XM)*XBFNO3(IZS)
    WQBFSAD(L)  = XM*XBFSAD(IZM)  + (1.0-XM)*XBFSAD(IZS)
    WQBFCOD(L)  = XM*XBFCOD(IZM)  + (1.0-XM)*XBFCOD(IZS)
    WQBFO2(L)   = XM*XBFO2(IZM)   + (1.0-XM)*XBFO2(IZS)
  ENDDO

  CLOSE(1)
  CLOSE(2)

  999 FORMAT(1X)
   50 FORMAT(A79)
   51 FORMAT(I8, 10F8.3)
   52 FORMAT(I7, 1X, A3)
   60 FORMAT(/, A24, I5, A24)

  RETURN

END


C/////////////////////////////////////////////////////////////////////////////
C/
C/ File:        Lec_Ideas.f
C/ Directory:   $TRUST_ROOT/Geometrie
C/
C/////////////////////////////////////////////////////////////////////////////

C-------------------------------------------------
C-------------------------------------------------
C
C     LECTURE DU FICHIER UNIVERSEL ISSU DE IDEAS
C
C-------------------------------------------------
C-------------------------------------------------

	SUBROUTINE LIREIDEAS
     *                       (NAME,
     *                        NDIM,
     *                        X,
     *                        Y,
     *                        Z,
     *                        TETRA,
     *                        FACB,
     *                        GROUP,
     *                        NNOEUDS,
     *                        NELEM,
     *                        NTETRA,
     *                        NFACB,
     *                        NGROUPE,
     *                        NGELEM,
     *                        WORK,
     *                        CAS)
C
C --------------------------------------------------------------------
C | Nom     | E/S/I |  Type  | Role                                  |
C --------------------------------------------------------------------
C | NDIM    |   E   | Entier | Dimension du probleme                 |
C | NELEM   |   E   | Entier | Nombre d'elements du maillage         |
C | NGROUPE |   E   | Entier | Nombre de groupes dans le .unv d'IDEAS|
C | NNOEUDS |   E   | Entier | Nombre de noeuds du maillage          |
C | NGELEM  |   E   | Entier | Nombre d'element par groupe           |
C | NAME    |   E   | Carac. | Nom du fichier universel              |
C | GROUP   |  E/S  | Entier | Table des groupes (no du groupe, surf)|
C | X,Y,Z   |  E/S  | Reels  | Table des coordonnees                 |
C | GRNAME  |  I/S  | Carac. | Noms de groupe                        |
C | WORK    |  E/I  | Entier | Tableau de travail                    |
C | Ligne   |   I   | Entier | Numero de la ligne dans un groupe     |
C | Nogroupe|   I   | Entier | Numero du groupe                      |
C | Nb_ligne|   I   | Entier | Nombre de ligne par groupe dans .unv  |
C | Reste   |   I   | Entier | Nombre restant d'element d'un groupe  |
C | Num     |   I   | Entier | Variable bidon                        |
C | ID      |   I   | Entier | Variable bidon                        |
C | Nbnoeud |   I   | Entier | Nombre de noeuds par element          |
C | i,j,k   |   I   | Entier | Compteur de boucle                    |
C | n       |   I   | Entier | Entier pour reperage unv              |
C | n*      |   I   | Entier | Variable bidon                        |
C | CAS     |   I   | Entier | Type d'entetes pour les groupes       |
C | Ch      |   I   | Carac. | Chaine de caractere pour reperage unv |
C --------------------------------------------------------------------
C
	Implicit None
C
C---> Debut des declarations
C
	Integer NDIM
	Integer NELEM
	Integer NTETRA
	Integer NFACB
	Integer NGROUPE
	Integer NNOEUDS
	Integer NGELEM(1:*)
	Integer TETRA(1:NTETRA,1:4)
	Integer FACB(1:NFACB,1:3)
	Integer GROUP(1:NGROUPE,1:NFACB)
	Integer Ligne
	Integer WORK(*)
	Integer Nogroupe
	Integer Nb_ligne
	Integer Reste
	Integer ID
	Integer Nbnoeud
	Integer CAS
	Integer Temp
	Integer Surplus
        Integer Total (100)
	Integer i, j, k, n
        Integer N1,N2,N3,N4,N5,N6
	Real*8  X(*), Y(*), Z(*)
        integer itetra,ifacb
C
	Character*80 NAME
        Character*30 GRNAME
	Character*6  Ch
C
C---> Fin des declarations
C
C
C---> Ouverture du fichier universel et du fichier des noms de groupes
C
	OPEN (Unit=1, FILE=NAME, Status='old')
	OPEN (Unit=2, FILE='nom.groupe', Status='unknown')
C
C--->
C---> Recherche de la table des noeuds (index 2411 dans Ideas)
C--->
C
	REWIND (1)
C
 10	Read(1,1000,END=99) Ch
	If (Ch .NE. '    -1') GOTO 10
C
 20	Read(1,*,END=99) n
C
	If(n.EQ.-1) Then
	   Goto 20
	Elseif (n .NE. 2411) Then
	   Goto 10
	Endif
C
C---> Lecture de la table des Noeuds, Remplissage des tableaux
C
	If (NDIM.EQ.2) Then
	   Do i = 1, NNOEUDS
	      Read(1,2200) N1, N2, N3, Temp
 	      Read(1,2210) X(i), Y(i)
	   Enddo
	Else
	   Do i = 1, NNOEUDS
	      Read(1,2200) N1, N2, N3, Temp
 	      Read(1,2210) X(i), Y(i), Z(i)
	   Enddo
	Endif
C
C--->
C---> Recherche de la table des elements (index 2412 dans Ideas)
C--->
C
	REWIND (1)
C
 30	Read(1,1000,END=99) Ch
	If (Ch .NE. '    -1') GOTO 30
C
 40	Read(1,*,END=99) n
C
	If(n.EQ.-1) Then
	   Goto 40
	Elseif (n .NE. 2412) Then
	   Goto 30
	Endif
C
C---> Remplissage du tableau des elements - TETRA pour les tetraedres
C     et FACB pour les faces de bord
C
	Surplus = NTETRA + NFACB
	write(*,*) Surplus,NELEM
C
        itetra=0
        ifacb=0
	Do i = 1, NELEM
	   Read(1,3200) Temp, ID, N1, N2, N3, Nbnoeud
c	   print *,temp,Nbnoeud
	   If (Nbnoeud.EQ.4) Then
              itetra=itetra+1

	      Read(1,3210) (TETRA(itetra,j),j=1,Nbnoeud)
c	      print *,temp, (TETRA(itetra,j),j=1,Nbnoeud)
	   Elseif (Nbnoeud.EQ.3) Then
              ifacb=ifacb+1
	      Read(1,3220) (FACB(ifacb,j),j=1,Nbnoeud)
	   Elseif (Nbnoeud.LT.3) Then
               Read(1,3220) N1,N2,N3
	       Read(1,3230) N1,N2
	   Endif
	Enddo
C
	if (itetra.ne.ntetra) then
	   print *,' Pb a la lecture des tetras'
	   STOP
	   endif
	 if (ifacb.ne.nfacb) then
	   print *,' Pb a la lecture des tetras'
	   STOP
	   endif

 12   Continue
C
C--->
C---> Recherche de la table des groupes (index 2429 ou 2417 dans Ideas)
C--->
C
	REWIND (1)
C
 50	Read(1,1000,END=99) Ch
	If (Ch .NE. '    -1') GOTO 50
C
 60	Read(1,*,END=99) n
C
	If(n.EQ.-1) Then
	   Goto 60
	Elseif ((n .NE. 2429).AND.(n .NE. 2417).AND.(n .NE. 2467)) Then
	   Goto 50
	Elseif ((n .EQ. 2429).OR.(n .EQ. 2417).OR.(n .EQ. 2467)) Then
	   Goto 61
	Endif
 61	Continue
C
C---> Differents cas sont possibles:
C--->     Entete simple pour plusieurs groupes - CAS = 1
C--->     Entete simple pour 1 seul groupe     - CAS = 2
C--->     Entete multiple                      - CAS = 3

	write(6,*) 'mon cas est ,******************************'
	write(6,*) CAS

	If (CAS.EQ.1) Then
C
C---> Remplissage des groupes
C
C---------------------------------------------------------------
C---> ATTENTION, le format differe entre l'index 2417 et 2429 !!
C---------------------------------------------------------------
C
	   If ((n.EQ.2429).OR.(n.EQ.2430)) Then
	      Do i= 1, NGROUPE
C
C---> Lecture de l'entete
C
		 Read(1,1050) Nogroupe,N1,N2,N3,N4,N5,N6,NGELEM(i)
		 Read(1,1110) GRNAME
                 Write(2,1110) GRNAME
C
C---> Calcul du nombre de lignes
C
		 Nb_ligne = NGELEM(i)*2/8
		 write(*,*) Nb_ligne
		 Reste = NGELEM(i)*2 - Nb_ligne*8
C
C---> Boucle sur le nombre de ligne et lecture dans un tableau de travail
C
		 Do j = 1, Nb_ligne
		    Ligne = j
		    Read(1,1050) (WORK(8*(Ligne-1)+k),k=1,8)
		    write(6,1050) (WORK(8*(Ligne-1)+k),k=1,8)
		 Enddo
C
C---> Les derniers elements sont lus et stockes
C
		 If (Reste.NE.0) Then
		    Read(1,1050) (WORK(Nb_ligne*8+k),k=1,Reste)
		 Endif
C
C---> On stocke dans le tableau GROUP 1 terme sur 2
C
                 Total(i) = 0
		 Do j = 1, NGELEM(i)
		    If ((WORK(2*j).LE.Surplus)
     1             .AND.(WORK(2*j).GT.NTETRA)) Then
                       Total(i) = Total(i) + 1
		       GROUP(i,Total(i)) = WORK(2*j)-NTETRA
C                       write(6,*) GROUP(i,Total(i))
		    Endif
		 Enddo
	      Enddo
C
C---> Mise a jour des nombres d'elements par groupe (on enleve les noeuds et les segments)
C
              Do i = 1, NGROUPE
                 NGELEM(i) = Total(i)
              Enddo

C              Do i = 1, NGROUPE
C              	Do j= 1 , NGELEM(i)
C              		write(6,*) GROUP(i,j)
C              	Enddo
C              Enddo
            elseif (n.eq.2467) then
	    Do i= 1, NGROUPE
C
C---> Lecture de l'entete
C
		 Read(1,1050) Nogroupe,N1,N2,N3,N4,N5,N6,NGELEM(i)
		 Read(1,1110) GRNAME
                 Write(2,1110) GRNAME
		 print *,GRNAME
C
C---> Calcul du nombre de lignes
C
		 Nb_ligne = NGELEM(i)/2
		 Reste = NGELEM(i) - Nb_ligne*2
C
C---> Boucle sur le nombre de ligne et lecture dans un tableau de travail
C
		 Do j = 1, Nb_ligne
		    Ligne = j
		    Read(1,1050) (WORK(8*(Ligne-1)+k),k=1,8)
		 Enddo
C
C---> Les derniers elements sont lus et stockes
C

		 If (Reste.NE.0) Then
		    Read(1,1050) (WORK(Nb_ligne*8+k),k=1,Reste*4)
		 Endif
C
C---> On stocke dans le tableau GROUP 1 terme sur 2
                 surplus=NELEM-NTETRA-NFACB
                 Total(i) = 0
		 Do j = 1, NGELEM(i)
		    If ((WORK(4*(j-1)+2).GE.Surplus)) then
c     1             .AND.(WORK(2*j).GT.NTETRA)) Then
c		    if (1.eq.1) then
                       Total(i) = Total(i) + 1
		       GROUP(i,Total(i)) = WORK(4*(j-1)+2)-surplus
		       Endif
		 Enddo
	      Enddo
C
C---> Mise a jour des nombres d'elements par groupe (on enleve les noeuds et les segments)
C
              Do i = 1, NGROUPE
                 NGELEM(i) = Total(i)
              Enddo

C              Do i = 1, NGROUPE
C              	Do j= 1 , NGELEM(i)
C              		write(6,*) GROUP(i,j)
C              	Enddo
C              Enddo

	   Else
	      Do i= 1, NGROUPE
C
C---> Lecture de l'entete
C
		 Read(1,1060) Nogroupe, N1, N2, N3, N4, N5, NGELEM(i)
		 Read(1,1110) GRNAME
                 Write(2,1110) GRNAME
C
C---> Calcul du nombre de lignes
C
		 Nb_ligne = NGELEM(i)*2./8
		 Reste = NGELEM(i)*2 - Nb_ligne*8
C
C---> Boucle sur le nombre de ligne et lecture dans un tableau de travail
C
		 Do j = 1, Nb_ligne
		    Ligne = j
		    Read(1,1050) (WORK(8*(Ligne-1)+k),k=1,8)
		 Enddo
C
C---> Les derniers elements sont lus et stockes
C
		 If (Reste.NE.0) Then
		    Read(1,1050) (WORK(Nb_ligne*8+k),k=1,Reste)
		 Endif
C
C---> On stocke dans le tableau GROUP 1 terme sur 2
C
		 Total(i) = 0
		 Do j = 1, NGELEM(i)
		    If ((WORK(2*j).LE.Surplus)
     1             .AND.(WORK(2*j).GT.NTETRA)) Then
		       Total(i) = Total(i) + 1
		       GROUP(i,Total(i)) = WORK(2*j) -NTETRA
		    Endif
		 Enddo
	      Enddo
C
C---> Mise a jour des nombres d'elements par groupe (on enleve les noeuds et les segments)
C
              Do i = 1, NGROUPE
                 NGELEM(i) = Total(i)
              Enddo
	   Endif
C
C---> Fin du cas no1 (i.e. 1 entete pour plusieurs groupes)
C
C
C---> Debut du cas no2 (1 entete pour 1 seul groupe)
C
	Elseif (CAS.EQ.2) Then
C
C---------------------------------------------------------------
C---> ATTENTION, le format differe entre l'index 2417 et 2429 !!
C---------------------------------------------------------------
C
	   If ((n.EQ.2429).OR.(n.EQ.2429)) Then
C
C---> Lecture de l'entete
C
	      Read(1,1050) Nogroupe, N1, N2, N3, N4, N5, N6, NGELEM(1)
	      Read(1,1110) GRNAME
              Write(2,1110) GRNAME
C
C---> Calcul du nombre de lignes
C
	      Nb_ligne = NGELEM(1)*2./8
	      Reste = NGELEM(1)*2 - Nb_ligne*8
C
C---> Boucle sur le nombre de ligne et lecture dans un tableau de travail
C
	      Do j = 1, Nb_ligne
		 Ligne = j
		 Read(1,1050) (WORK(8*(Ligne-1)+k),k=1,8)
	      Enddo
C
C---> Les derniers elements sont lus et stockes
C
	      If (Reste.NE.0) Then
		 Read(1,1050) (WORK(Nb_ligne*8+k),k=1,Reste)
	      Endif
C
C---> On stocke dans le tableau GROUP 1 terme sur 2
C
	      Total(1) = 0
	      Do j = 1, NGELEM(1)
		 If ((WORK(2*j).LE.Surplus).AND.
     1               (WORK(2*j).GT.NTETRA)) Then
		    Total(1) = Total(1) + 1
		    GROUP(1,Total(1)) = WORK(2*j) -NTETRA
		 Endif
	      Enddo
C
C---> Mise a jour des nombres d'elements par groupe (on enleve les noeuds et les segments)
C
              NGELEM(1) = Total(1)
C
 	   Else
C
C---> Lecture de l'entete
C
 	      Read(1,1060) Nogroupe, N1, N2, N3, N4, N5, NGELEM(1)
 	      Read(1,1110) GRNAME
              Write(2,1110) GRNAME
C
C---> Calcul du nombre de lignes
C
 	      Nb_ligne = NGELEM(1)*2./8
 	      Reste = NGELEM(1)*2 - Nb_ligne*8
C
C---> Boucle sur le nombre de ligne et lecture dans un tableau de travail
C
 	      Do j = 1, Nb_ligne
 		 Ligne = j
 		 Read(1,1050) (WORK(8*(Ligne-1)+k),k=1,8)
 	      Enddo
C
C---> Les derniers elements sont lus et stockes
C
 	      If (Reste.NE.0) Then
 		 Read(1,1050) (WORK(Nb_ligne*8+k),k=1,Reste)
 	      Endif
C
C---> On stocke dans le tableau GROUP 1 terme sur 2
C
 	      Total(1) = 0
 	      Do j = 1, NGELEM(1)
		 If ((WORK(2*j).LE.Surplus)
     1       .AND.(WORK(2*j).GT.NTETRA)) Then
 		    Total(1) = Total(1) + 1
 		    GROUP(1,Total(1)) = WORK(2*j) -NTETRA
 		 Endif
 	      Enddo
C
C---> Mise a jour des nombres d'elements par groupe (on enleve les noeuds et les segments)
C
 	      NGELEM(1) = Total(1)
 	   Endif
C
C---> Fin du cas no2
C
 	Elseif (CAS .EQ. 3) Then
C
C---> Debut du cas no3
C
C---------------------------------------------------------------
C---> ATTENTION, le format differe entre l'index 2417 et 2429 !!
C---------------------------------------------------------------
C
 	   If ((n.EQ.2429).OR.(n.EQ.2430)) Then
 	      Do i= 1, NGROUPE
C
C---> Lecture de l'entete
C
 		 Read(1,1050) Nogroupe,N1,N2,N3,N4,N5,N6,NGELEM(i)
 		 Read(1,1110) GRNAME
                 Write(2,1110) GRNAME
C
C---> Calcul du nombre de lignes
C
 		 Nb_ligne = NGELEM(i)*2./8
 		 Reste = NGELEM(i)*2 - Nb_ligne*8
C
C---> Boucle sur le nombre de ligne et lecture dans un tableau de travail
C
 		 Do j = 1, Nb_ligne
 		    Ligne = j
 		    Read(1,1050) (WORK(8*(Ligne-1)+k),k=1,8)
 		 Enddo
C
C---> Les derniers elements sont lus et stockes
C
 		 If (Reste.NE.0) Then
 		    Read(1,1050) (WORK(Nb_ligne*8+k),k=1,Reste)
 		 Endif
C
C---> On stocke dans le tableau GROUP 1 terme sur 2
C
 		 Total(i) = 0
 		 Do j = 1, NGELEM(i)
		    If ((WORK(2*j).LE.Surplus)
     1             .AND.(WORK(2*j).GT.NTETRA)) Then
 		       Total(i) = Total(i) + 1
 		       GROUP(i,Total(i)) = WORK(2*j) -NTETRA
 		    Endif
 		 Enddo
C
C---> On lit les trois prochaines lignes (entetes)
C
 		 If (i.NE.(NGROUPE)) Then
 		    Read(1,1000,END=99) Ch
 		    Read(1,1000,END=99) Ch
 		    Read(1,*,END=99) N1
 		 Endif
 	      Enddo
C
C---> Mise a jour des nombres d'elements par groupe (on enleve les noeuds et les segments)
C
              Do i = 1, NGROUPE
                 NGELEM(i) = Total(i)
              Enddo
 	   Else
 	      Do i= 1, NGROUPE
C
C---> Lecture de l'entete
C
 		 Read(1,1060) Nogroupe, N1, N2, N3, N4, N5, NGELEM(i)
 		 Read(1,1110) GRNAME
                 Write(2,1110) GRNAME
C
C---> Calcul du nombre de lignes
C
 		 Nb_ligne = NGELEM(i)*2./8
 		 Reste = NGELEM(i)*2 - Nb_ligne*8
C
C---> Boucle sur le nombre de ligne et lecture dans un tableau de travail
C
 		 Do j = 1, Nb_ligne
 		    Ligne = j
 		    Read(1,1050) (WORK(8*(Ligne-1)+k),k=1,8)
 		 Enddo
C
C---> Les derniers elements sont lus et stockes
C
 		 If (Reste.NE.0) Then
 		    Read(1,1050) (WORK(Nb_ligne*8+k),k=1,Reste)
 		 Endif
C
C---> On stocke dans le tableau GROUP 1 terme sur 2
C
 		 Total(i) = 0
 		 Do j = 1, NGELEM(i)
		    If ((WORK(2*j).LE.Surplus)
     1             .AND.(WORK(2*j).GT.NTETRA)) Then
 		       Total(i) = Total(i) + 1
 		       GROUP(i,Total(i)) = WORK(2*j) -NTETRA
 		    Endif
 		 Enddo
C
C---> On lit les trois prochaines lignes (entetes)
C
 		 If (i.NE.(NGROUPE)) Then
 		    Read(1,1000,END=99) Ch
 		    Read(1,1000,END=99) Ch
 		    Read(1,*,END=99) N1
 		 Endif
 	      Enddo
C
C---> Mise a jour des nombres d'elements par groupe (on enleve les noeuds et les segments)
C
              Do i = 1, NGROUPE
                 NGELEM(i) = Total(i)
              Enddo
 	   Endif
 	Endif
C
C---> Fin du cas no3
C
 99	Continue
C
	Close(1)
	Close(2)
C
	Return
C
C---> FORMATS
C
 1000	FORMAT(A6)
 1050	FORMAT(8I10)
 1060	FORMAT(7I10)
 1110	FORMAT(A20)
 2200	FORMAT(4I10)
 2210	FORMAT(1P3D25.16)
 3200	FORMAT(6I10)
 3210	FORMAT(8I10)
 3220	FORMAT(3I10)
 3230	FORMAT(2I10)
C
	END


[undefined] [version] [if]
: packver  swap 8 lshift or swap 24 lshift or ;
: (checkver)  ( ver ver - )
    over 0 = if 2drop exit then
    2dup
    swap $ff000000 and swap $ff000000 and <> abort" Incompatible major version!"
    2dup
    swap $00ffffff and swap $00ffffff and > abort" Incompatible minor version and/or revision!"
    swap $00ffff00 and swap $00ffff00 and < if
        cr  #2 attribute ." Version mismatch warning: "
        #3 attribute
        space including -path type ." : "
        space tib #tib @ type
        #0 attribute
    then
;
: .line  cr tib #tib @ type ;
: [version]  ( M m R - <name> )  .line packver constant ;
: [checkver]  ( M m R packver - )
    depth 4 < abort" Missing version spec!"
    >r packver r> (checkver) ;

[then]

\ versions are expressed as three values M = major, m = minor, R = revision
\ in documentation, they're expressed as M.m.r
\ Major versions are always source breaking
\ Minor versions are generally additions, but also sometimes deletions, renames, and semantic changes
\ Revisions are bugfixes, and benign tweaks such as dox and housekeeping


C
C $Id: pcexcd.f,v 1.4 2008-07-27 01:04:31 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C

      SUBROUTINE PCEXCD (IPNT,IPSS,NDGU)
C
C The subroutine PCEXCD extracts a specified character digitization
C from the PWRITX database.  Its arguments are as follows:
C
C   IPNT is an input variable.  It is given a positive integral value
C   and identifies a particular character digitization by specifying a
C   particular 15-bit pointer in the COMMON array INDA.
C
C   IPSS is an input variable. It specifies how much of the digitization
C   is required by the caller.  If IPSS is 1, the length of a character
C   string is being determined, and only the first two units of the
C   digitization are needed.  If IPSS is 2, the character string is
C   actually being drawn, and all units are needed.
C
C   NDGU is an output variable.  It is set to zero if IPNT specifies an
C   illegal digitization; otherwise, its value specifies how many units
C   have been returned in the COMMON array RDGU.
C
C Each word of the COMMON array INDA contains as many 15-bit pointers
C as will fit, packed together at the upper end of the word; any unused
C bits in the word are at the right end.  Each of the 15-bit pointers
C consists of a single bit which is zero if the digitization uses 6-bit
C units and 1 if it uses 12-bit units, followed by a 14-bit pointer
C into the COMMON array IDDA.
C
C The COMMON array IDDA contains character digitizations, each of which
C consists of a string of 6-bit or 12-bit quantities.  The digitization
C "n" starts at bit number 60*(n-1)+1 and continues until two zeroed
C units in a row are found.  The 6-bit or 12-bit units are stored as
C a bit stream and may cross one or more word boundaries.
C
C Each 6-bit or 12-bit unit of a digitization is transformed before
C being put into RDGU.  From each non-zero 6-bit unit, 32 is subtracted.
C From each non-zero 12-bit unit, 2048 is subtracted.  Each zeroed unit
C is replaced by the value -2048.
C
C COMMON block declarations.
C
      COMMON /PCCMN1/ INDA(789),INDL,IDDA(8625),IDDL
      COMMON /PCCMN2/ NBPW,NPPW
      COMMON /PCCMN3/ RDGU(7000)
C
C MXUN specifies the maximum number of units to be retrieved for a
C given value of IPSS.
C
      DIMENSION MXUN(2)
C
      DATA MXUN / 2,7000 /
C
C Zero the count of digitization units returned.
C
      NDGU=0
C
C If the given pointer is invalid, return.
C
      IF (IPNT.LE.0.OR.IPNT.GT.768) RETURN
C
C Retrieve the proper pointer from the array INDA.
C
      INDI=(IPNT-1)/NPPW+1
      IPIW=IPNT-(INDI-1)*NPPW
      IDGP=IAND(ISHIFT(INDA(INDI),IPIW*15-NBPW),32767)
C
C Separate the 6-bit/12-bit mode indicator from the pointer.
C
      IMDE=IAND(ISHIFT(IDGP,-14),1)
      IDGP=IAND(IDGP,16383)
C
C If there is no digitization for the specified pointer, return.
C
      IF (IDGP.EQ.0) RETURN
C
C Initialize the digitization-unit retrieval loop.  IDDI is the index
C of the word in IDDA containing the first bit of the next unit and
C IFBT is the index of that bit within the word, with zero indicating
C the leftmost bit.
C
      IFBT=(IDGP-1)*60
C
      IDDI=IFBT/NBPW+1
      IFBT=MOD(IFBT,NBPW)
C
C NBPU is the number of bits per digitization unit, MASK is a mask of
C NBPU right-justified one bits, and IOFF is the offset to be subtracted
C from the digitization unit.
C
      IF (IMDE.EQ.0) THEN
        NBPU=6
        MASK=63
        IOFF=32
      ELSE
        NBPU=12
        MASK=4095
        IOFF=2048
      END IF
C
C Extract the digitization.  NRGT is the number of bits in the "right
C end" of a word, starting with the first bit of a unit.
C
      DO 101 I=1,MXUN(IPSS)
        NDGU=NDGU+1
        NRGT=NBPW-IFBT
        IDGU=IAND(ISHIFT(IDDA(IDDI),NBPU-NRGT),MASK)
        IF (NRGT.LT.NBPU)
     +    IDGU=IOR(ISHIFT(ISHIFT(IDGU,NRGT-NBPU),NBPU-NRGT),
     +          ISHIFT(IAND(ISHIFT(IDDA(IDDI+1),NBPU-NBPW),MASK),-NRGT))
        IF (IDGU.EQ.0) THEN
          RDGU(I)=-2048.
        ELSE
          RDGU(I)=REAL(IDGU-IOFF)
        END IF
        IF (I.NE.1) THEN
          IF (RDGU(I).EQ.-2048..AND.RDGU(I-1).EQ.-2048.) GO TO 102
        END IF
        IFBT=IFBT+NBPU
        IF (IFBT.GE.NBPW) THEN
          IDDI=IDDI+1
          IFBT=IFBT-NBPW
        END IF
  101 CONTINUE
C
C Compensate for the fact that the Y coordinates are off by a little.
C (This error dates from the days of PWRITX.)
C
  102 DO 103 I=4,NDGU,2
        IF (RDGU(I-1).NE.-2048.) THEN
          RDGU(I)=RDGU(I)-1.5
        ELSE
          RDGU(I)=0.
        END IF
  103 CONTINUE
C
C Done.
C
      RETURN
C
      END


*
*     -------------------------------------------------------------
*      N O N R E L A T 5
*     -------------------------------------------------------------
*                                                                  *
*     THIS PACKAGE DETERMINES THE VALUES OF MATRIX ELEMENTS        *
*     OF TWO PARTICLE OPERATOR IN CASE :    N'1 = N1 (+-) 1        *
*                                           N'2 = N2 (+-) 1        *
*                                           N'3 = N3 (+-) 1        *
*                                           N'4 = N4 (+-) 1        *
*                                                                  *
*     Written by G. Gaigalas,                                      *
*     Vanderbilt University,  Nashville            February 1994   *
*
      SUBROUTINE NONRELAT5(IA,IB,IC,ID)
      IMPLICIT DOUBLEPRECISION (A-H,O-Z)
      COMMON/MEDEFN/IHSH,NJ(16),LJ(16),NOSH1(16),NOSH2(16),J1QN1(31,3),
     :     J1QN2(31,3),IJFUL(16)
      IF(IHSH.LE.3)RETURN
      IF(IB.LT.IC) THEN
        CALL NONRELAT51(IA,IB,IC,ID,1)
      ELSEIF(IA.GT.ID.AND.IB.GT.ID) THEN
        CALL NONRELAT51(IC,ID,IA,IB,2)
      ELSEIF(IB.GT.IC.AND.IB.LT.ID.AND.IA.LT.IC) THEN
        CALL NONRELAT52(IA,IC,IB,ID,1)
      ELSEIF(IB.GT.IC.AND.IB.GT.ID.AND.IA.GT.IC) THEN
        CALL NONRELAT52(IC,IA,ID,IB,2)
      ELSEIF(IB.GT.IC.AND.IB.GT.ID.AND.IA.LT.IC) THEN
        CALL NONRELAT53(IA,IC,ID,IB,1)
      ELSEIF(IB.GT.IC.AND.IB.LT.ID.AND.IA.GT.IC) THEN
        CALL NONRELAT53(IC,IA,IB,ID,2)
      ELSE
	WRITE(6,'(A)')  ' KLAIDA NONRELAT5  '
      STOP
      ENDIF
      RETURN
      END


*DECK DSOLSS
      SUBROUTINE DSOLSS (WK, IWK, X, TEM)
      INTEGER IWK
      DOUBLE PRECISION WK, X, TEM
      DIMENSION WK(*), IWK(*), X(*), TEM(*)
      INTEGER IOWND, IOWNS,
     1   ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L,
     2   LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER,
     3   MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU
      INTEGER IPLOST, IESP, ISTATC, IYS, IBA, IBIAN, IBJAN, IBJGP,
     1   IPIAN, IPJAN, IPJGP, IPIGP, IPR, IPC, IPIC, IPISP, IPRSP, IPA,
     2   LENYH, LENYHM, LENWK, LREQ, LRAT, LREST, LWMIN, MOSS, MSBJ,
     3   NSLJ, NGP, NLU, NNZ, NSP, NZL, NZU
      DOUBLE PRECISION ROWNS,
     1   CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND
      DOUBLE PRECISION RLSS
      COMMON /DLS001/ ROWNS(209),
     1   CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND,
     2   IOWND(6), IOWNS(6),
     3   ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L,
     4   LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER,
     5   MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU
      COMMON /DLSS01/ RLSS(6),
     1   IPLOST, IESP, ISTATC, IYS, IBA, IBIAN, IBJAN, IBJGP,
     2   IPIAN, IPJAN, IPJGP, IPIGP, IPR, IPC, IPIC, IPISP, IPRSP, IPA,
     3   LENYH, LENYHM, LENWK, LREQ, LRAT, LREST, LWMIN, MOSS, MSBJ,
     4   NSLJ, NGP, NLU, NNZ, NSP, NZL, NZU
      INTEGER I
      DOUBLE PRECISION DI, HL0, PHL0, R
C-----------------------------------------------------------------------
C This routine manages the solution of the linear system arising from
C a chord iteration.  It is called if MITER .ne. 0.
C If MITER is 1 or 2, it calls CDRV to accomplish this.
C If MITER = 3 it updates the coefficient H*EL0 in the diagonal
C matrix, and then computes the solution.
C communication with DSOLSS uses the following variables:
C WK    = real work space containing the inverse diagonal matrix if
C         MITER = 3 and the LU decomposition of the matrix otherwise.
C         Storage of matrix elements starts at WK(3).
C         WK also contains the following matrix-related data:
C         WK(1) = SQRT(UROUND) (not used here),
C         WK(2) = HL0, the previous value of H*EL0, used if MITER = 3.
C IWK   = integer work space for matrix-related data, assumed to
C         be equivalenced to WK.  In addition, WK(IPRSP) and IWK(IPISP)
C         are assumed to have identical locations.
C X     = the right-hand side vector on input, and the solution vector
C         on output, of length N.
C TEM   = vector of work space of length N, not used in this version.
C IERSL = output flag (in Common).
C         IERSL = 0  if no trouble occurred.
C         IERSL = -1 if CDRV returned an error flag (MITER = 1 or 2).
C                    This should never occur and is considered fatal.
C         IERSL = 1  if a singular matrix arose with MITER = 3.
C This routine also uses other variables in Common.
C-----------------------------------------------------------------------
      IERSL = 0
      GO TO (100, 100, 300), MITER
 100  CALL CDRV (N,IWK(IPR),IWK(IPC),IWK(IPIC),IWK(IPIAN),IWK(IPJAN),
     1   WK(IPA),X,X,NSP,IWK(IPISP),WK(IPRSP),IESP,4,IERSL)
      IF (IERSL .NE. 0) IERSL = -1
      RETURN
C
 300  PHL0 = WK(2)
      HL0 = H*EL0
      WK(2) = HL0
      IF (HL0 .EQ. PHL0) GO TO 330
      R = HL0/PHL0
      DO 320 I = 1,N
        DI = 1.0D0 - R*(1.0D0 - 1.0D0/WK(I+2))
        IF (ABS(DI) .EQ. 0.0D0) GO TO 390
 320    WK(I+2) = 1.0D0/DI
 330  DO 340 I = 1,N
 340    X(I) = WK(I+2)*X(I)
      RETURN
 390  IERSL = 1
      RETURN
C
C----------------------- End of Subroutine DSOLSS ----------------------
      END