MINICERN/mathlib/gen/j/cont.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1.1.1  1996/04/01 15:02:50  mclareni
   6 * Mathlib gen
   7 *
   8 *
   9 #include "gen/pilot.h"
  10       SUBROUTINE CONT(F,NUMBCS,CONTUR)
  11 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  12 C   PURPOSE                                                            C
  13 C     TO PRODUCE A CONTOUR PLOT BY MEANS OF THE PRINTER                C
  14 C   USAGE                                                              C
  15 C     THIS DEPENDS ON WHETHER THE FUNCTION TO BE PLOTTED HAS REAL      C
  16 C     ARGUMENTS OR INTEGER ARGUMENTS.                                  C
  17 C     THE FUNCTION HAS REAL ARGUMENTS, SUPPOSE THE FUNCTION HAS        C
  18 C     THE NAME Z.                                                      C
  19 C     EXTERNAL Z                                                       C
  20 C     DIMENSION CONTUR(10)                                             C
  21 C     CALL PAPER....                                                   C
  22 C     CALL NAMES....                                                   C
  23 C     CALL FRAME....                                                   C
  24 C     CONTUR(1)=....                                                   C
  25 C     CONTUR(2)=....                                                   C
  26 C     .                                                                C
  27 C     .                                                                C
  28 C     .                                                                C
  29 C     CALL CONT(Z,NUMBCS,CONTUR)                                       C
  30 C     IF YOU DO NOT KNOW WHAT SORT OF VALUES TO ASSIGN TO THE ARRAY    C
  31 C     CONTUR, YOU CAN CALL THE SUBROUTINE FINDEM WHICH WILL HELP YOU.  C
  32 C     CALL FINDEM(Z,NUMBCS,CONTUR)                                     C
  33 C                                                                      C
  34 C     F HAS INTEGER ARGUMENTS---                                       C
  35 C     EXTERNAL FREARG                                                  C
  36 C     DIMENSION CONTUR(10)                                             C
  37 C     CALL PAPER....                                                   C
  38 C     CALL NAMES....                                                   C
  39 C     CALL FRAME....                                                   C
  40 C     CONTUR(1)=....                                                   C
  41 C     CONTUR(2)=....                                                   C
  42 C     .                                                                C
  43 C     .                                                                C
  44 C     .                                                                C
  45 C     CALL SETUP....                                                   C
  46 C     CALL CONT(FREARG,NUMBCS,CONTUR)                                  C
  47 C     AGAIN, YOU MAY USE FINDEM TO ASSIGN VALUES TO THE ARRAY CONTUR.  C
  48 C     CALL FINDEM(FREARG,NUMBCS,CONTUR)                                C
  49 C     NOTE THAT THE FIRST PARAMETER OF CONT AND FINDEM MUST HAVE       C
  50 C     THE NAME FREARG.                                                 C
  51 C     THE FUNCTION TO BE PLOTTED MUST HAVE THE NAME FINARG.            C
  52 C   PARAMETERS                                                         C
  53 C     F      - THE FUNCTION TO BE PLOTTED. F MUST BE A REAL FUNCTION   C
  54 C              WITH TWO REAL PARAMETERS. IF THE FUNCTION YOU WANT TO   C
  55 C              PLOT HAS INTEGER ARGUMENTS, THIS FUNCTION SHOULD BE     C
  56 C              NAMED FINARG AND THE FIRST ACTUAL PARAMETER IN THE      C
  57 C              CALL TO CONT SHOULD BE FREARG.                          C
  58 C              (FREARG IS A FUNCTION WHICH CALLS FINARG FOUR TIMES     C
  59 C              AND PERFORMS A TWO-WAY LINEAR INTERPOLATION ON THESE    C
  60 C              FOUR VALUES.)                                           C
  61 C     NUMBCS - THE NUMBER OF CONTOURS TO BE PLOTTED. NUMBS MUST BE     C
  62 C              AT LEAST 1 AND AT MOST 10.                              C
  63 C     CONTUR - AN ARRAY CONTAINING THE FUNCTION VALUES ON THE VARIOUS  C
  64 C              CONTOURS. THESE FUNCTION VALUES DO NOT HAVE TO BE       C
  65 C              EQUIDISTANT AND NOT EVEN MONOTONOUS.                    C
  66 C              THE NUMBER 0 IS PRINTED WHERE F=CONTUR(1),              C
  67 C              THE NUMBER 1 IS PRINTED WHERE F=CONTUR(2),              C
  68 C              ETC.                                                    C
  69 C   REMARKS                                                            C
  70 C     THE CHOSEN NAME FOR F MUST APPEAR IN AN EXTERNAL STATEMENT IN    C
  71 C     THE PROGRAM CALLING CONT.                                        C
  72 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  73       EXTERNAL F
  74       DIMENSION CONTUR(10),SAVEC(10),SAVES(10)
  75       DIMENSION XVALUS(12)
  76       COMMON /J509C1/XBL,YBL,XUR,YUR,NX(6),NY(6),LETT1,LETT2,LINE1,LINE2
  77       REAL FU(133),FB(133)
  78       INTEGER LETTRI,MINUS,STAR,BLANK,SYMBOL(10),LINEIM(132)
  79       DATA LETTRI,MINUS,STAR,BLANK/1HI,1H-,1H*,1H /
  80 #if !defined(CERNLIB_F90)
  81       DATA SYMBOL(1),SYMBOL(2),SYMBOL(3),SYMBOL(4)/1H0,1H1,1H2,1H3/
  82       DATA SYMBOL(5),SYMBOL(6),SYMBOL(7),SYMBOL(8)/1H4,1H5,1H6,1H7/
  83       DATA SYMBOL(9),SYMBOL(10)/1H8,1H9/
  84       DATA LSLASH,LDOT/1H/ , 1H. /
  85 C=======================================================================
  86 #endif
  87 #if defined(CERNLIB_F90)
  88       INTEGER, DIMENSION(10) :: SYMBOL = (/ transfer('0   ', 0),        &
  89       transfer('1   ', 0), transfer('2   ', 0), transfer('3   ', 0),    &
  90       transfer('4   ', 0), transfer('5   ', 0), transfer('6   ', 0),    &
  91       transfer('7   ', 0), transfer('8   ', 0), transfer('9   ', 0) /)
  92       INTEGER :: LSLASH = transfer('/   ', 0), LDOT = transfer('.   ',0)
  93 !=======================================================================
  94 #endif
  95       IF (1.LE.NUMBCS.AND.NUMBCS.LE.10) GOTO 10
  96       WRITE (6, 1010) NUMBCS
  97       IF(1.LE.NUMBCS .AND. NUMBCS.LE.10)GO TO 10
  98       WRITE(6,1010)NUMBCS
  99       RETURN
 100    10 CONTINUE
 101 C
 102 C         INITIALIZE COMMON BLOCK IF NOT ALREADY DONE
 103       CALL J509BD
 104       LETT0 = LETT1 - 1
 105       LINE0 = LINE1 - 1
 106       LETT3 = LETT2 + 1
 107       LINE3 = LINE2 + 1
 108 C         SAVE CONTOUR VALUES AND ORDER THEM ASCENDING
 109       CALL UCOPY(CONTUR,SAVEC,NUMBCS)
 110       CALL UCOPY(SYMBOL,SAVES,NUMBCS)
 111       CALL ORDRE2(CONTUR,SYMBOL,NUMBCS)
 112 C
 113 C   THE ARRAY LINEIM IS A BUFFER FOR A LINE IMAGE.                     C
 114 C         PRINT LINE ALONG TOP OF FRAME
 115       WRITE(6,1030)NY
 116       LINEIM(LETT0)=STAR
 117       DO 30 LETT=LETT1,LETT2
 118    30 LINEIM(LETT)=MINUS
 119       LINEIM(LETT3)=STAR
 120       WRITE(6,1060)YUR,(LINEIM(LETT),LETT=LETT0,LETT3)
 121       MIDDLE=(LINE1+LINE2)/2
 122       DLINE = LINE2-LINE1+1
 123       DLETT = LETT2-LETT1+1
 124       DXVAL = (XUR-XBL) / DLETT
 125       DYVAL = (YUR-YBL) / DLINE
 126       YVAL = YUR
 127       XVAL = XBL
 128       DO 40 LETT=LETT1,LETT3
 129       FU(LETT) = F(XVAL,YVAL)
 130    40 XVAL = XVAL + DXVAL
 131 CCC
 132       MAXCON = 1
 133       MINCON = 10
 134       YVAL = YUR
 135 CCC       LOOP OVER LINES STARTS HERE
 136 C
 137       DO 90 LINE=LINE1,LINE2
 138       YVAL = YVAL - DYVAL
 139       XVAL = XBL-DXVAL
 140       DO 50 LETT=LETT1,LETT3
 141       XVAL = XVAL + DXVAL
 142    50 FB(LETT) = F(XVAL,YVAL)
 143       DO 70 LETT=LETT1,LETT2
 144       FUL=FU(LETT)
 145       FUR=FU(LETT+1)
 146       FBL=FB(LETT)
 147       FBR=FB(LETT+1)
 148 C   FUL IS THE FUNCTION VALUE AT THE POINT (LETT-1/2,LINE-1/2)         C
 149 C   FUR IS THE FUNCTION VALUE AT THE POINT (LETT+1/2,LINE-1/2)         C
 150 C   FBL IS THE FUNCTION VALUE AT THE POINT (LETT-1/2,LINE+1/2)         C
 151 C   FBR IS THE FUNCTION VALUE AT THE POINT (LETT+1/2,LINE+1/2)         C
 152 C                                                                      C
 153 C   FIND OUT IF THERE IS A CONTOUR VALUE WHICH FALLS BETWEEN THE       C
 154 C   BIGGEST AND THE SMALLEST OF THE FUNCTION VALUES AT THE FOUR        C
 155 C   CORNERS OF THE PRESENT PRINT POSITION (LETT,LINE).                 C
 156 C   IF SO, PRINT THE CORRESPONDING SYMBOL.                             C
 157 C   IF NOT, PRINT A BLANK AT THE POINT (LETT,LINE).                    C
 158       BIG  =MAX(FUL,FUR,FBL,FBR)
 159       SMALL=MIN(FUL,FUR,FBL,FBR)
 160       LINEIM(LETT)=BLANK
 161       DO 60 NUMBC=1,NUMBCS
 162       IF (BIG   .LT. CONTUR(NUMBC))  GO TO 70
 163       IF (SMALL .GT. CONTUR(NUMBC))  GO TO 60
 164       LINEIM(LETT) = SYMBOL(NUMBC)
 165       IF (NUMBC .GT. MAXCON)  MAXCON = NUMBC
 166       IF (NUMBC .LT. MINCON)  MINCON = NUMBC
 167    60 CONTINUE
 168    70 CONTINUE
 169       IF (MOD(LINE,10) .EQ. LINE0)  GO TO 73
 170 C         PRINT LINE (NORMAL LINE)
 171       LINEIM(LETT0) = LETTRI
 172       LINEIM(LETT3) = LETTRI
 173       WRITE(6,1050)      (LINEIM(LETT),LETT=LETT0,LETT3)
 174       GO TO 76
 175 C         PRINT LINE (EVEN TENTH LINE)
 176    73 LINEIM(LETT0) = LDOT
 177       LINEIM(LETT3) = LDOT
 178       WRITE(6,1040) YVAL,(LINEIM(LETT),LETT=LETT0,LETT3)
 179    76 CONTINUE
 180       DO 80 LETT=LETT1,LETT3
 181    80 FU(LETT)=FB(LETT)
 182    90 CONTINUE
 183 C         PRINT LINE ALONG BOTTOM OF FRAME
 184       LINEIM(LETT0)=STAR
 185       DO 100 LETT=LETT1,LETT2
 186   100 LINEIM(LETT)=MINUS
 187       LINEIM(LETT3)=STAR
 188       WRITE(6,1060)YBL,(LINEIM(LETT),LETT=LETT0,LETT3)
 189 C         PRINT LABELS ON X-AXIS EVERY 10 COLIMNS
 190       LETT2P = LETT2 + 10
 191       DO 119 LETT= 2, LETT2P
 192   119 LINEIM(LETT) = BLANK
 193       X10COL = 10.*DXVAL
 194       ITENMX = 11
 195       LETT = LETT0
 196       DO 129 ITEN= 1, ITENMX
 197       XVALUS(ITEN) = XBL + X10COL*(ITEN-1)
 198       LINEIM(LETT) = LSLASH
 199       LETT = LETT + 10
 200       IF (XVALUS(ITEN) .GT. (XUR-5.*DXVAL)) GO TO 139
 201   129 CONTINUE
 202       ITEN = ITENMX
 203   139 CONTINUE
 204       WRITE(6,1090)  (LINEIM(LETT),LETT=2,LETT2P)
 205       WRITE(6,1100) (XVALUS(II),II=1,ITEN)
 206 C         PRINT VARIABLE NAME FOR X-AXIS
 207       WRITE(6,1110)NX,DXVAL
 208       IF (MAXCON .LT. MINCON)  GO TO 125
 209       WRITE(6,1120) (SYMBOL(NN),CONTUR(NN),NN=MINCON,MAXCON)
 210       GO TO 135
 211   125 CONTINUE
 212       WRITE(6,1130)
 213   135 CONTINUE
 214 C         RESTORE INITIAL CONTOUR ORDERING
 215       CALL UCOPY(SAVES,SYMBOL,NUMBCS)
 216       CALL UCOPY(SAVEC,CONTUR,NUMBCS)
 217       RETURN
 218  1010 FORMAT(' HOW MANY CONTOURS DID YOU WANT---',I10,'---(CONT)')
 219  1030 FORMAT('1',120A1)
 220  1040 FORMAT(1X,F8.3,1X,122A1)
 221  1050 FORMAT(10X,122A1)
 222  1060 FORMAT(1X,F8.3,'-',122A1)
 223  1090 FORMAT(1X,131A1)
 224  1100 FORMAT(4X,12(1X,F9.3))
 225  1110 FORMAT(20X,6A1,20X,'ONE COLUMN =',E10.3,10X,
 226      *    2('CONTOUR FCN VALUE     '))
 227  1120 FORMAT(80X,A1,F14.5,7X,A1,F14.5)
 228  1130 FORMAT(80X,'NO CONTOURS FOUND'/)
 229       END