*
* $Id$
*
* $Log$
* Revision 1.1  1996/04/01 15:02:49  mclareni
* Initial revision
*
*
#include "gen/pilot.h"
      SUBROUTINE CONT(F,NUMBCS,CONTUR)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C   PURPOSE                                                            C
C     TO PRODUCE A CONTOUR PLOT BY MEANS OF THE PRINTER                C
C   USAGE                                                              C
C     THIS DEPENDS ON WHETHER THE FUNCTION TO BE PLOTTED HAS REAL      C
C     ARGUMENTS OR INTEGER ARGUMENTS.                                  C
C     THE FUNCTION HAS REAL ARGUMENTS, SUPPOSE THE FUNCTION HAS        C
C     THE NAME Z.                                                      C
C     EXTERNAL Z                                                       C
C     DIMENSION CONTUR(10)                                             C
C     CALL PAPER....                                                   C
C     CALL NAMES....                                                   C
C     CALL FRAME....                                                   C
C     CONTUR(1)=....                                                   C
C     CONTUR(2)=....                                                   C
C     .                                                                C
C     .                                                                C
C     .                                                                C
C     CALL CONT(Z,NUMBCS,CONTUR)                                       C
C     IF YOU DO NOT KNOW WHAT SORT OF VALUES TO ASSIGN TO THE ARRAY    C
C     CONTUR, YOU CAN CALL THE SUBROUTINE FINDEM WHICH WILL HELP YOU.  C
C     CALL FINDEM(Z,NUMBCS,CONTUR)                                     C
C                                                                      C
C     F HAS INTEGER ARGUMENTS---                                       C
C     EXTERNAL FREARG                                                  C
C     DIMENSION CONTUR(10)                                             C
C     CALL PAPER....                                                   C
C     CALL NAMES....                                                   C
C     CALL FRAME....                                                   C
C     CONTUR(1)=....                                                   C
C     CONTUR(2)=....                                                   C
C     .                                                                C
C     .                                                                C
C     .                                                                C
C     CALL SETUP....                                                   C
C     CALL CONT(FREARG,NUMBCS,CONTUR)                                  C
C     AGAIN, YOU MAY USE FINDEM TO ASSIGN VALUES TO THE ARRAY CONTUR.  C
C     CALL FINDEM(FREARG,NUMBCS,CONTUR)                                C
C     NOTE THAT THE FIRST PARAMETER OF CONT AND FINDEM MUST HAVE       C
C     THE NAME FREARG.                                                 C
C     THE FUNCTION TO BE PLOTTED MUST HAVE THE NAME FINARG.            C
C   PARAMETERS                                                         C
C     F      - THE FUNCTION TO BE PLOTTED. F MUST BE A REAL FUNCTION   C
C              WITH TWO REAL PARAMETERS. IF THE FUNCTION YOU WANT TO   C
C              PLOT HAS INTEGER ARGUMENTS, THIS FUNCTION SHOULD BE     C
C              NAMED FINARG AND THE FIRST ACTUAL PARAMETER IN THE      C
C              CALL TO CONT SHOULD BE FREARG.                          C
C              (FREARG IS A FUNCTION WHICH CALLS FINARG FOUR TIMES     C
C              AND PERFORMS A TWO-WAY LINEAR INTERPOLATION ON THESE    C
C              FOUR VALUES.)                                           C
C     NUMBCS - THE NUMBER OF CONTOURS TO BE PLOTTED. NUMBS MUST BE     C
C              AT LEAST 1 AND AT MOST 10.                              C
C     CONTUR - AN ARRAY CONTAINING THE FUNCTION VALUES ON THE VARIOUS  C
C              CONTOURS. THESE FUNCTION VALUES DO NOT HAVE TO BE       C
C              EQUIDISTANT AND NOT EVEN MONOTONOUS.                    C
C              THE NUMBER 0 IS PRINTED WHERE F=CONTUR(1),              C
C              THE NUMBER 1 IS PRINTED WHERE F=CONTUR(2),              C
C              ETC.                                                    C
C   REMARKS                                                            C
C     THE CHOSEN NAME FOR F MUST APPEAR IN AN EXTERNAL STATEMENT IN    C
C     THE PROGRAM CALLING CONT.                                        C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      EXTERNAL F
      DIMENSION CONTUR(10),SAVEC(10),SAVES(10)
      DIMENSION XVALUS(12)
      COMMON /J509C1/XBL,YBL,XUR,YUR,NX(6),NY(6),LETT1,LETT2,LINE1,LINE2
      REAL FU(133),FB(133)
      INTEGER LETTRI,MINUS,STAR,BLANK,SYMBOL(10),LINEIM(132)
      DATA LETTRI,MINUS,STAR,BLANK/1HI,1H-,1H*,1H /
#if !defined(CERNLIB_F90)
      DATA SYMBOL(1),SYMBOL(2),SYMBOL(3),SYMBOL(4)/1H0,1H1,1H2,1H3/
      DATA SYMBOL(5),SYMBOL(6),SYMBOL(7),SYMBOL(8)/1H4,1H5,1H6,1H7/
      DATA SYMBOL(9),SYMBOL(10)/1H8,1H9/
      DATA LSLASH,LDOT/1H/ , 1H. /
C=======================================================================
#endif
#if defined(CERNLIB_F90)
      INTEGER, DIMENSION(10) :: SYMBOL = (/ transfer('0   ', 0),        &
      transfer('1   ', 0), transfer('2   ', 0), transfer('3   ', 0),    &
      transfer('4   ', 0), transfer('5   ', 0), transfer('6   ', 0),    &
      transfer('7   ', 0), transfer('8   ', 0), transfer('9   ', 0) /)
      INTEGER :: LSLASH = transfer('/   ', 0), LDOT = transfer('.   ',0)
!=======================================================================
#endif
      IF (1.LE.NUMBCS.AND.NUMBCS.LE.10) GOTO 10
      WRITE (6, 1010) NUMBCS
      IF(1.LE.NUMBCS .AND. NUMBCS.LE.10)GO TO 10
      WRITE(6,1010)NUMBCS
      RETURN
   10 CONTINUE
C
C         INITIALIZE COMMON BLOCK IF NOT ALREADY DONE
      CALL J509BD
      LETT0 = LETT1 - 1
      LINE0 = LINE1 - 1
      LETT3 = LETT2 + 1
      LINE3 = LINE2 + 1
C         SAVE CONTOUR VALUES AND ORDER THEM ASCENDING
      CALL UCOPY(CONTUR,SAVEC,NUMBCS)
      CALL UCOPY(SYMBOL,SAVES,NUMBCS)
      CALL ORDRE2(CONTUR,SYMBOL,NUMBCS)
C
C   THE ARRAY LINEIM IS A BUFFER FOR A LINE IMAGE.                     C
C         PRINT LINE ALONG TOP OF FRAME
      WRITE(6,1030)NY
      LINEIM(LETT0)=STAR
      DO 30 LETT=LETT1,LETT2
   30 LINEIM(LETT)=MINUS
      LINEIM(LETT3)=STAR
      WRITE(6,1060)YUR,(LINEIM(LETT),LETT=LETT0,LETT3)
      MIDDLE=(LINE1+LINE2)/2
      DLINE = LINE2-LINE1+1
      DLETT = LETT2-LETT1+1
      DXVAL = (XUR-XBL) / DLETT
      DYVAL = (YUR-YBL) / DLINE
      YVAL = YUR
      XVAL = XBL
      DO 40 LETT=LETT1,LETT3
      FU(LETT) = F(XVAL,YVAL)
   40 XVAL = XVAL + DXVAL
CCC
      MAXCON = 1
      MINCON = 10
      YVAL = YUR
CCC       LOOP OVER LINES STARTS HERE
C
      DO 90 LINE=LINE1,LINE2
      YVAL = YVAL - DYVAL
      XVAL = XBL-DXVAL
      DO 50 LETT=LETT1,LETT3
      XVAL = XVAL + DXVAL
   50 FB(LETT) = F(XVAL,YVAL)
      DO 70 LETT=LETT1,LETT2
      FUL=FU(LETT)
      FUR=FU(LETT+1)
      FBL=FB(LETT)
      FBR=FB(LETT+1)
C   FUL IS THE FUNCTION VALUE AT THE POINT (LETT-1/2,LINE-1/2)         C
C   FUR IS THE FUNCTION VALUE AT THE POINT (LETT+1/2,LINE-1/2)         C
C   FBL IS THE FUNCTION VALUE AT THE POINT (LETT-1/2,LINE+1/2)         C
C   FBR IS THE FUNCTION VALUE AT THE POINT (LETT+1/2,LINE+1/2)         C
C                                                                      C
C   FIND OUT IF THERE IS A CONTOUR VALUE WHICH FALLS BETWEEN THE       C
C   BIGGEST AND THE SMALLEST OF THE FUNCTION VALUES AT THE FOUR        C
C   CORNERS OF THE PRESENT PRINT POSITION (LETT,LINE).                 C
C   IF SO, PRINT THE CORRESPONDING SYMBOL.                             C
C   IF NOT, PRINT A BLANK AT THE POINT (LETT,LINE).                    C
      BIG  =MAX(FUL,FUR,FBL,FBR)
      SMALL=MIN(FUL,FUR,FBL,FBR)
      LINEIM(LETT)=BLANK
      DO 60 NUMBC=1,NUMBCS
      IF (BIG   .LT. CONTUR(NUMBC))  GO TO 70
      IF (SMALL .GT. CONTUR(NUMBC))  GO TO 60
      LINEIM(LETT) = SYMBOL(NUMBC)
      IF (NUMBC .GT. MAXCON)  MAXCON = NUMBC
      IF (NUMBC .LT. MINCON)  MINCON = NUMBC
   60 CONTINUE
   70 CONTINUE
      IF (MOD(LINE,10) .EQ. LINE0)  GO TO 73
C         PRINT LINE (NORMAL LINE)
      LINEIM(LETT0) = LETTRI
      LINEIM(LETT3) = LETTRI
      WRITE(6,1050)      (LINEIM(LETT),LETT=LETT0,LETT3)
      GO TO 76
C         PRINT LINE (EVEN TENTH LINE)
   73 LINEIM(LETT0) = LDOT
      LINEIM(LETT3) = LDOT
      WRITE(6,1040) YVAL,(LINEIM(LETT),LETT=LETT0,LETT3)
   76 CONTINUE
      DO 80 LETT=LETT1,LETT3
   80 FU(LETT)=FB(LETT)
   90 CONTINUE
C         PRINT LINE ALONG BOTTOM OF FRAME
      LINEIM(LETT0)=STAR
      DO 100 LETT=LETT1,LETT2
  100 LINEIM(LETT)=MINUS
      LINEIM(LETT3)=STAR
      WRITE(6,1060)YBL,(LINEIM(LETT),LETT=LETT0,LETT3)
C         PRINT LABELS ON X-AXIS EVERY 10 COLIMNS
      LETT2P = LETT2 + 10
      DO 119 LETT= 2, LETT2P
  119 LINEIM(LETT) = BLANK
      X10COL = 10.*DXVAL
      ITENMX = 11
      LETT = LETT0
      DO 129 ITEN= 1, ITENMX
      XVALUS(ITEN) = XBL + X10COL*(ITEN-1)
      LINEIM(LETT) = LSLASH
      LETT = LETT + 10
      IF (XVALUS(ITEN) .GT. (XUR-5.*DXVAL)) GO TO 139
  129 CONTINUE
      ITEN = ITENMX
  139 CONTINUE
      WRITE(6,1090)  (LINEIM(LETT),LETT=2,LETT2P)
      WRITE(6,1100) (XVALUS(II),II=1,ITEN)
C         PRINT VARIABLE NAME FOR X-AXIS
      WRITE(6,1110)NX,DXVAL
      IF (MAXCON .LT. MINCON)  GO TO 125
      WRITE(6,1120) (SYMBOL(NN),CONTUR(NN),NN=MINCON,MAXCON)
      GO TO 135
  125 CONTINUE
      WRITE(6,1130)
  135 CONTINUE
C         RESTORE INITIAL CONTOUR ORDERING
      CALL UCOPY(SAVES,SYMBOL,NUMBCS)
      CALL UCOPY(SAVEC,CONTUR,NUMBCS)
      RETURN
 1010 FORMAT(' HOW MANY CONTOURS DID YOU WANT---',I10,'---(CONT)')
 1030 FORMAT('1',120A1)
 1040 FORMAT(1X,F8.3,1X,122A1)
 1050 FORMAT(10X,122A1)
 1060 FORMAT(1X,F8.3,'-',122A1)
 1090 FORMAT(1X,131A1)
 1100 FORMAT(4X,12(1X,F9.3))
 1110 FORMAT(20X,6A1,20X,'ONE COLUMN =',E10.3,10X,
     *    2('CONTOUR FCN VALUE     '))
 1120 FORMAT(80X,A1,F14.5,7X,A1,F14.5)
 1130 FORMAT(80X,'NO CONTOURS FOUND'/)
      END
