Repatch (from linux) of OSX IRAF

1 files changed, 165 insertions, 0 deletions

diff --git a/sys/gio/ncarutil/conlib/consld.f b/sys/gio/ncarutil/conlib/consld.f
new file mode 100644
index 00000000..fd40e10d
--- /dev/null
+++ b/sys/gio/ncarutil/conlib/consld.f
@@ -0,0 +1,165 @@
+        SUBROUTINE CONSLD (SCRARR)
+C                                                                               
+C +-----------------------------------------------------------------+           
+C |                                                                 |           
+C |                Copyright (C) 1986 by UCAR                       |           
+C |        University Corporation for Atmospheric Research          |           
+C |                    All Rights Reserved                          |           
+C |                                                                 |           
+C |                 NCARGRAPHICS  Version 1.00                      |           
+C |                                                                 |           
+C +-----------------------------------------------------------------+           
+C                                                                               
+C                                                                               
+C
+C  THIS ROUTINE IS USED TO GENERATE A SHIELD WHERE CONTOUR
+C  DRAWING IS ALLOWED.
+C
+C  THE ROUTINE TAKES THE SILHOUETTE INFORMATION FROM COMMON BLOCK
+C  CONR13 AND TRANSFORMS THIS INTO A SHIELD TO BE USED IN THE
+C  SCRATCH ARRAY PASSED IN BY THE USER (THE SCRATCH ARRAY HOLDS THE
+C  GRIDED DATA FROM THE INTERPOLATION).
+C
+C  INPUT
+C       SCRARR-THE SCRATCH ARRAY HOLDING THE INTERPOLATED DATA
+C
+C
+C
+C
+      COMMON /CONRA1/ CL(30)     ,NCL        ,OLDZ       ,PV(210)    ,
+     1                FINC       ,HI         ,FLO
+      COMMON /CONRA6/ XST        ,YST        ,XED        ,YED        ,
+     1                STPSZ      ,IGRAD      ,IG         ,XRG        ,
+     2                YRG        ,BORD       ,PXST       ,PYST       ,
+     3                PXED       ,PYED       ,ITICK
+      COMMON /CONRA9/ ICOORD(500),  NP       ,MXXY       ,TR         ,
+     1                BR         ,TL         ,BL         ,CONV       ,
+     2                XN         ,YN         ,ITLL       ,IBLL       ,
+     3                ITRL       ,IBRL       ,XC         ,YC         ,
+     4                ITLOC(210) ,JX         ,JY         ,ILOC       ,
+     5                ISHFCT     ,XO         ,YO         ,IOC        ,NC
+      COMMON /CONR12/ IXMAX      ,IYMAX      ,XMAX       ,YMAX
+      COMMON /CONR13/XVS(50),YVS(50),ICOUNT,SPVAL,SHIELD,
+     1               SLDPLT
+      LOGICAL SHIELD,SLDPLT
+C
+C  INCREASE THE RESOLUTION OF THE SHIELD PROFILE
+C
+      DIMENSION SCRARR(1)
+C
+      SAVE
+      DATA RESINC/8.0/
+C
+C  STATEMENT FUNCTION TO MAKE ARRAY ACCESS SEEM LIKE MATRIX ACCESS
+C
+C +NOAO
+C  These statement functions are never called.
+C     SCRTCH(IXX,IYY) = SCRARR(IYY+(IXX-1)*IYMAX)
+C     IARVL(IXX,IYY) = IYY+(IXX-1)*IYMAX
+C -NOAO
+      IGADDR(XXX,YYY) =
+     1 IFIX((YYY-YST)/STPSZ+.5)+(IFIX((XXX-XST)/STPSZ+.5))*IYMAX
+C
+C  SET THE SPECIAL VALUE
+C
+      SPVAL = SPVAL * 2.
+C
+C  SET THE USER ARRAY LOCATIONS TO TEMPORARY POINTERS
+C
+C  LOOP FOR ALL SHIELD ELEMENTS
+C
+      DO 100 IC = 1,ICOUNT
+C
+C       ASSIGN LINE SEGMENT END POINTS
+C
+        X1 = XVS(IC)
+        Y1 = YVS(IC)
+        IF (IC .EQ. ICOUNT) GO TO 10
+                X2 = XVS(IC+1)
+                Y2 = YVS(IC+1)
+                GO TO 15
+ 10             CONTINUE
+                X2 = XVS(1)
+                Y2 = YVS(1)
+ 15     CONTINUE
+C
+C  INSURE THAT ALL POINTS ARE IN THE CONVEX HULL
+C
+      IF (X1.GT.XED) X1 = XED
+      IF (X1.LT.XST) X1 = XST
+      IF (X2.GT.XED) X2 = XED
+      IF (X2.LT.XST) X2 = XST
+      IF (Y1.GT.YED) Y1 = YED
+      IF (Y1.LT.YST) Y1 = YST
+      IF (Y2.GT.YED) Y2 = YED
+      IF (Y2.LT.YST) Y2 = YST
+C
+C       SET THE START OF THE LINE SEGMENT SCRATCH LOCATION TO
+C       THE SPECIAL VALUE
+C
+        II = IGADDR(X1,Y1)
+        SCRARR(II) = SPVAL
+C
+C       FIND THE LENGTH OF THE LINE SEGMENT
+C
+        DIST = SQRT(((X2-X1)**2)+((Y2-Y1)**2))
+C
+C       IF LENGTH SHORTER THAN STEP SIZE THEN THERE IS NOTHING TO DO
+C
+        IF (DIST .LE. STPSZ) GO TO 100
+C
+C       SET UP LOOP TO SET ALL CELLS ON THE LINE SEGMENT
+C
+        NSTPS = (DIST/STPSZ)*RESINC
+        XSTP = (X2-X1)/FLOAT(NSTPS)
+        YSTP = (Y2-Y1)/FLOAT(NSTPS)
+        X = X1
+        Y = Y1
+        DO 20 K = 1,NSTPS
+                X = X + XSTP
+                Y = Y + YSTP
+                II = IGADDR(X,Y)
+                SCRARR(II) = SPVAL
+ 20     CONTINUE
+C
+ 100  CONTINUE
+C
+C  FILL THE SHIELDED AREAS
+C       FOR EACH COLUMN THE ELEMENTS ARE SET TO SPVAL IF FILL IS TRUE.
+C       THE VALUE OF FILL IS NEGATED EVERY TIME A SPVAL IS ENCOUNTERED,
+C       AND THAT CELL REMAINS UNCHANGED.
+C
+C       LOOP THROUGH THE GRID
+C
+        DO 39 I = 1,IXMAX
+C
+C               GET THE START AND END FOR THE COLUMN
+C
+                IYS = (I-1)*IYMAX+1
+                IYE = I*IYMAX
+C
+C               ADVANCE IN THE FORWARD DIRECTION
+C
+                DO 32 J = IYS,IYE
+C
+C                       IF NOT SPVAL THEN SET CELL AS APPROPIATE
+C
+                        IF (SCRARR(J).EQ.SPVAL) GO TO 33
+                                SCRARR(J) = SPVAL
+ 32             CONTINUE
+                GO TO 39
+C
+C               ADVANCE IN THE BACKWARD DIRECTION
+C
+ 33             CONTINUE
+                DO 34 J = 1,IYMAX
+                        NJ =IYE+1-J
+C                       IF NOT SPVAL THEN SET CELL AS APPROPIATE
+C
+                        IF (SCRARR(NJ).EQ.SPVAL) GO TO 39
+                                SCRARR(NJ) = SPVAL
+ 34             CONTINUE
+ 39     CONTINUE
+C
+      RETURN
+      END