C******************** START FILE INT2D.FOR ; GROUP INT2D ***************
C****************************************************
C  REV D. MC CUNE AUG 1982 - NO SIGN CHECK IS MADE.  ROUTINE
C  GENERALIZED TO HANDLE FUNCTIONS WHICH ARE NOT POSITIVE-DEFINITE
C
C  dmc 3/2008 -- clean up some FORMAT stmts
C
      SUBROUTINE INT2D(ZTDAT , ITDAT1,
     1			 ZRDAT , IRDAT1,
     2			 ZDAT2D, ITIM2D, IRDAT2,
     3			 ZTINT ,
     4			 ZRINT , IZRINT, ZOUT1D,
     5			 ZSLOPI,
     6			 INTTYP, ILDBUG, IERR, IOUT)
C
C   2.25   INTERPOLATE A 2-D ARRAY FNC. OF T&R TO GET
C	   A 1-D VECTOR FNC. OF R AT A GIVEN TIME
C
C=======
C  D. MC CUNE 11 JUNE 1981-- ADDED OUTPUT CHANNEL "IOUT"
C  REPLACES "TYPE" STATEMENTS
C=======
C   AUTHOR: BOB MCCANN, JAN.81
C
!============
! idecl:  explicitize implicit INTEGER declarations:
      IMPLICIT NONE
      INTEGER, PARAMETER :: R8=SELECTED_REAL_KIND(12,100)
      INTEGER irdat1,itim2d,irdat2,izrint,iout,itdat1,iclass,isub
      INTEGER icall,ihuge,i,iminr,imaxr,irev,jt,j,jt1,jt2,irdm1,ilb
      INTEGER iub,mark,jub,jlb
!============
! idecl:  explicitize implicit REAL declarations:
      REAL*8 ztint,zmin,zrmin,zrmax,zright,zsign,zzmin,zdr,zleft,zr
      REAL*8 zr2,zr1,zdt,zdt1,zdt2,zrg2,zlf2,zdr1,zdr2
!============
      INTEGER	INTTYP		!INPUT CONTROL FOR B.C.'S
C				!AND INTERPOLATION TYPE(SPLINE,
C				!LINEAR, ETC.)
C
      REAL*8	ZTDAT(ITDAT1)	!INPUT TIME VECTOR
      REAL*8	ZRDAT(IRDAT1)	!INPUT RADIUS VECTOR
      REAL*8	ZDAT2D(ITIM2D,IRDAT2)	!INPUT 2D ARRAY
      REAL*8	ZRINT(IZRINT)	!RADIUS VECTOR FOR OUTPUT
      REAL*8	ZOUT1D(IZRINT)	!OUTPUT 1D VECTOR FNC. OF RADIUS
      REAL*8	ZSLOPE,ZSLOPI   !SLOPE FOR EXTRAP. BEYOND EDGES
C				!IN RADIAL DIRECTION
      LOGICAL	ILDBUG		!LOGICAL SWITCH FOR DEBUGGING
C
      INTEGER	IERR		!ERROR FLAG FOR RETURN
C
C****	INCLUDE 'TRCOM/NOLIST'	!THIS SHOULDN'T BE NECESSARY
C
C   THIS SUBROUTINE INTERPOLATES THE 2D ARRAY ZDAT2D TO GET
C   A SLICE AT CONSTANT TIME=ZTINT AS A FUNCTION OF RADIUS
C
C   IF ZTINT IS BEFORE ZTDAT(1) OR AFTER ZTDAT(ITDAT1), THEN
C   THE FIRST OR LAST SLICE AVAILABLE IS USED. OTHERWISE LINEAR
C   INTERPOLATION IS USED IN TIME AND RADIUS TO GET THE VALUES
C   TO BE PUT INTO ZOUT1D.
C
C   IF ANY ZRINT(J) RADII ARE OUTSIDE ZRDAT(J) THEN THE END-
C   POINT VALUES ARE USED ACCORDING TO THE VALUES OF  INTTYP
C   AS FOLLOWS:
C
C	INTTYP.EQ.0     !no extrapolation -- out of range data = 0.0
C	INTTYP.EQ. 1	!FLAT EXTRAP. IN R
C	INTTYP.EQ.2	!LINEAR EXTRAPOLATION WITH SLOPE=ZSLOPI
C       INTTYP.EQ.3     !EXTRAP. WITH CONSTANT SLOPE.
C			!FOR BOTH SIDES IN R
C
C
      DATA	IHUGE/1000000/		!CRAZY TO INT.THIS MANY
C
C  PARM. TO PREVENT EXTRAPOLATION TO NEGATIVE NUMBERS
C  QUICK FIX D. MC CUNE 2 FEB 1982
C   EXTRAPOLATION TO .LT. ZMIN*EDGE VALUE EXTRAPOLATED FROM DISALLOWED
      DATA ZMIN/.05_R8/
C****************************************************
C
      ZSLOPE=ZSLOPI
      IERR = 0
C
C-----------------------
C   CHECK FOR BAD INPUTS
C-----------------------
C
      IF(IRDAT1.LT.2 .OR. IRDAT1.GT.IHUGE)GO TO 40100
      IF(IRDAT2.LT.2 .OR. IRDAT2.GT.IHUGE)GO TO 40120
      IF(IZRINT.LT.1 .OR. IZRINT.GT.IHUGE)GO TO 40200
      IF(ITDAT1.LT.1 .OR. ITDAT1.GT.IHUGE)GO TO 40300
      IF(ITIM2D.LT.1 .OR. ITIM2D.GT.IHUGE)GO TO 40320
      IF(IRDAT1.GT.IRDAT2)GO TO 40330
      IF(ITDAT1.GT.ITIM2D)GO TO 40340
C
      IF((INTTYP.LT.0).OR.(INTTYP.GT.3)) GO TO 40800
C
C   CHECK THE ORDER OF THE VECTORS
C
      DO 10 I = 1, IRDAT1-1
        IF(ZRDAT(I).GE.ZRDAT(I+1))GO TO 40400
10    CONTINUE
C
      IF(IZRINT.LE.1)GO TO 30
      DO 20 I = 1, IZRINT-1
        IF(ZRINT(I).GE.ZRINT(I+1))GO TO 40500
20    CONTINUE
C
30    CONTINUE
C
      IF(ITDAT1.LE.1)GO TO 50
      DO 40 I = 1, ITDAT1-1
        IF(ZTDAT(I).GE.ZTDAT(I+1))GO TO 40600
40    CONTINUE
C
50    CONTINUE
C
C-------------------------------
C   SET UP FOR THE INTERPOLATION
C-------------------------------
C
C
C   FIND THE INDICES FOR WHICH RADIAL INTERP IS DEFAULTED
C
      ZRMIN = ZRDAT(1)
      IMINR = 0
      ZRMAX = ZRDAT(IRDAT1)
      IMAXR = IZRINT + 1
C
      DO 100 I = 1, IZRINT
        IREV = IZRINT+1-I
        IF(ZRDAT(1).GT.ZRINT(I)) IMINR = I
        IF(ZRDAT(IRDAT1).LT.ZRINT(IREV)) IMAXR = IREV
100   CONTINUE
C
      IF(ILDBUG)WRITE(IOUT,101) ZRDAT(1),ZRDAT(IRDAT1),IMINR,IMAXR,
     1			  ZRINT(1),ZRINT(IZRINT)
C
101   FORMAT(' INT2D DBUG: ZRDATMIN,ZRDATMAX,IMINR,IMAXR,',/,
     1		' ZRLEFT,ZRIGHT=',2(1PE13.6),2I5,2(1PE13.6))
C
C   FIND THE TIME INDEX. I.E. INTERP BETWEEN JT1 & JT2
C
      JT = 0
C
      DO 200 J = 1, ITDAT1
        IF(ZTDAT(J).LE.ZTINT)JT = J
200   CONTINUE
C
      JT1 = max(1,JT)
      JT2 = min(ITDAT1,JT+1)
C
C   DO THE DEFAULT ANSWERS IF OUT OF BOUNDS
C   THE RADIAL VALUES ARE DEFAULTED FOR  I.LE.IMINR  AND  I.GE.IMAXR
C   THE ENTIRE VECTOR IS DEFAULTED IF JT=0 OR JT=ITDAT1
C
C
C---------------------------------------------------------
C   DO THE TIME DEFAULTED CASE FIRST (ZTINT OUT OF RANGE)
C---------------------------------------------------------
C
C
      IF(JT1.NE.JT2)GO TO 5000	!DO THE 4-POINT THERE
C
C	DO THE LEFT SIDE DEFAULT FIRST
C
      IF(IMINR.LT.1)GO TO 1000
C
      ZRIGHT = ZDAT2D(JT1,1)
      IF(INTTYP.EQ.3) ZSLOPE=(ZDAT2D(JT1,2)-ZDAT2D(JT1,1))/
     >                          (ZRDAT(2)-ZRDAT(1))
C  SIGN GENERALIZATION - EXTRAPOLATION NOT ALLOWED TO CHANGE SIGN
C  (PREVIOUSLY FORCED POSITIVE)
      ZSIGN=SIGN(1.0_R8,ZRIGHT)
      ZZMIN=ZMIN*ZRIGHT*ZSIGN
      ZDR = ZRDAT(1) - ZRINT(1)
      ZLEFT = ZDAT2D(JT1,1) - ZSLOPE*ZDR	!RMAJOR SIDE
C
      DO 500 I = 1, IMINR
        IF(INTTYP.EQ.0) THEN
          ZOUT1D(I)=0.0_R8
        ELSE IF(INTTYP.EQ.1) THEN
          ZOUT1D(I) = ZRIGHT	    !CONST.EXTRAP
        ELSE
          ZOUT1D(I) =  ZSIGN * max(ZZMIN,
     1		ZSIGN * ((ZRDAT(1)-ZRINT(I))*ZLEFT/ZDR +
     2		(ZRINT(I) - ZRINT(1))*ZRIGHT/ZDR)  )
        ENDIF
C	THAT'S THE LINEAR EXTRAP.
500   CONTINUE
C
1000  CONTINUE
C
C   	DO THE RIGHT SIDE DEFAULT NEXT
C
      IF(IMAXR.GT.IZRINT)GO TO 2000	!THEN DO THE INTERIOR
C
      IRDM1=IRDAT1-1
      IF(INTTYP.EQ.3) ZSLOPE=(ZDAT2D(JT1,IRDAT1)-ZDAT2D(JT1,IRDM1))/
     >                          (ZRDAT(IRDAT1)-ZRDAT(IRDM1))
      ZLEFT  = ZDAT2D(JT1,IRDAT1)
      ZSIGN=SIGN(1.0_R8,ZLEFT)
      ZZMIN=ZMIN*ZLEFT*ZSIGN
      ZDR = ZRINT(IZRINT) - ZRDAT(IRDAT1)
      ZRIGHT = ZLEFT + ZSLOPE*ZDR
C
      DO 1500 I = IMAXR, IZRINT
        IF(INTTYP.EQ.0) THEN
          ZOUT1D(I)=0.0_R8
        ELSE IF(INTTYP.EQ.1) THEN
          ZOUT1D(I) = ZLEFT	!CONST.EXTRAP
        ELSE
          ZOUT1D(I) = ZSIGN * max(ZZMIN,
     1		ZSIGN * ((ZRINT(IZRINT)-ZRINT(I))*ZLEFT/ZDR +
     2		(ZRINT(I) - ZRDAT(IRDAT1))*ZRIGHT/ZDR)  )
        ENDIF
C	THAT'S THE LINEAR EXTRAP
1500  CONTINUE
C
C	THEN DO THE INTERIOR
C
2000  CONTINUE
C
      IF( (IMINR+1).GT.(IMAXR-1) )GO TO 10000	!DONE
C
      ILB = IMINR+1
      IUB = IMAXR-1
      MARK = 1		!WE'LL BE MOVING THE L.B.
      JUB = IRDAT1 - 1
C
      DO 3000 I = ILB, IUB
        ZR = ZRINT(I)
        JLB = MARK		!NEVER DECREASE LOWER BOUND
C
        DO 3100 J = JLB, JUB
          MARK = J
          IF(ZRDAT(J).LE.ZR .AND. ZR.LE.ZRDAT(J+1))GO TO 3200
3100    CONTINUE
C
C		IF IT GOT HERE WE'RE IN DEEP TROUBLE
C
        GO TO 41000		!ERROR EXIT
C
C   DO THE INTERPOLATION HERE
C
3200    CONTINUE
C
        ZDR = ZRDAT(MARK+1) - ZRDAT(MARK)
        ZR2= (ZRDAT(MARK+1) - ZR)/ZDR
        ZR1 = (ZR - ZRDAT(MARK))/ZDR
C
        ZOUT1D(I)=ZR2*ZDAT2D(JT1,MARK)+ZR1*ZDAT2D(JT1,MARK+1)
C
3000  CONTINUE
C
      GO TO 10000				!DONE
C
C
C------------------------------------
C   DO THE FULL 2D INTERPOLATION HERE
C------------------------------------
C
C
5000  CONTINUE
C
      ZDT = ZTDAT(JT2) - ZTDAT(JT1)
      ZDT1 = (ZTINT - ZTDAT(JT1))/ZDT
      ZDT2 = (ZTDAT(JT2) - ZTINT)/ZDT
C
C	DO THE LEFT SIDE DEFAULT FIRST
C
      IF(IMINR.LT.1)GO TO 5200
C
      ZRIGHT = ZDT2*ZDAT2D(JT1,1) + ZDT1*ZDAT2D(JT2,1)
      IF(INTTYP.EQ.3) THEN
        ZRG2= ZDT2*ZDAT2D(JT1,2)+ZDT1*ZDAT2D(JT2,2)
        ZSLOPE=(ZRG2-ZRIGHT)/(ZRDAT(2)-ZRDAT(1))
      ENDIF
      ZSIGN=SIGN(1.0_R8,ZRIGHT)
      ZZMIN=ZMIN*ZRIGHT*ZSIGN
      ZDR = ZRDAT(1) - ZRINT(1)
      ZLEFT = ZDAT2D(JT1,1) - ZSLOPE*ZDR
C
      DO 5100 I = 1, IMINR
        IF(INTTYP.EQ.0) THEN
          ZOUT1D(I)=0.0_R8
        ELSE IF(INTTYP.EQ.1) THEN
          ZOUT1D(I) = ZRIGHT	!CONST. EXTRAP
        ELSE
      	ZOUT1D(I) = ZSIGN*max(ZZMIN,
     >             ZSIGN * ((ZRDAT(1)-ZRINT(I))*ZLEFT/ZDR
     2			+   (ZRINT(I)-ZRINT(1))*ZRIGHT/ZDR)  )
        ENDIF
C	THAT'S THE LINEAR EXTRAP
5100  CONTINUE
C
5200  CONTINUE
C
C	DO THE RIGHT SIDE DEFAULT NEXT
C
      IF(IMAXR.GT.IZRINT)GO TO 5400
C
      ZLEFT = ZDT2*ZDAT2D(JT1,IRDAT1)+ZDT1*ZDAT2D(JT2,IRDAT1)
      IF(INTTYP.EQ.3) THEN
        IRDM1=IRDAT1-1
        ZLF2=ZDT2*ZDAT2D(JT1,IRDM1)+ZDT1*ZDAT2D(JT2,IRDM1)
        ZSLOPE=(ZLEFT-ZLF2)/(ZRDAT(IRDAT1)-ZRDAT(IRDM1))
      ENDIF
      ZSIGN=SIGN(1.0_R8,ZLEFT)
      ZZMIN=ZMIN*ZLEFT*ZSIGN
      ZDR = ZRINT(IZRINT) - ZRDAT(IRDAT1)
      ZRIGHT = ZLEFT + ZSLOPE*ZDR
C
      DO 5300 I = IMAXR, IZRINT
        IF(INTTYP.EQ.0) THEN
          ZOUT1D(I)=0.0_R8
        ELSE IF(INTTYP.EQ.1) THEN
          ZOUT1D(I) = ZLEFT	!CONST. EXTRAP
        ELSE
          ZOUT1D(I) = ZSIGN*max(ZZMIN,
     1		ZSIGN*((ZRINT(IZRINT)-ZRINT(I))*ZLEFT/ZDR +
     2		(ZRINT(I) - ZRDAT(IRDAT1))*ZRIGHT/ZDR)  )
        ENDIF
C	THAT'S THE LINEAR EXTRAP
5300  CONTINUE
C
5400  CONTINUE
C
C	THEN DO THE INTERIOR
C
      ILB = IMINR + 1
      IUB = IMAXR - 1
      MARK = 1
      JUB = IRDAT1 - 1
C
      IF(ILB.GT.IUB)GO TO 10000	!DONE
C
      DO 6000 I = ILB, IUB
        ZR = ZRINT(I)
        JLB = MARK		!NEVER STEP BACKWARDS
C
        DO 6100 J = JLB, JUB
          MARK = J
          IF(ZRDAT(J).LE.ZR .AND. ZR.LE.ZRDAT(J+1))GO TO 6200
6100    CONTINUE
C
C	IF IT GOT HERE WE'RE IN DEEP TROUBLE
C
      GO TO 41100		!ERROR EXIT
C
C   DO THE 4-POINT INTERPOLATION
C
6200    CONTINUE
C
        ZDR = ZRDAT(MARK+1) - ZRDAT(MARK)
        ZDR1 = (ZR - ZRDAT(MARK))/ZDR
        ZDR2 = (ZRDAT(MARK+1) - ZR)/ZDR
C
        ZOUT1D(I) = ZDT2*(ZDR2*ZDAT2D(JT1,MARK) +
     1			    ZDR1*ZDAT2D(JT1,MARK+1) )  +
     2		      ZDT1*(ZDR2*ZDAT2D(JT2,MARK) +
     3			    ZDR1*ZDAT2D(JT2,MARK+1) )
C
6000  CONTINUE
C
C   DONE!
C
10000 CONTINUE
C
C---------------------------------
C   FINAL CLEAN-UP & ERROR CHECK
C---------------------------------
C
CT	DO 10100 I = 1, IZRINT
CT	  ISAVE = I			!BOTH NE & TE MUST BE POS.
CT	  IF(ZOUT1D(I).LE.0.0)GO TO 40700
CT10100	CONTINUE
C
20000 CONTINUE		!GO HERE AFTER ERROR MSG.
      RETURN
C
C
C---------------------------------
C   ERROR HANDLING, MESSAGES, ETC.
C---------------------------------
C
C
40100 CONTINUE
      WRITE(IOUT,40101) IRDAT1, IHUGE
40101 FORMAT(' INT2D ERROR: IRDAT1 OUT OF BOUNDS. IRDAT1=',
     1		I10,/,' IRDAT1 RANGE=2 TO ',I10)
C
      IERR = 1
      GO TO 20000
C
40120 CONTINUE
      WRITE(IOUT,40121) IRDAT2, IHUGE
40121 FORMAT(' INT2D ERROR: IRDAT2 OUT OF BOUNDS. IRDAT2=',
     1		I10,/,' IRDAT2 RANGE=2 TO ',I10)
C
      IERR = 2
      GO TO 20000
C
40200 CONTINUE
      WRITE(IOUT,40201) IZRINT, IHUGE
40201 FORMAT(' INT2D ERROR: IZRINT OUT OF BOUNDS. IZRINT=',
     1		I10,/,' IZRINT RANGE=1 TO ',I10)
C
      IERR = 3
      GO TO 20000
C
40300 CONTINUE
      WRITE(IOUT,40301) ITDAT1, IHUGE
40301 FORMAT(' INT2D ERROR: ITDAT1 OUT OF BOUNDS. ITDAT1=',
     1		I10,/,' ITDAT1 RANGE=1 TO ',I10)
C
      IERR = 4
      GO TO 20000
C
40320 CONTINUE
      WRITE(IOUT,40321) ITIM2D, IHUGE
40321 FORMAT(' INT2D ERROR: ITIM2D OUT OF BOUNDS. ITIM2D=',
     1		I10,/,' ITIM2D RANGE=1 TO ',I10)
C
      IERR = 5
      GO TO 20000
C
40330 CONTINUE
      WRITE(IOUT,40331) IRDAT1, IRDAT2
40331 FORMAT(' INT2D ERROR: ARRAY DIMENSION ERROR;',/,
     1		' 1D RADIAL DIM. MUST BE .LE. 2D DIM.',/,
     2		' 1D DIM=',I6,' 2D DIM=',I6)
C
      IERR = 6
      GO TO 20000
C
40340 CONTINUE
      WRITE(IOUT,40341) ITDAT1, ITIM2D
40341 FORMAT(' INT2D ERROR: ARRAY DIMENSION ERROR;',/,
     1		' 1D TIME DIM. MUST BE .LE. 2D DIM.',/,
     2		' 1D DIM=',I6,' 2D DIM=',I6)
C
      IERR = 7
      GO TO 20000
C
40400 CONTINUE
      WRITE(IOUT,40401) ZRDAT
40401 FORMAT(' INT2D ERROR: ZRDAT MUST BE IN ASCENDING ORDER.'
     1		,/,' ZRDAT = ',/,(' ',5(1PE13.6)))
      write(iout,40699) 'ZRDAT',i,zrdat(i),'ZRDAT',i+1,zrdat(i+1)
C
      IERR = 8
      GO TO 20000
C
40500 CONTINUE
      WRITE(IOUT,40501) ZRINT
40501 FORMAT(' INT2D ERROR: ZRINT MUST HAVE ASCENDING ORDER.'
     1		,/,' ZRINT = ',/,(' ',5(1PE13.6)))
      write(iout,40699) 'ZRINT',i,zrint(i),'ZRINT',i+1,zrint(i+1)
C
      IERR = 9
      GO TO 20000
C
40600 CONTINUE
      WRITE(IOUT,40601) ZTDAT
40601 FORMAT(' INT2D ERROR: ZTDAT MUST HAVE ASCENDING ORDER.'
     1		,/,' ZTDAT = ',/,(' ',5(1PE13.6)))
      write(iout,40699) 'ZTDAT',i,ztdat(i),'ZTDAT',i+1,ztdat(i+1)
C
40699 format(4x,a,'(',i5,')=',1pe13.6,4x,a,'(',i5,')=',1pe13.6)
C
      IERR = 10
      GO TO 20000
C
CT40700	CONTINUE
CT	WRITE(IOUT,40701) ISAVE, (ZOUT1D(I),I=1,IZRINT)
CT40701	FORMAT(' INT2D ERROR: VAL(INDEX) MUST BE POSITIVE,',/,
CT     1		' INDEX=',I5,' VALUES=',/,(' ',5(1PE13.6)) )
C
CT	IERR = 11
CT	GO TO 20000
C
40800 CONTINUE
      WRITE(IOUT,40801) INTTYP
40801 FORMAT(' INT2D ERROR: INTERPOLATION TYPE =',I5,' NOT',
     1		' SUPPORTED')
C
      IERR = 12
      GO TO 20000
C
41000 CONTINUE
      WRITE(IOUT,41001) ZR, ZRDAT(1), ZRDAT(IRDAT1)
41001 FORMAT(' INT2D ERROR: R=',1pe13.6,' NOT IN RANGE',/,
     1		' ',1pe13.6,' .LE. R .LE. ',1pe13.6,/,
     2		' @TIME DEFAULT RADIAL EXTRAP. SOMETHING ',/,
     3		' IS LIKELY TO BE WRONG WITH IMINR OR IMAXR',/,
     4		' OR THEIR USE.')
C
      IERR = 13
      GO TO 20000
C
41100 CONTINUE
      WRITE(IOUT,41101) ZR, ZRDAT(1), ZRDAT(IRDAT1)
41101 FORMAT(' INT2D ERROR: R=',1pe13.6,' NOT IN RANGE',/,
     1		' ',1pe13.6,' .LE. R .LE. ',1pe13.6,/,
     2		' @FULL 2D RADIAL EXTRAP. SOMETHING IS LIKELY',
     3	    /,' TO BE WRONG WITH IMINR OR IMAXR OR THEIR USE.')
C
      IERR = 14
      GO TO 20000
C
      END
C******************** END FILE INT2D.FOR ; GROUP INT2D *****************
! 19jan2003 fgtok -s r8_precision.sub all.sub "r8con.csh conversion"
