C                       LGEOM
C       28 APR 93  SP           Made portable for UNIX.  Changed code to use
C                               BYTE2INT AND INT2BYTE for converting
C                               between BYTE and INTEGER.  Gave control over
C                               progress messages to PRINT parameter.  Added
C                               PMEM parameter.  Changed call to STACKA so
C                               GDIR and BDIR allocated in one chunk to insure
C                               they are contiguous.
C	07 JUL 92  HJF		CORRECT ERROR WITH 'NOIN WHEN R = IRMAX+.5
C				PROGRAM WAS USING LINE IRMAX+1 WHICH WAS NOT
C				IN MEMORY. CHANGED GSUB, GSUBH, GSUB1, GSUBH1
C				ALSO, ADDED NOIZ OPTION TO NOT INTERPOLATE
C				WHEN DN IS ZERO.
C
C	05 APR 91  HJF		USE STACKA TO ALLOCATE SPACE TO AVOID
C				EXCEEDING PAGE FILE QUOTA FOR SMALL QUOTAS
C				AND ALLOW USE OF LARGER WORKING SETS AND
C				PICTURE SIZES
C
C	08 NOV 90  HJF		USE WORKING SET EXTENT TO ALLOCATE SPACE.
C				ONE PASS VERSION WHEN ENTIRE INPUT PICTURE
C				FITS IN MEMORY
C
C	31 OCT 90  HJF		KEEP TRACK OF IDS BLOCK NUMBERS IN MEMORY.
C				READ IDS IN FORWARD DIRECTION TO IMPROVE
C				EXECUTION TIME.
C
C      20 APR 90   ...SP...     INCREASED BUFFER SIZES TO ALLOW FOR LARGER
C                               IMAGES.  ADDED PRINT PARAMETER FOR PRINTING
C                               TIEPOINT VALUES AND PERIODIC PROGRESS MESSAGES.
C                               CHANGED FBI,CSD,PBN,MAXNB,NSAMP TO INTEGER*4.
C                               ADDED SOME FLOATs TO PREVENT INTEGER OVERFLOW.
C                               INCREASED NUMBER OF TIEPOINT RECTANGLES ALLOWED
C                               TO 40000.
C      14 OCT 88   ...SP...     CHANGED TO IGNORE FORMAT PARAMETER BECAUSE
C                               VICAR2 USES ONLY THE FORMAT IN LABEL.
C                               CHANGED GSUB AND GSUBH TO SET NEXSAM FALSE
C                               IF NSAMP LE 0 TO ALLOW MAPTRANS POLECASE TO
C                               WORK.
C      20 APR 88   ...SP...     CORRECTED ROUNDING FROM ADDING .5 TO USING NINT
C                               IN GSUBH.  THIS AFFECTS THE CASE OF NEGATIVE
C                               HALFWORD DNS.
C       1 SEP 87   ...SP...     CORRECTED CODE WHERE NSI USED INSTEAD OF NWI
C                               FOR NUMBER OF SAMPLES IN SUBROUTINE GSUBH.
C      31 JUL 87   ...FM...     MODIFIED HELP FILE TO GIVE CORRECT INFORMATION
C                               ABOUT PARAMETERS "PDS" AND "PARMS".
C      14 MAY 87   ...SP...     CORRECTED AN INFREQUENT ROUNDING PROBLEM IN
C                               GSUB AND GSUBH THAT LED TO AN OVERINDEXED ARRAY.
C                               (R WAS EQUAL TO RMAX AND RFRAC .GE. SMALL, BUT
C                                BIGBUF(IR+1) UNDEFINED.)
C                               ALSO CORRECTED CASE WHERE IP .EQ. NSI AND
C                               LBUF(INDEX+1) UNDEFINED.)
C      16 APR 87   ...SP...     CORRECTED THE COUNT OF RECTANGLES IN THE
C                               TIEPOINT GRID BY SUBTRACTING 1.  THIS WAS
C                               CAUSING VARIOUS ERRORS.
C      16 APR 86   ...SP...     CORRECTED HANDLING OF SS VALUE FOR HALFWORD.
C       1 APR 87   ...SP...     REDUCED SIZE OF IDS AND UPDATED HELP AS
C                               SUGGESTED BY LWK.
C      25 JAN 84   ...DFS...    FIX BOUNDARY CHECK WITH RER
C      16 JAN 84   ...DFS...	FIX NSI IN GSUBH
C      15 SEP 83   ...DFS...    CONVERT FOR USE ON VAX/VMS
C      12 APR 81   ...JBS...    CONVERT TO FIXED POINT INTENSITY INTERP
C      12 APR 81   ...JBS...    ALLOW NEGATIVE DN
C       8 OCT 80   ...JBS...    CORRECT RARE SPACE ALLOCATION PROBLEM
C       9 OCT 79   ...JBS...    ADD SAVE AREAS TO GSUB, GSUBH.  OVERLAY.
C      12 OCT 78   ...JBS...    ADD HALFWORD OPTION
C      27 JUN 75   ...DAH...    CHANGES FOR CONVERSION TO 360/OS
C      21 JUN 71     HJF31      VICAR 4-1
C       3 MAY 71     HJF31      REDUCE SIZE FOR RELEASE 7
C
C       THIS PROGRAM WILL REMOVE GEOMETRIC DISTORTION FROM RECORDED
C       PICTURES BASED ON USER INPUT DISPLACEMENT RECTANGLES
C
      PROGRAM LGEOM
C
C       MUST CONFORM TO "MAIN44" STANDARD
      INCLUDE 'VICMAIN_FOR'
C
C--BEGIN MAIN PROGRAM
C
      SUBROUTINE MAIN44

      IMPLICIT NONE
C
C       VARIABLES:
C
C	BLOCK KEEPS TRACK OF BLOCK NUMBER ON IDS
C	BIGBUF IS THE WORKING BUFFER, ALSO KNOWN AS LBUF AND I2BUF.
C	MAXBUF IS THE SIZE (IN BYTES) OF BIGBUF.
C	MAXP2 IS THE SIZE (IN BYTES) OF THE SECOND PASS BUFFER
C	FBI - FIRST BYTE INDEX
C	CSD - CURRENT STRING DISPLACEMENT
C	BBC - BUFFER BYTE COUNT
C	GDIR - GROUP DIRECTORY FOR BLOCKS ON IDS
C	BDIR - BLOCK DIRECTORY FOR GROUPS ON IDS
C	CNT - COUNT OF BLOCKS FOR EACH GROUP
C	LOC - CURRENT LOC FOR EACH GROUP
C
C	IN PASS 1, THE INPUT PICTURE IS READ AND STRINGS OF POINTS FOR THE
C	OUTPUT PICTURE ARE WRITTEN ON THE INTERMEDIATE DATASET (IDS).
C	THE GROUP NUMBER FOR EACH BLOCK ON THE IDS IS SAVED IN GDIR.
C	IN PASS 2, DATA FOR ONE GROUP OF LINES AT A TIME IS READ FROM THE
C	IDS AND WRITTEN TO THE OUTPUT DATASET.
C
C	AT THE END OF PASS 1, GDIR IS TRANSFORMED INTO BDIR SO PASS 2 KNOWS
C	WHICH BLOCKS BELONG TO EACH GROUP AND CAN READ THEM IN THE FORWARD
C	DIRECTION AND TAKE ADVANTAGE OF DISK BLOCKING.
C
C	IF THE ENTIRE PICTURE FITS IN MEMORY, LGEOM OPERATES IN A ONE-PASS
C	MODE AND THE IDS IS NOT USED.
C
C	INPUT,IDS,AND OUT ARE THE UNIT NUMBERS FOR VICAR2
C	V2UNITS KEEPS TRACK OF THE UNIT NUMBERS OF THE FILES
	INTEGER INPUT,IDS,OUT

	EXTERNAL LGM ! SUBROUTINE CALLED BY STACKA

      INTEGER MAXNBPAR,BUFLENPAR,COUNT,NAH,NAV,MAXREC
      PARAMETER (MAXNBPAR=1200)     ! MAXIMUM NUMBER OF BUFFERS FOR PASS 1.
      PARAMETER (BUFLENPAR=1000)    ! DEFAULT NS FOR IDS FILE.

	INTEGER*2 CNT(MAXNBPAR)
	INTEGER*4 LOC(MAXNBPAR)

      INTEGER MAXBUF,MAXP2,MAXTP,IUSE,IDEL,LPB,ILC,IMAX
      INTEGER IND,ILB
      INTEGER I,NSO,NSI
      INTEGER NB,K,K1,MEMSIZE
      REAL FSSI,FLNT
C
C--EQUIVALENT AREA
      INTEGER SLI,SSI,NLO,NBO,NLI,NBI
      INTEGER LOCAT(10)
C
      INTEGER CBBC,CCSD,CFBI,ICR,ISAMP,LD,MAXBBC,MAXB1
      INTEGER SC,BLOCK,BUFLEN,MAXCSD
      INTEGER B,FBI(MAXNBPAR), PIXSIZ
      INTEGER MAXNB,BBC(MAXNBPAR)
      LOGICAL HALFW,XVPTST,NOIN,NOIZ, PRINT
      REAL LARGE,SMALL,FLN,FSM,FSMT,RMIN
      REAL RMAX, RATIO
      INTEGER XVPIXSIZEU
      CHARACTER*8 FMT
      CHARACTER*256 IDSNAM
C
C--INCLUDE COMMON BLOCKS

      COMMON /V2UNITS/ INPUT,IDS,OUT

      COMMON/P1/ HALFW,NOIN,NOIZ,ILC,ILB,IUSE,IDEL,LPB,IMAX,NB,FSSI,FLNT

      COMMON /A1/ ICR,FLN,FSM,FSMT,LARGE,SMALL,
     .             RMIN,RMAX,CBBC,CCSD,CFBI,B,PRINT,
     .             SC,ISAMP,LD,BLOCK,BUFLEN,MAXBBC,MAXCSD,
     .             LOCAT,FBI,BBC,CNT,LOC
C
      EQUIVALENCE (SLI,LOCAT(1)),(SSI,LOCAT(2)),(NLO,LOCAT(3)),
     2            (NBO,LOCAT(4)),(NLI,LOCAT(5)),(NBI,LOCAT(6))
C
      DATA MAXNB/MAXNBPAR/
      DATA NOIN,NOIZ,HALFW /.FALSE.,.FALSE.,.FALSE./
      DATA LARGE,SMALL,BLOCK /0.99,0.01,0/

C--BEGIN EXECUTION

	PRINT = XVPTST( 'PRINT' ) ! PRINT TIEPOINTS AND PROGRESS MESSAGES

	CALL XVEACTION('SA',' ') ! SET XV ERROR ACTION
	CALL XVUNIT(INPUT,'INP',1,IND,' ')
	CALL XVOPEN(INPUT,IND,' ')
	CALL XVPARM('IDSNS',BUFLEN,I,K,0)
	BUFLEN=(BUFLEN/4)*4
	IF (BUFLEN .LT. 100) THEN
	  CALL XVMESSAGE('IDSNS too small, 1000 bytes used',' ')
	  BUFLEN = 1000
	ENDIF
C
C--Get the name and unit number of the IDS
	CALL XVPARM('IDSNAM',IDSNAM,I,K,0)
	CALL XVUNIT(IDS,'XX',1,IND,'U_NAME',IDSNAM,' ')

C--Get image size
      CALL XVSIZE(SLI,SSI,NLO,NSO,NLI,NSI)
      IF (NSO .GT. 32767)
     .     CALL MABEND( 'ERROR: NSO > 32767')

      CALL XVGET( INPUT, IND, 'FORMAT', FMT, ' ')
      IND = XVPIXSIZEU( PIXSIZ, FMT, INPUT)  !PIXEL SIZE IN BYTES

      IF ( PIXSIZ .NE. 1 .AND. PIXSIZ .NE. 2 )
     .     CALL MABEND('ERROR:INP. IMAGE IS NOT BYTE OR HALF FORMAT')
C
C--GET NUMBER OF BYTES PER LINE
      NBO = NSO*PIXSIZ
      NBI = NSI*PIXSIZ
C
C-- SET HALFWORD FLAG IF INPUT IS HALFWORD
      HALFW = PIXSIZ .EQ. 2
C
C--INDEX TO LBUF FOR BYTE 0 OF FIRST OF ILC INPUT LINES
      IUSE = 4*NLI
      IDEL = 4*((NBI+3)/4)

	CALL XVPCNT('INP',COUNT) ! FIND MAX # OF RECTANGLES
	IF(COUNT.EQ.2) THEN ! IF 2 INPUTS, LGEOM WAS CALLED FROM MAP2
	 MAXREC=401 ! ASSUME MAX OF 401 RECTANGLES FROM MAP2
	 MAXTP=441  ! AND MAX OF 441 TIEPOINTS
	ELSE
	 CALL XVP('NAH',NAH,COUNT)
         IF (COUNT .EQ. 0)        CALL MABEND('NAH not specified')
	 CALL XVP('NAV',NAV,COUNT)
         IF (COUNT .EQ. 0)        CALL MABEND('NAV not specified')
	 MAXREC=(NAV*NAH)+1 ! MAX # OF RECTANGLES
	 MAXTP=(NAH+1)*(NAV+1) ! MAX # OF TIEPOINTS
	ENDIF

        CALL GET_MEM_SIZE(MEMSIZE) ! GET PHYSICAL MEMORY SIZE
	MAXBUF = MEMSIZE-48*MAXREC ! SUBTRACT SIZE OF INCRMNTS ->SIZE OF BIGBUF
	MAXB1=4*NLI+IDEL*NLI+NBO ! MAXBUF FOR 1 PASS LGEOM
	IF(MAXBUF.GT.MAXB1) MAXBUF=MAXB1
	IF(MAXBUF.LT.150000) MAXBUF=150000
	IF(MAXBUF.LT.16*MAXTP) MAXBUF=16*MAXTP
C MAKE SURE BUF CAN HOLD THE TIEPOINTS

C
C   SEE IF WE CAN DO IT IN ONE PASS
C
	ILB=0 ! ASSUME 2 PASSES
	ILC=(MAXBUF-4*NLI-NBO)/IDEL
	IF(ILC.GE.NLI) THEN
	  ILB=4*NLI+IDEL*NLI+1
	  LPB=NLO
	  IMAX=IUSE+NLI*IDEL
	  CALL XVUNIT(OUT,'OUT',1,IND,' ')
	  CALL XVOPEN(OUT,IND,'OP','WRITE','U_NS',NSO,'U_NL',NLO,' ')
	  K=1 ! PROVIDE DUMMY NL FOR IDS
	  GOTO 120 ! WE CAN DO IT IN 1 PASS
	ENDIF
C
	MAXP2=MAXBUF+48*MAXREC ! USE BIGBUF + INCRMNTS IN SECOND PASS
50	LPB=(MAXP2-BUFLEN)/NBO ! LINES PER BUFFER
	NB=(NLO+LPB-1)/LPB ! NUMBER OF BUFFERS
	ILC=(MAXBUF-4*NLI-NB*BUFLEN)/IDEL ! INPUT LINES IN CORE
	IF(NB.LE.MAXNB.AND.ILC.GE.8) GOTO 100 ! IF OK, GOTO 100
	BUFLEN=BUFLEN-100 ! MAKE BUFLEN SMALLER
	IF(BUFLEN.GE.100) GOTO 50 ! IF BUFLEN OK, GO TRY THIS VALUE

	CALL TOOBIG ! EXPLAIN THIS IMAGE IS TOO BIG AND ABEND.

100	CONTINUE

C--CALCULATE NUMBER OF LINES NEEDED FOR IDS.
C  TOTAL SIZE OF IDS = RATIO * OUTPUT IMAGE, DEFAULT RATIO OF 2.0

	CALL XVP('RATIO',RATIO,COUNT)
	K=(RATIO*NBO*NLO)/BUFLEN ! EST # OF LINES IN IDS FOR GDIR-BDIR
	K1=(1.1*NBO*NLO)/BUFLEN ! ESTIMATE FOR DISK SIZE

C--OPEN IDS  (Note that since this is an intermediate data set that is written
C             and read and then deleted by the same program, we can assume that
C             it will be read on the same machine that writes it.  Thus it is
C             not a problem that lgeom mixes bytes and halfwords in this file.

      CALL XVOPEN(IDS,IND,'OP','WRITE','U_NS',BUFLEN,'U_NL',K1,
     2    'U_FORMAT','BYTE','O_FORMAT','BYTE',' ')

      IMAX=IUSE+(ILC-1)*IDEL
      FBI(1)=IMAX+IDEL+1
C--INDEX TO LBUF FOR BYTE 1 OF FIRST OF NB BUFFERS
      DO I = 2,NB
        FBI(I) = FBI(I-1)+BUFLEN
      END DO

      DO I = 1,NB
	BBC(I)=0
	CNT(I)=0
      END DO

      MAXBBC=BUFLEN-2
      MAXCSD=BUFLEN-12
120   FSSI=SSI   ! FLOATING TEST VALUES
      FLNT=SLI+NLO
      FSMT=SSI+NSO

	CALL STACKA(7,LGM,3,MAXBUF,48*MAXREC,6*K,MAXREC,K)
C USE STACKA TO ALLOCATE THE 3 BIG BUFFERS AND CALL LGM
	RETURN
	END

	SUBROUTINE LGM(LBUF,L1,INCRMNTS,L2,GDIR,L3,MAXREC,K)
	BYTE LBUF(L1)
	REAL INCRMNTS(12,MAXREC)
	INTEGER*2 GDIR(*)
C
        CALL CHECK_VMS_PAGE_FILE_QUOTA  ! DUMMY SUBROUTINE IF NOT VMS.

	CALL LGEM(LBUF,LBUF,LBUF,INCRMNTS,GDIR,GDIR,MAXREC,K)

C CALL LGEM TO DO THE WORK, PASSING LBUF 3 TIMES FOR THE EQUIVALENT
C BYTE, INTEGER*2 AND INTEGER*4 ARRAY, AND PASSING GDIR 2 TIMES.
C BDIR WILL BE PLACED RIGHT AFTER THE END OF THE GDIR THAT WAS
C ACTUALLY USED.  K IS THE ESTIMATED # OF BLOCKS ON IDS.  IF THE
C PAGE FILE QUOTA IS EXCEEDED, STACKA DOES NOT RETURN AN ERROR AND
C NO ERROR WILL OCCUR UNTIL THE UNAVAILABLE MEMORY IS ACTUALLY USED.
C THAT IS THE REASON FOR ONLY USING THE GDIR-BDIR SPACE THAT IS
C ACTUALLY REQUIRED AND POSSIBLY REQUESTING MORE THAN IS AVAILABLE.

	RETURN
	END

	SUBROUTINE LGEM(LBUF,I2BUF,BIGBUF,INCRMNTS,GDIR,BDIR,MAXREC,K)
	IMPLICIT NONE
	INTEGER MAXREC,K
	BYTE LBUF(*)
	INTEGER*2 I2BUF(*)
	INTEGER*4 BIGBUF(*)
	REAL INCRMNTS(12,MAXREC)
	INTEGER*2 GDIR(*)
	INTEGER*4 BDIR(*),BO

C	INPUT,IDS,AND OUT ARE THE UNIT NUMBERS FOR VICAR2
C	V2UNITS KEEPS TRACK OF THE UNIT NUMBERS OF THE FILES
	INTEGER INPUT,IDS,OUT
C
	INTEGER MAXNBPAR
	PARAMETER (MAXNBPAR=1200) ! MAXIMUM NUMBER OF BUFFERS FOR PASS 1.

	INTEGER*2 CNT(MAXNBPAR)
	INTEGER*4 LOC(MAXNBPAR)

      INTEGER IUSE,IDEL,LPB,ILC,IMAX
      INTEGER IRMIN,IR,IRMAX,INFORM,IFR,IND,ILB
      INTEGER I,ITEMP,NSO,NRECT
      INTEGER NB,LABREC
      REAL RLT,FSSI,FLNT
C
C--EQUIVALENT AREA
      INTEGER SLI,SSI,NLO,NBO,NLI,NBI
      INTEGER LOCAT(10)
C
      INTEGER CBBC,CCSD,CFBI,ICR,ISAMP,LD,MAXBBC
      INTEGER SC,BLOCK,BUFLEN,MAXCSD
      INTEGER B,FBI(MAXNBPAR)
      INTEGER BBC(MAXNBPAR)
      LOGICAL HALFW,DONE,NEXREC,XVPTST,NOIN,NOIZ, PRINT
      REAL LARGE,SMALL,FLN,FSM,FSMT,RMIN
      REAL RMAX
      CHARACTER*80 PBUF
C
C--INCLUDE COMMON BLOCK -- USED TO SEQUENCE BUFFERS

      COMMON /V2UNITS/ INPUT,IDS,OUT

      COMMON/P1/ HALFW,NOIN,NOIZ,ILC,ILB,IUSE,IDEL,LPB,IMAX,NB,FSSI,FLNT

      COMMON /A1/ ICR,FLN,FSM,FSMT,LARGE,SMALL,
     .             RMIN,RMAX,CBBC,CCSD,CFBI,B,PRINT,
     .             SC,ISAMP,LD,BLOCK,BUFLEN,MAXBBC,MAXCSD,
     .             LOCAT,FBI,BBC,CNT,LOC
C
      EQUIVALENCE (SLI,LOCAT(1)),(SSI,LOCAT(2)),(NLO,LOCAT(3)),
     2            (NBO,LOCAT(4)),(NLI,LOCAT(5)),(NBI,LOCAT(6))
C
C
C--Get tiepoints and fill array of INCRMNTS
      CALL GET_TIEPOINTS(BIGBUF,INCRMNTS,NRECT,PRINT)
      IF(NRECT.GT.MAXREC) CALL MABEND('TOO MANY RECTANGLES')
C
      IF (XVPTST('NOIN')) NOIN = .TRUE. 	! COULD ALREADY BE SET
      IF (XVPTST('NOIZ')) NOIZ = .TRUE.		! COULD ALREADY BE SET
      IF (NOIN) THEN
	  LARGE = 0.5
	  SMALL = 0.5
      ENDIF
C
      IRMIN=1
      IR=1
      IRMAX=ILC
C--BEGIN MAIN IRMIN LOOP
      DO WHILE (IRMIN.NE.NLI)
        IF (IRMAX.GT.NLI) IRMAX = NLI
C--BEGIN IR LOOP
        DO IR = IR,IRMAX
          BIGBUF(IR) = IUSE
C--STORE POINTER FOR NEW LINE
          ITEMP = IUSE+1
          IUSE = IUSE+IDEL
          IF (IUSE.GT.IMAX) IUSE = 4*NLI
	  CALL XVREAD(INPUT,LBUF(ITEMP),INFORM,'LINE',IR,' ')
C--END IR LOOP
        END DO
        IF (PRINT)  THEN
           WRITE (PBUF, 55) IRMIN, IRMAX
55         FORMAT('PROCESSING INPUT LINES',I6,' TO',I6)
           CALL XVMESSAGE( PBUF, ' ')
        END IF
C--DOUBLE CHECK FINAL VALUE OF IR FOR DIFFERENT COMPILERS
        IR = IRMAX+1
        RMIN = IRMIN-SMALL
        RMAX = IRMAX+SMALL
        ICR = 1
C--INDEX TO CURRENT RECTANGLE, ALSO USED TO START RECT SEARCH
        B = 1
        CFBI = FBI(1)
        CBBC = BBC(1)
        LD = 0
        FLN = SLI
        FSM = FSSI
C
C--FLN IS CURRENT LINE AND FSM IS CURRENT SAMPLE
C
C--BEGIN OUTER FLN LOOP
        DONE = .FALSE.
        DO WHILE (.NOT.DONE)
C--DONE INDICATES WHETHER ALL LINES AND ALL RECTANGLES HAVE BEEN DONE,
C--     INDICATED BY THE CONDITION (FLN.GE.FLNT)
C--NEXREC INDICATES WHETHER THERE ARE ANY MORE RECTANGLES ON THE CURRENT
C--       LINE TO BE PROCESSED.
          NEXREC = .TRUE.
C
C--SEARCH FOR RECTANGLE LINE FOR FLN
C--IF LAST LINE OF RECTANGLES, TERMINATE SEARCH
          DO WHILE ((FLN.GT.INCRMNTS(2,ICR)).AND.
     2              (INCRMNTS(2,ICR).NE.INCRMNTS(2,NRECT)))
            ICR = ICR+1
          END DO
C
C--SEARCH FOR RECTANGLE ON THIS LINE FOR FSM
C--IF LAST RECTANGLE ON LINE, TERMINATE SEARCH
          DO WHILE ((FSM.GT.INCRMNTS(4,ICR)).AND. ICR .LT. NRECT .AND.
     2              (INCRMNTS(2,ICR).EQ.INCRMNTS(2,ICR+1)))
            ICR = ICR+1
          END DO
C--SAVE INDEX TO FIRST RECT ON LINE
          IFR = ICR
          RLT = INCRMNTS(2,ICR)
C--STORE LAST LINE THAT USES THIS RECTANGLE
          IF (RLT.EQ.INCRMNTS(2,NRECT)) RLT = FLNT
C
C--BEGIN INNER FLN LOOP
          DO WHILE (NEXREC.AND.(.NOT.DONE))
	   IF(ILB.NE.0) THEN ! IF ONE-PASS
	    IF (HALFW) THEN
		CALL GSUBH1(INCRMNTS,LBUF(ILB),LBUF,I2BUF,BIGBUF)
	      ELSE
		CALL GSUB1(INCRMNTS,LBUF(ILB),LBUF,I2BUF,BIGBUF)
	    ENDIF

	  ELSE

            IF (HALFW) THEN
                CALL GSUBH(INCRMNTS,GDIR,LBUF,I2BUF,BIGBUF,K)
              ELSE
                CALL GSUB(INCRMNTS,GDIR,LBUF,I2BUF,BIGBUF,K)
            END IF
            BBC(B) = CBBC

	  ENDIF

            FLN = FLN+1
C--CHECK FOR ALL LINES DONE
            IF (FLN.GE.FLNT) THEN
                DONE = .TRUE.
              ELSE
C--STEP LINE DISPLACEMENT
                LD = LD+1
C--CHECK FOR ALL LINES IN THIS BUFFER DONE
                IF (LD.GE.LPB) THEN
                  LD = 0
                  B = B+1
                  CFBI = FBI(B)
                  CBBC = BBC(B)
                END IF
                FSM = FSSI

                IF (FLN.GT.RLT) THEN
                    NEXREC = .FALSE.
                  ELSE
                    ICR = IFR
                END IF
            END IF
C--END INNER FLN LOOP
          END DO
C--END OUTER FLN LOOP
        END DO
        IRMIN = IRMAX
        IRMAX = IRMIN+ILC-1
        IR = IRMIN+1
C--END MAIN IRMIN LOOP
      END DO

	IF(ILB.NE.0) THEN ! IF ONE PASS
	  CALL XVCLOSE(OUT,IND,' ')
	  RETURN
	ENDIF

      DO B = 1,NB
        IF (BBC(B).NE.0) THEN
          ITEMP  =  (FBI(B)+1)/2
          I2BUF((BBC(B)+1)/2+ITEMP) = 0
	  CALL XVWRIT(IDS,LBUF(FBI(B)),IND,' ')
          BLOCK = BLOCK+1
	  IF(BLOCK.GT.K) CALL MABEND('IDS_NL OVFLO, INCREASE RATIO')
	  CNT(B)=CNT(B)+1
	  GDIR(BLOCK)=B
        END IF
      END DO
C
C--UPDATE NL IN LABEL
      CALL XLDEL(IDS,'SYSTEM','NL',IND,' ')
      CALL XLADD(IDS,'SYSTEM','NL',BLOCK,IND,'FORMAT','INT',' ')
C
      CALL XVCLOSE(IDS,IND,' ')
      CALL XVCLOSE(INPUT,IND,' ')
      CALL XVOPEN(IDS,IND,' ')
      CALL XVUNIT(OUT,'OUT',1,IND,' ')
      CALL XVOPEN(OUT,IND,'OP','WRITE','U_NS',NSO,'U_NL',NLO,' ')
C
C--CONVERT GDIR TABLE TO BDIR TABLE FOR PASS 2
	LOC(1)=0
	DO 500 I=2,NB
500	LOC(I)=LOC(I-1)+CNT(I-1) ! SET UP LOC TABLE
	BO=(BLOCK+1)/2 ! OFFSET FOR BDIR TO PUT IT RIGHT AFTER GDIR
	DO 600 I=1,BLOCK
	B=GDIR(I)
	LOC(B)=LOC(B)+1
600	BDIR(LOC(B)+BO)=I ! STORE BLOCK # IN BDIR
C
C--CALL IN SECOND PASS TO READ INTERMEDIATE DISK AND WRITE OUTPUT
      CALL LGP2(LABREC,NB,BUFLEN,NLO,NBO,LPB,CNT,BDIR(BO+1),LBUF,I2BUF,
     .          PRINT)
      CALL XVCLOSE(IDS,IND,'CLOS_ACT','DELETE',' ')
      CALL XVCLOSE(OUT,IND,' ')
      RETURN
C--END OF MAIN44 (MAIN BODY OF LGEOM)
      END
C
C                       GSUB
C
C       SUBROUTINE TO PROCESS ONE LINE OF BYTE DATA FOR LGEOM
C
      SUBROUTINE GSUB(INCRMNTS,GDIR,LBUF,I2BUF,BIGBUF,K)
C
C       NOTE:
C               IN THE COMMENTS, VERTICAL REFERS TO LINE POSITION
C               WHEN IT IS A REAL NUMBER, AND HORIZONTAL REFERS TO
C               SAMPLE POSITION WHEN IT IS A REAL NUMBER.
C
C               COORDINATE PAIRS ARE GIVEN WITH THE VERTICAL COORDINATE
C               FIRST.
C
C       METHOD:
C
C               EACH OUTPUT POINT IS USED TO GENERATE A COORDINATE IN THE
C               INPUT FILE FOR A DATA POINT, HERE DENOTED BY (R,P), WHERE
C               R IS THE LINE NUMBER AND P IS THE SAMPLE NUMBER.    IF
C               INTERPOLATION IS ACTIVE, THE POINT IS INTERPOLATED USING
C               ITS FOUR NEAREST NEIGHBORS AS FOLLOWS.
C
C               VAL1    TRY1                    VAL2
C                *       *                       *
C              (IR,IP)                         (IR,IP+1)
C
C
C                      (R,P)
C                        *
C
C
C              (IR+1,IP)                      (IR+1,IP+1)
C                *       *                       *
C               VAL3    TRY2                    VAL4
C
C
C               FIRST VAL1 AND VAL2 ARE INTERPOLATED SO THAT
C                       TRY1 = VAL1+(P-IP)*(VAL2-VAL1)
C
C               TRY2 IS THEN INTERPOLATED SIMILARLY USING VAL3 AND VAL4,
C               AND THEN A VALUE FOR POINT (R,P) IS INTERPOLATED FROM
C               TRY1 AND TRY2.
C
C
C--ALL VARIABLES MUST BE EXPLICITLY TYPED
      IMPLICIT NONE

      include 'fortport'  ! DEFINES INT2BYTE AND BYTE2INT CONVERSIONS.

C--PASSED VARIABLES
C
C       INCRMNTS    -- ARRAY CONTAINING INFORMATION OF RECTANGLES
C
        INTEGER*2 I2BUF(*)
        BYTE LBUF(*)
	REAL INCRMNTS(12,*)
	INTEGER*2 GDIR(*)
C
C--LOCAL VARIABLES
C
C       DELP   -- CHANGE IN HORIZONTAL POSITION PER UNIT CHANGE IN VERTICAL
C                 POSITION.
C       DELR   -- CHANGE IN VERTICAL POSITION PER UNIT CHANGE IN HORIZONTAL
C                 POSITION.
C       ICR    -- INDEX TO FIRST DIMENSION OF INCRMNTS ARRAY (Index to Current
C                 Rectangle)
C	IDS    -- UNIT NUMBER OF INTERMEDIATE DATA SET
C       INDEX  -- TEMPORARY VARIABLE FOR ARRAY INDEXING
C       IP     -- INTEGER VALUE OF P
C       IR     -- INTEGER VALUE OF R
C       ITEMP  -- INTEGER TEMPORARY VARIABLE
C       ITEMP2 -- SECOND INTEGER TEMP.
C       NEXSAM -- FLAG TO INDICATE WHETHER THERE ARE MORE SAMPLES TO BE
C                 PROCESSED ON THE CURRENT LINE
C       NSAMP  -- NUMBER OF SAMPLES LEFT TO PROCESS
C       P      -- HORIZONTAL POSITION OF CURRENT POINT IN INPUT FILE.
C       PFRAC  -- FRACTIONAL PART OF P
C       POINT  -- PIXEL VALUE OF INTERPOLATED POINT (R,P) IN INPUT FILE
C       R      -- VERTICAL POSITION OF CURRENT POINT IN INPUT FILE
C       RER    -- FINAL VALUE OF R FOR CURRENT PASS
C       RFRAC  -- FRACTIONAL PART OF R
C       TEMP   -- REAL TEMPORARY VARIABLE
C       VAL1   -- VALUE OF POINT (IR,IP) OF INPUT PICTURE
C       VAL2   -- SAME FOR (IR,IP+1)
C       VAL3   -- SAME FOR (IR+1,IP)
C       VAL4   -- SAME FOR (IR+1,IP+1)
C	V2UNITS KEEPS TRACK OF THE UNIT NUMBERS OF THE FILES
      INTEGER INPUT,IDS,OUT
      COMMON /V2UNITS/ INPUT,IDS,OUT

      LOGICAL HALFW,NOIN,NOIZ
      INTEGER DUMMY !DUMMY ARRAY USED TO PREVENT WARNINGS FROM COMPILERS THAT
                    !WANT ALL OCCURRENCES OF A COMMON BLOCK TO HAVE SAME SIXE.
      COMMON /P1/ HALFW,NOIN,NOIZ,DUMMY(9)
      INTEGER NSAMP,IR,IP,ITEMP,ITEMP2,INDEX,LD,K
      INTEGER VAL1,VAL2,VAL3,VAL4,POINT,SAMP,HFBI,HBBC,HCSD
      REAL RER,R,P,DELR,DELP,TEMP,RFRAC,PFRAC,TEMP2,INZ
      LOGICAL NEXSAM, PRINT
C
C--INCLUDE COMMON BLOCK
      INTEGER ICR,CBBC,CCSD,CFBI,B,SC,ISAMP,BLOCK
      INTEGER BUFLEN,MAXBBC,MAXCSD,LOCAT(10),BIGBUF(*)
      REAL FLN,FSM,FSMT,LARGE,SMALL,RMIN,RMAX
      INTEGER MAXNBPAR
      PARAMETER (MAXNBPAR=1200)     ! MAXIMUM NUMBER OF BUFFERS FOR PASS 1.

	INTEGER*2 CNT(MAXNBPAR)
	INTEGER   LOC(MAXNBPAR),FBI(MAXNBPAR),BBC(MAXNBPAR)
C
C--VARIABLES EQUIVALENCED INTO COMMON BLOCK
      INTEGER SLI,SSI,NLO,NSO,NLI,NSI
C

      COMMON /A1/ ICR,FLN,FSM,FSMT,LARGE,SMALL,
     .             RMIN,RMAX,CBBC,CCSD,CFBI,B,PRINT,
     .             SC,ISAMP,LD,BLOCK,BUFLEN,MAXBBC,MAXCSD,
     .             LOCAT,FBI,BBC,CNT,LOC
C
      EQUIVALENCE (SLI,LOCAT(1)),(SSI,LOCAT(2)),(NLO,LOCAT(3)),
     2            (NSO,LOCAT(4)),(NLI,LOCAT(5)),(NSI,LOCAT(6))
C
C--BEGIN EXECUTION
C
C--INITIALIZE FOR FIRST RUN
      SC = 0
      SAMP = 0
      HFBI = (CFBI+1)/2
      HBBC = CBBC/2
      HCSD = CCSD/2
C
C--BEGIN MAIN RECTANGLE PROCESSING LOOP
      DO WHILE (SAMP.LT.NSO)
C
C--DETERMINE COORDINATE IN INPUT FILE OF CURRENT POINT
        ITEMP = FLN-INCRMNTS(1,ICR)
        DELR = INCRMNTS(12,ICR)+ITEMP*INCRMNTS(11,ICR)
        DELP = INCRMNTS(7,ICR)+ITEMP*INCRMNTS(8,ICR)
        ITEMP2 = FSM-INCRMNTS(3,ICR)
        P = INCRMNTS(5,ICR)+ITEMP*INCRMNTS(9,ICR)+DELP*ITEMP2
        R = INCRMNTS(6,ICR)+ITEMP2*INCRMNTS(12,ICR)+ITEMP*
     2      (INCRMNTS(10,ICR)+ITEMP2*INCRMNTS(11,ICR))
        ITEMP = INCRMNTS(4,ICR)
        IF ((INCRMNTS(2,ICR).NE.INCRMNTS(2,ICR+1)).OR.(ITEMP.GT.FSMT))
     2       ITEMP = FSMT
C
        RER = (ITEMP-FSM)*DELR+R
        NSAMP = ITEMP-FSM
        FSM = ITEMP
        ISAMP = SAMP+NSAMP
C
        NEXSAM = .TRUE.
        IF (NSAMP .LE. 0)  NEXSAM = .FALSE.       ! ADDED FOR MAPTRANS.
C
C--BEGIN SAMPLE PROCESSING LOOP
        DO WHILE (NEXSAM)
C
C--BEGIN MAIN IF BLOCK
          IF (R.LT.RMIN) THEN
              IF (RER.LT.RMIN) THEN
                  SAMP = ISAMP
                  NEXSAM = .FALSE.
                ELSE
                  SAMP = SAMP+1
                  R = R+DELR
                  P = P+DELP
                  NSAMP = NSAMP-1
              END IF
              IF (SC.NE.0) THEN
                I2BUF(HFBI+HCSD) = SC
                SC = 0
              END IF
            ELSE IF (R.GE.RMAX) THEN	! CHANGED .GT. TO .GE.		HJF
              IF (RER.GE.RMAX) THEN
                  SAMP = ISAMP
                  NEXSAM = .FALSE.
                ELSE
                  SAMP = SAMP+1
                  R = R+DELR
                  P = P+DELP
                  NSAMP = NSAMP-1
              END IF
              IF (SC.NE.0) THEN
                I2BUF(HFBI+HCSD) = SC
                SC = 0
              END IF
            ELSE
              IR = R
              RFRAC = R-IR
              IP = P
              PFRAC = P-IP
C
C--CHECK FOR POINTS OUTSIDE OF BOUNDARY
              IF ((P.LT.0).OR.
     2           ((IP.EQ.0).AND.(PFRAC.LE.LARGE)).OR.
     3            (IP.GT.NSI).OR.
     4           ((IP.EQ.NSI).AND.(PFRAC.GE.SMALL))) THEN
C
C--CURRENT POINT NO GOOD
                  IF (SC.NE.0) THEN
                    I2BUF(HFBI+HCSD) = SC
                    SC = 0
                  END IF
                ELSE
C
C--POINT IS WITHIN BOUNDARIES
                  IF ((RFRAC.GE.SMALL).AND.(RFRAC.LT.LARGE) .AND.
     .                (RMAX .GE. IR+1)                          )  THEN
                      INDEX = BIGBUF(IR)+IP
                      VAL1 = BYTE2INT( LBUF(INDEX) )
                      IF (IP .EQ. NSI) THEN
                        VAL2 = VAL1
                      ELSE
                        VAL2 = BYTE2INT( LBUF(INDEX+1) )
                      END IF
                      INDEX = IP+BIGBUF(IR+1)
                      VAL3   = BYTE2INT( LBUF(INDEX) )
                      IF (IP .EQ. NSI) THEN
                        VAL4 = VAL3
                      ELSE
                        VAL4 = BYTE2INT( LBUF(INDEX+1) )
                      END IF
		      IF(NOIZ) THEN
			TEMP = INZ(FLOAT(VAL1),FLOAT(VAL2),PFRAC)
			TEMP2 = INZ(FLOAT(VAL3),FLOAT(VAL4),PFRAC)
			POINT = INZ(TEMP,TEMP2,RFRAC)+0.5
		      ELSE
                      	TEMP = FLOAT(VAL1)+PFRAC*(VAL2-VAL1)
                      	TEMP2 = FLOAT(VAL3)+PFRAC*(VAL4-VAL3)
                      	POINT = TEMP+RFRAC*(TEMP2-TEMP)+0.5
		      ENDIF
                    ELSE
                      IF (RFRAC.GE.LARGE) IR = IR+1
                      INDEX = IP+BIGBUF(IR)
                      VAL1 = BYTE2INT( LBUF(INDEX) )
                      POINT = VAL1
                      IF (PFRAC.GE.SMALL) THEN
                        VAL2 = BYTE2INT( LBUF(INDEX+1) )
                        POINT = VAL2
                        IF (PFRAC.LE.LARGE) THEN
			  IF(NOIZ) THEN
			   POINT = INZ(FLOAT(VAL1),FLOAT(VAL2),PFRAC)+.5
			  ELSE
                           POINT = FLOAT(VAL1)+PFRAC*(VAL2-VAL1)+0.5
			  ENDIF
                        END IF
                      END IF
                  END IF
                  IF ((SC.NE.0).AND.(CBBC.GE.MAXBBC)) THEN
                    I2BUF(HFBI+HCSD) = SC
                    SC = 0
                  END IF
                  IF (SC.EQ.0) THEN
C
C--FORCE CBBC TO BE A MULTIPLE OF TWO
                      IF ( MOD(CBBC,2) .EQ. 1) CBBC = CBBC+1
                      HBBC = CBBC/2
                      IF (CBBC.GE.MAXCSD) THEN
C--ZERO LAST STRING COUNT IN BUFFER
                        I2BUF(HFBI+HBBC) = 0
                        CBBC = 0
                        HBBC = 0
			CALL XVWRIT(IDS,LBUF(CFBI),ITEMP,' ')
                        BLOCK = BLOCK+1
		        IF(BLOCK.GT.K) GOTO 900
			CNT(B)=CNT(B)+1 ! ADD TO COUNT FOR THIS GROUP
			GDIR(BLOCK)=B ! SAVE GROUP # FOR THIS BLOCK
                      END IF
                      CCSD = CBBC
                      HCSD = HBBC
                      SC = 1
                      INDEX = HFBI+HBBC
C--STORE LINE DISPLACEMENT
                      I2BUF(INDEX+1) = LD
C--STORE SAMPLE DISPLACEMENT
                      I2BUF(INDEX+2) = SAMP
C--STORE FIRST DATA POINT IN STRING
                      LBUF(CFBI+CBBC+6) = INT2BYTE(POINT)
                      CBBC = CBBC+7
                    ELSE
                      SC = SC+1
                      LBUF(CFBI+CBBC) =  INT2BYTE(POINT)
                      CBBC = CBBC+1
                  END IF
C
C--END BOUNDARY CHECKING IF BLOCK
              END IF
C
C--PREPARE FOR NEXT SAMPLE IN RECTANGLE
              SAMP = SAMP+1
              R = R+DELR
              P = P+DELP
              NSAMP = NSAMP-1
C
C--END MAIN IF BLOCK
          END IF
          IF (NSAMP.EQ.0) NEXSAM = .FALSE.
C
C--END SAMPLE PROCESSING LOOP
        END DO
C
C--NEXT RECTANGLE
        ICR = ICR+1
C
C--END MAIN RECTANGLE PROCESSING LOOP
      END DO
      IF (SC.NE.0) THEN
        I2BUF(HFBI+HCSD) = SC
      END IF
      RETURN
C
900	CALL MABEND('IDS_NL OVFLO, INCREASE RATIO')
C--END OF SUBROUTINE GSUB
      END
C
C                       GSUBH
C
C       SUBROUTINE TO PROCESS ONE LINE OF HALFWORD DATA FOR LGEOM
C
C       IDENTICAL TO GSUB EXCEPT FOR INDEXING OF ARRAYS AND LENGTH
C       OF DATA (HALFWORD INSTEAD OF BYTE)
C
      SUBROUTINE GSUBH(INCRMNTS,GDIR,LBUF,I2BUF,BIGBUF,K)
C
C--ALL VARIABLES MUST BE EXPLICITLY TYPED
      IMPLICIT NONE

C
C--PASSED VARIABLES
C
        INTEGER*2 I2BUF(*)
        BYTE LBUF(*)
	REAL INCRMNTS(12,*)
	INTEGER*2 GDIR(*)
C
C--LOCAL VARIABLES
C
C       DELP   -- CHANGE IN HORIZONTAL POSITION PER UNIT CHANGE IN VERTICAL
C                 POSITION.
C       DELR   -- CHANGE IN VERTICAL POSITION PER UNIT CHANGE IN HORIZONTAL
C                 POSITION.
C       ICR    -- INDEX TO FIRST DIMENSION OF INCRMNTS ARRAY (Index to Current
C                 Rectangle)
C	IDS    -- UNIT NUMBER OF INTERMEDIATE DATA SET
C       INDEX  -- TEMPORARY VARIABLE FOR ARRAY INDEXING
C       IP     -- INTEGER VALUE OF P
C       IR     -- INTEGER VALUE OF R
C       ITEMP  -- INTEGER TEMPORARY VARIABLE
C       ITEMP2 -- SECOND INTEGER TEMP.
C       NEXSAM -- FLAG TO INDICATE WHETHER THERE ARE MORE SAMPLES TO BE
C                 PROCESSED ON THE CURRENT LINE
C       NSAMP  -- NUMBER OF SAMPLES LEFT TO PROCESS
C	NWI    -- LOCAL VERSION OF NSI (NUMBER SAMPLES IN).  NOTE THAT NSI IN
C                 GSUBH IS THE SAME AS NBI IN MAIN44 BECAUSE OF THE WAY THAT
C                 THE COMMON BLOCK IS SET UP.
C       P      -- HORIZONTAL POSITION OF CURRENT POINT IN INPUT FILE.
C       PFRAC  -- FRACTIONAL PART OF P
C       POINT  -- PIXEL VALUE OF INTERPOLATED POINT (R,P) IN INPUT FILE
C       R      -- VERTICAL POSITION OF CURRENT POINT IN INPUT FILE
C       RER    -- FINAL VALUE OF R FOR CURRENT PASS
C       RFRAC  -- FRACTIONAL PART OF R
C       TEMP   -- REAL TEMPORARY VARIABLE
C       VAL1   -- VALUE OF POINT (IR,IP) OF INPUT PICTURE
C       VAL2   -- SAME FOR (IR,IP+1)
C       VAL3   -- SAME FOR (IR+1,IP)
C       VAL4   -- SAME FOR (IR+1,IP+1)
C	V2UNITS KEEPS TRACK OF THE UNIT NUMBERS OF THE FILES
      INTEGER INPUT,IDS,OUT
      COMMON /V2UNITS/ INPUT,IDS,OUT
      LOGICAL HALFW,NOIN,NOIZ
      INTEGER DUMMY !DUMMY ARRAY USED TO PREVENT WARNINGS FROM COMPILERS THAT
                    !WANT ALL OCCURRENCES OF A COMMON BLOCK TO HAVE SAME SIXE.
      COMMON /P1/ HALFW,NOIN,NOIZ,DUMMY(9)
      INTEGER NSAMP,IR,IP,ITEMP,ITEMP2,INDEX,LD,SAMP,HFBI,CSD,HBBC,NWI
      REAL RER,R,P,DELR,DELP,TEMP,RFRAC,PFRAC,VAL1,VAL2,VAL3
      REAL VAL4,TEMP2,POINT,INZ
      LOGICAL NEXSAM, PRINT
C--INCLUDE COMMON BLOCK
      INTEGER ICR,CBBC,CCSD,CFBI,B,SC,ISAMP,BLOCK,K
      INTEGER BUFLEN,MAXBBC,MAXCSD,LOCAT(10),BIGBUF(*)
      REAL FLN,FSM,FSMT,LARGE,SMALL,RMIN,RMAX
      INTEGER MAXNBPAR
      PARAMETER (MAXNBPAR=1200)     ! MAXIMUM NUMBER OF BUFFERS FOR PASS 1.

	INTEGER*2 CNT(MAXNBPAR)
	INTEGER   LOC(MAXNBPAR),FBI(MAXNBPAR),BBC(MAXNBPAR)
C
C--VARIABLES EQUIVALENCED INTO COMMON BLOCK
      INTEGER SLI,SSI,NLO,NSO,NLI,NSI
C
      COMMON /A1/ ICR,FLN,FSM,FSMT,LARGE,SMALL,
     .             RMIN,RMAX,CBBC,CCSD,CFBI,B,PRINT,
     .             SC,ISAMP,LD,BLOCK,BUFLEN,MAXBBC,MAXCSD,
     .             LOCAT,FBI,BBC,CNT,LOC
C
      EQUIVALENCE (SLI,LOCAT(1)),(SSI,LOCAT(2)),(NLO,LOCAT(3)),
     2            (NSO,LOCAT(4)),(NLI,LOCAT(5)),(NSI,LOCAT(6))
C
C--BEGIN EXECUTION
C
C--INITIALIZE FOR FIRST RUN
      SC = 0
      SAMP = 0
      NWI = NSI/2
      HFBI = (CFBI+1)/2
      CSD = CCSD/2
      HBBC = CBBC/2
C
C--BEGIN MAIN RECTANGLE PROCESSING LOOP
      DO WHILE (SAMP.LT.NSO)
C
C--DETERMINE COORDINATE IN INPUT FILE OF CURRENT POINT
        ITEMP = FLN-INCRMNTS(1,ICR)
        DELR = INCRMNTS(12,ICR)+ITEMP*INCRMNTS(11,ICR)
        DELP = INCRMNTS(7,ICR)+ITEMP*INCRMNTS(8,ICR)
        ITEMP2 = FSM-INCRMNTS(3,ICR)
        P = INCRMNTS(5,ICR)+ITEMP*INCRMNTS(9,ICR)+DELP*ITEMP2
        R = INCRMNTS(6,ICR)+ITEMP2*INCRMNTS(12,ICR)+ITEMP*
     2      (INCRMNTS(10,ICR)+ITEMP2*INCRMNTS(11,ICR))
        ITEMP = INCRMNTS(4,ICR)
        IF ((INCRMNTS(2,ICR).NE.INCRMNTS(2,ICR+1)).OR.(ITEMP.GT.FSMT))
     2       ITEMP = FSMT
C
        RER = (ITEMP-FSM)*DELR+R
        NSAMP = ITEMP-FSM
        FSM = ITEMP
        NSAMP = NSAMP*2
        ISAMP = SAMP+NSAMP
C
        NEXSAM = .TRUE.
        IF (NSAMP .LE. 0)  NEXSAM = .FALSE.       ! ADDED FOR MAPTRANS.
C
C--BEGIN SAMPLE PROCESSING LOOP
        DO WHILE (NEXSAM)
C
C--BEGIN MAIN IF BLOCK
          IF (R.LT.RMIN) THEN
              IF (RER.LT.RMIN) THEN
                  SAMP = ISAMP
                  NEXSAM = .FALSE.
                ELSE
                  SAMP = SAMP+2
                  R = R+DELR
                  P = P+DELP
                  NSAMP = NSAMP-2
              END IF
              IF (SC.NE.0) THEN
                I2BUF(HFBI+CSD) = SC
                SC = 0
              END IF
            ELSE IF (R.GE.RMAX) THEN
              IF (RER.GE.RMAX) THEN
                  SAMP = ISAMP
                  NEXSAM = .FALSE.
                ELSE
                  SAMP = SAMP+2
                  R = R+DELR
                  P = P+DELP
                  NSAMP = NSAMP-2
              END IF
              IF (SC.NE.0) THEN
                I2BUF(HFBI+CSD) = SC
                SC = 0
              END IF
            ELSE
              IR = R
              RFRAC = R-IR
              IP = P
              PFRAC = P-IP
C
C--CHECK FOR POINTS OUTSIDE OF BOUNDARY
              IF ((P.LT.0).OR.
     2           ((IP.EQ.0).AND.(PFRAC.LE.LARGE)).OR.
     3            (IP.GT.NWI).OR.
     4           ((IP.EQ.NWI).AND.(PFRAC.GE.SMALL))) THEN
C
C--CURRENT POINT NO GOOD
                  IF (SC.NE.0) THEN
                    I2BUF(HFBI+CSD) = SC
                    SC = 0
                  END IF
                ELSE
C
C--POINT IS WITHIN BOUNDARIES
                  IF ((RFRAC.GE.SMALL).AND.(RFRAC.LT.LARGE) .AND.
     .                (RMAX .GE. IR+1)                          )  THEN
                      INDEX = (BIGBUF(IR)+1)/2+IP
                      VAL1 = I2BUF(INDEX)
                      IF (IP .EQ. NWI) THEN
                        VAL2 = VAL1
                      ELSE
                        VAL2 = I2BUF(INDEX+1)
                      END IF
                      INDEX = IP+(BIGBUF(IR+1)+1)/2
                      VAL3 = I2BUF(INDEX)
                      IF (IP .EQ. NWI) THEN
                        VAL4 = VAL3
                      ELSE
                        VAL4 = I2BUF(INDEX+1)
                      END IF
		      IF(NOIZ) THEN
			TEMP = INZ(VAL1,VAL2,PFRAC)
			TEMP2 = INZ(VAL3,VAL4,PFRAC)
			POINT = INZ(TEMP,TEMP2,RFRAC)
		      ELSE
                      	TEMP = VAL1+PFRAC*(VAL2-VAL1)
                      	TEMP2 = VAL3+PFRAC*(VAL4-VAL3)
                      	POINT = TEMP+RFRAC*(TEMP2-TEMP)
		      ENDIF
                    ELSE
                      IF (RFRAC.GE.LARGE) IR = IR+1
                      INDEX = IP+(BIGBUF(IR)+1)/2
                      POINT = I2BUF(INDEX)
                      IF (PFRAC.GE.SMALL) THEN
                        VAL1 = POINT
                        POINT = I2BUF(INDEX+1)
                        IF (PFRAC.LE.LARGE) THEN
                          VAL2 = POINT
			  IF(NOIZ) THEN
			    POINT = INZ(VAL1,VAL2,PFRAC)
			  ELSE
                            POINT = VAL1+PFRAC*(VAL2-VAL1)
			  ENDIF
                        END IF
                      END IF
                  END IF
                  IF ((SC.NE.0).AND.(HBBC.GE.MAXBBC/2)) THEN
                    I2BUF(HFBI+CSD) = SC
                    SC = 0
                  END IF
                  IF (SC.EQ.0) THEN
                      IF (HBBC.GE.MAXCSD/2) THEN
C--ZERO LAST STRING COUNT IN BUFFER
                        I2BUF(HFBI+HBBC) = 0
                        HBBC = 0
			CALL XVWRIT(IDS,LBUF(HFBI*2-1),ITEMP,' ')
                        BLOCK = BLOCK+1
		        IF(BLOCK.GT.K) GOTO 900
                        CNT(B)=CNT(B)+1
			GDIR(BLOCK)=B
                      END IF
                      CSD = HBBC
                      SC = 2
                      INDEX = HFBI+HBBC
C--STORE LINE DISPLACEMENT
                      I2BUF(INDEX+1) = LD
C--STORE SAMPLE DISPLACEMENT
                      I2BUF(INDEX+2) = SAMP
C--STORE FIRST DATA POINT IN STRING
                      I2BUF(INDEX+3) = NINT( POINT )
                      HBBC = HBBC+4
                    ELSE
                      SC = SC+2
                      INDEX = HFBI+HBBC
                      I2BUF(INDEX) = NINT( POINT )
                      HBBC = HBBC+1
                  END IF
C
C--END BOUNDARY CHECKING IF BLOCK
              END IF
C
C--PREPARE FOR NEXT SAMPLE IN RECTANGLE
              SAMP = SAMP+2
              R = R+DELR
              P = P+DELP
              NSAMP = NSAMP-2
C
C--END MAIN IF BLOCK
          END IF
          IF (NSAMP.EQ.0) NEXSAM = .FALSE.
C
C--END SAMPLE PROCESSING LOOP
        END DO
C
C--NEXT RECTANGLE
        ICR = ICR+1
C
C--END MAIN RECTANGLE PROCESSING LOOP
      END DO
      IF (SC.NE.0) THEN
        I2BUF(HFBI+CSD) = SC
      END IF
      CFBI = HFBI*2-1
      CBBC = HBBC*2
      CCSD = CSD*2
      RETURN
C
900	CALL MABEND('IDS_NL OVFLO, INCREASE RATIO')
C--END OF SUBROUTINE GSUBH
      END
C
C                       GSUB1
C
C       SUBROUTINE TO PROCESS ONE LINE OF BYTE DATA FOR LGEOM (1 PASS)
C
      SUBROUTINE GSUB1(INCRMNTS,LINBUF,LBUF,I2BUF,BIGBUF)
C
C--ALL VARIABLES MUST BE EXPLICITLY TYPED
      IMPLICIT NONE

      include 'fortport'  ! DEFINES INT2BYTE AND BYTE2INT CONVERSIONS.

C
C--PASSED VARIABLES
C
C       INCRMNTS    -- ARRAY CONTAINING INFORMATION ON RECTANGLES
C
        INTEGER*2 I2BUF(*)
        BYTE LBUF(*)
	REAL INCRMNTS(12,*)
	BYTE LINBUF(*)
C
C--LOCAL VARIABLES
C
C       DELP   -- CHANGE IN HORIZONTAL POSITION PER UNIT CHANGE IN VERTICAL
C                 POSITION.
C       DELR   -- CHANGE IN VERTICAL POSITION PER UNIT CHANGE IN HORIZONTAL
C                 POSITION.
C       ICR    -- INDEX TO FIRST DIMENSION OF INCRMNTS ARRAY (Index to Current
C                 Rectangle)
C	OUT    -- UNIT NUMBER OF OUTPUT DATA SET
C       INDEX  -- TEMPORARY VARIABLE FOR ARRAY INDEXING
C       IP     -- INTEGER VALUE OF P
C       IR     -- INTEGER VALUE OF R
C       ITEMP  -- INTEGER TEMPORARY VARIABLE
C       ITEMP2 -- SECOND INTEGER TEMP.
C       NEXSAM -- FLAG TO INDICATE WHETHER THERE ARE MORE SAMPLES TO BE
C                 PROCESSED ON THE CURRENT LINE
C       NSAMP  -- NUMBER OF SAMPLES LEFT TO PROCESS
C       P      -- HORIZONTAL POSITION OF CURRENT POINT IN INPUT FILE.
C       PFRAC  -- FRACTIONAL PART OF P
C       POINT  -- PIXEL VALUE OF INTERPOLATED POINT (R,P) IN INPUT FILE
C       R      -- VERTICAL POSITION OF CURRENT POINT IN INPUT FILE
C       RER    -- FINAL VALUE OF R FOR CURRENT PASS
C       RFRAC  -- FRACTIONAL PART OF R
C       TEMP   -- REAL TEMPORARY VARIABLE
C       VAL1   -- VALUE OF POINT (IR,IP) OF INPUT PICTURE
C       VAL2   -- SAME FOR (IR,IP+1)
C       VAL3   -- SAME FOR (IR+1,IP)
C       VAL4   -- SAME FOR (IR+1,IP+1)
C	V2UNITS KEEPS TRACK OF THE UNIT NUMBERS OF THE FILES
      INTEGER INPUT,IDS,OUT
      COMMON /V2UNITS/ INPUT,IDS,OUT
      LOGICAL HALFW,NOIN,NOIZ
      INTEGER DUMMY !DUMMY ARRAY USED TO PREVENT WARNINGS FROM COMPILERS THAT
                    !WANT ALL OCCURRENCES OF A COMMON BLOCK TO HAVE SAME SIXE.
      COMMON /P1/ HALFW,NOIN,NOIZ,DUMMY(9)
      INTEGER NSAMP,IR,IP,ITEMP,ITEMP2,INDEX,LD
      INTEGER VAL1,VAL2,VAL3,VAL4,POINT,SAMP
      REAL RER,R,P,DELR,DELP,TEMP,RFRAC,PFRAC,TEMP2,INZ
      LOGICAL NEXSAM, PRINT
C
C--INCLUDE COMMON BLOCK
      INTEGER ICR,CBBC,CCSD,CFBI,B,SC,ISAMP,BLOCK
      INTEGER BUFLEN,MAXBBC,MAXCSD,LOCAT(10),BIGBUF(*)
      REAL FLN,FSM,FSMT,LARGE,SMALL,RMIN,RMAX
      INTEGER MAXNBPAR
      PARAMETER (MAXNBPAR=1200)     ! MAXIMUM NUMBER OF BUFFERS FOR PASS 1.

	INTEGER*2 CNT(MAXNBPAR)
	INTEGER   LOC(MAXNBPAR),FBI(MAXNBPAR),BBC(MAXNBPAR)
C
C--VARIABLES EQUIVALENCED INTO COMMON BLOCK
      INTEGER SLI,SSI,NLO,NSO,NLI,NSI
C
      COMMON /A1/ ICR,FLN,FSM,FSMT,LARGE,SMALL,
     .             RMIN,RMAX,CBBC,CCSD,CFBI,B,PRINT,
     .             SC,ISAMP,LD,BLOCK,BUFLEN,MAXBBC,MAXCSD,
     .             LOCAT,FBI,BBC,CNT,LOC
C
      EQUIVALENCE (SLI,LOCAT(1)),(SSI,LOCAT(2)),(NLO,LOCAT(3)),
     2            (NSO,LOCAT(4)),(NLI,LOCAT(5)),(NSI,LOCAT(6))
C
      SAMP = 0
      CALL ZBA(LINBUF,NSO) ! ZERO THE OUTPUT BUFFER
C
C--BEGIN MAIN RECTANGLE PROCESSING LOOP
      DO WHILE (SAMP.LT.NSO)
C
C--DETERMINE COORDINATE IN INPUT FILE OF CURRENT POINT
        ITEMP = FLN-INCRMNTS(1,ICR)
        DELR = INCRMNTS(12,ICR)+ITEMP*INCRMNTS(11,ICR)
        DELP = INCRMNTS(7,ICR)+ITEMP*INCRMNTS(8,ICR)
        ITEMP2 = FSM-INCRMNTS(3,ICR)
        P = INCRMNTS(5,ICR)+ITEMP*INCRMNTS(9,ICR)+DELP*ITEMP2
        R = INCRMNTS(6,ICR)+ITEMP2*INCRMNTS(12,ICR)+ITEMP*
     2      (INCRMNTS(10,ICR)+ITEMP2*INCRMNTS(11,ICR))
        ITEMP = INCRMNTS(4,ICR)
        IF ((INCRMNTS(2,ICR).NE.INCRMNTS(2,ICR+1)).OR.(ITEMP.GT.FSMT))
     2       ITEMP = FSMT
C
        RER = (ITEMP-FSM)*DELR+R
        NSAMP = ITEMP-FSM
        FSM = ITEMP
        ISAMP = SAMP+NSAMP
C
        NEXSAM = .TRUE.
        IF (NSAMP .LE. 0)  NEXSAM = .FALSE.       ! ADDED FOR MAPTRANS.
C
C--BEGIN SAMPLE PROCESSING LOOP
        DO WHILE (NEXSAM)
C
C--BEGIN MAIN IF BLOCK
          IF (R.LT.RMIN) THEN
              IF (RER.LT.RMIN) THEN
                  SAMP = ISAMP
                  NEXSAM = .FALSE.
                ELSE
                  SAMP = SAMP+1
                  R = R+DELR
                  P = P+DELP
                  NSAMP = NSAMP-1
              END IF
            ELSE IF (R.GE.RMAX) THEN
              IF (RER.GE.RMAX) THEN
                  SAMP = ISAMP
                  NEXSAM = .FALSE.
                ELSE
                  SAMP = SAMP+1
                  R = R+DELR
                  P = P+DELP
                  NSAMP = NSAMP-1
              END IF
            ELSE
              IR = R
              RFRAC = R-IR
              IP = P
              PFRAC = P-IP
C
C--CHECK FOR POINTS OUTSIDE OF BOUNDARY
              IF ((P.LT.0).OR.
     2           ((IP.EQ.0).AND.(PFRAC.LE.LARGE)).OR.
     3            (IP.GT.NSI).OR.
     4           ((IP.EQ.NSI).AND.(PFRAC.GE.SMALL))) GOTO 100
C
C--POINT IS WITHIN BOUNDARIES
                  IF ((RFRAC.GE.SMALL).AND.(RFRAC.LT.LARGE) .AND.
     .                (RMAX .GE. IR+1)                          )  THEN
                      INDEX = BIGBUF(IR)+IP
                      VAL1 = BYTE2INT( LBUF(INDEX) )
                      IF (IP .EQ. NSI) THEN
                        VAL2 = VAL1
                      ELSE
                        VAL2 = BYTE2INT( LBUF(INDEX+1) )
                      END IF
                      INDEX = IP+BIGBUF(IR+1)
                      VAL3 = BYTE2INT( LBUF(INDEX) )
                      IF (IP .EQ. NSI) THEN
                        VAL4 = VAL3
                      ELSE
                        VAL4 = BYTE2INT( LBUF(INDEX+1) )
                      END IF
		      IF(NOIZ) THEN
			TEMP = INZ(FLOAT(VAL1),FLOAT(VAL2),PFRAC)
			TEMP2 = INZ(FLOAT(VAL3),FLOAT(VAL4),PFRAC)
			POINT = INZ(TEMP,TEMP2,RFRAC)+.5
		      ELSE
                      	TEMP = FLOAT(VAL1)+PFRAC*(VAL2-VAL1)
                      	TEMP2 = FLOAT(VAL3)+PFRAC*(VAL4-VAL3)
                      	POINT = TEMP+RFRAC*(TEMP2-TEMP)+0.5
		      ENDIF
                    ELSE
                      IF (RFRAC.GE.LARGE) IR = IR+1
                      INDEX = IP+BIGBUF(IR)
                      VAL1 = BYTE2INT( LBUF(INDEX) )
                      POINT = VAL1
                      IF (PFRAC.GE.SMALL) THEN
                        VAL2 = BYTE2INT( LBUF(INDEX+1) )
                        POINT = VAL2
                        IF (PFRAC.LE.LARGE) THEN
			  IF(NOIZ) THEN
			   POINT = INZ(FLOAT(VAL1),FLOAT(VAL2),PFRAC)+.5
			  ELSE
                           POINT = FLOAT(VAL1)+PFRAC*(VAL2-VAL1)+0.5
			  ENDIF
                        END IF
                      END IF
                  END IF

		LINBUF(SAMP+1)= INT2BYTE(POINT) ! STORE SAMPLE
C
C--PREPARE FOR NEXT SAMPLE IN RECTANGLE
100	      SAMP=SAMP+1
              R = R+DELR
              P = P+DELP
              NSAMP = NSAMP-1
C
C--END MAIN IF BLOCK
          END IF
          IF (NSAMP.EQ.0) NEXSAM = .FALSE.
C
C--END SAMPLE PROCESSING LOOP
        END DO
C
C--NEXT RECTANGLE
        ICR = ICR+1
C
C--END MAIN RECTANGLE PROCESSING LOOP
      END DO

	CALL XVWRIT(OUT,LINBUF,ITEMP,' ') ! WRITE OUTPUT LINE
	RETURN
C
C--END OF SUBROUTINE GSUB1
      END
C
C                       GSUBH1
C
C       SUBROUTINE TO PROCESS ONE LINE OF HALFWORD DATA FOR LGEOM (ONE-PASS)
C
C       SIMILAR TO GSUB1 EXCEPT FOR INDEXING OF ARRAYS AND LENGTH
C       OF DATA (HALFWORD INSTEAD OF BYTE)
C
      SUBROUTINE GSUBH1(INCRMNTS,LINBUF,LBUF,I2BUF,BIGBUF)
C
C--ALL VARIABLES MUST BE EXPLICITLY TYPED
      IMPLICIT NONE

C
C--PASSED VARIABLES
C
        INTEGER*2 I2BUF(*)
        BYTE LBUF(*)
	REAL INCRMNTS(12,*)
	INTEGER*2 LINBUF(*)
C
C--LOCAL VARIABLES
C
C       DELP   -- CHANGE IN HORIZONTAL POSITION PER UNIT CHANGE IN VERTICAL
C                 POSITION.
C       DELR   -- CHANGE IN VERTICAL POSITION PER UNIT CHANGE IN HORIZONTAL
C                 POSITION.
C       ICR    -- INDEX TO FIRST DIMENSION OF INCRMNTS ARRAY (Index to Current
C                 Rectangle)
C	IDS    -- UNIT NUMBER OF INTERMEDIATE DATA SET
C       INDEX  -- TEMPORARY VARIABLE FOR ARRAY INDEXING
C       IP     -- INTEGER VALUE OF P
C       IR     -- INTEGER VALUE OF R
C       ITEMP  -- INTEGER TEMPORARY VARIABLE
C       ITEMP2 -- SECOND INTEGER TEMP.
C       NEXSAM -- FLAG TO INDICATE WHETHER THERE ARE MORE SAMPLES TO BE
C                 PROCESSED ON THE CURRENT LINE
C       NSAMP  -- NUMBER OF SAMPLES LEFT TO PROCESS
C	NWI    -- NUMBER OF WORDS INPUT
C       NWO    -- NUMBER OF WORDS OUTPUT
C       P      -- HORIZONTAL POSITION OF CURRENT POINT IN INPUT FILE.
C       PFRAC  -- FRACTIONAL PART OF P
C       POINT  -- PIXEL VALUE OF INTERPOLATED POINT (R,P) IN INPUT FILE
C       R      -- VERTICAL POSITION OF CURRENT POINT IN INPUT FILE
C       RER    -- FINAL VALUE OF R FOR CURRENT PASS
C       RFRAC  -- FRACTIONAL PART OF R
C       TEMP   -- REAL TEMPORARY VARIABLE
C       VAL1   -- VALUE OF POINT (IR,IP) OF INPUT PICTURE
C       VAL2   -- SAME FOR (IR,IP+1)
C       VAL3   -- SAME FOR (IR+1,IP)
C       VAL4   -- SAME FOR (IR+1,IP+1)
C	V2UNITS KEEPS TRACK OF THE UNIT NUMBERS OF THE FILES
      INTEGER INPUT,IDS,OUT
      COMMON /V2UNITS/ INPUT,IDS,OUT
      LOGICAL HALFW,NOIN,NOIZ
      INTEGER DUMMY !DUMMY ARRAY USED TO PREVENT WARNINGS FROM COMPILERS THAT
                    !WANT ALL OCCURRENCES OF A COMMON BLOCK TO HAVE SAME SIXE.
      COMMON /P1/ HALFW,NOIN,NOIZ,DUMMY(9)
      INTEGER NSAMP,IR,IP,ITEMP,ITEMP2,INDEX,LD,SAMP
      REAL RER,R,P,DELR,DELP,TEMP,RFRAC,PFRAC,VAL1,VAL2,VAL3
      REAL VAL4,TEMP2,POINT,INZ
      LOGICAL NEXSAM, PRINT
C--INCLUDE COMMON BLOCK
      INTEGER ICR,CBBC,CCSD,CFBI,B,SC,ISAMP,BLOCK
      INTEGER BUFLEN,MAXBBC,MAXCSD,LOCAT(10),BIGBUF(*)
      REAL FLN,FSM,FSMT,LARGE,SMALL,RMIN,RMAX
      INTEGER MAXNBPAR
      PARAMETER (MAXNBPAR=1200)     ! MAXIMUM NUMBER OF BUFFERS FOR PASS 1.

	INTEGER*2 CNT(MAXNBPAR)
	INTEGER   LOC(MAXNBPAR),FBI(MAXNBPAR),BBC(MAXNBPAR)
C
C--VARIABLES EQUIVALENCED INTO COMMON BLOCK
      INTEGER SLI,SSI,NLO,NBO,NLI,NBI,NWO,NWI
C
      COMMON /A1/ ICR,FLN,FSM,FSMT,LARGE,SMALL,
     .             RMIN,RMAX,CBBC,CCSD,CFBI,B,PRINT,
     .             SC,ISAMP,LD,BLOCK,BUFLEN,MAXBBC,MAXCSD,
     .             LOCAT,FBI,BBC,CNT,LOC
C
      EQUIVALENCE (SLI,LOCAT(1)),(SSI,LOCAT(2)),(NLO,LOCAT(3)),
     2            (NBO,LOCAT(4)),(NLI,LOCAT(5)),(NBI,LOCAT(6))
C
C
      SAMP = 0
      NWI = NBI/2
      NWO = NBO/2
      CALL ZBA(LINBUF,NBO) ! ZERO THE OUTPUT LINE
C
C--BEGIN MAIN RECTANGLE PROCESSING LOOP
      DO WHILE (SAMP.LT.NWO)
C
C--DETERMINE COORDINATE IN INPUT FILE OF CURRENT POINT
        ITEMP = FLN-INCRMNTS(1,ICR)
        DELR = INCRMNTS(12,ICR)+ITEMP*INCRMNTS(11,ICR)
        DELP = INCRMNTS(7,ICR)+ITEMP*INCRMNTS(8,ICR)
        ITEMP2 = FSM-INCRMNTS(3,ICR)
        P = INCRMNTS(5,ICR)+ITEMP*INCRMNTS(9,ICR)+DELP*ITEMP2
        R = INCRMNTS(6,ICR)+ITEMP2*INCRMNTS(12,ICR)+ITEMP*
     2      (INCRMNTS(10,ICR)+ITEMP2*INCRMNTS(11,ICR))
        ITEMP = INCRMNTS(4,ICR)
        IF ((INCRMNTS(2,ICR).NE.INCRMNTS(2,ICR+1)).OR.(ITEMP.GT.FSMT))
     2       ITEMP = FSMT
C
        RER = (ITEMP-FSM)*DELR+R
        NSAMP = ITEMP-FSM
        FSM = ITEMP
        ISAMP = SAMP+NSAMP
C
        NEXSAM = .TRUE.
        IF (NSAMP .LE. 0)  NEXSAM = .FALSE.       ! ADDED FOR MAPTRANS.
C
C--BEGIN SAMPLE PROCESSING LOOP
        DO WHILE (NEXSAM)
C
C--BEGIN MAIN IF BLOCK
          IF (R.LT.RMIN) THEN
              IF (RER.LT.RMIN) THEN
                  SAMP = ISAMP
                  NEXSAM = .FALSE.
                ELSE
                  SAMP = SAMP+1
                  R = R+DELR
                  P = P+DELP
                  NSAMP = NSAMP-1
              END IF
            ELSE IF (R.GE.RMAX) THEN
              IF (RER.GE.RMAX) THEN
                  SAMP = ISAMP
                  NEXSAM = .FALSE.
                ELSE
                  SAMP = SAMP+1
                  R = R+DELR
                  P = P+DELP
                  NSAMP = NSAMP-1
              END IF
            ELSE
              IR = R
              RFRAC = R-IR
              IP = P
              PFRAC = P-IP
C
C--CHECK FOR POINTS OUTSIDE OF BOUNDARY
              IF ((P.LT.0).OR.
     2           ((IP.EQ.0).AND.(PFRAC.LE.LARGE)).OR.
     3            (IP.GT.NWI).OR.
     4           ((IP.EQ.NWI).AND.(PFRAC.GE.SMALL))) GOTO 100
C
C--POINT IS WITHIN BOUNDARIES
                  IF ((RFRAC.GE.SMALL).AND.(RFRAC.LT.LARGE) .AND.
     .                (RMAX .GE. IR+1)                          )  THEN
                      INDEX = (BIGBUF(IR)+1)/2+IP
                      VAL1 = I2BUF(INDEX)
                      IF (IP .EQ. NWI) THEN
                        VAL2 = VAL1
                      ELSE
                        VAL2 = I2BUF(INDEX+1)
                      END IF
                      INDEX = IP+(BIGBUF(IR+1)+1)/2
                      VAL3 = I2BUF(INDEX)
                      IF (IP .EQ. NWI) THEN
                        VAL4 = VAL3
                      ELSE
                        VAL4 = I2BUF(INDEX+1)
                      END IF
		      IF(NOIZ) THEN
			TEMP = INZ(VAL1,VAL2,PFRAC)
			TEMP2 = INZ(VAL3,VAL4,PFRAC)
			POINT = INZ(TEMP,TEMP2,RFRAC)
		      ELSE
                      	TEMP = VAL1+PFRAC*(VAL2-VAL1)
                      	TEMP2 = VAL3+PFRAC*(VAL4-VAL3)
                      	POINT = TEMP+RFRAC*(TEMP2-TEMP)
		      ENDIF
                    ELSE
                      IF (RFRAC.GE.LARGE) IR = IR+1
                      INDEX = IP+(BIGBUF(IR)+1)/2
                      POINT = I2BUF(INDEX)
                      IF (PFRAC.GE.SMALL) THEN
                        VAL1 = POINT
                        POINT = I2BUF(INDEX+1)
                        IF (PFRAC.LE.LARGE) THEN
                          VAL2 = POINT
			  IF(NOIZ) THEN
			    POINT = INZ(VAL1,VAL2,PFRAC)
			  ELSE
                            POINT = VAL1+PFRAC*(VAL2-VAL1)
			  ENDIF
                        END IF
                      END IF
                  END IF

		LINBUF(SAMP+1) = NINT(POINT) ! STORE OUTPUT WORD
C
C--PREPARE FOR NEXT SAMPLE IN RECTANGLE
100           SAMP = SAMP+1
              R = R+DELR
              P = P+DELP
              NSAMP = NSAMP-1
C
C--END MAIN IF BLOCK
          END IF
          IF (NSAMP.EQ.0) NEXSAM = .FALSE.
C
C--END SAMPLE PROCESSING LOOP
        END DO
C
C--NEXT RECTANGLE
        ICR = ICR+1
C
C--END MAIN RECTANGLE PROCESSING LOOP
      END DO

	CALL XVWRIT(OUT,LINBUF,ITEMP,' ')

      RETURN
C
C--END OF SUBROUTINE GSUBH1
      END
C
C	INZ FUNCTION
C
C	INTERPOLATE NON-ZERO DN VALUES
C	USE NEAREST NEIGHBOR IF EITHER DN IS ZERO
C
	REAL FUNCTION INZ(VAL1,VAL2,FRAC)
C
	IF(VAL1.EQ.0.0.OR.VAL2.EQ.0.0) THEN
		IF(FRAC .LT. .5) THEN
			INZ=VAL1
		ELSE
			INZ=VAL2
		ENDIF
	ELSE
		INZ=VAL1+FRAC*(VAL2-VAL1)
	ENDIF
	RETURN
	END
C               LGP2
C
C       SECOND PASS FOR LGEOM
C
      SUBROUTINE LGP2(LABREC,NB,BUFLEN,NLO,NSO,LPB,CNT,BDIR,LBUF,I2BUF,
     .                PRINT)
C
      IMPLICIT NONE
C
C       PASSED VARIABLES:
C
	INTEGER NB,BUFLEN,NLO,NSO,LPB,LABREC
	INTEGER*2 CNT(*)
	INTEGER*4 BDIR(*)
	BYTE LBUF(*)
	INTEGER*2 I2BUF(*)
        LOGICAL PRINT
C
C       LOCAL VARIABLES:
C
C	V2UNITS KEEPS TRACK OF THE UNIT NUMBERS OF THE FILES
      INTEGER INPUT,IDS,OUT
      COMMON /V2UNITS/ INPUT,IDS,OUT
      INTEGER IB,G,ITEMP,NL
      INTEGER SC,INDEX,I2IND,I,IND
      CHARACTER*80 PBUF
C
C
C
C--BEGIN EXECUTION
C
C--INITIALIZE ARRAY INDEXES
	IB=1 ! INDEX TO BDIR
	G=1 ! GROUP NUMBER
	NL=NLO ! SAVE NLO FOR TEST
40	CALL ZBA(LBUF(BUFLEN+1),LPB*NSO) ! ZERO LPB LINES OF OUTPUT
        IF (PRINT)  THEN
           WRITE (PBUF, 55) (G-1)*LPB+1,MIN(NL,G*LPB)
55         FORMAT('PROCESSING OUTPUT LINES',I6,' TO',I6)
           CALL XVMESSAGE( PBUF, ' ')
        END IF
80	IF(CNT(G).EQ.0) GOTO 300 ! IF NO MORE DATA FOR THIS GROUP
100	CALL XVREAD(IDS,LBUF,IND,'LINE',BDIR(IB) ,' ')
	IB=IB+1
	CNT(G)=CNT(G)-1
	INDEX=1
	I2IND=1
150	SC=I2BUF(I2IND) ! STRING COUNT
	IF(SC.EQ.0) GOTO 80 ! IF END OF BLOCK, GOTO 80
	ITEMP = I2BUF(I2IND+1)*NSO+I2BUF(I2IND+2)+BUFLEN
	CALL MVB(LBUF(INDEX+6),LBUF(ITEMP+1),SC)
	INDEX=(INDEX+6+SC)                         ! STEP INDEX
        IF ( MOD(INDEX,2) .EQ. 0) INDEX= INDEX+1   ! (ADD 1 IF NECESSARY)
	I2IND=(INDEX+1)/2
	GOTO 150

300	INDEX=BUFLEN
	DO 400 I=1,LPB
	CALL XVWRIT(OUT,LBUF(INDEX+1),IND,' ')
	NLO = NLO-1
	IF(NLO.EQ.0) RETURN
400	INDEX=INDEX+NSO
	G=G+1 ! STEP TO NEXT GROUP
	GOTO 40
C
C--END OF LGP2
      END
C
      SUBROUTINE GET_TIEPOINTS(BUF,INCREMENTS,NRECT,PRINT)
      IMPLICIT NONE
C
C	GET_TIEPOINTS reads in the tiepoints parameter, calculates
C	the offsets needed by the main program, and stores them in
C	INCREMENTS.
C
C	Passed variables:
C
C INCREMENTS -- Array of increments needed by LGEOM to step across
C		the rectangles
C BUF	-- Large working buffer

      REAL INCREMENTS(12,*),BUF(*)
C
C	Local variables:
C
C
C       Output image rectangle:         Input image quadrilateral
C
C                                                      * (A2,B2)
C       (X1,Y1)*      * (X1,Y2)         (A1,B1)*
C
C                                                    * (A4,B4)
C       (X2,Y1)*      * (X2,Y2)         (A3,B3)*
C
C NAH	-- Number of rectangles (areas) horizontally
C NAV	-- Number of rectangles (areas) vertically
C TX1,TY1 etc -- Temporary real variables to fill common block
C DELX,DELY  -- X2-X1,Y2-Y1
C TOP     -- index into buffer of top line of rects
C BOTTOM  -- index into buffer for bottom line of rects
C ROW     -- current rectangle row
C COL     -- current rectangle column
C NVALS   -- number of values needed in TIEPOINTS
C NRECT   -- total number of rectangles
C
      INTEGER NAH,NAV,TOP,BOTTOM,ROW,COL,NVALS,I,N,NRECT
      CHARACTER*80 PBUF
      REAL DELX,DELY
      REAL X1,Y1,A1,B1,TX1,Y2,A2,B2,X2,TY1,A3,B3,TX2,TY2,A4,B4
C
C COUNT -- Variable count returned from xvparm
C DEFAULTED -- Default flag from xvparm
C PDS	-- Logical indicating the presence of a parameter data set.
C PRINT -- Print extra info.
      INTEGER COUNT,DEFAULTED
      LOGICAL PRINT
C
C--Begin execution
C
C--Check for the presence of a parameter data set
      CALL XVPCNT('INP',COUNT)
      IF (COUNT .EQ. 2) THEN
	  CALL LOAD_PDS(BUF,BUF,INCREMENTS,NRECT)
	  RETURN
      ENDIF
C
C--Get the size of the grid
      CALL XVPARM('NAH',NAH,COUNT,DEFAULTED,0)
      IF (COUNT .EQ. 0) THEN
	  CALL XVMESSAGE('NAH not specified',' ')
	  CALL ABEND
      ENDIF
      CALL XVPARM('NAV',NAV,COUNT,DEFAULTED,0)
      IF (COUNT .EQ. 0) THEN
	  CALL XVMESSAGE('NAV not specified',' ')
	  CALL ABEND
      ENDIF
C
C--Get the tiepoints
      CALL XVPARM('TIEPOINT',BUF,COUNT,DEFAULTED,0)
C
C--Check for proper number of tiepoints
      NVALS = 4*(NAH + 1) * (NAV + 1)
      IF (COUNT .NE. NVALS) THEN
	  CALL XVMESSAGE('Improper number of tiepoints specified',' ')
	  CALL ABEND
      ENDIF

C CODE TO PRINT TIEPOINTS

      IF (PRINT) THEN
      CALL XVMESSAGE( '   TIEPOINTS:',' ')
      DO I = 1, NVALS, 4
         WRITE(PBUF,9000) BUF(I), BUF(I+1), BUF(I+2), BUF(I+3)
9000     FORMAT( 4F10.3 )
         CALL XVMESSAGE ( PBUF(1:40), ' ')
      END DO
      END IF
C
C--Verify that the rectangles in the output image are whole numbers
      NVALS = 4*(NAH + 1)
      DO ROW = 1, NAV*NVALS+1, NVALS
	X1 = BUF(ROW)
	I = X1			! TRUNCATE
	IF ((X1 - I) .NE. 0) THEN
	    CALL XVMESSAGE
     2      ('Grid on output not on integral pixel numbers',' ')
	    CALL ABEND
	ENDIF
      ENDDO
      DO COL = 1, 4*NAH+1, 4
	Y1 = BUF(COL)
	I = Y1			! TRUNCATE
	IF ((Y1 - I) .NE. 0) THEN
	    CALL XVMESSAGE
     2      ('Grid on output not on integral pixel numbers',' ')
	    CALL ABEND
	ENDIF
      ENDDO
C
C--Cycle through the rectangles, storing each set of increments
      N = 1
      TOP = 1
      BOTTOM = 4 * NAH + 5
      DO ROW = 1,NAV
	DO COL = 1,NAH
C
C--Move current tiepoint pair into local variables

          X1 = BUF(TOP )
          Y1 = BUF(TOP+1 )
          A1 = BUF(TOP+2 )
          B1 = BUF(TOP+3 )
          TX1 = BUF(TOP+4 )
          Y2 = BUF(TOP+5 )
          A2 = BUF(TOP+6 )
          B2 = BUF(TOP+7 )

          X2 = BUF(BOTTOM )
          TY1 = BUF(BOTTOM+1 )
          A3 = BUF(BOTTOM+2 )
          B3 = BUF(BOTTOM+3 )
          TX2 = BUF(BOTTOM+4 )
          TY2 = BUF(BOTTOM+5 )
          A4 = BUF(BOTTOM+6 )
          B4 = BUF(BOTTOM+7 )
C
C--Verify that tiepoint represents a rectangle
	  IF ((X1 .NE. TX1) .OR. (X2 .NE. TX2) .OR.
     2      (Y1 .NE. TY1) .OR. (Y2 .NE. TY2))
     3      CALL MABEND('Tiepoints are not rectangular')
C
C--Now store the increments
	  INCREMENTS(1,N) = X1
	  INCREMENTS(2,N) = X2
	  INCREMENTS(3,N) = Y1
	  INCREMENTS(4,N) = Y2
	  INCREMENTS(5,N) = B1
	  INCREMENTS(6,N) = A1
	  DELX = X2 - X1
	  DELY = Y2 - Y1
	  INCREMENTS(7,N) = (B2 - B1)/DELY
	  INCREMENTS(8,N) = (B4 - B3 - B2 + B1) / (DELX * DELY)
	  INCREMENTS(9,N) = (B3 - B1) / DELX
	  INCREMENTS(10,N) = (A3 - A1) / DELX
	  INCREMENTS(11,N) = (A4 - A3 - A2 + A1) / (DELY * DELX)
	  INCREMENTS(12,N) = (A2 - A1) / DELY
C
C--Next rectangle
	  TOP = TOP + 4
	  BOTTOM = BOTTOM + 4
	  N = N + 1
	ENDDO
C
C--Next line of rectangles
	TOP = TOP + 4
	BOTTOM = BOTTOM + 4
      ENDDO
      NRECT = N - 1
C
C--End of GET_TIEPOINTS
      RETURN
      END
C
C
      SUBROUTINE LOAD_PDS(BUF,I_BUF,INCREMENTS,ISAVE)
      IMPLICIT NONE

	INTEGER  MAXRPAR,INCRPAR
	PARAMETER (MAXRPAR=400) ! MAX RECTS FROM MAP2
	PARAMETER (INCRPAR=401) ! MAX RECTS FROM MAP2
C
C
C	LOAD_PDS gets the LGEOM parameters from a parameter
C	data set (PDS)  in the old format, and sorts them into
C	the INCREMENTS array.
C
C	Passed variables:
      REAL BUF(*),INCREMENTS(12,INCRPAR)
      INTEGER I_BUF(*)	! Same address as BUF
C
C	Local variables:
      CHARACTER*43 NORECT
      CHARACTER*38 NOSAMP
      CHARACTER*36 NOLINE
      CHARACTER*21 LINES
      CHARACTER*21 RECTAN
      CHARACTER*4  CSAVE
C
      INTEGER IND,INPUT,NP,LOCSMP,I,J,K,INDEX,NSAMP,NB
      INTEGER IM,IN,M,N,ISAVE,MLOC,NLOC
      INTEGER*2 ITAB(3,INCRPAR)
      REAL ROW,SAM,VMA,TEMP,TEMPM,TEMP2
      LOGICAL HALFW,NOIN,NOIZ
      INTEGER DUMMY !DUMMY ARRAY USED TO PREVENT WARNINGS FROM COMPILERS THAT
                    !WANT ALL OCCURRENCES OF A COMMON BLOCK TO HAVE SAME SIXE.
      COMMON /P1/ HALFW,NOIN,NOIZ,DUMMY(9)

      DATA NORECT/'THERE WERE NOT ENOUGH PARAMETERS FOR GEOM.'/
      DATA NOSAMP/'GEOM COULD NOT FIND ANY SAMPLE CARDS.'/
      DATA NOLINE/'GEOM COULD NOT FIND ANY LINE CARDS.'/
      DATA LINES/'TOO MANY LINE CARDS.'/
      DATA RECTAN/'TOO MANY RECTANGLES.'/
C==================================================================
C
      CALL XVUNIT(INPUT,'INP',2,IND,' ')
      CALL XVOPEN(INPUT,IND,' ')
C
C--CALL READ READING INTO BUF
      CALL XVREAD(INPUT,BUF,IND,' ')
      NP = I_BUF(1)
      BUF(NP+2) = 0
      CALL XVCLOSE(INPUT,IND,' ')

C
C     THE LINE NUMBERS FROM THE USER INPUT CARDS ARE GOING TO BE STORED
C     IN ITAB AND THEN THEY WILL BE SORTED IN ASCENDING ORDER
C     WHEN THE COMPUTATION IS DONE FOR EACH RECTANGLE,THE CORRESPONDING
C     SAMPLE NUMBERS MUST BE USED ALSO. LOCSMP WILL TELL WHERE IN BUF
C     THE SAMPLE VALUES ARE STORED WHICH CORRESPOND TO A LINE NUMBER.
C     K WILL BE USED TO COUNT THE NUMBER OF LINES IN ITAB
      LOCSMP=0
      K=0
      I = 1
C
C--BEGIN PARAMETER PROCESSING LOOP
      DO WHILE ((I.LT.NP).AND.(K.LT.MAXRPAR))
        I = I+1
        CALL MVLC(I_BUF(I), CSAVE, 4)   ! MOVE TO CHARACTER VARIABLE.
C
C--BEGIN PARAMETER PROCESSING IF BLOCK
        IF (CSAVE.EQ.'SAMP') THEN
            LOCSMP = I+2
          ELSE IF (CSAVE.EQ.'NBUF') THEN
	    NB = I_BUF(I+2)
          ELSE IF (CSAVE.EQ.'NOIN') THEN
C--FORCE NO INTERPOLATION (USE NEAREST POINT)
	    NOIN = .TRUE.	! SET FLAG FOR MAIN44
	  ELSE IF (CSAVE.EQ.'NOIZ') THEN
C--NO INTERPOLATION FOR ZERO DN POINTS
	    NOIZ = .TRUE.
          ELSE IF (CSAVE.EQ.'HALF') THEN
            HALFW = .TRUE.
          ELSE IF (CSAVE.EQ.'LINE') THEN
            K = K+1
            ITAB(1,K)=BUF(I+2)
            ITAB(2,K)=I+2
            ITAB(3,K)=LOCSMP
            IF (K.EQ.INCRPAR) CALL XVMESSAGE(LINES,' ')
C
C--END PARAMETER PROCESSING IF BLOCK
        END IF
C
C--END PARAMETER PROCESSING LOOP
      END DO
C
C
      IF (LOCSMP.EQ.0) THEN
C--NO KEYWORD 'SAMPLE' FOUND
        CALL XVMESSAGE(NOSAMP,' ')
        CALL ABEND
      END IF
C
C--NOW THAT THE LINES ARE ALL IN ITAB - SORT THEM IN ASCENDING ORDER
      DO I = 1,K-1
        M = I+1
        DO J = M,K
          IF (ITAB(1,I).GT.ITAB(1,J)) THEN
            DO N = 1,3
              ISAVE = ITAB(N,I)
              ITAB(N,I) = ITAB(N,J)
              ITAB(N,J) = ISAVE
            END DO
          END IF
        END DO
C--END OF SORT
      END DO
C--WHEN THE LINES ARE SORTED, PROCESS THE RECTANGLES IN THAT ORDER
C
C--ISAVE WILL INDICATE WHERE IN THE BUFFER INCREMENTS THE RESULTS OF THE
C--RECTANGLE CALCULATIONS SHOULD BE STORED
C
C--NSAMP WILL BE USED WITH EACH LINE THAT IS PROCESSED TO TELL HOW
C--MANY SAMPLES WERE SPECIFIED FOR THIS LINE. THE NUMBER OF
C--RECTANGULAR CALCULATIONS DONE WILL BE ONE LESS THAN THE NUMBER
C--OF SAMPLES
      ISAVE=0
C
C--BEGIN PARAMETER STORAGE LOOP
      J = 0
      DO WHILE ((J.LT.K).AND.(ISAVE.LT.MAXRPAR))
        J = J+1
        NSAMP = 1
        INDEX = ITAB(3,J)+1
C
C--COUNT THE NUMBER PER LINE
        CALL MVLC(BUF(INDEX), CSAVE, 4)   ! MOVE TO CHARACTER VARIABLE.
        DO WHILE ((CSAVE.NE.'LINE').AND.(INDEX.LE.NP))
          NSAMP = NSAMP+1
          INDEX = INDEX+1
          CALL MVLC(BUF(INDEX), CSAVE, 4)   ! MOVE TO CHARACTER VARIABLE.
        END DO
C
C--CHECK FOR ERROR (LACK OF KEYWORD "LINE")
        IF (INDEX.GT.NP) THEN
          CALL XVMESSAGE(NOLINE,' ')
          CALL ABEND
        END IF
C
C--IM IS A SUBSCRIPT TO PICK UP THE FIRST LINE IN THE RECTANGLE FROM
C--BUF
        IM=ITAB(2,J)
        CALL MVLC(BUF(IM+1+2*NSAMP), CSAVE, 4)   ! MOVE TO CHARACTER VARIABLE.
        IF (CSAVE .EQ.'LINE') THEN
C--INDEX IS RESET TO POINT TO THE FIRST OF THE SAMPLES
          INDEX = ITAB(3,J)
C--IN WILL POINT TO THE LOCATION OF THE SECOND LINE OF THE RECTANGLE
          IN=IM+3+2*NSAMP
          NSAMP = NSAMP-1
          M=BUF(IM)
          N=BUF(IN)
C--M AND N NOW HAVE THE LINES FOR THE RECTANGLE
          I = 0
C--BEGIN SAMPLE PROCESSING LOOP
          DO WHILE ((I.LT.NSAMP).AND.(ISAVE.LT.MAXRPAR))
            I = I+1
            ISAVE = ISAVE+1
            SAM = I_BUF(INDEX+1)-I_BUF(INDEX)
            ROW = N-M
            MLOC = IM+2*(I-1)+1
C--MLOC IS THE LOCATION IN THE BUFFER BUF OF THE DISPLACEMENTS FOR
C--THE FIRST LINE IN THE CURRENT RECTANGLE
            NLOC = IN+2*(I-1)+1
C--NLOC IS THE SAME FOR THE SECOND LINE
            INCREMENTS(1,ISAVE)=M
            INCREMENTS(2,ISAVE)=N
            INCREMENTS(3,ISAVE)=I_BUF(INDEX)
C--SAVE LINES AND SAMPLES WHICH DEFINE THIS RECTANGLE
            INCREMENTS(4,ISAVE)=I_BUF(INDEX+1)
            INCREMENTS(5,ISAVE)=BUF(MLOC)+I_BUF(INDEX)
C--SAVE THE HORIZONTAL AND VERTICAL DISPLACEMENTS FOR LINE 1
            VMA=BUF(MLOC+1)
            INCREMENTS(6,ISAVE)=VMA+M
            TEMP=BUF(MLOC+2)
            TEMPM=BUF(MLOC)
            INCREMENTS(7,ISAVE)=1.0+((TEMP-TEMPM)/SAM)
            TEMP2=BUF(NLOC)
            TEMP=1.+(BUF(NLOC+2)-TEMP2)/SAM
            INCREMENTS(8,ISAVE)=(TEMP-INCREMENTS(7,ISAVE))/ROW
            INCREMENTS(9,ISAVE)=(TEMP2-TEMPM)/ROW
            TEMP=BUF(NLOC+1)
            INCREMENTS(10,ISAVE)=1.0+(TEMP-VMA)/ROW
            TEMP2=BUF(MLOC+3)
            TEMP=1.+(BUF(NLOC+3)-TEMP2)/ROW
            INCREMENTS(11,ISAVE)=(TEMP-INCREMENTS(10,ISAVE))/SAM
            INCREMENTS(12,ISAVE)=(TEMP2-VMA)/SAM
C--WORD 7 HAS THE DELTA P FOR M (M BEING LINE 1)- STEP SIZE FOR LINE
C--WORD 8 HAS DELTA L -INCREMENT TO STEP SIZE BETWEEN LINES M AND N
C--WORD 9 HAS DELTA M - INCREMENT TO FIRST POINT BETWEEN LINES
C--WORD 10 HAS DELTA L FOR A - STEP SIZE ALONG SAMPLES FOR A
C--WORD 11 HAS DELTA P -INCREMENT TO STEP SIZE BETWEEN SAMPLES A
C--        AND B
C--WORD 12 HAS DELTA A -INCREMENT TO FIRST POINT BETWEEN SAMPLES A
C--        AND B
C
C--INCREMENT TO GET NEXT SAMPLE FOR THIS LINE
            INDEX=INDEX+1
C
C--END SAMPLE PROCESSING LOOP
          END DO
C
C--END "IF (BUF(...).EQ.LINE)" BLOCK
        END IF
C
C--END PARAMETER STORING LOOP
      END DO
C
C--CHECK FOR EXIT CAUSED BY TOO MANY RECTANGLES
      IF (ISAVE.GE.MAXRPAR) THEN
        ISAVE = MAXRPAR
        CALL XVMESSAGE(RECTAN,' ')
      END IF
C--MAKE SURE TEST FOR LAST RECTANGLE ON LINE WORKS
      INCREMENTS(2,ISAVE+1) = 0
      RETURN
      END


      subroutine hyd2dh(bndval,typbnd,thick ,nobnd ,notims,kmax  ,
     *                  nolay ,dav                               )
!----- GPL ---------------------------------------------------------------------
!
!  Copyright (C)  Stichting Deltares, 2011-2016.
!
!  This program is free software: you can redistribute it and/or modify
!  it under the terms of the GNU General Public License as published by
!  the Free Software Foundation version 3.
!
!  This program is distributed in the hope that it will be useful,
!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!  GNU General Public License for more details.
!
!  You should have received a copy of the GNU General Public License
!  along with this program.  If not, see <http://www.gnu.org/licenses/>.
!
!  contact: delft3d.support@deltares.nl
!  Stichting Deltares
!  P.O. Box 177
!  2600 MH Delft, The Netherlands
!
!  All indications and logos of, and references to, "Delft3D" and "Deltares"
!  are registered trademarks of Stichting Deltares, and remain the property of
!  Stichting Deltares. All rights reserved.
!
!-------------------------------------------------------------------------------
!  $Id: hyd2dh.f 5717 2016-01-12 11:35:24Z mourits $
!  $HeadURL: https://svn.oss.deltares.nl/repos/delft3d/tags/6686/src/tools_gpl/nesthd2/packages/nesthd2/src/hyd2dh.f $
!***********************************************************************
! Deltares                         marine and coastal management
!
! subroutine         : dethyd
! version            : v1.0
! date               : July 1997
! programmer         : Theo van der Kaaij
!
! function           : Determines depth-averaged velocities from 3D
!                      computation
! limitations        :
! subroutines called :
! note               : nolay reset to 1 for depth averaged velocities
!                      typbnd set to 'u'
!***********************************************************************

      real        thick (kmax  )

      real        bndval(nobnd ,notims,kmax  ,1     ,2     )

      logical     dav

      character*1 typbnd(nobnd )

      nolay = kmax

      if (kmax .eq. 1) then
         do 1 ibnd = 1, nobnd
            if (typbnd(ibnd) .eq. 'c') then
               typbnd(ibnd) = 'u'
            endif
    1    continue
      endif

      if (.not. dav) goto 999
!
!-----determine 2Dh velocities and store in layer 1 (k=1)
!
      do 10 ibnd = 1, nobnd
         if (typbnd(ibnd) .eq. 'c') then

            typbnd (ibnd) = 'u'

            do 20 isize = 1, 2
               do 20 itim = 1, notims

                  k = 1
                  bndval (ibnd,itim,k,1,isize) =
     *            thick(k)*bndval (ibnd,itim,k,1,isize)

                  do 20 k = 2, kmax
                     bndval (ibnd,itim,1,1,isize) =
     *               bndval (ibnd,itim,1,1,isize) +
     *               thick(k)*bndval (ibnd,itim,k,1,isize)
   20       continue
         endif
   10 continue

      nolay = 1

  999 continue

      return

      end


      SUBROUTINE MG5_1_MP_COMPUTE_LOOP_COEFS(PS,ANSDP)
C
C     Generated by MadGraph5_aMC@NLO v. %(version)s, %(date)s
C     By the MadGraph5_aMC@NLO Development Team
C     Visit launchpad.net/madgraph5 and amcatnlo.web.cern.ch
C
C     Returns amplitude squared summed/avg over colors
C     and helicities for the point in phase space P(0:3,NEXTERNAL)
C     and external lines W(0:6,NEXTERNAL)
C
C     Process: u u~ > u u~ [ virt = QCD ] @1
C
      IMPLICIT NONE
C
C     CONSTANTS
C
      CHARACTER*64 PARAMFILENAME
      PARAMETER ( PARAMFILENAME='MadLoopParams.dat')
      INTEGER NBORNAMPS
      PARAMETER (NBORNAMPS=2)
      INTEGER    NLOOPS, NLOOPGROUPS, NCTAMPS
      PARAMETER (NLOOPS=22, NLOOPGROUPS=13, NCTAMPS=54)
      INTEGER    NLOOPAMPS
      PARAMETER (NLOOPAMPS=76)
      INTEGER    NCOLORROWS
      PARAMETER (NCOLORROWS=NLOOPAMPS)
      INTEGER    NEXTERNAL
      PARAMETER (NEXTERNAL=4)
      INTEGER    NWAVEFUNCS,NLOOPWAVEFUNCS
      PARAMETER (NWAVEFUNCS=8,NLOOPWAVEFUNCS=50)
      INTEGER MAXLWFSIZE
      PARAMETER (MAXLWFSIZE=4)
      INTEGER LOOPMAXCOEFS, VERTEXMAXCOEFS
      PARAMETER (LOOPMAXCOEFS=15, VERTEXMAXCOEFS=5)
      INTEGER    NCOMB
      PARAMETER (NCOMB=16)
      REAL*16    ZERO
      PARAMETER (ZERO=0E0_16)
      COMPLEX*32 IMAG1
      PARAMETER (IMAG1=(0E0_16,1E0_16))
C     These are constants related to the split orders
      INTEGER    NSO, NSQUAREDSO, NAMPSO
      PARAMETER (NSO=1, NSQUAREDSO=1, NAMPSO=2)

C
C     ARGUMENTS
C
      REAL*16 PS(0:3,NEXTERNAL)
      REAL*8 ANSDP(3,0:NSQUAREDSO)
C
C     LOCAL VARIABLES
C
      LOGICAL DPW_COPIED
      INTEGER I,J,K,H,HEL_MULT,ITEMP
      REAL*16 TEMP2
      INTEGER NHEL(NEXTERNAL), IC(NEXTERNAL)
      REAL*16 P(0:3,NEXTERNAL)
      DATA IC/NEXTERNAL*1/
      REAL*16 ANS(3,0:NSQUAREDSO)
      COMPLEX*32 COEFS(MAXLWFSIZE,0:VERTEXMAXCOEFS-1,MAXLWFSIZE)
      COMPLEX*32 CFTOT
C
C     FUNCTIONS
C
      INTEGER MG5_1_ML5SOINDEX_FOR_BORN_AMP
      INTEGER MG5_1_ML5SOINDEX_FOR_LOOP_AMP
      INTEGER MG5_1_ML5SQSOINDEX
C
C     GLOBAL VARIABLES
C
      INCLUDE 'mp_coupl_same_name.inc'

      LOGICAL CHECKPHASE, HELDOUBLECHECKED
      COMMON/MG5_1_INIT/CHECKPHASE, HELDOUBLECHECKED

      INTEGER HELOFFSET
      INTEGER GOODHEL(NCOMB)
      LOGICAL GOODAMP(NSQUAREDSO,NLOOPGROUPS)
      COMMON/MG5_1_FILTERS/GOODAMP,GOODHEL,HELOFFSET

      INTEGER HELPICKED
      COMMON/MG5_1_HELCHOICE/HELPICKED

      INTEGER USERHEL
      COMMON/MG5_1_USERCHOICE/USERHEL

      INTEGER SQSO_TARGET
      COMMON/MG5_1_SOCHOICE/SQSO_TARGET

      LOGICAL UVCT_REQ_SO_DONE,MP_UVCT_REQ_SO_DONE,CT_REQ_SO_DONE
     $ ,MP_CT_REQ_SO_DONE,LOOP_REQ_SO_DONE,MP_LOOP_REQ_SO_DONE
     $ ,CTCALL_REQ_SO_DONE,FILTER_SO
      COMMON/MG5_1_SO_REQS/UVCT_REQ_SO_DONE,MP_UVCT_REQ_SO_DONE
     $ ,CT_REQ_SO_DONE,MP_CT_REQ_SO_DONE,LOOP_REQ_SO_DONE,MP_LOOP_REQ_S
     $ O_DONE,CTCALL_REQ_SO_DONE,FILTER_SO

      COMPLEX*32 AMP(NBORNAMPS)
      COMMON/MG5_1_MP_AMPS/AMP
      COMPLEX*16 DP_AMP(NBORNAMPS)
      COMMON/MG5_1_AMPS/DP_AMP
      COMPLEX*32 W(20,NWAVEFUNCS)
      COMMON/MG5_1_MP_W/W

      COMPLEX*16 DPW(20,NWAVEFUNCS)
      COMMON/MG5_1_W/DPW

      COMPLEX*32 WL(MAXLWFSIZE,0:LOOPMAXCOEFS-1,MAXLWFSIZE,0:NLOOPWAVEF
     $ UNCS)
      COMPLEX*32 PL(0:3,0:NLOOPWAVEFUNCS)
      COMMON/MG5_1_MP_WL/WL,PL

      COMPLEX*32 LOOPCOEFS(0:LOOPMAXCOEFS-1,NSQUAREDSO,NLOOPGROUPS)
      COMMON/MG5_1_MP_LCOEFS/LOOPCOEFS

      COMPLEX*32 AMPL(3,NCTAMPS)
      COMMON/MG5_1_MP_AMPL/AMPL

      INTEGER CF_D(NCOLORROWS,NBORNAMPS)
      INTEGER CF_N(NCOLORROWS,NBORNAMPS)
      COMMON/MG5_1_CF/CF_D,CF_N

      INTEGER HELC(NEXTERNAL,NCOMB)
      COMMON/MG5_1_HELCONFIGS/HELC

      LOGICAL MP_DONE_ONCE
      COMMON/MG5_1_MP_DONE_ONCE/MP_DONE_ONCE

C     ----------
C     BEGIN CODE
C     ----------

C     To be on the safe side, we always update the MP params here.
C     It can be redundant as this routine can be called a couple of
C      times for the same PS point during the stability checks.
C     But it is really not time consuming and I would rather be safe.
      CALL MP_UPDATE_AS_PARAM()

      MP_DONE_ONCE = .TRUE.

C     AS A SAFETY MEASURE WE FIRST COPY HERE THE PS POINT
      DO I=1,NEXTERNAL
        DO J=0,3
          P(J,I)=PS(J,I)
        ENDDO
      ENDDO

      DO I=0,3
        PL(I,0)=(ZERO,ZERO)
      ENDDO
      DO I=1,MAXLWFSIZE
        DO J=0,LOOPMAXCOEFS-1
          DO K=1,MAXLWFSIZE
            IF(I.EQ.K.AND.J.EQ.0) THEN
              WL(I,J,K,0)=(1.0E0_16,ZERO)
            ELSE
              WL(I,J,K,0)=(ZERO,ZERO)
            ENDIF
          ENDDO
        ENDDO
      ENDDO

      DO K=1, 3
        DO I=1,NCTAMPS
          AMPL(K,I)=(ZERO,ZERO)
        ENDDO
      ENDDO

      DO I=1, NBORNAMPS
        DP_AMP(I) = (0.0D0,0.0D0)
        AMP(I) = (ZERO, ZERO)
      ENDDO

      DO I=1,NLOOPGROUPS
        DO J=0,LOOPMAXCOEFS-1
          DO K=1,NSQUAREDSO
            LOOPCOEFS(J,K,I)=(ZERO,ZERO)
          ENDDO
        ENDDO
      ENDDO

      DO K=1,3
        DO J=0,NSQUAREDSO
          ANSDP(K,J)=0.0D0
          ANS(K,J)=ZERO
        ENDDO
      ENDDO

      DPW_COPIED = .FALSE.
      DO H=1,NCOMB
        IF ((HELPICKED.EQ.H).OR.((HELPICKED.EQ.-1).AND.(CHECKPHASE.OR.(
     $   .NOT.HELDOUBLECHECKED).OR.(GOODHEL(H).GT.-HELOFFSET.AND.GOODHE
     $   L(H).NE.0)))) THEN
          DO I=1,NEXTERNAL
            NHEL(I)=HELC(I,H)
          ENDDO

          MP_UVCT_REQ_SO_DONE=.FALSE.
          MP_CT_REQ_SO_DONE=.FALSE.
          MP_LOOP_REQ_SO_DONE=.FALSE.

          IF (.NOT.CHECKPHASE.AND.HELDOUBLECHECKED.AND.HELPICKED.EQ.
     $     -1) THEN
            HEL_MULT=GOODHEL(H)
          ELSE
            HEL_MULT=1
          ENDIF

          CALL MP_IXXXXX(P(0,1),ZERO,NHEL(1),+1*IC(1),W(1,1))
          CALL MP_OXXXXX(P(0,2),ZERO,NHEL(2),-1*IC(2),W(1,2))
          CALL MP_OXXXXX(P(0,3),ZERO,NHEL(3),+1*IC(3),W(1,3))
          CALL MP_IXXXXX(P(0,4),ZERO,NHEL(4),-1*IC(4),W(1,4))
          CALL MP_FFV1P0_3(W(1,1),W(1,2),GC_5,ZERO,ZERO,W(1,5))
C         Amplitude(s) for born diagram with ID 1
          CALL MP_FFV1_0(W(1,4),W(1,3),W(1,5),GC_5,AMP(1))
          CALL MP_FFV1P0_3(W(1,1),W(1,3),GC_5,ZERO,ZERO,W(1,6))
C         Amplitude(s) for born diagram with ID 2
          CALL MP_FFV1_0(W(1,4),W(1,2),W(1,6),GC_5,AMP(2))
          CALL MP_FFV1P0_3(W(1,4),W(1,3),GC_5,ZERO,ZERO,W(1,7))
C         Counter-term amplitude(s) for loop diagram number 3
          CALL MP_R2_GG_1_0(W(1,5),W(1,7),R2_GGQ,AMPL(1,1))
          CALL MP_R2_GG_1_0(W(1,5),W(1,7),R2_GGQ,AMPL(1,2))
          CALL MP_R2_GG_1_0(W(1,5),W(1,7),R2_GGQ,AMPL(1,3))
          CALL MP_R2_GG_1_0(W(1,5),W(1,7),R2_GGQ,AMPL(1,4))
          CALL MP_FFV1P0_3(W(1,4),W(1,2),GC_5,ZERO,ZERO,W(1,8))
C         Counter-term amplitude(s) for loop diagram number 4
          CALL MP_R2_GG_1_0(W(1,6),W(1,8),R2_GGQ,AMPL(1,5))
          CALL MP_R2_GG_1_0(W(1,6),W(1,8),R2_GGQ,AMPL(1,6))
          CALL MP_R2_GG_1_0(W(1,6),W(1,8),R2_GGQ,AMPL(1,7))
          CALL MP_R2_GG_1_0(W(1,6),W(1,8),R2_GGQ,AMPL(1,8))
C         Counter-term amplitude(s) for loop diagram number 5
          CALL MP_FFV1_0(W(1,4),W(1,3),W(1,5),UV_GQQQ_1EPS,AMPL(2,9))
          CALL MP_FFV1_0(W(1,4),W(1,3),W(1,5),UV_GQQQ_1EPS,AMPL(2,10))
          CALL MP_FFV1_0(W(1,4),W(1,3),W(1,5),UV_GQQQ_1EPS,AMPL(2,11))
          CALL MP_FFV1_0(W(1,4),W(1,3),W(1,5),UV_GQQQ_1EPS,AMPL(2,12))
          CALL MP_FFV1_0(W(1,4),W(1,3),W(1,5),UV_GQQB,AMPL(1,13))
          CALL MP_FFV1_0(W(1,4),W(1,3),W(1,5),UV_GQQQ_1EPS,AMPL(2,14))
          CALL MP_FFV1_0(W(1,4),W(1,3),W(1,5),UV_GQQT,AMPL(1,15))
          CALL MP_FFV1_0(W(1,4),W(1,3),W(1,5),UV_GQQQ_1EPS,AMPL(2,16))
          CALL MP_FFV1_0(W(1,4),W(1,3),W(1,5),UV_GQQG_1EPS,AMPL(2,17))
          CALL MP_FFV1_0(W(1,4),W(1,3),W(1,5),R2_GQQ,AMPL(1,18))
C         Counter-term amplitude(s) for loop diagram number 7
          CALL MP_FFV1_0(W(1,4),W(1,2),W(1,6),UV_GQQQ_1EPS,AMPL(2,19))
          CALL MP_FFV1_0(W(1,4),W(1,2),W(1,6),UV_GQQQ_1EPS,AMPL(2,20))
          CALL MP_FFV1_0(W(1,4),W(1,2),W(1,6),UV_GQQQ_1EPS,AMPL(2,21))
          CALL MP_FFV1_0(W(1,4),W(1,2),W(1,6),UV_GQQQ_1EPS,AMPL(2,22))
          CALL MP_FFV1_0(W(1,4),W(1,2),W(1,6),UV_GQQB,AMPL(1,23))
          CALL MP_FFV1_0(W(1,4),W(1,2),W(1,6),UV_GQQQ_1EPS,AMPL(2,24))
          CALL MP_FFV1_0(W(1,4),W(1,2),W(1,6),UV_GQQT,AMPL(1,25))
          CALL MP_FFV1_0(W(1,4),W(1,2),W(1,6),UV_GQQQ_1EPS,AMPL(2,26))
          CALL MP_FFV1_0(W(1,4),W(1,2),W(1,6),UV_GQQG_1EPS,AMPL(2,27))
          CALL MP_FFV1_0(W(1,4),W(1,2),W(1,6),R2_GQQ,AMPL(1,28))
C         Counter-term amplitude(s) for loop diagram number 9
          CALL MP_FFV1_0(W(1,1),W(1,3),W(1,8),UV_GQQQ_1EPS,AMPL(2,29))
          CALL MP_FFV1_0(W(1,1),W(1,3),W(1,8),UV_GQQQ_1EPS,AMPL(2,30))
          CALL MP_FFV1_0(W(1,1),W(1,3),W(1,8),UV_GQQQ_1EPS,AMPL(2,31))
          CALL MP_FFV1_0(W(1,1),W(1,3),W(1,8),UV_GQQQ_1EPS,AMPL(2,32))
          CALL MP_FFV1_0(W(1,1),W(1,3),W(1,8),UV_GQQB,AMPL(1,33))
          CALL MP_FFV1_0(W(1,1),W(1,3),W(1,8),UV_GQQQ_1EPS,AMPL(2,34))
          CALL MP_FFV1_0(W(1,1),W(1,3),W(1,8),UV_GQQT,AMPL(1,35))
          CALL MP_FFV1_0(W(1,1),W(1,3),W(1,8),UV_GQQQ_1EPS,AMPL(2,36))
          CALL MP_FFV1_0(W(1,1),W(1,3),W(1,8),UV_GQQG_1EPS,AMPL(2,37))
          CALL MP_FFV1_0(W(1,1),W(1,3),W(1,8),R2_GQQ,AMPL(1,38))
C         Counter-term amplitude(s) for loop diagram number 13
          CALL MP_FFV1_0(W(1,1),W(1,2),W(1,7),UV_GQQQ_1EPS,AMPL(2,39))
          CALL MP_FFV1_0(W(1,1),W(1,2),W(1,7),UV_GQQQ_1EPS,AMPL(2,40))
          CALL MP_FFV1_0(W(1,1),W(1,2),W(1,7),UV_GQQQ_1EPS,AMPL(2,41))
          CALL MP_FFV1_0(W(1,1),W(1,2),W(1,7),UV_GQQQ_1EPS,AMPL(2,42))
          CALL MP_FFV1_0(W(1,1),W(1,2),W(1,7),UV_GQQB,AMPL(1,43))
          CALL MP_FFV1_0(W(1,1),W(1,2),W(1,7),UV_GQQQ_1EPS,AMPL(2,44))
          CALL MP_FFV1_0(W(1,1),W(1,2),W(1,7),UV_GQQT,AMPL(1,45))
          CALL MP_FFV1_0(W(1,1),W(1,2),W(1,7),UV_GQQQ_1EPS,AMPL(2,46))
          CALL MP_FFV1_0(W(1,1),W(1,2),W(1,7),UV_GQQG_1EPS,AMPL(2,47))
          CALL MP_FFV1_0(W(1,1),W(1,2),W(1,7),R2_GQQ,AMPL(1,48))
C         Counter-term amplitude(s) for loop diagram number 17
          CALL MP_R2_GG_1_R2_GG_3_0(W(1,5),W(1,7),R2_GGQ,R2_GGB,AMPL(1
     $     ,49))
C         Counter-term amplitude(s) for loop diagram number 18
          CALL MP_R2_GG_1_R2_GG_3_0(W(1,6),W(1,8),R2_GGQ,R2_GGB,AMPL(1
     $     ,50))
C         Counter-term amplitude(s) for loop diagram number 19
          CALL MP_R2_GG_1_R2_GG_3_0(W(1,5),W(1,7),R2_GGQ,R2_GGT,AMPL(1
     $     ,51))
C         Counter-term amplitude(s) for loop diagram number 20
          CALL MP_R2_GG_1_R2_GG_3_0(W(1,6),W(1,8),R2_GGQ,R2_GGT,AMPL(1
     $     ,52))
C         Counter-term amplitude(s) for loop diagram number 21
          CALL MP_R2_GG_1_R2_GG_2_0(W(1,5),W(1,7),R2_GGG_1,R2_GGG_2
     $     ,AMPL(1,53))
C         Counter-term amplitude(s) for loop diagram number 22
          CALL MP_R2_GG_1_R2_GG_2_0(W(1,6),W(1,8),R2_GGG_1,R2_GGG_2
     $     ,AMPL(1,54))
C         At this point, all CT amps needed for (QCD=6), i.e. of split
C          order ID=1, are computed.
          IF(FILTER_SO.AND.SQSO_TARGET.EQ.1) GOTO 2000
 2000     CONTINUE
          MP_CT_REQ_SO_DONE=.TRUE.

 3000     CONTINUE
          MP_UVCT_REQ_SO_DONE=.TRUE.

          DO I=1,NCTAMPS
            DO J=1,NBORNAMPS
              CFTOT=CMPLX(CF_N(I,J)/REAL(ABS(CF_D(I,J)),KIND=16)
     $         ,0.0E0_16,KIND=16)
              IF(CF_D(I,J).LT.0) CFTOT=CFTOT*IMAG1
              ITEMP = MG5_1_ML5SQSOINDEX(MG5_1_ML5SOINDEX_FOR_LOOP_AMP(
     $         I),MG5_1_ML5SOINDEX_FOR_BORN_AMP(J))
              IF (.NOT.FILTER_SO.OR.SQSO_TARGET.EQ.ITEMP) THEN
                DO K=1,3
                  TEMP2 = HEL_MULT*2.0E0_16*REAL(CFTOT*AMPL(K,I)
     $             *CONJG(AMP(J)),KIND=16)
                  ANS(K,ITEMP)=ANS(K,ITEMP)+TEMP2
                  ANS(K,0)=ANS(K,0)+TEMP2
                ENDDO
              ENDIF
            ENDDO
          ENDDO

C         Coefficient construction for loop diagram with ID 3
          CALL MP_FFV1L2_1(PL(0,0),W(1,5),GC_5,ZERO,ZERO,PL(0,1),COEFS)
          CALL MP_MG5_1_UPDATE_WL_0_1(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1
     $     ,1))
          CALL MP_FFV1L2_1(PL(0,1),W(1,7),GC_5,ZERO,ZERO,PL(0,2),COEFS)
          CALL MP_MG5_1_UPDATE_WL_1_1(WL(1,0,1,1),4,COEFS,4,4,WL(1,0,1
     $     ,2))
          CALL MP_MG5_1_CREATE_LOOP_COEFS(WL(1,0,1,2),2,4,1,1,4,55,H)
C         Coefficient construction for loop diagram with ID 4
          CALL MP_FFV1L2_1(PL(0,0),W(1,6),GC_5,ZERO,ZERO,PL(0,3),COEFS)
          CALL MP_MG5_1_UPDATE_WL_0_1(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1
     $     ,3))
          CALL MP_FFV1L2_1(PL(0,3),W(1,8),GC_5,ZERO,ZERO,PL(0,4),COEFS)
          CALL MP_MG5_1_UPDATE_WL_1_1(WL(1,0,1,3),4,COEFS,4,4,WL(1,0,1
     $     ,4))
          CALL MP_MG5_1_CREATE_LOOP_COEFS(WL(1,0,1,4),2,4,2,1,4,56,H)
C         Coefficient construction for loop diagram with ID 5
          CALL MP_FFV1L1P0_3(PL(0,0),W(1,3),GC_5,ZERO,ZERO,PL(0,5)
     $     ,COEFS)
          CALL MP_MG5_1_UPDATE_WL_0_0(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1
     $     ,5))
          CALL MP_FFV1L3_2(PL(0,5),W(1,4),GC_5,ZERO,ZERO,PL(0,6),COEFS)
          CALL MP_MG5_1_UPDATE_WL_0_1(WL(1,0,1,5),4,COEFS,4,4,WL(1,0,1
     $     ,6))
          CALL MP_FFV1L1_2(PL(0,6),W(1,5),GC_5,ZERO,ZERO,PL(0,7),COEFS)
          CALL MP_MG5_1_UPDATE_WL_1_1(WL(1,0,1,6),4,COEFS,4,4,WL(1,0,1
     $     ,7))
          CALL MP_MG5_1_CREATE_LOOP_COEFS(WL(1,0,1,7),2,4,3,1,1,57,H)
C         Coefficient construction for loop diagram with ID 6
          CALL MP_FFV1L3_1(PL(0,0),W(1,3),GC_5,ZERO,ZERO,PL(0,8),COEFS)
          CALL MP_MG5_1_UPDATE_WL_0_1(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1
     $     ,8))
          CALL MP_FFV1L2P0_3(PL(0,8),W(1,4),GC_5,ZERO,ZERO,PL(0,9)
     $     ,COEFS)
          CALL MP_MG5_1_UPDATE_WL_1_0(WL(1,0,1,8),4,COEFS,4,4,WL(1,0,1
     $     ,9))
          CALL MP_VVV1L2P0_1(PL(0,9),W(1,5),GC_4,ZERO,ZERO,PL(0,10)
     $     ,COEFS)
          CALL MP_MG5_1_UPDATE_WL_1_1(WL(1,0,1,9),4,COEFS,4,4,WL(1,0,1
     $     ,10))
          CALL MP_MG5_1_CREATE_LOOP_COEFS(WL(1,0,1,10),2,4,3,1,1,58,H)
C         Coefficient construction for loop diagram with ID 7
          CALL MP_FFV1L1P0_3(PL(0,0),W(1,2),GC_5,ZERO,ZERO,PL(0,11)
     $     ,COEFS)
          CALL MP_MG5_1_UPDATE_WL_0_0(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1
     $     ,11))
          CALL MP_FFV1L3_2(PL(0,11),W(1,4),GC_5,ZERO,ZERO,PL(0,12)
     $     ,COEFS)
          CALL MP_MG5_1_UPDATE_WL_0_1(WL(1,0,1,11),4,COEFS,4,4,WL(1,0
     $     ,1,12))
          CALL MP_FFV1L1_2(PL(0,12),W(1,6),GC_5,ZERO,ZERO,PL(0,13)
     $     ,COEFS)
          CALL MP_MG5_1_UPDATE_WL_1_1(WL(1,0,1,12),4,COEFS,4,4,WL(1,0
     $     ,1,13))
          CALL MP_MG5_1_CREATE_LOOP_COEFS(WL(1,0,1,13),2,4,4,1,1,59,H)
C         Coefficient construction for loop diagram with ID 8
          CALL MP_FFV1L3_1(PL(0,0),W(1,2),GC_5,ZERO,ZERO,PL(0,14)
     $     ,COEFS)
          CALL MP_MG5_1_UPDATE_WL_0_1(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1
     $     ,14))
          CALL MP_FFV1L2P0_3(PL(0,14),W(1,4),GC_5,ZERO,ZERO,PL(0,15)
     $     ,COEFS)
          CALL MP_MG5_1_UPDATE_WL_1_0(WL(1,0,1,14),4,COEFS,4,4,WL(1,0
     $     ,1,15))
          CALL MP_VVV1L2P0_1(PL(0,15),W(1,6),GC_4,ZERO,ZERO,PL(0,16)
     $     ,COEFS)
          CALL MP_MG5_1_UPDATE_WL_1_1(WL(1,0,1,15),4,COEFS,4,4,WL(1,0
     $     ,1,16))
          CALL MP_MG5_1_CREATE_LOOP_COEFS(WL(1,0,1,16),2,4,4,1,1,60,H)
C         Coefficient construction for loop diagram with ID 9
          CALL MP_FFV1L2P0_3(PL(0,0),W(1,1),GC_5,ZERO,ZERO,PL(0,17)
     $     ,COEFS)
          CALL MP_MG5_1_UPDATE_WL_0_0(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1
     $     ,17))
          CALL MP_FFV1L3_1(PL(0,17),W(1,3),GC_5,ZERO,ZERO,PL(0,18)
     $     ,COEFS)
          CALL MP_MG5_1_UPDATE_WL_0_1(WL(1,0,1,17),4,COEFS,4,4,WL(1,0
     $     ,1,18))
          CALL MP_FFV1L2_1(PL(0,18),W(1,8),GC_5,ZERO,ZERO,PL(0,19)
     $     ,COEFS)
          CALL MP_MG5_1_UPDATE_WL_1_1(WL(1,0,1,18),4,COEFS,4,4,WL(1,0
     $     ,1,19))
          CALL MP_MG5_1_CREATE_LOOP_COEFS(WL(1,0,1,19),2,4,5,1,1,61,H)
C         Coefficient construction for loop diagram with ID 10
          CALL MP_FFV1L3_2(PL(0,0),W(1,1),GC_5,ZERO,ZERO,PL(0,20)
     $     ,COEFS)
          CALL MP_MG5_1_UPDATE_WL_0_1(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1
     $     ,20))
          CALL MP_FFV1L1P0_3(PL(0,20),W(1,3),GC_5,ZERO,ZERO,PL(0,21)
     $     ,COEFS)
          CALL MP_MG5_1_UPDATE_WL_1_0(WL(1,0,1,20),4,COEFS,4,4,WL(1,0
     $     ,1,21))
          CALL MP_VVV1L2P0_1(PL(0,21),W(1,8),GC_4,ZERO,ZERO,PL(0,22)
     $     ,COEFS)
          CALL MP_MG5_1_UPDATE_WL_1_1(WL(1,0,1,21),4,COEFS,4,4,WL(1,0
     $     ,1,22))
          CALL MP_MG5_1_CREATE_LOOP_COEFS(WL(1,0,1,22),2,4,5,1,1,62,H)
C         Coefficient construction for loop diagram with ID 11
          CALL MP_FFV1L1P0_3(PL(0,20),W(1,2),GC_5,ZERO,ZERO,PL(0,23)
     $     ,COEFS)
          CALL MP_MG5_1_UPDATE_WL_1_0(WL(1,0,1,20),4,COEFS,4,4,WL(1,0
     $     ,1,23))
          CALL MP_FFV1L3_2(PL(0,23),W(1,4),GC_5,ZERO,ZERO,PL(0,24)
     $     ,COEFS)
          CALL MP_MG5_1_UPDATE_WL_1_1(WL(1,0,1,23),4,COEFS,4,4,WL(1,0
     $     ,1,24))
          CALL MP_FFV1L1P0_3(PL(0,24),W(1,3),GC_5,ZERO,ZERO,PL(0,25)
     $     ,COEFS)
          CALL MP_MG5_1_UPDATE_WL_2_0(WL(1,0,1,24),4,COEFS,4,4,WL(1,0
     $     ,1,25))
          CALL MP_MG5_1_CREATE_LOOP_COEFS(WL(1,0,1,25),2,4,6,1,1,63,H)
C         Coefficient construction for loop diagram with ID 12
          CALL MP_FFV1L3_1(PL(0,23),W(1,3),GC_5,ZERO,ZERO,PL(0,26)
     $     ,COEFS)
          CALL MP_MG5_1_UPDATE_WL_1_1(WL(1,0,1,23),4,COEFS,4,4,WL(1,0
     $     ,1,26))
          CALL MP_FFV1L2P0_3(PL(0,26),W(1,4),GC_5,ZERO,ZERO,PL(0,27)
     $     ,COEFS)
          CALL MP_MG5_1_UPDATE_WL_2_0(WL(1,0,1,26),4,COEFS,4,4,WL(1,0
     $     ,1,27))
          CALL MP_MG5_1_CREATE_LOOP_COEFS(WL(1,0,1,27),2,4,7,1,1,64,H)
C         Coefficient construction for loop diagram with ID 13
          CALL MP_VVV1L2P0_1(PL(0,23),W(1,7),GC_4,ZERO,ZERO,PL(0,28)
     $     ,COEFS)
          CALL MP_MG5_1_UPDATE_WL_1_1(WL(1,0,1,23),4,COEFS,4,4,WL(1,0
     $     ,1,28))
          CALL MP_MG5_1_CREATE_LOOP_COEFS(WL(1,0,1,28),2,4,8,1,1,65,H)
C         Coefficient construction for loop diagram with ID 14
          CALL MP_FFV1L3_1(PL(0,17),W(1,2),GC_5,ZERO,ZERO,PL(0,29)
     $     ,COEFS)
          CALL MP_MG5_1_UPDATE_WL_0_1(WL(1,0,1,17),4,COEFS,4,4,WL(1,0
     $     ,1,29))
          CALL MP_FFV1L2_1(PL(0,29),W(1,7),GC_5,ZERO,ZERO,PL(0,30)
     $     ,COEFS)
          CALL MP_MG5_1_UPDATE_WL_1_1(WL(1,0,1,29),4,COEFS,4,4,WL(1,0
     $     ,1,30))
          CALL MP_MG5_1_CREATE_LOOP_COEFS(WL(1,0,1,30),2,4,8,1,1,66,H)
C         Coefficient construction for loop diagram with ID 15
          CALL MP_FFV1L2P0_3(PL(0,29),W(1,4),GC_5,ZERO,ZERO,PL(0,31)
     $     ,COEFS)
          CALL MP_MG5_1_UPDATE_WL_1_0(WL(1,0,1,29),4,COEFS,4,4,WL(1,0
     $     ,1,31))
          CALL MP_FFV1L3_1(PL(0,31),W(1,3),GC_5,ZERO,ZERO,PL(0,32)
     $     ,COEFS)
          CALL MP_MG5_1_UPDATE_WL_1_1(WL(1,0,1,31),4,COEFS,4,4,WL(1,0
     $     ,1,32))
          CALL MP_MG5_1_CREATE_LOOP_COEFS(WL(1,0,1,32),2,4,6,1,1,67,H)
C         Coefficient construction for loop diagram with ID 16
          CALL MP_FFV1L3_1(PL(0,21),W(1,2),GC_5,ZERO,ZERO,PL(0,33)
     $     ,COEFS)
          CALL MP_MG5_1_UPDATE_WL_1_1(WL(1,0,1,21),4,COEFS,4,4,WL(1,0
     $     ,1,33))
          CALL MP_FFV1L2P0_3(PL(0,33),W(1,4),GC_5,ZERO,ZERO,PL(0,34)
     $     ,COEFS)
          CALL MP_MG5_1_UPDATE_WL_2_0(WL(1,0,1,33),4,COEFS,4,4,WL(1,0
     $     ,1,34))
          CALL MP_MG5_1_CREATE_LOOP_COEFS(WL(1,0,1,34),2,4,9,1,1,68,H)
C         Coefficient construction for loop diagram with ID 17
          CALL MP_FFV1L2_1(PL(0,0),W(1,5),GC_5,MDL_MB,ZERO,PL(0,35)
     $     ,COEFS)
          CALL MP_MG5_1_UPDATE_WL_0_1(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1
     $     ,35))
          CALL MP_FFV1L2_1(PL(0,35),W(1,7),GC_5,MDL_MB,ZERO,PL(0,36)
     $     ,COEFS)
          CALL MP_MG5_1_UPDATE_WL_1_1(WL(1,0,1,35),4,COEFS,4,4,WL(1,0
     $     ,1,36))
          CALL MP_MG5_1_CREATE_LOOP_COEFS(WL(1,0,1,36),2,4,10,1,1,69,H)
C         Coefficient construction for loop diagram with ID 18
          CALL MP_FFV1L2_1(PL(0,0),W(1,6),GC_5,MDL_MB,ZERO,PL(0,37)
     $     ,COEFS)
          CALL MP_MG5_1_UPDATE_WL_0_1(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1
     $     ,37))
          CALL MP_FFV1L2_1(PL(0,37),W(1,8),GC_5,MDL_MB,ZERO,PL(0,38)
     $     ,COEFS)
          CALL MP_MG5_1_UPDATE_WL_1_1(WL(1,0,1,37),4,COEFS,4,4,WL(1,0
     $     ,1,38))
          CALL MP_MG5_1_CREATE_LOOP_COEFS(WL(1,0,1,38),2,4,11,1,1,70,H)
C         Coefficient construction for loop diagram with ID 19
          CALL MP_FFV1L2_1(PL(0,0),W(1,5),GC_5,MDL_MT,MDL_WT,PL(0,39)
     $     ,COEFS)
          CALL MP_MG5_1_UPDATE_WL_0_1(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1
     $     ,39))
          CALL MP_FFV1L2_1(PL(0,39),W(1,7),GC_5,MDL_MT,MDL_WT,PL(0,40)
     $     ,COEFS)
          CALL MP_MG5_1_UPDATE_WL_1_1(WL(1,0,1,39),4,COEFS,4,4,WL(1,0
     $     ,1,40))
          CALL MP_MG5_1_CREATE_LOOP_COEFS(WL(1,0,1,40),2,4,12,1,1,71,H)
C         Coefficient construction for loop diagram with ID 20
          CALL MP_FFV1L2_1(PL(0,0),W(1,6),GC_5,MDL_MT,MDL_WT,PL(0,41)
     $     ,COEFS)
          CALL MP_MG5_1_UPDATE_WL_0_1(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1
     $     ,41))
          CALL MP_FFV1L2_1(PL(0,41),W(1,8),GC_5,MDL_MT,MDL_WT,PL(0,42)
     $     ,COEFS)
          CALL MP_MG5_1_UPDATE_WL_1_1(WL(1,0,1,41),4,COEFS,4,4,WL(1,0
     $     ,1,42))
          CALL MP_MG5_1_CREATE_LOOP_COEFS(WL(1,0,1,42),2,4,13,1,1,72,H)
C         Coefficient construction for loop diagram with ID 21
          CALL MP_VVV1L2P0_1(PL(0,0),W(1,5),GC_4,ZERO,ZERO,PL(0,43)
     $     ,COEFS)
          CALL MP_MG5_1_UPDATE_WL_0_1(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1
     $     ,43))
          CALL MP_VVV1L2P0_1(PL(0,43),W(1,7),GC_4,ZERO,ZERO,PL(0,44)
     $     ,COEFS)
          CALL MP_MG5_1_UPDATE_WL_1_1(WL(1,0,1,43),4,COEFS,4,4,WL(1,0
     $     ,1,44))
          CALL MP_MG5_1_CREATE_LOOP_COEFS(WL(1,0,1,44),2,4,1,2,1,73,H)
C         Coefficient construction for loop diagram with ID 22
          CALL MP_VVV1L2P0_1(PL(0,0),W(1,6),GC_4,ZERO,ZERO,PL(0,45)
     $     ,COEFS)
          CALL MP_MG5_1_UPDATE_WL_0_1(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1
     $     ,45))
          CALL MP_VVV1L2P0_1(PL(0,45),W(1,8),GC_4,ZERO,ZERO,PL(0,46)
     $     ,COEFS)
          CALL MP_MG5_1_UPDATE_WL_1_1(WL(1,0,1,45),4,COEFS,4,4,WL(1,0
     $     ,1,46))
          CALL MP_MG5_1_CREATE_LOOP_COEFS(WL(1,0,1,46),2,4,2,2,1,74,H)
C         Coefficient construction for loop diagram with ID 23
          CALL MP_GHGHGL2_1(PL(0,0),W(1,5),GC_4,ZERO,ZERO,PL(0,47)
     $     ,COEFS)
          CALL MP_MG5_1_UPDATE_WL_0_1(WL(1,0,1,0),1,COEFS,1,1,WL(1,0,1
     $     ,47))
          CALL MP_GHGHGL2_1(PL(0,47),W(1,7),GC_4,ZERO,ZERO,PL(0,48)
     $     ,COEFS)
          CALL MP_MG5_1_UPDATE_WL_1_1(WL(1,0,1,47),1,COEFS,1,1,WL(1,0
     $     ,1,48))
          CALL MP_MG5_1_CREATE_LOOP_COEFS(WL(1,0,1,48),2,1,1,1,1,75,H)
C         Coefficient construction for loop diagram with ID 24
          CALL MP_GHGHGL2_1(PL(0,0),W(1,6),GC_4,ZERO,ZERO,PL(0,49)
     $     ,COEFS)
          CALL MP_MG5_1_UPDATE_WL_0_1(WL(1,0,1,0),1,COEFS,1,1,WL(1,0,1
     $     ,49))
          CALL MP_GHGHGL2_1(PL(0,49),W(1,8),GC_4,ZERO,ZERO,PL(0,50)
     $     ,COEFS)
          CALL MP_MG5_1_UPDATE_WL_1_1(WL(1,0,1,49),1,COEFS,1,1,WL(1,0
     $     ,1,50))
          CALL MP_MG5_1_CREATE_LOOP_COEFS(WL(1,0,1,50),2,1,2,1,1,76,H)
C         At this point, all loop coefficients needed for (QCD=6),
C          i.e. of split order ID=1, are computed.
          IF(FILTER_SO.AND.SQSO_TARGET.EQ.1) GOTO 4000
 4000     CONTINUE
          MP_LOOP_REQ_SO_DONE=.TRUE.

C         Copy the qp wfs to the dp ones as they are used to setup the
C          CT calls.
C         This needs to be done once since only the momenta of these
C          WF matters.
          IF(.NOT.DPW_COPIED) THEN
            DO I=1,NWAVEFUNCS
              DO J=1,MAXLWFSIZE+4
                DPW(J,I)=DBLE(W(J,I))
              ENDDO
            ENDDO
            DPW_COPIED=.TRUE.
          ENDIF

        ENDIF
      ENDDO

      DO I=1,3
        DO J=0,NSQUAREDSO
          ANSDP(I,J)=ANS(I,J)
        ENDDO
      ENDDO

C     Grouping of loop diagrams now done directly when creating the
C      LOOPCOEFS.

      END


!-----------------------------------------------------------------------
      subroutine w3ctzdat(ntz,idat,jdat)
!$$$   SUBPROGRAM  DOCUMENTATION  BLOCK
!
! SUBPROGRAM: W3CTZDAT       CHANGE THE TIME ZONE OF A DATE AND TIME
!   AUTHOR: MARK IREDELL     ORG: WP23       DATE: 98-01-05
!
! ABSTRACT: THIS SUBPROGRAM CONVERTS AN NCEP ABSOLUTE DATE AND TIME
!   TO ANOTHER TIME ZONE.
!
! PROGRAM HISTORY LOG:
!   98-01-05  MARK IREDELL
!
! USAGE:  CALL W3CTZDAT(NTZ,IDAT,JDAT)
!
!   INPUT VARIABLES:
!     NTZ        INTEGER NEW TIME ZONE DIFFERENTIAL FROM UTC
!                IN SIGNED HH OR HHMM FORMAT
!                (IF NTZ IS INVALID, NO CHANGE IS MADE.)
!     IDAT       INTEGER (8) NCEP ABSOLUTE DATE AND TIME
!                (YEAR, MONTH, DAY, TIME ZONE,
!                 HOUR, MINUTE, SECOND, MILLISECOND)
!
!   OUTPUT VARIABLES:
!     JDAT       INTEGER (8) NCEP ABSOLUTE DATE AND TIME
!                (YEAR, MONTH, DAY, TIME ZONE,
!                 HOUR, MINUTE, SECOND, MILLISECOND)
!
! SUBPROGRAMS CALLED:
!     IW3JDN         COMPUTE JULIAN DAY NUMBER
!     W3FS26         YEAR, MONTH, DAY FROM JULIAN DAY NUMBER
!     W3REDDAT       REDUCE A TIME INTERVAL TO A CANONICAL FORM
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
      integer idat(8),jdat(8)
      real rinc1(5),rinc2(5)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  determine if the input time zone is in valid hh or hhmm format
      if(ntz.gt.-24.and.ntz.lt.24) then
        itz=ntz*100
      elseif(ntz.eq.mod(ntz/100,24)*100+mod(mod(ntz,100),60)/30*30) then
        itz=ntz
      else
        itz=idat(4)
      endif
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  determine new time of day, putting into reduced form
!  and possibly adjust the date as well
      rinc1(1)=0
      rinc1(2)=idat(5)+itz/100-idat(4)/100
      rinc1(3)=idat(6)+mod(itz,100)-mod(idat(4),100)
      rinc1(4)=idat(7)
      rinc1(5)=idat(8)
      call w3reddat(-1,rinc1,rinc2)
      jldayn=iw3jdn(idat(1),idat(2),idat(3))+nint(rinc2(1))
      call w3fs26(jldayn,jdat(1),jdat(2),jdat(3),jdow,jdoy)
      jdat(4)=itz
      jdat(5:8)=nint(rinc2(2:5))
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      end


      subroutine rdmvc(x0,y0,xm,ym,dl)
C.....subroutine rdmvc  01/06/75     01/01/80
      common/gfgel/gf(28)
      if(gf(9).ge.0.) call strmod(0)
      i=abs(gf(9))
      if(gf(i).ne.0.) goto 5
      x0=gf(i+1)
      y0=gf(i+2)
      delx=gf(i+6)-gf(i+1)
      dely=gf(i+7)-gf(i+2)
      xm=gf(i+1)+delx/2
      ym=gf(i+2)+dely/2
      dl=sqrt(delx**2+dely**2)
      goto 6
  5   call gffals(6)
  6   if(gf(9).gt.0.) call strmod(0)
      return
      end