C-----PROGRAM SARGONB                   E,SARGONB,A,B,,PAR
C-----THIS PROGRAM WILL INTERPOLATE OVER ARBITRARY POLYGONS.
C-----IT CAN HANDLE UP TO 25 POLYGONS OF UP TO 25 VERTICES EACH.

C     05 AUG 02   ..KLEM...  "&998" change to "*998" (lines 210, 211, 442)
C                            to compile on LINUX.  Explicit type declaration
C                            for INDEX (warning) not addressed.
C     01 JUL 94   ...CRI...   MSTP S/W CONVERSION (VICAR PORTING)
C     28 JAN 94   ...LWK...   CHANGED DIMENSION OF 'LINE' BUFFER FROM 100000
C				BYTES TO 20000 BECAUSE OF HALFWORD CONVERSION
C				IN SUBR. OPRATE (TO SUPPORT MGN. IMAGES)
C     28 AUG 87   ...SP....   DELETED UNNECESSARY REFERENCE TO MISSPELLED
C                             VARIABLE BUF IN COLECT.  REMOVED SOME DEAD CODE.
C     4-NOV-85   ...LWK...  CHANGE PROCESSING OF (RADIUS,PERC,MIN,MAX)
C     17 OCT 85   ...FFM...  1. PUT "NL,NS" IN COMMON AREA
C                            2. DELETE PARAMETERS "SIZE" AND "FORMAT"
C                            3. CONVERT TO VICAR2 I/O
C                            4. ADD 75 MORE KEYWORDS "FUNC1,CONST1,VERT1..."
C                               SO THE USER CAN SPECIFY UP TO 25 SEPARATE
C                               POLYGONS
C     29 DEC 83   ...HBD...   CHECKS IF SPECIFIED POLYGON IS COMPLETELY
C                             OUTSIDE IMAGE
C     20 OCT 82   ...CCA...   INITIAL RELEASE
C
      INCLUDE 'VICMAIN_FOR'
C
	subroutine main44
C
c     IMPLICIT INTEGER (A-Z)
	implicit none
c      INCLUDE 'fortport'
      COMMON/C/NVERT,V,PTBUF,LINE,SORT,SEGM
      COMMON/D/DBUG,ICODE,DNMIN,DNMAX
      COMMON/E/NL,NS
      COMMON/F/OUTUNIT

c	integer*2 PTBUF(3,40000),SEGM(3,20000),SORT(2,40000)
        integer*4 inunit,outunit,a,count,dbug,def,i,j,n
        integer*4 nl,ns,npts,narea,nv,nseg,radi,stat,icode
        integer*4 NVERT(25),FUNC(25)		!,ICONST(4,25),IRR(4)
	integer*4 SORT(2,40000), SEGM(3,40000)
        real*4 V(2,26,25),T,dnmin,dnmax
c        BYTE LINE(20000)
c
c	PTBUF is real because ptbuf(3,n) is real (DN value)
c	ptbuf(1,n)=line  ptbuf(2,n)=samp
c
c	SEGM is I*4 segm(1,n) = line, segm(2,n) = SS, segm(3,n) = ES
c
c	SORT is I*4 sort(1,m) = line, sort(2,n) = sample
c
c	LINE(40000) is input and output line buffer
c
c	V holds vertex points
c
	real*4  LINE(40000),PTBUF(3,40000)
	real*4 ICONST(4,25),IRR(4)
c
        logical*4 XVPTST

	character*6 FUNCNAME(25),INCHAR
	character*7 CNSTNAME(25)
	character*6 VERTNAME(25)
	character*8 FBUF
	character*8 fmt(4)/'BYTE','HALF','FULL','REAL'/
        character*8 format

C
      DATA FUNCNAME/'FUNC1 ','FUNC2 ','FUNC3 ','FUNC4 ',
     &'FUNC5 ','FUNC6 ','FUNC7 ','FUNC8 ','FUNC9 ','FUNC10','FUNC11',
     &'FUNC12','FUNC13','FUNC14','FUNC15','FUNC16','FUNC17','FUNC18',
     &'FUNC19','FUNC20','FUNC21','FUNC22','FUNC23','FUNC24','FUNC25'/
      DATA CNSTNAME/'CONST1 ','CONST2 ','CONST3 ','CONST4 ',
     &'CONST5 ','CONST6 ','CONST7 ','CONST8 ','CONST9 ','CONST10',
     &'CONST11','CONST12','CONST13','CONST14','CONST15','CONST16',
     &'CONST17','CONST18','CONST19','CONST20','CONST21','CONST22',
     &'CONST23','CONST24','CONST25'/
      DATA VERTNAME/'VERT1 ','VERT2 ','VERT3 ','VERT4 ',
     &'VERT5 ','VERT6 ','VERT7 ','VERT8 ','VERT9 ','VERT10','VERT11',
     &'VERT12','VERT13','VERT14','VERT15','VERT16','VERT17','VERT18',
     &'VERT19','VERT20','VERT21','VERT22','VERT23','VERT24','VERT25'/
      DATA NVERT/25*0/,FUNC/25*0/,IRR/4*0.0/
      DATA SORT/80000*0/
      DATA V/1300*0.0/,T/0.0/
c      DATA LINE/20000*' '/
      DATA FBUF/'        '/
C      DATA XVPTST/0/, INDEX/0/
C
      CALL IFMESSAGE('SARGONB version 2016-05-26')

      DO  I=1,4
          DO  J=1,25
              ICONST(1,J)=0.0
	  ENDDO
      ENDDO
      do i=1,3
	do j=1,40000
	  ptbuf(i,j) = 0.0
	  segm(i,j) = 0
	enddo
      enddo
      do i=1,2
        do j=1,40000
          sort(i,j) = 0
        enddo
      enddo

C     OPEN INPUT
      CALL XVEACTION('SA',' ')
      CALL XVUNIT(INUNIT,'INP',1,STAT,' ')
      CALL XVOPEN(INUNIT,STAT,' ')
C
C     FIND OUT FORMAT,NUMBER OF LINES,NUMBER OF SAMPLES
      CALL XVGET(INUNIT,STAT,'NL',NL,'NS',NS,'FORMAT',
     &           format,' ')

        icode = 0
        if (format.eq.'BYTE') icode=1
        if (format.eq.'HALF'.or.format.eq.'WORD') icode=2
        if (format.eq.'FULL') icode=3
        if (format.eq.'REAL') icode=4
        if (icode.eq.0) then
                call xvmessage('??E - Unknown data format for input image',' ')
                call abend
        endif
        call xvclose(inunit,stat,' ')
        call xvopen(inunit,stat,'OPEN_ACT','SA','IO_ACT','SA',
     &          'I_FORMAT',fmt(icode),'U_FORMAT',fmt(4),' ')            !FMT(INCODE),' ')

c      IF (BYTPIX .EQ. 1) THEN
c          ICOD=1
c      ELSE IF (BYTPIX .EQ. 2) THEN
c          ICOD=2
c      ELSE
c         CALL XVMESSAGE('??E - Wrong input format',' ')
c          CALL ABEND
c      END IF
C
C----------------------------------------------------------------------
C-----PROCESS PARAMETERS
C     param "DBUG"
      DBUG=0
      IF (XVPTST('DBUG')) DBUG=1
	if (icode.eq.1) then
	   dnmin=0.0
	   dnmax=255.0
	elseif (icode.eq.2) then
           dnmin=-32768.0
           dnmax=32767.0
	elseif (icode.eq.3) then
           dnmin=-999999999.
           dnmax=2147483647.
	else
           dnmin=-999999999.
           dnmax=2147483647.
	endif
C
C----------------------------------------------------------------------
C-----SET DEFAULTS
      NAREA = 0
C------------------------------------------------------------------
C-----    FUNC OR FNC  =  0.......INTERPOLATE
C-----                    1.......MULTIPLY
C-----                    2.......ADD
C-----                    3.......SUBTRACT
C-----                    4.......DIVIDE
C-----                    5.......SET TO DN
C-----                    6.......ZERO OUT
C-------------------------------------------------------------------
C
      DO I=1,25

      INCHAR=FUNCNAME(I)
      CALL XVPARM(INCHAR,FBUF,COUNT,DEF,1)
      IF (COUNT.EQ.0 .OR. DEF.EQ.1) GO TO 1
      NAREA=NAREA+1
      IF (INDEX(FBUF,'INTERP').ne.0 .OR. INDEX(FBUF,'interp').ne.0) THEN
          FUNC(NAREA)=0			!interpolate
c max val of 32 bit int = 2,147,483,647
C					!DEFAULTS:
	  ICONST(1,NAREA) = 200.	!RADIUS
	  ICONST(2,NAREA) = 30.	!PERCENT
	  ICONST(3,NAREA) = dnmin	!DNMIN
	  ICONST(4,NAREA) = dnmax	!DNMAX
c
c	legal cnstnames are: ZERO,SETTO,MULT,ADD,SUBTRACT,DIVIDE
          CALL XVPARM(CNSTNAME(I),IRR,COUNT,DEF,4)
	  IF (COUNT.GE.1) ICONST(1,NAREA) = IRR(1)
	  IF (COUNT.GE.2) ICONST(2,NAREA) = IRR(2)
	  IF (COUNT.GE.3) ICONST(3,NAREA) = IRR(3)
	  IF (COUNT.GE.4) ICONST(4,NAREA) = IRR(4)
      ELSEIF (INDEX(FBUF,'ZERO').ne.0 .OR. INDEX(FBUF,'zero').ne.0) THEN
          FUNC(NAREA)=6		!zero
      ELSEIF (INDEX(FBUF,'SETTO').ne.0 .OR. INDEX(FBUF,'setto').ne.0)
     &        THEN
          FUNC(NAREA)=5		!setto
          CALL XVPARM(CNSTNAME(I),IRR,COUNT,DEF,4)
          ICONST(1,NAREA) = IRR(1)
      ELSEIF (INDEX(FBUF,'MULT').ne.0 .OR.INDEX(FBUF,'mult').ne.0)
     &        THEN
          FUNC(NAREA)=1		!multiply
          CALL XVPARM(CNSTNAME(I),IRR,COUNT,DEF,4)
	  ICONST(1,NAREA) = IRR(1)
      ELSEIF (INDEX(FBUF,'ADD').ne.0 .OR.INDEX(FBUF,'add').ne.0) THEN
          FUNC(NAREA)=2		!add
          CALL XVPARM(CNSTNAME(I),IRR,COUNT,DEF,4)
	  ICONST(1,NAREA) = IRR(1)
      ELSEIF (INDEX(FBUF,'SUBTRACT').ne.0 .OR.
     &	  INDEX(FBUF,'subtract').ne.0) THEN
          FUNC(NAREA)=3		!subtract
          CALL XVPARM(CNSTNAME(I),IRR,COUNT,DEF,4)
	  ICONST(1,NAREA) = IRR(1)
      ELSEIF (INDEX(FBUF,'DIVIDE').ne.0 .OR.
     &	  INDEX(FBUF,'divide').ne.0) THEN
          FUNC(NAREA)=4		!divide
          CALL XVPARM(CNSTNAME(I),IRR,COUNT,DEF,4)
	  ICONST(1,NAREA) = IRR(1)
      ELSE
          CALL XVMESSAGE('??E - Illegal function string',' ')
          CALL ABEND
      END IF
      CALL XVPARM(VERTNAME(I),V(1,1,NAREA),COUNT,DEF,1300)
      IF (MOD(COUNT,2) .NE. 0) THEN
          CALL XVMESSAGE('??E - Vertices have to be in pairs',' ')
          CALL ABEND
      ELSE IF (COUNT .LT. 6) THEN
          CALL XVMESSAGE('??E - Needs to be at least 3 pairs of vertices',' ')
          CALL ABEND
      END IF
          NVERT(NAREA)=COUNT/2
      END DO
c
c
    1   continue
	RADI = RADI*RADI
C
C---------------------------------------------------------------------
C-----CHECK FOR DUICATED END VERTEX AND REARRANGE AS (S,L)
      DO 200 A=1,NAREA
         NV = NVERT(A)
         IF(V(1,NV,A).EQ.V(1,1,A) .AND. V(2,NV,A).EQ.V(2,1,A)) GO TO 150
         V(1,NV+1,A) = V(1,1,A)
         V(2,NV+1,A) = V(2,1,A)
         GO TO 160
  150    NV = NV -1
         NVERT(A) = NV
  160    CONTINUE
         N = NV + 1
         DO 180 J=1,N
            T = V(1,J,A)
            V(1,J,A) = V(2,J,A)
  180    V(2,J,A) = T
  200 CONTINUE
C
C-----------------------------------------------------------------
C     OPEN OUTPUT
      CALL XVUNIT(OUTUNIT,'OUT',1,STAT,' ')
      CALL XVOPEN(OUTUNIT,STAT,'OP','WRITE','O_FORMAT',fmt(icode),'U_FORMAT',fmt(4),' ')
C
      DO 110 I=1,NL
      CALL XVREAD(INUNIT,LINE,STAT,' ')
  110 CALL XVWRIT(OUTUNIT,LINE,STAT,' ')
C
C     CLOSE INPUT AND OUTPUT
      CALL XVCLOSE(INUNIT,STAT,' ')
      CALL XVCLOSE(OUTUNIT,STAT,' ')
C     UPDATE OUTPUT
      CALL XVOPEN(OUTUNIT,STAT,'OP','UPDATE','O_FORMAT',fmt(icode),
     +       'U_FORMAT',fmt(4),' ')

C
C----------------------------------------------------------------
C-----BEGIN PROCESSING FOR EACH AREA
      DO 1500 A=1,NAREA
         NV = NVERT(A)
C-----CHECK IF POLYGON IS COMPLETELY OUTSIDE OF IMAGE
         DO 1510 I = 1, NV
            IF (V(1,I,A) .LE. NS .AND. V(2,I,A) .LE. NL) GOTO 1520
 1510    CONTINUE
         CALL XVMESSAGE('??E - Polygon is completely outside of image',' ')
         CALL XVMESSAGE('**** ABEND',' ')
         CALL ABEND
 1520    CALL COLECT(A,NSEG,NPTS,FUNC(A),ICONST(1,A),*998)
         CALL OPRATE(NSEG,FUNC(A),ICONST(1,A),NPTS,*998)
 1500 CONTINUE
C-----------------------------------------------------------------
C
      CALL XVCLOSE(OUTUNIT,STAT,' ')
      RETURN
  998 continue
	call xvmessage('??E - Error return from COLECT or OPRATE',' ')
	CALL ABEND
      END
C
C*****************************************************************
C
      SUBROUTINE COLECT(A,NSEG,NPTS,XFUNC,CONST,*)
C-----THIS ROUTINE WILL COLLECT THE NECESSARY POINTS ABOUT THE
C-----PERIPHERY OF THE SPECIFIED POLYGON.
C
c      IMPLICIT INTEGER (A-Z)
	implicit none
      COMMON/C/NVERT,V,PTBUF,LINE,SORT,SEGM
      COMMON/D/DBUG,ICODE,DNMIN,DNMAX
      COMMON/E/NL,NS
      COMMON /CSEED/SEED
	INTEGER*8 SEED
	integer*4 a,nseg,npts,xfunc,nv,nx,sl,ss,el,es,ps,pl
	integer*4 i,ii,j,l,n,p,ll,mm,s,px,stl,nonl,nl,ns,mxl,mnl,mv
	integer*4 dbug,minl,maxl,weed,perc,icode
	integer*4 inc
	integer*4 NVERT(25),SORT(2,40000),PT(3,40000)		!,CONST(4)
	integer*4 SEGM(3,40000)
c	INTEGER*2 PTBUF(3,40000),SEGM(3,20000),PT(3,10000),SORT(2,40000)
	REAL*4 POINT(2),V(2,26,25),T,SLOPE,RANNUM
c
	real*4 CONST(4)
	real*4 LINE(40000),PTBUF(3,40000)
	real*4 dnmin,dnmax,radi
c
	CHARACTER*132 PBUF
c	BYTE LINE(20000)
	logical*4 INSIDE
C
C---------------------------------------------------------------
C-----FOR EACH SIDE OF POLYGON,COLLECT POINTS OF INTERSECTION
C-----WITH LINES.
C-----N IS THE NUMBER OF INTERSECTION POINTS
C-----NPTS IS THE NUMBER OF EXTERIOR POINTS
C-----NSEG IS THE NUMBER OF LINE SEGMENTS TO OPERATE ON
      NV = NVERT(A)
      NPTS = 0
      NSEG = 0
      N = 0
	inc=0
	px=0
      DO 2200 J=1,NV
         SL = V(2,J,A)
         SS = V(1,J,A)
         EL = V(2,J+1,A)
         ES = V(1,J+1,A)
C-------------------------------------------------------------
C-----NOW COLLECT A DUPLICATE POINT FOR VERTICIES WHICH ARE
C-----LOCAL MINIMA OR MAXIMA, SO WE WILL END UP WITH TWO
C-----INTERSECTION POINTS AT THESE VERTICIES
         IF(J .EQ. 1) GO TO 550
         PL = V(2,J-1,A)
         PS = V(1,J-1,A)
         GO TO  560
  550    PL = V(2,NV,A)
         PS = V(1,NV,A)
  560    IF(PL .EQ. SL .OR. EL .EQ. SL) GO TO 570
         IF(MIN0(PL,SL,EL) .NE. SL .AND. MAX0(PL,SL,EL) .NE. SL)
     +      GO TO 570
         N = N + 1
         SORT(1,N) = SL
         SORT(2,N) = SS
  570    CONTINUE
C----------------------------------------------------------------
         IF(EL .GT. SL) INC = 1
         IF(EL .LT. SL) INC = -1
         IF(EL .NE. SL) GO TO 2100
         N = N + 1
         SORT(1,N) = SL
         SORT(2,N) = SS
         GO TO 2200
 2100    SLOPE = FLOAT(ES-SS) / FLOAT(EL-SL)
         L = SL
 2110    T = SLOPE * FLOAT(L-SL)
         S = IFIX(T+SS+0.5)
         N = N + 1
         SORT(1,N) = L
         SORT(2,N) = S
         L = L + INC
         IF(L .NE. EL) GO TO 2110
 2200 CONTINUE
C
C------------------------------------------------------------
C-----SORT INTERSECTION POINTS BY LINE AND SAMPLE SIMULTANEOUSLY
      CALL SORTX(SORT,N)
      IF(DBUG .EQ. 1) CALL PRNT(2,2*N,SORT,'Aft line.')
C--------------------------------------------------------------
C-----TRANSFORM INTERSECTION PTS INTO LINE SEGMENTS MAKING UP POLYGON
      MINL = SORT(1,1)
      MAXL = SORT(1,N)
      STL = 1
      IF(DBUG .EQ. 1) CALL PRNT(4,1,N,'No intrsctn pts.')
      DO 2300 L=MINL,MAXL
         NONL = 0
C-----FIND NUMBER OF POINTS ON LINE L
         DO 2250 P=STL,N
            IF(SORT(1,P) .NE. L) GO TO 2260
 2250    NONL = NONL + 1
 2260    CONTINUE
C-----CHECK FOR EVEN NUMBER OF POINTS ON THIS LINE
         IF(MOD(NONL,2) .EQ. 0) GO TO 2265
C-----FIXUP NECESSARY FOR THIS LINE.  IT HAS ODD # OF INTERSECTION
C-----POINTS.  WE WILL THROW OUT HE POINTS WHICH IS BOTH A VERTEX
C-----AND AN EVEN # OF POINTS FROM BEGINNING INTERSECTION.

         WRITE (PBUF,9900) NONL,L
9900  FORMAT (' ',I2,' Intersection points for line ',I4)
         CALL XVMESSAGE(PBUF(2:37),' ')
         DO 200 LL=2,NONL,2
            PX = STL + LL - 1
            DO 200 MM=1,NV
              IF(SORT(1,PX).EQ.V(2,MM,A) .AND. SORT(2,PX).EQ.V(1,MM,A))
     +           GOTO 250
  200    CONTINUE
         CALL XVMESSAGE('??E - No even points were vertices',' ')
         CALL XVMESSAGE('??E - Pathological figure....TRY AGAIN',' ')
	call abend
c         RETURN 1
  250    MV = 2 * (N-PX)
         CALL MVE(4,MV,SORT(1,PX+1),SORT(1,PX),1,1)
         N = N - 1
         NONL = NONL - 1
         CALL XVMESSAGE('??I - Fixup successful',' ')
         CALL PRNT(4,1,NONL,'Pts on line.')
 2265    CONTINUE
C
C---------------------------------------------------------------
C-----FILL LINE SEGMENT AND EXTERIOR POINTS BUFFERS
         P = 1
 2268    NSEG = NSEG + 1
         SEGM(1,NSEG) = L
         NX = STL+P-1
         SEGM(2,NSEG) = SORT(2,NX)
         NX = NX + 1
         IF(P .EQ. NONL-1) GO TO 2269
         IF(SORT(2,NX) .NE. SORT(2,NX+1)) GO TO 2269
         NX = NX + 2
         P = P + 2
 2269    SEGM(3,NSEG) = SORT(2,NX)
         IF(SEGM(2,NSEG) .LE. 1) GO TO 2270
         NPTS = NPTS + 1
         PTBUF(1,NPTS) = SEGM(2,NSEG) - 1
         PTBUF(2,NPTS) = L
 2270    CONTINUE
         IF(SEGM(3,NSEG) .GE. NS) GO TO 2290
         NPTS = NPTS + 1
         PTBUF(1,NPTS) = SEGM(3,NSEG) + 1
         PTBUF(2,NPTS) = L
 2290    P = P + 2
         IF(P .LE. NONL) GO TO 2268
 2300 STL = STL + NONL
C
      IF(DBUG .EQ. 0) GO TO 2301
      CALL PRNT(4,1,NSEG,'No line segments.')
      CALL PRNT(2,3*NSEG,SEGM,'Segm buf.')
 2301 IF(XFUNC .NE. 0) RETURN
C
C-----------------------------------------------------------------
C  INTERPOLATE:  GET CONSTANTS
      RADI = CONST(1)
      PERC = IFIX(CONST(2))		!PERCENT
      DNMIN = CONST(3)
      DNMAX = CONST(4)
C--------------------------------------------------------------
C-----COLLECT EXTERIOR POINTS ABOVE AND BELOW EACH SIDE BY
C-----MOVING IN SAMPLE DIRECTION (HENCE THE FUNNY SLOPE)
      DO 1400 J=1,NV
         SL = V(2,J,A)
         SS = V(1,J,A)
         EL = V(2,J+1,A)
         ES = V(1,J+1,A)
         S = SS
         IF(ES .GT. SS) INC = 1
         IF(ES .LT. SS) INC = -1
         IF(ES .EQ. SS) GO TO 1340
         SLOPE = FLOAT(EL-SL) / FLOAT(ES-SS)
 1310    T = SLOPE * FLOAT(S-SS) + SL
         IF(T .EQ. 1. .OR. T .EQ. 1.*NL) GO TO 1320
         L = IFIX(T - 0.001)
         POINT(1) = S
         POINT(2) = T - 1.
         IF(INSIDE(POINT,V(1,1,A),NV)) L = IFIX(T + 1. )
         CALL PTADD(L,S,NPTS)
 1320    S = S + INC
         IF(S .NE. ES) GO TO 1310
         GO TO 1400
 1340    MNL = MIN0(SL,EL)
         MXL = MAX0(SL,EL)
         IF(MNL .EQ. 1) GO TO 1350
         NPTS = NPTS + 1
         PTBUF(1,NPTS) = S
         PTBUF(2,NPTS) = MNL - 1
 1350    IF(MXL .EQ. NL) GO TO 1400
         NPTS = NPTS + 1
         PTBUF(1,NPTS) = S
         PTBUF(2,NPTS) = MXL + 1
 1400 CONTINUE
      IF(DBUG .EQ. 1) CALL PRNT(4,1,NPTS,'No pts total.')
C
c 1500 CONTINUE
      IF(DBUG .EQ. 1) CALL PRNT(2,3*NPTS,PTBUF,'Aft samp.')
C
C-----------------------------------------------------------------
C-----CUT BACK ON THE NUMBER OF POINTS BY SELECTING (WEED) POINTS
C-----AT RANDOM (I HOPE).  MAKE SURE N IS IN RANGE 1 - NPTS AND
C-----IS NOT REPEATED.
      IF(PERC .EQ. 100) GO TO 1100
        WEED = PERC * NPTS / 100
	SEED = 15289
C	SEED2 = 8597
C
        DO 1000 I=1,WEED
1001      call rangen(seed,rannum)
          N=RANNUM*NPTS
          IF(N .LT. 1 .OR. N .GT. NPTS) GO TO 1001
	  IF(I .EQ. 1) GO TO 1003
          DO 1002 L=1,I
            IF(N .EQ. PT(3,L)) GO TO 1001
1002      CONTINUE
1003	  PT(1,I) = PTBUF(1,N)
          PT(3,I) = N
1000      PT(2,I) = PTBUF(2,N)

        NPTS = WEED
        CALL MVE(4,3*NPTS,PT,PTBUF,1,1)
 1100 CONTINUE
      IF(DBUG .EQ. 1) CALL PRNT(4,1,NPTS,'Npts aft weed.')
C
C----------------------------------------------------------------
C-----SORT EXTERIOR POINTS BY LINE AND SAMPLE IN ORDER TO READ DNS
	do ii=1,npts
           sort(1,ii) = ifix(ptbuf(2,ii))
           sort(2,ii) = ifix(ptbuf(1,ii))
	enddo
c      CALL MVE(4,NPTS,PTBUF(2,1),SORT(1,1),3,2)
c      CALL MVE(4,NPTS,PTBUF(1,1),SORT(2,1),3,2)
      CALL SORTX(SORT,NPTS)
C
C-------------------------------------------------------------------
C-----FILL PTBUF BY READING DNS OF SORTED POINTS
      CALL GETDN(NPTS,*998)
C
C--------------------------------------------------------------------
C-----CHECK FOR THRESHHOLD CRITERIAN
      IF(DNMIN .EQ. -9999 .AND. DNMAX .EQ. 32768) GO TO 650
      I = 0
  600 I = I + 1
      IF(I .GT. NPTS) GO TO 650
      IF(PTBUF(3,I) .GE. DNMIN .AND. PTBUF(3,I) .LE. DNMAX) GO TO 600
      CALL MVE(4,3,PTBUF(1,NPTS),PTBUF(1,I),1,1)
      NPTS = NPTS - 1
      I = I - 1
      GO TO 600
  650 CONTINUE
C---------------------------------------------------------------------
      IF(NPTS .LT. 1) GO TO 997
      IF(DBUG .EQ. 0) RETURN
      CALL PRNT(4,1,NPTS,'Npts aft thresh.')
      CALL PRNT(2,NPTS*3,PTBUF,'PTBUF.')
C
C----------------------------------------------------------------
C
      RETURN
  997 CALL XVMESSAGE('??E - No pts in range min to max',' ')
  998 RETURN 1
      END
C
C**************************************************************
C
      SUBROUTINE OPRATE(NSEG,XFUNC,CONST,NPTS,*)
c      IMPLICIT INTEGER (A-Z)
	implicit none
      COMMON/C/NVERT,V,PTBUF,LINE,SORT,SEGM
      COMMON/D/DBUG,ICODE,DNMIN,DNMAX
      COMMON/F/OUTUNIT
c      INTEGER*4 CONST(4)
c	fil substitutes for INVERT and V, FIL2 substitutes for SORT
	integer*4 nvert(25),SORT(2,40000),SEGM(3,40000)
c      INTEGER*2 LINE(10000),SEGM(3,20000)
      INTEGER*4 XFUNC
	integer*4 dbug,i,n,l,ss,es,ns,npts,status
	integer*4 outunit,nseg,icode
c	integer*4 PTBUF(3,40000)
c
	real*4 LINE(40000),PTBUF(3,40000),CONST(4)
	real*4 ULIM,LLIM,r,dnmin,dnmax
	real*4 V(2,26,25)
C
c      DATA ULIM/2147483647.0/,LLIM/-999999999.0/
C
C-----------------------------------------------------------
C-----LOOP THROUGH ALL SEGMENTS
c max val of 32 bit int = 2,147,483,647
c      IF(ICOD .EQ. 1) GO TO 10
      LLIM = dnmin
      ULIM = dnmax
c   10 CONTINUE
C
C-----ZERO OUT LINE BUFFER
      IF(XFUNC .EQ. 6) THEN
	do i=1,40000
         LINE(i) = 0.0
	enddo
      ENDIF
C-----SET LINE BUFFER HALFWORDS TO CONST
      CALL MVE(7,40000,CONST(1),LINE,0,1)		!-6
C
      DO 1000 N=1,NSEG
         L = SEGM(1,N)
         SS = SEGM(2,N)
         ES = SEGM(3,N)
         NS = ES - SS + 1
         GO TO (810,810,810,810,900,900),XFUNC
C-----INTERPOLATE
	 R = CONST(1)*CONST(1)
         CALL REXTRAP(NPTS,L,SS,ES,PTBUF,LINE,R)
         GO TO 900
C-----ADD SUBTRACT MULTIPLY DIVIDE
  810    continue
         CALL XVREAD(OUTUNIT,LINE,STATUS,'LINE',L,'SAMP',SS,
     +   'NSAMPS',NS,' ')
         GO TO (820,840,880,830),XFUNC
C-----MULTIPLY
  820    DO 890 I=1,NS
            LINE(I) = LINE(I) * CONST(1)
            IF(LINE(I) .GT. ULIM) LINE(I) = ULIM
  890    IF(LINE(I) .LT. LLIM) LINE(I) = LLIM
         GO TO 900
C-----DIVIDE
  830    DO 891 I=1,NS
            IF (CONST(1) .EQ. 0) GOTO 970
            LINE(I) = LINE(I) / CONST(1)
            IF(LINE(I) .GT. ULIM) LINE(I) = ULIM
  891    IF(LINE(I) .LT. LLIM) LINE(I) = LLIM
         GO TO 900
C-----ADD
  840    DO 892 I=1,NS
            LINE(I) = LINE(I) + CONST(1)
            IF(LINE(I) .GT. ULIM) LINE(I) = ULIM
  892    IF(LINE(I) .LT. LLIM) LINE(I) = LLIM
         GO TO 900
C-----SUBTRACT
  880    DO 893 I=1,NS
            LINE(I) = LINE(I) - CONST(1)
            IF(LINE(I) .GT. ULIM) LINE(I) = ULIM
  893    IF(LINE(I) .LT. LLIM) LINE(I) = LLIM
  900    CALL XVWRIT(OUTUNIT,LINE,STATUS,'LINE',L,'SAMP',SS,
     +   'NSAMPS',NS,' ')
C------------------------------------------------------------------
 1000 CONTINUE
C
      RETURN
C  998 RETURN 1
970   CALL XVMESSAGE ('??E - Invalid CONST value.',' ')
c999
	CALL XVMESSAGE ('***SARGONB task cancelled',' ')
      CALL ABEND
      END
C
C***************************************************************
C
      SUBROUTINE PTADD(L,S,NPTS)
C-----THIS ROUTINE WILL ADD THE NEW POINTS TO PTBUF OR SKIP THEM
C-----IF THE ARE ALREADY RECORDED THERE.
c      IMPLICIT INTEGER (A-Z)
	implicit none
c	fil substitutes for INVERT and V, FIL3 substitutes for seqm and sort
      COMMON/C/NVERT,V,PTBUF,LINE,SORT,SEGM
c      INTEGER*2 PTBUF(3,40000)
	integer*4 nvert(25),SORT(2,40000),SEGM(3,40000)
	integer*4 j,l,npts,s,d
c
	real*4 V(2,26,25)
	real*4 PTBUF(3,40000)
	real*4 LINE(40000)
C
      DO 90 J=1,NPTS
         D = IABS(L-(IFIX(PTBUF(2,J))))
         IF(S .EQ. PTBUF(1,J) .AND. D .LE. 1) GO TO 100
   90 CONTINUE
      NPTS = NPTS + 1
      PTBUF(1,NPTS) = S
      PTBUF(2,NPTS) = L
  100 CONTINUE
C
      RETURN
      END
C
C**************************************************************
C
      SUBROUTINE GETDN(NPTS,*)
c      IMPLICIT INTEGER (A-Z)
	implicit none
c	fil substitutes for INVERT and V, FIL3 substitutes for SEGM
      COMMON/C/NVERT,V,PTBUF,LINE,SORT,SEGM
      COMMON/D/DBUG,ICODE,DNMIN,DNMAX
      COMMON/F/OUTUNIT
      INTEGER*4 SORT(2,40000),SEGM(3,40000)
c      INTEGER*2 LINE(10000)
	integer*4 i,j,l,np,spt,minl,maxl,nonl,ifp,ilp,npts
	integer*4 sfp,slp,nb,s,samp,e,dbug,icode
	integer*4 outunit,status
	integer*4 NVERT(25)
c
	real*4 V(2,26,25),dnmin,dnmax
	real*4 LINE(40000)
	real*4 PTBUF(3,40000)
C
C------------------------------------------------------------------
C-----SORT HAS BEEN SORTED BY LINE THEN SAMP
      NP = 0
      SPT = 1
      MINL = SORT(1,1)
      MAXL = SORT(1,NPTS)
C
C-----GET DNS ONE LINE AT A TIME
      DO 2000 L=MINL,MAXL
         NONL = 0
C
C-----FIND NUMBER OF POINTS ON THIS LINE
         DO 1150 I=SPT,NPTS
            IF(SORT(1,I) .NE. L) GO TO 1200
 1150    NONL = NONL + 1
C-----IFP & ILP ARE ELEMENTS OF SORT WHICH ARE FIRST & LAST PTS ON LINE
 1200    IF(NONL .EQ. 0) GO TO 2000
         IFP = SPT
         ILP = IFP + NONL - 1
C-----SFP & SLP ARE SAMP # IN PIC OF FIRST AND LAST POINT ON LINE L
         SFP = SORT(2,IFP)
         SLP = SORT(2,ILP)
         NB = SLP - SFP + 1
         CALL XVREAD(OUTUNIT,LINE,STATUS,'LINE',L,'SAMP',SFP,
     +   'NSAMPS',NB,' ')
C-----FOR EACH POINTS ON THIS LINE FILL PTBUF
         DO 1300 J=1,NONL
C-----S IS # WITHIN SORT OF THE JTH PT ON LINE
            S = IFP - 1 + J
C-----SAMP IS SAMP # OF J TH PT
            SAMP = SORT(2,S)
C-----E IS ELEMENT # WITHIN LINE BUFFER
            E = SAMP - SFP + 1
C           EX = 2 * E - 1
            NP = NP + 1
            PTBUF(1,NP) = SAMP
            PTBUF(2,NP) = L
C           IF(ICOD .EQ. 1) CALL MVE(3,1,LINE(E),PTBUF(3,NP))
C           IF(ICOD .EQ. 2) CALL MVE(2,1,LINE(EX),PTBUF(3,NP),1,1)
            CALL MVE(7,1,LINE(E),PTBUF(3,NP),1,1)
 1300    CONTINUE
         SPT = SPT +NONL
 2000 CONTINUE
      IF(NP .NE. NPTS) CALL XVMESSAGE('??E - No dns read ne npts',' ')
      RETURN
C  999 RETURN 1
      END
C
C*******************************************************************
C
	SUBROUTINE SORTX(BUF,N)
C-----THIS ROUTINE WILL SWAP THE HALFWORDS OF THE FULLWORD BUFFER
C-----SO THAT VAX WILL SORT LIKE THE IBM.
	implicit none
	integer*4 I,N,II
c        INTEGER*2 BUF(2,N)
	INTEGER*4 BUF(2,N)
c        INTEGER*2 BUFVAL1(40000), BUFVAL2(40000)
	INTEGER*4 BUFVAL1(40000), BUFVAL2(40000)
        INTEGER*4 BUFVAL3(40000)
        INTEGER*4 BUFNDX1(40000)
C
        DO 100 I=1,N
          BUFVAL3(I) = ((BUF(1,I)*32768) + BUF(2,I))
          BUFVAL1(I) = BUF(1,I)
          BUFVAL2(I) = BUF(2,I)
          BUFNDX1(I) = I
100     CONTINUE
c
c	isortp is I*4, ssortp is R*4
        CALL ISORTP(BUFVAL3,1,N,BUFNDX1)

        DO 200 I=1,N
          II = BUFNDX1(I)
          BUF(1,I) = BUFVAL1(II)
          BUF(2,I) = BUFVAL2(II)
200     CONTINUE

C	INTEGER*2 BUF(2,N),J
C
C	DO 100 I=1,N
C	   J = BUF(1,I)
C	   BUF(1,I) = BUF(2,I)
C	   BUF(2,I) = J
C100	CONTINUE
C
C	CALL ISORT(BUF, 1, N)
C
C	DO 200 I=1,N
C	   J = BUF(1,I)
C	   BUF(1,I) = BUF(2,I)
C	   BUF(2,I) = J
C200	CONTINUE
C
	RETURN
	END
c***************************************************************
      SUBROUTINE REXTRAP(N,L,SS,ES,PTS,BUF,RM)
C
C-----THIS IS A FLOATING POINT VERSION OF EXTRAP FROM SUBLIB
c
c      IMPLICIT INTEGER (A-Z)
	implicit none
      INTEGER*4 I,J,K,L,N,S,SS,ES
      REAL*4 R,R1,R2,NOOM,DENO,RMAX
c      INTEGER*2 PTS(3,N),BUF(1)	- BUF(1) to BUF(*) 2013-09-02
      REAL*4 PTS(3,N),BUF(*),RM
C
      RMAX = RM
      K = 0
C
      DO 10 J=SS,ES
      K = K + 1
      BUF(K) = 0.0
      NOOM = 0.0
      DENO = 0.0
        DO 5 I=1,N
        S = I
        R1 = J - PTS(1,I)
        R2 = L - PTS(2,I)
        R = R1**2 + R2**2
        IF(R .EQ. 0.0) GO TO 6
        IF(R .GT. RMAX) GO TO 5
        NOOM = NOOM + PTS(3,I) / R
        DENO = DENO + 1./R
    5   CONTINUE
C
      IF(NOOM .EQ. 0.0 .OR. DENO .EQ. 0.0) GO TO 10
      BUF(K) = NOOM / DENO + 0.5
      GO TO 10
    6 BUF(K) = PTS(3,S)
   10 CONTINUE
C
      RETURN
      END


C  PROGRAM RESNORM
C-----------------------------------------------------------------------
C  This is a simple resolution normalisation program, which was modified
C  from QUASI_LINES_2D.FOR . It reads in a 2-D resolution file, which
C  should be of the same intermediate GENIE binary format as that of the
C  2-D quasi-elastic data to be subsequently analysed. The output is in
C  file FOR007.DAT .
C-----------------------------------------------------------------------
C  Written by: D.S. Sivia, Rutherford Appleton Lab., Oxfordshire, England.
C-----------------------------------------------------------------------
C  Initial release for trials by CJC, MAA, WSH.       (DSS: 10-MAR-1992)
C  Stretch-factor range increased to +/- 10%.         (DSS: 27-MAY-1992)
C  WBF array-size increased in subroutine INBUFF.     (DSS: 28-MAY-1992)
C  Also put in READONLY for the resolution file.      (DSS: 28-MAY-1992)
C  Fixed bug in CLRBUF; problem for lots of detectors.(DSS: 29-MAY-1992)
C  Hard-wired meV input & ueV output, increased search
C  to +/- 15% and added silent-running option.        (DSS:  2-OCT-1992)
C  Took out small and negative number safety-valve.   (DSS: 17-DEC-1992)
C  Fixed bug in DATIN1 (no more large error-bars!).   (DSS: 27-SEP-1993)
C-----------------------------------------------------------------------
c	nd,xout,yout,eout,yfit=resnorm.resnorm(numb,Xv,Yv,Ev,reals,Xdat,Xb,Yb,wrk,lwrk)
c	numb = [ngrp, nsp, ntc, Ndat, nbin, Imin, Imax, Nb]
c	reals = [efix, theta[0], rscl, bnorm]
c
      SUBROUTINE RESNORM(numb,x_in,y_in,e_in,reals,
     1 XD_in,XB_in,YB_in,vfile,rfile,l_fn,
     2 nd_out,xout,yout,eout,yfit,pfit)
      INCLUDE 'mod_data.f90'
      INCLUDE 'mod_files.f90'
      INCLUDE 'options.f90'
      common/mess/ness
      COMMON /FFTCOM/ FRES(m_d2),FWRK(m_d2),XJ(m_d),TWOPIK(m_d1),NFFT
      COMMON /DATCOM/ XDAT(m_d),DAT(m_d),SIG(m_d),NDAT
      COMMON /DINTRP/ IPDAT(m_d),XPDAT(m_d)
      COMMON /FITCOM/ FIT(m_d),RESID(m_d),NFEW,FITP(m_p),EXPF(m_d1,6)
      COMMON /SCLCOM/ BSCL,ASCL,WSCL,SCLVEC(m_p,2),GSCL
      COMMON /GRDCOM/ DDDPAR(m_d,m_p),FR2PIK(m_d2,2)
      COMMON /WRKCOM/ WORK(m_d2,2)
      COMMON /ModPars/ NBIN,IMIN,IMAX,RSCL,BNORM
      real x_in(m_d), y_in(m_d), e_in(m_d)
cf2py intent(in) :: x_in, y_in, e_in                    !sample data
      real reals(4)
cf2py intent(in) :: reals                               !real parameters
      real XD_in(m_d), XB_in(m_d), YB_in(m_d)
cf2py intent(in) :: XD_in, XB_in, YB_in                 !sample xrange, res data (blur)
      integer numb(8)
cf2py intent(in) :: numb                                !integer parameters
      integer l_fn
cf2py intent(in) :: l_fn                                 !length of filenames
      character*140 vfile, rfile
cf2py intent(in) :: vfile, rfile                         !van & res filenames
      integer nd_out
cf2py intent(out) :: nd_out                              !number of output points
      real xout(m_d), yout(m_d), eout(m_d), yfit(m_d), pfit(4)
cf2py intent(out) :: xout, yout, eout, yfit, pfit              !data values
      real*4 XBLR(m_d),YBLR(m_d)
      real*4 GRAD(m_p),HESS(m_p,m_p),DPAR(m_p),COVAR(m_p,m_p)
      real*4 SIGPAR(m_p),FITPSV(m_p)
      real*4 PRBSV(4,m_sp),PRMSV(7,4,m_sp),SIGSV(7,4,m_sp)
      real*4 CHIX(31),BPARSV(m_p),CCHIX(31)
      real*4 DTNORM(m_sp),XSCALE(m_sp)
      integer INDX(m_p)
      character*80 text,TITLE
      DATA NCHIX /31/
      prog='r'
      o_bgd=1
      o_w1=0
      CALL init_paras
      do n=1,m_p
       GRAD(n)=0.0
       DPAR(n)=0.0
       SIGPAR(n)=0.0
       FITPSV(n)=0.0
       BPARSV(n)=0.0
       do m=1,m_p
        HESS(n,m)=0.0
        COVAR(n,m)=0.0
       end do
      end do
      do n=1,m_sp
       do n1=1,4
        PRBSV(n1,n)=0.0
        do n2=1,7
         PRMSV(n2,n1,n)=0.0
         SIGSV(n2,n1,n)=0.0
        end do
       end do
      end do
      do n=1,31
       CHIX(n)=0.0
       CCHIX(n)=0.0
      end do
c
c     numb = [ngrp, nsp, ntc, Ndat, nbin, Imin, Imax, Nb]
      NSPEC=numb(1)                                      !no. of groups
      ISP=numb(2)                                   !group number
      ntc=numb(3)                                     !no. of points
      NDAT=numb(4)
      NBIN=numb(5)
      IMIN=numb(6)
      IMAX=numb(7)
      NB=numb(8)
c     reals = [efix, theta[isp], rscl, bnorm]
      efix=reals(1)
      theta(ISP)=reals(2)
      RSCL=reals(3)
      BNORM=reals(4)
      do n=1,m_d
       xin(n)=x_in(n)
       yin(n)=y_in(n)
       ein(n)=e_in(n)
       XDAT(n)=XD_in(n)
       XBLR(n)=XB_in(n)
       YBLR(n)=YB_in(n)
      end do
      do n=1,m_sp                          !ResNorm output not used
       DTNORM(n)=1.0                       !DTNORM, NSPEC
       XSCALE(n)=1.0                       !XSCALE, NSPEC
      end do
	    lptfile = ''
      l_lpt=l_fn+11
      lptfile(1:l_lpt)=vfile(1:l_fn)//'_resnrm.lpt'
      if(ISP.eq.1)then                  !print info
       call open_f(53,lptfile)
       write(53,1107)vfile
1107   format(' Vanadium file : ',a140)
       write(53,1108)rfile
1108   format(' Resolution file : ',a140)
       close(unit=53)
      endif
      NDAT=ntc
      CALL BLRINT(XBLR,YBLR,NB,1.0,.false.)
      CALL DPINIT
      CALL GDINIT
      DCHIX=0.010
      CHIX0=1.0-DCHIX*FLOAT((NCHIX-1)/2)
c spectrum starts
      NDAT=ntc
      CALL DATIN(ISP,DTNORM,IDUF)
      if(ISP.eq.1)then                  !print info
       OPEN(UNIT=53,FILE=lptfile,STATUS='old',FORM='formatted',
     1 access='append')
       write(53,1110)xin(1),xin(ntc)
1110   format(' Energy range: ',f8.3,' to ',f8.3,' meV')
       write(53,1002)xblr(1),xblr(NB+1)
1002   format(' Energy range after BLRint: ',f8.3,' to ',f8.3,' meV')
       close(unit=53)
      endif
      CMINSV=1.0E+20
      DO IX=1,NCHIX
        CHIX(IX)=CHIX0+FLOAT(IX-1)*DCHIX
        CALL BLRINT(XBLR,YBLR,NB,CHIX(IX),.false.)
        CALL DPINIT
        CALL PRINIT(FITP,3,NFEW,IX)
        CALL REFINA(GRAD,HESS,DPAR,3+NFEW,DETLOG,INDX,COVAR)
        NPARMS=4+2*NFEW
        CHIOLD=CCHI(FITP)
        CALL VCOPY(FITP,FITPSV,NPARMS)
        STEPSZ=0.3
        IF (NFEW.GT.1) STEPSZ=STEPSZ/10.0
        IAGAIN=0
        CDIFMN=0.003
        ness=0
        DO I=1,200
          CALL REFINE(GRAD,HESS,NPARMS,DETLOG,INDX,COVAR,
     1    STEPSZ,.FALSE.)
          CALL NEWEST(COVAR,GRAD,NPARMS,NFEW,DPAR,FITP)
          CNORM=CCHI(FITP)
          IF (CNORM.LE.CHIOLD) THEN
            CHIDIF=(CHIOLD-CNORM)/CNORM
            IF (ABS(CHIDIF).LE.CDIFMN) THEN
              IF (IAGAIN.EQ.0) THEN
                CDIFMN=0.00005
                STEPSZ=0.15
                IAGAIN=1
              ELSE
                GOTO 3
              ENDIF
            ENDIF
            CHIOLD=CNORM
            CALL VCOPY(FITP,FITPSV,NPARMS)
          ELSE
            CALL VCOPY(FITPSV,FITP,NPARMS)
            STEPSZ=STEPSZ*0.6
          ENDIF
        END DO
   3    CCHIX(IX)=CNORM
        IF (CNORM.LT.CMINSV) THEN
          IXMIN=IX
          CMINSV=CNORM
          XSCLSV=CHIX(IX)
          FLUXSV=FITP(3)*ASCL
          CALL VCOPY(FITP,BPARSV,NPARMS)
        ENDIF
      END DO
      CALL VCOPY(BPARSV,FITP,NPARMS)
      CALL QUADRT(CCHIX,IXMIN,NCHIX,XSCLSV,CHIX)
      CALL BLRINT(XBLR,YBLR,NB,XSCLSV,.false.)
      CALL DPINIT
      CALL PRINIT(FITP,3,NFEW,2)
      do I=1,5
        CALL REFINE(GRAD,HESS,NPARMS,DETLOG,INDX,COVAR,
     1  0.01,.TRUE.)
        CALL NEWEST(COVAR,GRAD,NPARMS,NFEW,DPAR,FITP)
      end do
      CALL ERRBAR(COVAR,NPARMS,SIGPAR)
      CNORM=CCHI(FITP)
      pfit(1)=FITP(3)*ASCL
      pfit(2)=XSCLSV
      pfit(3)=CNORM
      pfit(4)=FITP(4)*GSCL
      OPEN(UNIT=53,FILE=lptfile,STATUS='old',FORM='formatted',
     1 access='append')
      write(53,110) pfit(1),pfit(2),pfit(3),pfit(4)
 110  FORMAT(G15.5,F8.3,5X,2F10.3)
      close(unit=53)

      nd_out=NDAT
      do n=1,nd_out
       xout(n)=XDAT(n)
       yout(n)=DAT(n)
       if(SIG(n).gt.1.0e-20)then
        eout(n)=SQRT(2.0/SIG(n))
       else
        eout(n)=0.0
       endif
       yfit(n)=FIT(n)
      end do
c spectrum ends
      CLOSE(unit=53)
      RETURN
      END


MODULE dom_oce
  USE par_oce
  IMPLICIT NONE
  PUBLIC
  PUBLIC :: dom_oce_alloc
  LOGICAL, PUBLIC :: ln_linssh
  LOGICAL, PUBLIC :: ln_meshmask
  REAL(KIND = wp), PUBLIC :: rn_isfhmin
  REAL(KIND = wp), PUBLIC :: rn_rdt
  REAL(KIND = wp), PUBLIC :: rn_atfp
  INTEGER, PUBLIC :: nn_euler
  LOGICAL, PUBLIC :: ln_iscpl
  LOGICAL, PUBLIC :: ln_crs
  LOGICAL, PUBLIC :: ln_dynspg_exp
  LOGICAL, PUBLIC :: ln_dynspg_ts
  LOGICAL, PUBLIC :: ln_bt_fw
  LOGICAL, PUBLIC :: ln_bt_av
  LOGICAL, PUBLIC :: ln_bt_auto
  INTEGER, PUBLIC :: nn_bt_flt
  INTEGER, PUBLIC :: nn_baro
  REAL(KIND = wp), PUBLIC :: rn_bt_cmax
  REAL(KIND = wp), PUBLIC :: rn_bt_alpha
  REAL(KIND = wp), PUBLIC :: atfp
  REAL(KIND = wp), PUBLIC :: rdt
  INTEGER, PUBLIC :: neuler
  REAL(KIND = wp), PUBLIC :: r2dt
  INTEGER, PUBLIC :: jperio
  LOGICAL, PUBLIC :: l_Iperio, l_Jperio
  INTEGER, PUBLIC :: nimpp, njmpp
  INTEGER, PUBLIC :: nreci, nrecj
  INTEGER, PUBLIC :: nproc
  INTEGER, PUBLIC :: narea
  INTEGER, PUBLIC :: nbondi, nbondj
  INTEGER, ALLOCATABLE, PUBLIC :: nbondi_bdy(:)
  INTEGER, ALLOCATABLE, PUBLIC :: nbondj_bdy(:)
  INTEGER, ALLOCATABLE, PUBLIC :: nbondi_bdy_b(:)
  INTEGER, ALLOCATABLE, PUBLIC :: nbondj_bdy_b(:)
  INTEGER, PUBLIC :: npolj
  INTEGER, PUBLIC :: nlci, nldi, nlei
  INTEGER, PUBLIC :: nlcj, nldj, nlej
  INTEGER, PUBLIC :: noea, nowe
  INTEGER, PUBLIC :: noso, nono
  INTEGER, PUBLIC :: nidom
  INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mig
  INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mjg
  INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mi0, mi1
  INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mj0, mj1
  INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nimppt, njmppt
  INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ibonit, ibonjt
  INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nlcit, nlcjt
  INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nldit, nldjt
  INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nleit, nlejt
  INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :) :: nfiimpp, nfipproc, nfilcit
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :) :: glamt, glamu, glamv, glamf
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :) :: gphit, gphiu, gphiv, gphif
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:, :) :: e1t, e2t, r1_e1t, r1_e2t
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:, :) :: e1u, e2u, r1_e1u, r1_e2u
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:, :) :: e1v, e2v, r1_e1v, r1_e2v
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:, :) :: e1f, e2f, r1_e1f, r1_e2f
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :) :: e1e2t, r1_e1e2t
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :) :: e1e2u, r1_e1e2u, e2_e1u
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :) :: e1e2v, r1_e1e2v, e1_e2v
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :) :: e1e2f, r1_e1e2f
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :) :: ff_f, ff_t
  LOGICAL, PUBLIC :: ln_zco
  LOGICAL, PUBLIC :: ln_zps
  LOGICAL, PUBLIC :: ln_sco
  LOGICAL, PUBLIC :: ln_isfcav
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :, :) :: e3t_0, e3t_b, e3t_n, e3t_a
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :, :) :: e3u_0, e3u_b, e3u_n, e3u_a
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :, :) :: e3v_0, e3v_b, e3v_n, e3v_a
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :, :) :: e3f_0, e3f_n
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :, :) :: e3w_0, e3w_b, e3w_n
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :, :) :: e3uw_0, e3uw_b, e3uw_n
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :, :) :: e3vw_0, e3vw_b, e3vw_n
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :, :) :: gdept_0, gdept_b, gdept_n
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :, :) :: gdepw_0, gdepw_b, gdepw_n
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :, :) :: gde3w_0, gde3w_n
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :) :: ht_0, ht_n
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :) :: hu_0, hu_b, hu_n, hu_a
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :) :: hv_0, hv_b, hv_n, hv_a
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :) :: r1_hu_b, r1_hu_n, r1_hu_a
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :) :: r1_hv_b, r1_hv_n, r1_hv_a
  INTEGER, PUBLIC :: nla10
  INTEGER, PUBLIC :: nlb10
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: gdept_1d, gdepw_1d
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: e3t_1d, e3w_1d
  INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :) :: mbkt, mbku, mbkv
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :) :: tmask_i
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :) :: tmask_h
  INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :) :: misfdep
  INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :) :: mikt, miku, mikv, mikf
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :) :: risfdep
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :) :: ssmask, ssumask, ssvmask
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :, :), TARGET :: tmask, umask, vmask, fmask
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :, :), TARGET :: wmask, wumask, wvmask
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: tpol, fpol
  INTEGER, PUBLIC :: nyear
  INTEGER, PUBLIC :: nmonth
  INTEGER, PUBLIC :: nday
  INTEGER, PUBLIC :: nhour
  INTEGER, PUBLIC :: nminute
  INTEGER, PUBLIC :: ndastp
  INTEGER, PUBLIC :: nday_year
  INTEGER, PUBLIC :: nsec_year
  INTEGER, PUBLIC :: nsec_month
  INTEGER, PUBLIC :: nsec_week
  INTEGER, PUBLIC :: nsec_day
  REAL(KIND = wp), PUBLIC :: fjulday
  REAL(KIND = wp), PUBLIC :: fjulstartyear
  REAL(KIND = wp), PUBLIC :: adatrj
  INTEGER, PUBLIC, DIMENSION(0 : 2) :: nyear_len
  INTEGER, PUBLIC, DIMENSION(0 : 13) :: nmonth_len
  INTEGER, PUBLIC, DIMENSION(0 : 13) :: nmonth_half
  INTEGER, PUBLIC, DIMENSION(0 : 13) :: nmonth_end
  INTEGER, PUBLIC :: nsec1jan000
  LOGICAL, PUBLIC, PARAMETER :: lk_agrif = .FALSE.
  CONTAINS
  LOGICAL FUNCTION Agrif_Root()
    Agrif_Root = .TRUE.
  END FUNCTION Agrif_Root
  CHARACTER(LEN = 3) FUNCTION Agrif_CFixed()
    Agrif_CFixed = '0'
  END FUNCTION Agrif_CFixed
  INTEGER FUNCTION dom_oce_alloc()
    INTEGER, DIMENSION(12) :: ierr
    ierr(:) = 0
    ALLOCATE(mig(jpi), mjg(jpj), STAT = ierr(1))
    ALLOCATE(mi0(jpiglo), mi1(jpiglo), mj0(jpjglo), mj1(jpjglo), tpol(jpiglo), fpol(jpiglo), STAT = ierr(2))
    ALLOCATE(glamt(jpi, jpj), glamu(jpi, jpj), glamv(jpi, jpj), glamf(jpi, jpj), gphit(jpi, jpj), gphiu(jpi, jpj), gphiv(jpi, jpj), gphif(jpi, jpj), e1t(jpi, jpj), e2t(jpi, jpj), r1_e1t(jpi, jpj), r1_e2t(jpi, jpj), e1u(jpi, jpj), e2u(jpi, jpj), r1_e1u(jpi, jpj), r1_e2u(jpi, jpj), e1v(jpi, jpj), e2v(jpi, jpj), r1_e1v(jpi, jpj), r1_e2v(jpi, jpj), e1f(jpi, jpj), e2f(jpi, jpj), r1_e1f(jpi, jpj), r1_e2f(jpi, jpj), e1e2t(jpi, jpj), r1_e1e2t(jpi, jpj), e1e2u(jpi, jpj), r1_e1e2u(jpi, jpj), e2_e1u(jpi, jpj), e1e2v(jpi, jpj), r1_e1e2v(jpi, jpj), e1_e2v(jpi, jpj), e1e2f(jpi, jpj), r1_e1e2f(jpi, jpj), ff_f(jpi, jpj), ff_t(jpi, jpj), STAT = ierr(3))
    ALLOCATE(gdept_0(jpi, jpj, jpk), gdepw_0(jpi, jpj, jpk), gde3w_0(jpi, jpj, jpk), gdept_b(jpi, jpj, jpk), gdepw_b(jpi, jpj, jpk), gdept_n(jpi, jpj, jpk), gdepw_n(jpi, jpj, jpk), gde3w_n(jpi, jpj, jpk), STAT = ierr(4))
    ALLOCATE(e3t_0(jpi, jpj, jpk), e3u_0(jpi, jpj, jpk), e3v_0(jpi, jpj, jpk), e3f_0(jpi, jpj, jpk), e3w_0(jpi, jpj, jpk), e3t_b(jpi, jpj, jpk), e3u_b(jpi, jpj, jpk), e3v_b(jpi, jpj, jpk), e3w_b(jpi, jpj, jpk), e3t_n(jpi, jpj, jpk), e3u_n(jpi, jpj, jpk), e3v_n(jpi, jpj, jpk), e3f_n(jpi, jpj, jpk), e3w_n(jpi, jpj, jpk), e3t_a(jpi, jpj, jpk), e3u_a(jpi, jpj, jpk), e3v_a(jpi, jpj, jpk), e3uw_0(jpi, jpj, jpk), e3vw_0(jpi, jpj, jpk), e3uw_b(jpi, jpj, jpk), e3vw_b(jpi, jpj, jpk), e3uw_n(jpi, jpj, jpk), e3vw_n(jpi, jpj, jpk), STAT = ierr(5))
    ALLOCATE(ht_0(jpi, jpj), hu_0(jpi, jpj), hv_0(jpi, jpj), hu_b(jpi, jpj), hv_b(jpi, jpj), r1_hu_b(jpi, jpj), r1_hv_b(jpi, jpj), ht_n(jpi, jpj), hu_n(jpi, jpj), hv_n(jpi, jpj), r1_hu_n(jpi, jpj), r1_hv_n(jpi, jpj), hu_a(jpi, jpj), hv_a(jpi, jpj), r1_hu_a(jpi, jpj), r1_hv_a(jpi, jpj), STAT = ierr(6))
    ALLOCATE(gdept_1d(jpk), gdepw_1d(jpk), e3t_1d(jpk), e3w_1d(jpk), STAT = ierr(7))
    ALLOCATE(tmask_i(jpi, jpj), tmask_h(jpi, jpj), ssmask(jpi, jpj), ssumask(jpi, jpj), ssvmask(jpi, jpj), mbkt(jpi, jpj), mbku(jpi, jpj), mbkv(jpi, jpj), STAT = ierr(9))
    ALLOCATE(misfdep(jpi, jpj), mikt(jpi, jpj), miku(jpi, jpj), risfdep(jpi, jpj), mikv(jpi, jpj), mikf(jpi, jpj), STAT = ierr(10))
    ALLOCATE(tmask(jpi, jpj, jpk), umask(jpi, jpj, jpk), vmask(jpi, jpj, jpk), fmask(jpi, jpj, jpk), STAT = ierr(11))
    ALLOCATE(wmask(jpi, jpj, jpk), wumask(jpi, jpj, jpk), wvmask(jpi, jpj, jpk), STAT = ierr(12))
    dom_oce_alloc = MAXVAL(ierr)
  END FUNCTION dom_oce_alloc
END MODULE dom_oce


module da_rain

   use module_domain, only : domain

#ifdef DM_PARALLEL
   use module_dm, only : local_communicator, mytask, ntasks, ntasks_x, &
      ntasks_y
   use module_comm_dm, only : halo_em_rain_sub
#endif

   use da_control, only : obs_qc_pointer,missing_r, &
      check_max_iv_print, check_max_iv_unit, v_interp_p, v_interp_h, &
      check_max_iv, missing, rootproc, max_error_rain, &
      rain, trace_use,fails_error_max, &
      max_stheight_diff,missing_data,anal_type_verify, &
      anal_type_verify,max_ext_its,qcstat_conv_unit,ob_vars, &
      ids,ide,jds,jde,kds,kde, ims,ime,jms,jme,kms,kme, &
      ips,ipe,jps,jpe,kps,kpe,num_fgat_time, write_rej_obs_conv

   use da_define_structures, only : maxmin_type, iv_type, y_type, jo_type, &
      bad_data_type, x_type, number_type, bad_data_type
   use da_interpolation, only : da_to_zk, &
      da_interp_lin_3d,da_interp_lin_3d_adj, &
      da_interp_lin_2d, da_interp_lin_2d_adj, da_interp_lin_2d_partial
   use da_par_util1, only : da_proc_sum_int
   use da_par_util, only : da_proc_stats_combine
   use da_statistics, only : da_stats_calculate
   use da_tools, only : da_max_error_qc, da_residual, da_obs_sfc_correction, &
       da_convert_zk,map_info,da_llxy_wrf, da_llxy_default
   use da_tracing, only : da_trace_entry, da_trace_exit

   ! The "stats_rain_type" is ONLY used locally in da_rain:

   type residual_rain1_type
      real          :: rain
   end type residual_rain1_type

   type maxmin_rain_stats_type
      type (maxmin_type)         :: rain
   end type maxmin_rain_stats_type

   type stats_rain_type
      type (maxmin_rain_stats_type)  :: maximum, minimum
      type (residual_rain1_type)     :: average, rms_err
   end type stats_rain_type

contains

#include "da_ao_stats_rain.inc"
#include "da_jo_and_grady_rain.inc"
#include "da_residual_rain.inc"
#include "da_oi_stats_rain.inc"
#include "da_print_stats_rain.inc"
#include "da_transform_xtoy_rain.inc"
#include "da_transform_xtoy_rain_adj.inc"
#include "da_check_max_iv_rain.inc"
#include "da_get_hr_rain.inc"
#include "da_get_innov_vector_rain.inc"
#include "da_calculate_grady_rain.inc"

end module da_rain


| SNAKES'n'LA--wait no, UPSIES-DOWNSIES
: +++ ." ++++++++++++++++" cr 800 ms ;

needs os/fakeconsole
needs alg/array
needs alg/stack
needs random/gm
needs util/doers
| ~sys make prompt  .s ." ok> " ; exit~

context: ~game
~struct ~game

doer validkey?

   variable stack)
: .stk ( --)                                         | print contents of data stack to screen
       0 17 stack) @ dup>r + gotoxy r> (.) type ." ." .s stack) ++ ;

| ooooooooooooooooooOooooooooooooooooo
| GiN ::::: BeGiN ::::: BeGiN ::::: Be
| ooooooooooooooooooOooooooooooooooooo

    0 null !
     '_ value tile
       3 value heart                                   | roll again, destroy a down, +1 to dice
       '# value border
        '\ value ramp1
        '/ value ramp2
        '@ value human
      179 value down
     197 value up
      1 value #players
    'S value screen-key
    32 value roll-key
    'Q value quit-key
     60 value speed
      16 value cols
        16 value rows
          6 value die
              stack frozens                            | stores frozen players until freed
                list keys                              | all keyboard commands
                  list sides                           | where the ramps are
                   list players                        | all players
         rows cols 2array board                        | our game board array, created at runtime

| ooooooooooooooooooOooooooooooooooooo
| oLs ::::: tOoLs ::::: tOoLs ::::: tO
| ooooooooooooooooooOooooooooooooooooo

: seed  ms@ dup 2dup seed4 ;
: rnd ( max -- n<max) rand swap mod abs ;

: swapper ( data1 data2 <name> --)
   create , ,
   does> dup @ swap 2dup cell+ xchg swap ! ;

: rnd[] ( -- a)  size rnd cells ary @ + ;              | a random board square
: start[] ( -- a)  1 rows 2 - xy>c ;                   | players' starting square
: win[] ( -- a)  1 1 xy>c ;                            | arrive here to win the game

: center ( u -- )
        cols swap - 2/ 1- abs rows gotoxy space ;
: msg ( a u --)
        yellow bold fg 0 rows gotoxy cols 2* spaces       | center string below the board and print
        dup center type space normal ;

    ' W ' E swapper otherway
    false true swapper mode?
    ramp1 ramp2 swapper ramp

| ooooooooooooooooooooooOoooooooooooooooooooooo
| hIcS ::::: gRaPhIcS ::::: gRaPhIcS ::::: gRaP
| ooooooooooooooooooooooOoooooooooooooooooooooo

: pos+  pos@ 1+ gotoxy savepos ;

: .dice ( n --)
        cyan fg
        cols 2 + 9 gotoxy savepos
       ."  ____"
        pos+ ." |\\ __`"
        pos+ ." |" 250 emit ." |   |"
        pos+ ." |" 250 emit ." | " white fg . cyan fg ." |"
        pos+ ."  \\|___|"
        normal ;

: 2red  red fg 2 rnd 0; drop bold red fg ;
: 2green  green fg 2 rnd 0; drop bold green fg ;
: 2grey  2 rnd 0if black bold fg ;then white fg ;

: colours ( c --)
        case
           up of 2green endof
           down of 2red endof
           human of cyan bold fg endof
           border of black bold fg endof
           heart of magenta bold fg endof
           drop 2grey
        endcase ;

: .[] ( a --)
        dup c>xy gotoxy                                | go to screen position,
        (pek) dup colours emit                         | fetch and colour data, then print.
        normal ;                                       | restore to default colour

| ooooooooooooooooooOooooooooooooooooo
| aRd ::::: bOaRd ::::: bOaRd ::::: bO
| ooooooooooooooooooOooooooooooooooooo

: .preview ( c a -- c a)
        2dup c>xy gotoxy emit 0 ms ;

: 0board ( --)
        all 2dup swap . .  cr do                                         | for the entire board
		+++
           i dup (rmv) 0 swap (psh)                    | remove every stack, then store a zero
           3 skip
        loop ;

: .board ( --)
        all do                                         | for the entire board,
           i (pek) if i .[] then                       | if the square is non-zero, colour and print
           3 skip                                      | then advance to next square
        loop cr ;

: tiles ( xt-dir a -- xt-dir a t)
        over execute tile over .preview (pok) ( xt a')
        2dup swap execute (pek) border <> ;
: ramp'n'link ( a c -- a)
        over .preview (pok) dup ins ;
: ramps ( xt-dir a -- a)
        nip  32 ramp'n'link  S ramp ramp'n'link ;
: fixups ( a --)
        border over (pok) N tile swap (pok)
        32 start[] tuck (pok) sides del
        16 win[] (pok) ;
: ramps'n'tiles ( -- a-last)
        sides
        0 1 xy>c                                       | set sides as current list
        rows 2 - 0do
           otherway swap
           repeat tiles while
           ramps
        loop
        fixups ;

: border! ( x y --)
        xy>c border swap .preview (pok) ;
: borders ( --)
        cols 0do i 0 border! i rows 1- border! loop
        rows 0do 0 i border! cols 1- i border! loop ;

: tile? ( a -- t)
        (pek) tile = ;

: -tileN/S? ( xt-dir a a -- xt-dir a t)
        dup tile? 0; drop
        third execute tile? not ;

: slide ( c xt-dir --)
        rnd[] ( c xt a)
        -rot third ( a c xt a)
        cols 2/ rnd 1+ 0do
           dup -tileN/S? if
              drop 3drop unloop
           ;then ( a c xt a)
           third over .preview (pok) ( a c xt a)
           over 4 pick ( a c xt a xt) (-psh)           | setup slides
           over execute ( a c xt a')
        loop drop 3drop ;
: slides ( n c xt-dir --)
        rot 0 ?do 2dup slide loop 2drop ;
: ups ( n --)
        up ['] N slides ;
: downs ( n --)
        down ['] S slides ;

: specials ( n c --)
         swap 0 ?do dup rnd[] ( c c a)
            dup tile? 0if
               2drop remains 1+  unloop swap specials
            ;then
            .preview (pok)
         loop drop ;

| oooooooooooooooooooOooooooooooooooooooo
| IoN ::::: aCtIoN ::::: aCtIoN ::::: aCt
| oooooooooooooooooooOooooooooooooooooooo

make validkey? :: keys fnd ;

: getkey ( -- k)
        repeat 40 ms key? not while ekey               | wait until a key is pressed
        dup validkey? if                               | if valid
           undo validkey?                              | exit,
       ;then drop getkey ;                             | else continue waiting

: roll ( -- n)
        die rnd 1+ dup .dice ;

: ?quit ( --)
        " Quit? (y/n)" msg
       { dup 'y = swap 'n = or } >defer validkey?
        getkey 'y = throw " " msg ;
: "quit" ( --)
        normal " So long!" msg cr  1 cursor ;

: whichway ( a -- xt-direction)
        c>xy nip 2 mod 0if ['] E ;then ['] W ;
: -whichway ( a -- xt-direction)
        dup whichway ['] E = if ['] W ;then ['] E ;
: wipe ( c a a' -- c a')
        >r 2dup (del) .[] r> ;
: .new ( c a a' -- c a')
        wipe 2dup (psh) dup .[] speed ms ;
: back ( a - a')
        -whichway execute .new dup
        dup sides fnd 0; drop S back ;
: ahead ( a -- a')
        dup whichway execute .new dup
        dup sides fnd 0; drop N ahead ;
: win? ( c a -- c a | a t)
        dup win[] = 0; drop
        nip unloop unloop false ;
: line? ( a -- t)
        (-pek) dup ['] N = swap ['] S = or ;
: slide ( c a -- c a')
        dup 1 (th) ( c a node)
       { >r dup r> @execute .new true }
        swap iterate ;
: .announce ( c a u --)
        msg dup colours emit yellow bold ." !" ;
: choose-player ( c a -- c a c-player)
        over human =if
          { players fnd } >defer validkey?
           getkey
        ;then
         players num rnd th cell+ @ dup
            fourth = 0; 2drop choose-player ;
: freeze ( c a -- c a)
        choose-player
        dup del
        dup frozens psh 4 rnd 2 + 0do 0 psh loop
        " You're frozen" .announce 750 ms ;

: chance ( c a -- c a')
        players num 1 >if 3 rnd else 2 rnd then
        case
           0 of " Back 3 spaces!" msg 3 0do dup back .new loop endof
           1 of " Ahead 3 spaces!" msg 3 0do dup ahead .new win? loop endof
           2 of " Freeze which player?" msg freeze endof
        endcase ;
: ?event ( c a -- c a')
        dup line? if slide ?event ;then
        heart over (fnd) 0;
        tile swap !  chance ;

: move ( c a n -- c a')
        0do
           dup ahead                                   | move ahead, leveling up if necessary
           .new win?                                   | print player at new location, see if we've won
        loop ?event drop ;                             | after moving, check if we're at a slide or heart

: act ( c a k -- a' | false)
        case
           roll-key of roll move endof
           quit-key of ?quit getkey act endof
           screen-key of mode? fullscreen getkey act endof
           drop
        endcase ;

| ooooooooooooooooOoooooooooooooooo
| aY ::::: pLaY ::::: pLaY ::::: pL
| ooooooooooooooooOoooooooooooooooo

: keys! ( --)
        keys  roll-key ins quit-key ins screen-key ins 'y ins 'n ins ;

: #players? ( --)
        " players? (1-9)" msg
       { '1 '9 between } >defer validkey?
        getkey digit> to #players ;

: start[]! ( --)
        start[] { @ over (psh) true } players itr    | copy each player from list to start square
        drop ;
: start ( --)
        players
        #players 0do i '@ + ins loop                   | store all players in list
       { 2drop roll roll > } >defer compare          | roll to see who goes first,
        srt start[]! ;                                 | populate start square accordingly
: setup ( --)
        0board borders
		ramps'n'tiles
        14 ups  14 downs  12 heart specials
        #players? start ;

: melt ( c --)
        dup " You're free" .announce 750 ms players ins ;
: ?frozen ( -- c t)
        frozens num 0; drop pop 0; melt ;
: search ( c -- a | failed: c)
        all do
            dup i (fnd) if drop i unloop ;then
            3 skip
         loop ;
: GO! ( --)
        ?frozen                                        | continue melting any frozen players
        0 { nip @ dup " Go" .announce ( c)            | announce player's turn
           dup search over ( c a c)                    | search board for the current player
           human =if getkey else 32 then               | if human, wait for keypress, else roll.
           act dup }
        players itr
        0; drop GO! ;

: blink ( a -- a)
        dup (pop) over .[] speed ms over (psh) dup .[] speed ms ;
: victory ( a --)
        dup (pek) " You win" msg emit yellow bold fg ." !"
        6 0do yellow blink fg loop drop ;
: cleanup ( --)
        players rmv  sides rmv  frozens rmv ;
: ?again ( --)
        " Again?" msg
       { dup 'y = swap 'n = or } >defer validkey?
        getkey 'n = throw " " msg ;

: game ( --)
        setup .board GO! victory cleanup ?again game ;

: instructions ( --)
        cols 2 + 0 gotoxy savepos
        pos+ ." Welcome to " green bold fg ." Upsies" normal ." -" red bold fg ." Downsies" normal ." ,"
        pos+ ." the game of mInD-nUmBiNg StRaTeGy!"
        pos+ ." "
        pos+ ." <space> ... roll die"
        pos+ ." <" quit-key emit ." > ....... quit game"
        pos+ ." <" screen-key emit ." > ....... fullscreen" ;

: play ( --)
        0 cursor
        " Upsies-Downsies" title
        seed  keys!                                    | seed RNG, store keyboard commands
        cols rows (2array) ['] board !                 | create board
        board                                          | activate
        instructions
        repeat                                         | start game and keep playing
           ['] game catch if cleanup "quit" ;then      | until 'Q'uit button pressed
        again ;

: exe ( --)
        " ~sys ' play is appstart exit~ nosavedict on save upsies-downsies.exe" eval ;

play


!
!*****************************************************************************80
!
subroutine print_primary_decay(ilib_dir, lib_dir, ifile, file_name,        &
                               e_in, reaction_cs)
!
!*****************************************************************************80
!
!  Discussion:
!
!    This Subroutine prints populations following the first, primary decay step
!    to the appropriate file in the library directory
!
!   Dependencies:
!
!     Modules:
!
!        variable_kinds
!        options
!        constants
!        nodeinfo
!        nuclei
!        Channel_info
!        particles_def
!
!     Subroutines:
!
!        None
!
!     External functions:
!
!        None
!
!     MPI routines:
!
!        None
!
!  Licensing:
!
!    SPDX-License-Identifier: MIT
!
!  Date:
!
!    11 May 2021
!
!  Author:
!
!      Erich Ormand, LLNL
!
!*****************************************************************************80
!
   use variable_kinds
   use options
   use constants
   use nodeinfo
   use nuclei
   use Channel_info
   use particles_def
   implicit none
   integer(kind=4), intent(in):: ilib_dir
   character(len=132), intent(in) :: lib_dir
   integer(kind=4), intent(in):: ifile
   character(len=40), intent(in) :: file_name
   real(kind=8), intent(in) :: e_in
   real(kind=8), intent(in) :: reaction_cs
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   integer(kind=4) :: jj, k, ip
   integer(kind=4) :: num_states
   integer(kind=4) :: ilast
   integer(kind=4) :: if1, inuc
   integer(kind=4) :: idir
   real(kind=8) :: energy
   character(len=132) :: directory
   character(len=132) :: temp_string, fstring
   character(len=132) :: file_char
!----------------------------------------------------------------------------------------
   directory(1:ilib_dir) = lib_dir(1:ilib_dir)
   idir = ilib_dir + 1
   directory(idir:idir) = '/'
   idir = idir + 1
   directory(idir:idir+12) = 'Primary-decay'
   idir = idir + 13
   directory(idir:idir) = '/'

   do if1 = 1, nucleus(1)%num_decay
      inuc = nucleus(1)%decay_to(if1)
      ilast = index(nucleus(inuc)%Label,' ')-1
      if(ilast < 0)ilast = 5

      file_char(1:132) = ' '
      file_char = directory(1:idir)//file_name(1:ifile)//   &
                  "-"//trim(adjustl(nucleus(inuc)%Label))//".dat"
      ilast = index(file_char,' ') - 1
      if(ilast < 1)ilast = 132

      open(unit = 24, file = trim(adjustl(file_char)), status = 'unknown')
      write(24,'(''#Cross section from the primary decay '')')
      write(24,'(''#Population for ead discrete state and continuous energy bin '')')
      write(24,'(''#Incident energy = '',f10.4)')e_in
      num_states = nucleus(inuc)%ncut
      if(all_discrete_states)num_states = nucleus(inuc)%num_discrete
      write(24,'(''#'')')
      write(24,'(''#Discrete states '')')
      do k = 1, num_states
         write(24,'(''    #       Ex     J   par     cs('',a2,'')'')')cs_units
         write(24,'(''  ---     ------  --- ----  ---------------'')')
         write(24,'(1x,i4,1x,f10.4,2(1x,f4.1),1x,1pe15.7)')                                  &
                     k-1,nucleus(inuc)%state(k)%energy,                                      &
                     nucleus(inuc)%state(k)%spin, nucleus(inuc)%state(k)%parity,             &
                     nucleus(inuc)%state(k)%pop*reaction_cs*cs_scale
      end do
      ip = 0
      write(24,'(''#'')')
      write(24,'(''#Positive-Parity Continuous Energy Bins '')')
      write(temp_string,*)min(nucleus(inuc)%j_max,60)+1
      fstring = "('#  Energy  ',"//trim(adjustl(temp_string))//"(5x,'J = ',f4.1,3x))"
      write(24,fstring)(real(jj) + nucleus(inuc)%jshift, jj = 0, min(nucleus(inuc)%j_max,60))
      fstring = "('#----------',"//trim(adjustl(temp_string))//"(1x,'---------------'))"
      write(24,fstring)
      fstring = "(1x,f10.4,"//trim(adjustl(temp_string))//"(1x,1pe15.7))"
      do k = 1, nucleus(inuc)%nbin
         energy = nucleus(inuc)%e_grid(k)
         write(24,fstring)                                                                   &
            energy,(nucleus(inuc)%bins(jj,ip,k)%pop*reaction_cs*cs_scale,jj = 0, min(nucleus(inuc)%j_max,60))
      end do
      ip = 1
      write(24,'(''#'')')
      write(24,'(''#Negative-Parity Continuous Energy Bins '')')
      fstring = "('#  Energy  ',"//trim(adjustl(temp_string))//"(5x,'J = ',f4.1,3x))"
      write(24,fstring)(real(jj) + nucleus(inuc)%jshift, jj = 0, min(nucleus(inuc)%j_max,60))
      fstring= "('#----------',"//trim(adjustl(temp_string))//"(1x,'---------------'))"
      write(24,fstring)
      fstring= "(1x,f10.4,"//trim(adjustl(temp_string))//"(1x,1pe15.7))"
      do k = 1, nucleus(inuc)%nbin
         energy = nucleus(inuc)%e_grid(k)
         write(24,fstring)                                                                   &
            energy,(nucleus(inuc)%bins(jj,ip,k)%pop*reaction_cs*cs_scale,jj = 0, min(nucleus(inuc)%j_max,60))
      end do
      close(unit=24)
   end do

   return
end subroutine print_primary_decay


      subroutine read_afgwc_satdat(c_filename,
     &                       isat,jtype,l_cell_afwa,
     &                       chtype,i_delta_t,
     &                       i4time_current,
     &                       nlines,nelems,
     &                       image_data,
     &                       i4time_data,
     &                       istatus)
c
      Implicit None

      Integer     cell_depth
      Integer     cell_width
      parameter  (cell_depth=64,
     &            cell_width=256)

      Integer     nlines,nelems

      Integer     n
      Integer     i4time_current
      Integer     i4time_data
      Integer     i4time_diff
      Integer     istatus
      Integer     i_delta_t
      Integer     isat,jtype
      Integer     nefi,nlfi
      Integer     lun

      INTEGER DECIMAT
      INTEGER STRPIX     !Start Pixel
      INTEGER STRSCNL    !Start Scanline
      INTEGER STPPIX     !Stop Pixel
      INTEGER STPSCNL    !Stop Scanline
      INTEGER REQOBSTM   !Requested Observation Time
      INTEGER BEPIXFC
      INTEGER BESCNFC
      INTEGER FSCI
      INTEGER STRBDY1    !Requested Start Boundary 1
      INTEGER STRBDY2    !Requested Start Boundary 2
      INTEGER STPBDY1    !Requested Stop Boundary 1
      INTEGER STPBDY2    !Requested Stop Boundary 2
      REAL   GOLONSBP      !GOES Longitude Subpoint
      REAL   GOLATSBP      !GOES Latitude Subpoint
      REAL   GOALPHA       !GOES Alpha

      REAL   image_data  (nelems,nlines)

      INTEGER WIDTH      !Tracks in Width of image
      INTEGER DEPTH      !Tracks in Depth of image
      CHARACTER*2 IMGTYPE  !Image Type

      Character     c_filetime*9
      Character     cfname*9
      Character     chtype*3
      Character     c_filename*255

      logical       lopen,lext
      logical       l_cell_afwa

      istatus=0

      n=index(c_filename,' ')-1

      inquire(file=c_filename,exist=lext,opened=lopen,number=lun)
      if(.not.lext)then
         print*,'File does not exist: ',c_filename(1:n)
         goto 1000
      endif
      if(lopen)then
         print*,'File is already open: ',c_filename(1:n)
         goto 1000
      endif
      call read_gwc_header(c_filename(1:n),l_cell_afwa,STRPIX,STRSCNL,
     +   STPPIX,STPSCNL,REQOBSTM,IMGTYPE,GOLATSBP,GOLONSBP,WIDTH,DEPTH,
     +   GOALPHA,STRBDY1,STRBDY2,STPBDY1,STPBDY2,BEPIXFC,BESCNFC,
     +   FSCI,DECIMAT,istatus)
      if(istatus.eq.0)then
         write(6,*)'Got gwc header info'
      else
         write(6,*)'Error reading gwc header '
         goto 1000
      endif

c     write(c_filetime(1:7),111)reqobstm
c111   format(i7)
c     do i=1,7
c        if(c_filetime(i:i).eq.' ')then
c           c_filetime(i:i)='0'
c        endif
c     enddo
c     call make_fnam_lp(i4time_current,cfname,istatus)
c     c_yr = cfname(1:2)
c     c_jday = c_filetime(1:3)
c     c_hhmm = c_filetime(4:7)
c     c_filetime=c_yr//c_jday//c_hhmm
c     call cv_asc_i4time(c_filetime,i4time_data)

c
c put check in here for latest file time in lvd subdirectory.
c
      i4time_data=reqobstm

      i4time_diff = 0  !i4time_current-i4time_data    <---- Don't forget to un-comment.
      if(i4time_diff.gt.i_delta_t)then
         write(6,*)'Data is too old!'
         write(6,*)'Data    Time: ',c_filetime
         call make_fnam_lp(i4time_current,c_filetime,istatus)
         write(6,*)'Current Time: ',c_filetime
         goto 902
      elseif(i4time_diff.lt.0)then
         write(6,*)'Data time is more recent than current time!?'
         write(6,*)'This does not make sense!'
      else
         write(6,*)'Found AFWA data'
      endif
c
c read afgwc binary data file
c
      if(l_cell_afwa)then
         nlfi=depth*cell_depth
         nefi=width*cell_width
      else
         nlfi=stpscnl-strscnl+1
         nefi=stppix-strpix+1
      endif

      call Process_SDHS_GVAR_sub(c_filename,chtype,isat,jtype,
     &nelems,nlines,image_data,nlfi,nefi,depth,width,istatus)

      if(istatus.eq.1)then
         write(6,*)'Got AFWA satellite data'
      else
         write(6,*)'Error reading gwc sat data - Process_SDHS_sub'
      endif

      goto 1000

902   write(6,*)'Returning without new data'

1000  return
      end


!-----------------------------------------------------------------------
! Interface file for ssebpush2.c
      module ssebpush2_h
      implicit none
!
      interface
         subroutine csse2xiscan2(isdata,nths)
         implicit none
         integer :: nths
         integer, dimension(nths) :: isdata
         end subroutine
      end interface
!
      interface
         subroutine csse2gbpush23lt(part,fxy,bxy,qbm,dt,dtc,ek,idimp,   &
     &nop,npe,nx,ny,nxv,nyv,ipbc)
         implicit none
         integer :: idimp, nop, npe, nx, ny, nxv, nyv, ipbc
         real :: qbm, dt, dtc, ek
         real, dimension(npe,idimp) :: part
         real, dimension(4,nxv,nyv) :: fxy, bxy
         end subroutine
      end interface
!
      interface
         subroutine csse2grbpush23lt(part,fxy,bxy,qbm,dt,dtc,ci,ek,     &
     &idimp,nop,npe,nx,ny,nxv,nyv,ipbc)
         implicit none
         integer :: idimp, nop, npe, nx, ny, nxv, nyv, ipbc
         real :: qbm, dt, dtc, ci, ek
         real, dimension(npe,idimp) :: part
         real, dimension(4,nxv,nyv) :: fxy, bxy
         end subroutine
      end interface
!
      interface
         subroutine csse2gpost2lt(part,q,qm,nop,npe,idimp,nxv,nyv)
         implicit none
         integer :: nop, npe, idimp, nxv, nyv
         real :: qm
         real, dimension(npe,idimp) :: part
         real, dimension(nxv,nyv) :: q
         end subroutine
      end interface
!
      interface
         subroutine csse2gjpost2lt(part,cu,qm,dt,nop,npe,idimp,nx,ny,nxv&
    &,nyv,ipbc)
         implicit none
         integer :: nop, npe, idimp, nx, ny, nxv, nyv, ipbc
         real :: qm, dt
         real, dimension(npe,idimp) :: part
         real, dimension(4,nxv,nyv) :: cu
         end subroutine
      end interface
!
      interface
         subroutine csse2grjpost2lt(part,cu,qm,dt,ci,nop,npe,idimp,nx,ny&
     &,nxv,nyv,ipbc)
         implicit none
         integer :: nop, npe, idimp, nx, ny, nxv, nyv, ipbc
         real :: qm, dt, ci
         real, dimension(npe,idimp) :: part
         real, dimension(4,nxv,nyv) :: cu
         end subroutine
      end interface
!
      interface
         subroutine csse2dsortp2ylt(parta,partb,npic,idimp,nop,npe,ny1)
         implicit none
         integer :: idimp, nop, npe, ny1
         real, dimension(npe,idimp) :: parta, partb
         integer, dimension(ny1) :: npic
         end subroutine
      end interface
!
      interface
         subroutine csse2bguard2l(bxy,nx,ny,nxe,nye)
         implicit none
         integer :: nx, ny, nxe, nye
         real, dimension(4,nxe,nye) :: bxy
         end subroutine
      end interface
!
      interface
         subroutine csse2acguard2l(cu,nx,ny,nxe,nye)
         implicit none
         integer :: nx, ny, nxe, nye
         real, dimension(4,nxe,nye) :: cu
         end subroutine
      end interface
!
      interface
         subroutine csse2aguard2l(q,nx,ny,nxe,nye)
         implicit none
         integer :: nx, ny, nxe, nye
         real, dimension(nxe,nye) :: q
         end subroutine
      end interface
!
      interface
         subroutine csse2pois23(q,fxy,isign,ffc,ax,ay,affp,we,nx,ny,nxvh&
     &,nyv,nxhd,nyhd)
         implicit none
         integer :: isign, nx, ny, nxvh, nyv, nxhd, nyhd
         real :: ax, ay, affp ,we
         real, dimension(2*nxvh,nyv) :: q
         real, dimension(4,2*nxvh,nyv) :: fxy
         complex, dimension(nxhd,nyhd) :: ffc
         end subroutine
      end interface
!
      interface
         subroutine csse2cuperp2(cu,nx,ny,nxvh,nyv)
         implicit none
         integer :: nx, ny, nxvh, nyv
         real, dimension(4,2*nxvh,nyv) :: cu
         end subroutine
      end interface
!
      interface
         subroutine csse2ibpois23(cu,bxy,ffc,ci,wm,nx,ny,nxvh,nyv,nxhd, &
     &nyhd)
         implicit none
         integer :: nx, ny, nxvh, nyv, nxhd, nyhd
         real :: ci, wm
         real, dimension(4,2*nxvh,nyv) :: cu
         complex, dimension(4,nxvh,nyv) :: bxy
         complex, dimension(nxhd,nyhd) :: ffc
         end subroutine
      end interface
!
      interface
         subroutine csse2maxwel2(exy,bxy,cu,ffc,ci,dt,wf,wm,nx,ny,nxvh, &
     &nyv,nxhd,nyhd)
         implicit none
         integer :: nx, ny, nxvh, nyv, nxhd, nyhd
         real :: ci, dt, wf, wm
         complex, dimension(4,nxvh,nyv) :: exy, bxy
         real, dimension(4,2*nxvh,nyv) :: cu
         complex, dimension(nxhd,nyhd) :: ffc
         end subroutine
      end interface
!
      interface
         subroutine csse2emfield2(fxy,exy,ffc,isign,nx,ny,nxvh,nyv,nxhd,&
     &nyhd)
         implicit none
         integer :: isign, nx, ny, nxvh, nyv, nxhd, nyhd
         real, dimension(4,2*nxvh,nyv) :: fxy
         complex, dimension(4,nxvh,nyv) :: exy
         complex, dimension(nxhd,nyhd) :: ffc
         end subroutine
      end interface
!
      interface
         subroutine csse2wfft2rx(f,isign,mixup,sct,indx,indy,nxhd,nyd,  &
     &nxhyd,nxyhd)
         implicit none
         integer :: isign, indx, indy, nxhd, nyd, nxhyd, nxyhd
         real, dimension(2*nxhd,nyd) :: f
         integer, dimension(nxhyd) :: mixup
         complex, dimension(nxyhd) :: sct
         end subroutine
      end interface
!
      interface
         subroutine csse2wfft2r3(f,isign,mixup,sct,indx,indy,nxhd,nyd,  &
     &nxhyd,nxyhd)
         implicit none
         integer :: isign, indx, indy, nxhd, nyd, nxhyd, nxyhd
         real, dimension(4,2*nxhd,nyd) :: f
         integer, dimension(nxhyd) :: mixup
         complex, dimension(nxyhd) :: sct
         end subroutine
      end interface
!
      end module


*----------------------------------------------------------------------*
      subroutine form_fact_new(fl_fact,contr,
     &     op_info,str_info,orb_info,iscale_stat,cost_stat,mem_stat,
     &     iitem)
*----------------------------------------------------------------------*
*     find optimum factorization of a given contraction
*     and write a sequence of unary/binary operations to fl_fact
*----------------------------------------------------------------------*
      implicit none

      include 'opdim.h'
      include 'stdunit.h'
      include 'routes.h'
      include 'def_contraction.h'
      include 'def_graph.h'
      include 'def_strinf.h'
      include 'def_orbinf.h'
      include 'def_reorder_info.h'
      include 'mdef_operator_info.h'
      include 'def_formula_item.h'

      integer, parameter ::
     &     maxcount = 1000000, ! at most 1000000 iterations
     &     ndisconn = 14,     ! at most 4 extra levels for disconnected
     &     ntest = 00         ! vertices

      type(contraction), intent(inout) ::
     &     contr
      type(formula_item), intent(inout) ::
     &     fl_fact

      type(operator_info), intent(inout) ::
     &     op_info
      type(strinf), intent(inout) ::
     &     str_info
      type(orbinf), intent(in), target ::
     &     orb_info
      integer, intent(inout) ::
     &     iscale_stat(ngastp,2), iitem
      real(8), intent(inout) ::
     &     cost_stat, mem_stat

      integer ::
     &     ngas, nsym, maxidx, iarc, ivtx, icount, njoined, ncost_eval,
     &     idx, narc_full, nvtx_full, nlevel, nlevel_best,
     &     command, target, idx_intm, idum, nvtx_max, nreo_op1op2
      integer, pointer ::
     &     ihpvgas(:,:),
     &     ifact(:,:), ifact_best(:,:), occ_vtx(:,:,:),
     &     irestr_vtx(:,:,:,:,:), info_vtx(:,:),
     &     irestr_res(:,:,:,:,:)

*----------------------------------------------------------------------*
*     ifact(4,*): describes factorization by giving
*            ( vertex-number 1, vertex-number 2,
*                         result-vertex-number, arc-number )
*          all numbers might refer to fused vertices/arcs
*          the number is then an ordered list of all vertices/arcs fused
*          packed using the number of plain arcs (narc) or vertices (nvtx)
*          in the current contraction (as given in contr)
*----------------------------------------------------------------------*
      real(8) ::
     &     cost(3), costmin(3)
      integer ::
     &     iscale(ngastp,2), iscalemin(ngastp,2)
      type(operator), pointer ::
     &     op_res
      type(reorder_info) ::
     &     reo_info0

      logical ::
     &     possible, found, predef, reo_add
      real(8) ::
     &     cpu0, sys0, wall0, cpu, sys, wall

      integer(8), pointer ::
     &     vtx(:), topo(:,:), xlines(:,:), op_res_p(:), xlines_dum(:,:)
      integer, pointer ::
     &     svertex(:),
     &     iocc_ori(:,:,:), iocc_reo(:,:,:),
     &     irst_ori(:,:,:,:,:), irst_reo(:,:,:,:,:),
     &     merge_stp1(:), merge_stp1inv(:),
     &     merge_stp2(:), merge_stp2inv(:)

      logical, external ::
     &     next_fact
      integer, external ::
     &     int_pack, ifac

      if (ntest.ge.100) then
        call write_title(lulog,wst_dbg_subr,'form_fact_new at work!')
        call prt_contr2(lulog,contr,op_info)
      end if
c dbg
c      call check_xarcs(contr,op_info)
c dbg

      call atim_csw(cpu0,sys0,wall0)

      if (orb_info%ngas.eq.0)
     &     call quit(1,'form_fact_new','buggy ngas !')
      if (orb_info%nsym.eq.0)
     &     call quit(1,'form_fact_new','buggy nsym !')

      ngas = orb_info%ngas
      nsym = orb_info%nsym
      ihpvgas => orb_info%ihpvgas

      narc_full = contr%narc
      nvtx_full = contr%nvtx

      op_res => op_info%op_arr(contr%idx_res)%op
      njoined = op_res%njoined

      ! if only 1 vertex is present, we need not bother too much
      if (contr%nsupvtx.eq.1.and.narc_full.eq.0) then

        reo_add = .false.
        if (nvtx_full.gt.1) then
          ! we have to check whether reordering is necessary
          call init_reo_info(reo_info0)
          nvtx_max = max(nvtx_full,njoined)
          allocate(svertex(nvtx_full),vtx(nvtx_full),op_res_p(njoined),
     &             topo(nvtx_full,nvtx_full),xlines(nvtx_max,njoined),
     &             xlines_dum(nvtx_max,nvtx_max))
          xlines = 0
          xlines_dum = 0
          call pack_contr(svertex,vtx,topo,
     &                    xlines(1:nvtx_full,1:njoined),contr,njoined)
c dbg
c          write(lulog,*) 'checking for necessary reordering:'
c          call prt_contr_p(lulog,svertex,vtx,topo,
c     &            xlines(1:nvtx_full,1:njoined),nvtx_full,njoined)
c dbgend
          op_res_p = 0
          do idx = 1, njoined
            do ivtx = 1, nvtx_full
              op_res_p(idx) = op_res_p(idx) + xlines(ivtx,idx)
            end do
          end do

          xlines_dum = 0
          xlines_dum(1:nvtx_full,1:njoined)
     &          = xlines(1:nvtx_full,1:njoined)
          call set_final_reo(reo_info0,xlines,xlines_dum,op_res_p,
     &                     contr%vertex(1)%idx_op,nvtx_full,njoined)

          reo_add = (reo_info0%nreo.gt.0)
          deallocate(svertex,vtx,topo,xlines,op_res_p,xlines_dum)
          if (.not.reo_add) call dealloc_reo_info(reo_info0)
        end if

        ! set index info for ITF here ... unclear, how ITF can cope with reordering
        call contr_set_indices(contr,op_info)

        if (reo_add) then

          allocate(iocc_reo(ngastp,2,nvtx_max),
     &             iocc_ori(ngastp,2,nvtx_max),
     &             irst_reo(2,ngas,2,2,nvtx_max),
     &             irst_ori(2,ngas,2,2,nvtx_max),
     &             merge_stp1(2*nvtx_max*nvtx_max),
     &             merge_stp1inv(2*nvtx_max*nvtx_max),
     &             merge_stp2(2*nvtx_max*nvtx_max),
     &             merge_stp2inv(2*nvtx_max*nvtx_max),
     &             occ_vtx(ngastp,2,nvtx_max+njoined),
     &             irestr_vtx(2,ngas,2,2,nvtx_max+njoined),
     &             info_vtx(2,nvtx_max+njoined),
     &             svertex(nvtx_max))
          iocc_reo = 0
          iocc_ori = 0
          irst_reo = 0
          irst_ori = 0
          occ_vtx = 0
          irestr_vtx = 0
          svertex(1:nvtx_max) = 1

          call occvtx4contr(0,occ_vtx,contr,op_info)

          call vtxinf4contr(irestr_vtx,info_vtx,contr,op_info,ngas)

          call get_reo_info2(-1,1,
     &           iocc_reo,iocc_ori,
     &           irst_reo,irst_ori,
     &           ivtx,idx,idum, ! <-- dummies
     &           merge_stp1,merge_stp1inv,merge_stp2,merge_stp2inv,
     &           occ_vtx,irestr_vtx,
     &                   svertex,info_vtx,
     &                       njoined,nvtx_max,
     &           reo_info0,nreo_op1op2,str_info,orb_info)

          command = command_add_reo
          target = contr%idx_res
          call new_formula_item(fl_fact,command,target)
          call store_add_intm(fl_fact,contr,op_info,orb_info)
          call store_reorder(fl_fact,
     &       op_res%name,op_info%op_arr(contr%vertex(1)%idx_op)%op%name,
     &       contr%iblk_res,(contr%vertex(1)%iblk_op-1)/nvtx_full+1,
     &       contr%dagger,contr%vertex(1)%dagger,
     &       reo_info0%sign_reo,reo_info0%iocc_opreo0,
     &       reo_info0%from_to,reo_info0%iocc_reo,nreo_op1op2,
     &       reo_info0%nreo-nreo_op1op2,
     &       iocc_reo,irst_reo,nvtx_max,
     &       iocc_ori,irst_ori,nvtx_max,
     &       merge_stp1,merge_stp1inv,merge_stp2,merge_stp2inv,
     &       orb_info)
          if (lustat.gt.0)
     &       call print_form_item(lustat,iitem,fl_fact,op_info)
          deallocate(iocc_reo,iocc_ori,irst_reo,irst_ori,
     &             merge_stp1,merge_stp1inv,merge_stp2,merge_stp2inv,
     &             occ_vtx,irestr_vtx,info_vtx,svertex)
          call dealloc_reo_info(reo_info0)
          return
        else
          command = command_add_intm
          target = contr%idx_res
          call new_formula_item(fl_fact,command,target)
          call store_add_intm(fl_fact,contr,op_info,orb_info)
          if (lustat.gt.0)
     &       call print_form_item(lustat,iitem,fl_fact,op_info)
          return
        end if
      else
        allocate(occ_vtx(ngastp,2,nvtx_full+njoined),
     &       irestr_vtx(2,orb_info%ngas,2,2,nvtx_full+njoined),
     &       info_vtx(2,nvtx_full+njoined))
      end if

      allocate(ifact(ld_inffac,narc_full+ndisconn),
     &     ifact_best(ld_inffac,narc_full+ndisconn))

      call occvtx4contr(0,occ_vtx,contr,op_info)

      call vtxinf4contr(irestr_vtx,info_vtx,contr,op_info,ngas)

      ! add 0-contractions, if necessary
cmh      if (nvtx_full.ne.njoined) call check_disconnected(contr)
      call check_disconnected(contr)

      found = .false.
      costmin = huge(costmin)
      nlevel = 1
      icount = 0
      ncost_eval = 0
      iscale = 0

      idx_intm = 0

      ! allow predefined contraction sequence:
      predef = contr%nfac.gt.0
      if (predef) ifact(4,1:contr%nfac) = contr%inffac(4,1:contr%nfac)

c dbg
c      print *,'now diving into the recursions, njoined = ',njoined
c dbg
      call form_fact_rec_new('FIND',predef,nlevel,ifact,fl_fact,
     &     cost,iscale,iitem,
     &     contr,occ_vtx,irestr_vtx,info_vtx)

      if (iprlvl.ge.10) then
        write(lulog,*) '# of dummy contractions: ',ncost_eval
      end if

      if (.not.found) then
        call prt_contr3(lulog,contr,-1)
        call prt_contr2(lulog,contr,op_info)
        call quit(1,'form_fact_new','Did not find any factorization!')
      end if

      if (ntest.ge.10) then
        write(lulog,*) 'optimal factorization: '
        write(lulog,'(x,a,g15.10)') 'flops: ',costmin(1)
        write(lulog,'(x,a,2g15.10)') 'mem:   ',costmin(2:3)
        write(lulog,'(x,a,"H^",i2," P^",i2,"V^",i2,"X^",i2)')
     &       'contraction scaling:  ',iscalemin(1:4,1)
        write(lulog,'(x,a,"H^",i2," P^",i2,"V^",i2,"X^",i2)')
     &       'intermediate scaling: ',iscalemin(1:4,2)
      end if

      ! statistics
      iscale_stat(1:4,1:2) = iscalemin(1:4,1:2)
      cost_stat = costmin(1)
      mem_stat  = costmin(2)

      idx_intm = 0

c dbg
c      print *,'now SETting'
c        call prt_contr2(lulog,contr,op_info)
c        call wrt_occ_n(lulog,occ_vtx,nvtx_full+njoined)
c dbg

      ! analyze the diagram and set helper variables required for ITF translator
      call contr_set_indices(contr,op_info)
      call contr_get_eqv_line_factor(contr,op_info)

      ! call kernel again for optimal sequence --> set fl_fact now
      call form_fact_rec_new('SET ',.true.,nlevel,ifact_best,fl_fact,
     &     cost,iscale,iitem,
     &     contr,occ_vtx,irestr_vtx,info_vtx)

      deallocate(ifact,ifact_best,
     &     occ_vtx,irestr_vtx,info_vtx)

      call atim_csw(cpu,sys,wall)
      if (iprlvl.ge.5)
     &    call prtim(lulog,'time in form_fact_new',
     &     cpu-cpu0,sys-sys0,wall-wall0)

      if (ntest.ge.100) then
        write(lulog,*) 'generated formula'
        call print_form_list(lulog,fl_fact,op_info)
      end if

      ! Optionally check for permutation factors used in
      ! the ITF translator
      ! TODO: make this optional

      if (trim(op_info%op_arr(contr%idx_res)%op%name)=="INTHE1") then
        write(lulog,*) 'HERE IT COMES: '
        call prt_contr2(lulog,contr,op_info)
      end if

      call check_itf_permute(contr,fl_fact)

      return

      contains
*----------------------------------------------------------------------*
*     the recursive kernel:
*----------------------------------------------------------------------*
      recursive subroutine form_fact_rec_new(mode,predef,
     &     nlevel,ifact,fl_in,
     &     cost_in,iscale_in,iitem,
     &     contr,occ_vtx,irestr_vtx,info_vtx)
*----------------------------------------------------------------------*

      implicit none

      type(formula_item), intent(inout), target ::
     &     fl_in
      character(len=*), intent(in) ::
     &     mode
      integer, intent(inout) ::
     &     ifact(ld_inffac,*)
      type(contraction), intent(in) ::
     &     contr
      integer, intent(in) ::
     &     iscale_in(ngastp,2), nlevel,
     &     occ_vtx(ngastp,2,contr%nvtx+njoined),
     &     irestr_vtx(2,ngas,2,2,contr%nvtx+njoined),
     &     info_vtx(2,contr%nvtx+njoined)
      integer, intent(inout) ::
     &     iitem
      real(8), intent(in) ::
     &     cost_in(3)
      logical, intent(in) ::
     &     predef

      logical ::
     &     possible, new
      integer ::
     &     narc, ivtx_new, iarc, idx_op_new, ilist, len_list,
     &     iscale(ngastp,2), nlist
      real(8) ::
     &     cost(3)
      type(contraction) ::
     &     contr_red
      integer ::
     &     occ_vtx_red(ngastp,2,contr%nvtx+njoined),
     &     irestr_vtx_red(2,ngas,2,2,contr%nvtx+njoined),
     &     info_vtx_red(2,contr%nvtx+njoined),
     &     arc_list(contr%narc)
      type(formula_item), pointer ::
     &     fl_pnt

      integer, external ::
     &     joint_idx

      if (orb_info%nsym.eq.0)
     &     call quit(1,'form_fact_rec_new','buggy nsym !')
      if (ntest.ge.1000) then
        call write_title(lulog,wst_dbg_subr,
     &       'form_fact_rec_new rursively at work')
        write(lulog,*) 'nlevel = ',nlevel
        write(lulog,*) 'current cost: ',cost_in(1:3)
        if (nlevel.gt.1) then
          write(lulog,*) 'current ifact: '
          write(lulog,'(x,i5,"*",i5,"->",i5,"(",i5,")")')
     &         ifact(1:4,1:nlevel-1)
        end if
        write(lulog,*) 'result: njoined = ',njoined
        call wrt_occ_n(lulog,occ_vtx,njoined)
        write(lulog,*) 'current (reduced) contraction:'
        call prt_contr3(lulog,contr,occ_vtx(1,1,njoined+1))
      end if

      fl_pnt => fl_in

      call init_contr(contr_red)

      narc = contr%narc

      if (nlevel.gt.narc_full+ndisconn)
     &     call quit(1,'form_fact_rec_new','emergency exit')

      if (orb_info%nsym.eq.0) call quit(1,'form_fact_rec_new'
     &                                   ,'buggy nsym!')
      if (mode(1:4).eq.'FIND'.and..not.predef) then
        ! get list of (non-redundant) arcs, ordered according to
        ! contractraction strength (descending)
        call get_arc_list(arc_list,len_list,contr,orb_info)
      else if (mode(1:3).eq.'SET'
     &         .or.mode(1:4).eq.'FIND'.and.predef) then
        ! get arc form previously set ifact array
        len_list = 1
        arc_list(1) = ifact(4,nlevel)
      else
        call quit(1,'form_fact_rec_new'
     &             ,'unknown mode: "'//trim(MODE)//'"')
      end if

      ! only try first maxbranch elements of arc_list (if maxbranch is set)
      nlist = len_list
      if (maxbranch.gt.0) nlist = min(len_list,maxbranch)

      do ilist = 1, nlist

        iarc = arc_list(ilist)

        icount = icount+1
        if (ntest.ge.1000) then
          write(lulog,*) ' next arc, narc, icount: ',iarc,narc,icount
        end if

        ! reset
        cost = cost_in
        iscale = iscale_in

        if (icount.gt.maxcount)
     &       call quit(1,'form_fact_rec_new','too many cycles')

        new = .true.
        ! process binary contraction
        ! 'FIND' -- get cost of contraction
        ! 'SET'  -- set fl_fact
        call process_bc(mode,fl_pnt,possible,cost,iscale,
     &       iarc,njoined,nlevel,idx_intm,iitem,
     &       contr,occ_vtx,irestr_vtx,info_vtx,
     &       contr_red,occ_vtx_red,irestr_vtx_red,info_vtx_red,
     &       op_info,str_info,orb_info)
        ! advance pointer
        do while(fl_pnt%command.ne.command_end_of_formula)
          fl_pnt => fl_pnt%next
        end do

        if (ntest.ge.1000) then
          write(lulog,'(x,a,l1)')
     &         'possible: ',possible
          if (possible) then
            write(lulog,'(x,a,3f20.2)') 'cost:    ',cost
            write(lulog,'(x,a,3f20.2)') 'costmin: ',costmin
            if (cost(1).ge.costmin(1))
     &           write(lulog,*) 'too expensive !'
          end if
        end if

        ! the contraction is not allowed (for some reason)
        if (.not.possible) cycle

        ncost_eval = ncost_eval+1
        ! already more expensive than current best factorization?
        if (cost(1).ge.costmin(1)) cycle

        ! if the binary contraction is accepted, ...

        ! ... update ifact array ...
        ifact(1,nlevel) = contr%vertex(contr%arc(iarc)%link(1))%idx_op
        ifact(2,nlevel) = contr%vertex(contr%arc(iarc)%link(2))%idx_op
        ifact(3,nlevel) = -nlevel
        ifact(4,nlevel) = iarc
        ifact(5,nlevel) = iarc

        ! add 0-contractions, if necessary
        ! I think it is needed here as we else miss disconnected
        ! terms ....
        call check_disconnected(contr_red)

        ! any contraction left?
        if (contr_red%narc.gt.0) then

          ! add 0-contractions, if necessary
          call form_fact_rec_new(mode,predef,nlevel+1,ifact,fl_pnt,
     &         cost,iscale,iitem,contr_red,occ_vtx_red,
     &                              irestr_vtx_red,info_vtx_red)

          if (ntest.ge.1000) then
            write(lulog,*) 'back in level ',nlevel
            write(lulog,*) ' current arc: ',iarc,narc
          end if

          ! reset intermediate counter
          idx_intm = 1 - nlevel

        else

          ! report, that we found at least one possible
          ! factorization
          found = .true.
          ! if we survived up to here, we are the current champion!
          costmin = cost
          iscalemin = iscale
          ifact_best(1:ld_inffac,1:nlevel) =
     &         ifact(1:ld_inffac,1:nlevel)
          nlevel_best = nlevel

          if (ntest.ge.1000) then
            write(lulog,*) 'currently best factorization:'
            write(lulog,'(x,i5,"*",i5,"->",i5,"(",i5,")")')
     &           ifact_best(1:4,1:nlevel_best)
            write(lulog,*) 'current costmin:',costmin
          end if

        end if

      end do

      if (ntest.ge.1000) then
        write(lulog,*) 'returning from level ',nlevel
      end if

      if (new) call dealloc_contr(contr_red)

      return

      end subroutine

      end