RMAGEN84/SRC84/cgen.f90

       SUBROUTINE CGEN

!     Routine to establish contour lines

       USE BLKMAP
       USE BLK1MOD 
!       INCLUDE 'BLK1.COM'
       DIMENSION XINT(2),YINT(2),CSEL(100)&
       ,X(5),Y(5),VALC(5)
       COMMON /CCGEN/ XCLIN(4000,2),YCLIN(4000,2),ALIN(-4000:4000,2),IUSED(4000)
       COMMON /OPTION/ SWITCH(4),NUMV,CONTUR(99),IQUAL,XCSQ,NUMCOL
       common itempel(5000)

!     Set up contours to be developed
!
       CALL TOLMAX(WD,TTMIN,TTMAX)


       ISZ=1
       CALL CSET(TTMIN,TTMAX,isz) 

       NCLIN=NUMV

       DO N=1,NUMV
         CSEL(N)=CONTUR(N)
       ENDDO

!     Loop through each contour then each element

       DO J=1,NCLIN

         ILIN=0
         DO N=1,NE
           IF(IMAT(N) .GT. 0  .AND.  IMAT(N) .LT. 901  .AND.  NCORN(N) .GT. 5) THEN
             ISWT=0
             NCNX=NCORN(N)/2
             DO K=1,3
               X(K)=XUSR(NOP(N,2*K-1))
               Y(K)=YUSR(NOP(N,2*K-1))
               VALC(K)=WD(NOP(N,2*K-1))
             ENDDO
             NCNXX=3
             CALL CGENTR(N,ISWT,NCNXX,X,Y,VALC,CSEL(J),XINT,YINT)
             IF(ISWT .GT. 0) THEN
               ILIN=ILIN+1
               DO K=1,2
                 XCLIN(ILIN,K)=XINT(K)
                 YCLIN(ILIN,K)=YINT(K)
               ENDDO
               itempel(ilin)=n
             ENDIF

             IF(NCNX .EQ. 4) THEN
               ISWT=0
               DO K=3,5
                 IF(K .LT. 5) THEN
                   KK=2*K-1
                 ELSE
                   KK=1
                 ENDIF
                 X(K-2)=XUSR(NOP(N,KK))
                 Y(K-2)=YUSR(NOP(N,KK))
                 VALC(K-2)=WD(NOP(N,KK))
               ENDDO
               CALL CGENTR(N,ISWT,NCNXX,X,Y,VALC,CSEL(J),XINT,YINT)
               IF(ISWT .GT. 0) THEN
                 ILIN=ILIN+1
                 DO K=1,2
                   XCLIN(ILIN,K)=XINT(K)
                   YCLIN(ILIN,K)=YINT(K)
                 ENDDO
               ENDIF
             ENDIF
           ENDIF
         ENDDO
         do k=1,ilin
         write(199,'(2i5,4f15.3)') k,itempel(k),xclin(k,1),yclin(k,1),xclin(k,2),yclin(k,2)
         enddo

!     Join up points to form contour lines

         IF(ILIN .GT. 0) CALL JLINE(ILIN,CSEL(J))

       ENDDO
       MAXPTS=MAXPTS+1
       CMAP(MAXPTS,1) = VOID 
       CMAP(MAXPTS,2) = VOID 
       XMAP(MAXPTS) = VOID 
       YMAP(MAXPTS) = VOID 

       RETURN

       END

       SUBROUTINE CGENTR(N,ISWT,NCN,X,Y,VAL,CVAL,XINT,YINT)

!     Routine to find line (if it exists) across element N

       DIMENSION X(5),Y(5),VAL(5),XINT(2),YINT(2)

!     Get the max and min

       IF(NCN .EQ. 3) THEN
         CMAX=MAX(VAL(1),VAL(2),VAL(3))
         CMIN=MIN(VAL(1),VAL(2),VAL(3))
       ELSE
         CMAX=MAX(VAL(1),VAL(2),VAL(3),VAL(4))
         CMIN=MIN(VAL(1),VAL(2),VAL(3),VAL(4))
       ENDIF

!     Test if there is a contour

       IF(CVAL .LT. CMIN  .OR. CVAL .GT. CMAX) THEN

!     No then return

         ISWT=0
         RETURN
       ELSE

!     Yes, determine end locations

         ISWT=1
       ENDIF 

!     Find the line number that it crosses

       X(NCN+1)=X(1)
       Y(NCN+1)=Y(1)
       VAL(NCN+1)=VAL(1)

       DO K=1,NCN
         IF(CVAL .GE. VAL(K)  .AND.  CVAL .LT. VAL(K+1)) THEN
           FRAC=(CVAL-VAL(K))/(VAL(K+1)-VAL(K))
           XINT(ISWT)=X(K)+FRAC*(X(K+1)-X(K))
           YINT(ISWT)=Y(K)+FRAC*(Y(K+1)-Y(K))
           write(199,'(2i5,4f12.4)') n,k,frac,cval,val(k),val(k+1)
           ISWT=ISWT+1
         ELSEIF(CVAL .LT. VAL(K)  .AND.  CVAL .GE. VAL(K+1)) THEN
           FRAC=(VAL(K)-CVAL)/(VAL(K)-VAL(K+1))
           XINT(ISWT)=X(K)+FRAC*(X(K+1)-X(K))
           YINT(ISWT)=Y(K)+FRAC*(Y(K+1)-Y(K))
           write(199,'(2i5,4f12.4)') n,k,frac,cval,val(k),val(k+1)
           ISWT=ISWT+1
         ENDIF

       ENDDO

       RETURN
       END