SUBROUTINE CONTUR( KHANEL, IOERR ) IMPLICIT REAL (A-H,O-Z) INCLUDE 'SIZES' REAL XCORD, YCORD, XTEMP, YTEMP, THETA, ZTEMP, XLAST, YLAST REAL XEND INTEGER PIXROW, PIXCOL, PIXEL INTEGER*2 ATBOND CHARACTER*1 ESC, CAR, ASCII CHARACTER*4 TEKINT CHARACTER*5 TEKCOR, STEMP CHARACTER*6 CBCD CHARACTER*80 LINE1,LINE2,LINE3 CHARACTER*80 DUMMY, KEYWRD, KOMENT, TITLE LOGICAL MONOC, FIRST, UPWARD, MORE COMMON /ASCIIC/ ASCII ( 0: 255 ) COMMON /PLOTS/ XMIN,XMAX,YMIN,YMAX,ZMIN,ZMAX,CMIN,CMAX,SCALE COMMON /DISPLY/ IREM(200), BSCALE, ATBOND( NUMATM, NUMATM), . ISTYPE, LATYPE, IMASK( NUMATM), ISCOLO COMMON /OUTPUT/ IPAPER,IPAGE COMMON /KEYS/ KEYWRD,KOMENT,TITLE COMMON /TERM/ IMAXR, IMAXC, PIXROW, PIXCOL, PIXEL, LCOUNT, INGRAF, . IXL, IXR, IYT, IYB, NCOLOR, MCOLOR( 64 ), ITTRM, . MARGX, MARGY * VARIABLES IN COMMON TERM: * IMAXR = MAX NUMBER OF ROWS * IMAXC = MAX NUMBER OF COLUMNS * PIXROW = NUMBER OF PIXELS PER ROW * PIXCOL = NUMBER OF PIXELS PER COLUMN * PIXEL = LESSER OF PIXROW OR PIXCOL * LCOUNT = NUMBER OF LINES CURRENTLY WRITTEN TO DIALOG AREA * INGRAF = 0=> HOST TEXT GOES TO MONITOR SPACE\\ 1=> TEXT TO GRAPHICS * IXL = LEFT MOST VALUE OF X * IXR = RIGHT MOST VALUE OF X * IYT = VALUE OF Y AT TOP OF SCREEN * IYB = VALUE OF Y AT BOTTOM OF SCREEN * NCOLOR = NUMBER OF COLORS IN MCOLOR MAP * MCOLOR = MAP OF COLORS * ITTRM = UNIQUE MODEL NUMBER OF GENERAL TERMINAL TYPE * MARGX = NUMBER OF PIXELS PADDED TO X-COORDINATE * MARGY = NUMBER OF PIXELS PADDED TO Y-COORDINATE * * DATA MORE/.FALSE./ * XMIN = 0.0D0 XMAX = 1.0D0 YMIN = 0.0D0 YMAX = 1.0D0 ZMIN = 0.0D0 ZMAX = 1.0D0 CMIN = 0.0D0 CMAX = 1.0D0 SCALE = 1.0D0 CSCALE = 0.85D0 C? MAXCOL = 7 C? TOPLST = 1.0 TOPLST = 0.85 ISTYPE = 9 MONOC = .FALSE. FIRST = .TRUE. UPWARD = .TRUE. * * SET UP TERMINAL CALL PLOT( 0.0, 0.0, 6) IF ( NCOLOR.GT.0) THEN MAXCOL = NCOLOR ELSE MAXCOL = 1 ENDIF * IF ( .NOT. MORE) REWIND ( UNIT = KHANEL ) * 2 READ (KHANEL,'(A)',END=31) DUMMY IF (INDEX ( DUMMY, 'NUMBER OF CONTOURS') .GT. 0) THEN IEQ = INDEX(DUMMY,'=') DO 130 IZ = IEQ+1, 80 IF (DUMMY(IZ:IZ).NE.' ') THEN NRCONT = READA(DUMMY,IZ,ERROR) * THIS IS FOR TEKTRONIX 4105 TERMINAL INCONT = ( NRCONT / MAXCOL ) + 1 GOTO 5 ENDIF 130 CONTINUE ELSE IF ( INDEX( DUMMY, 'MONOCHROME') .GT. 0 ) MONOC = .TRUE. GOTO 2 ENDIF 5 CONTINUE * IF ( NRCONT .EQ. 1 ) MONOC = .TRUE. * DO 150 IL = 1,3 READ ( KHANEL, '(A)') LINE1 IF ( IL.EQ.1) KEYWRD = LINE1 IF ( IL.EQ.2) KOMENT = LINE1 IF ( IL.EQ.3) TITLE = LINE1 C? DO 140 ICC = 80,2,-1 C? IF ( LINE1(ICC:ICC) .NE. ' ') GOTO 6 C? 140 CONTINUE ICC = LLENG( LINE1 ) ICC = MAX( 1, ICC ) 6 CALL GTEXT( IL, 1, LINE1(1:ICC) ) C? 6 CALL DEBUGR( LINE1(1:ICC) ) 150 CONTINUE * MCONTR = -1 CONOLD = 0.0D0 ICOLOR = 1 XTEMP = ICOLOR CALL PLOT ( XTEMP, YCORD, 99) * 10 CONTINUE READ ( KHANEL, '( A )', END = 100) DUMMY * READ ( KHANEL, *, END=99) XCORD,YCORD,IPEN,CONTOR IF (INDEX ( DUMMY, 'NUMBER OF CONTOURS') .GT. 0) THEN * More than one picture in this file BACKSPACE (KHANEL) MORE = .TRUE. RETURN ENDIF CALL LCLEAN( DUMMY, DUMMY , .TRUE.) XCORD = READA ( DUMMY, 1, ERROR) DUMMY = DUMMY ( INDEX( DUMMY, ' '): ) CALL LCLEAN( DUMMY, DUMMY , .TRUE.) YCORD = READA ( DUMMY, 1, ERROR) DUMMY = DUMMY ( INDEX( DUMMY, ' '): ) CALL LCLEAN( DUMMY, DUMMY , .TRUE.) I = 1 IF ( DUMMY(I:I) .GE. '0' .AND. DUMMY(I:I) .LE. '9' ) THEN IPEN = READA ( DUMMY, I, ERROR) DO 16 I = 1,80 IF ( DUMMY(I:I) .NE. ' ') GOTO 17 16 CONTINUE 17 I = I + 2 CONTOR = READA ( DUMMY, I, ERROR) C# WRITE (*,*) XCORD,YCORD,IPEN,CONTOR IF ( ABS( CONTOR) .GE. 99.0D0) THEN IF ( CONOLD .LT. CONTOR) THEN STEMP = TEKINT( ICOLOR) XTEMP = 1.03 YTEMP = TOPLST - ICOLOR / 25.0 CALL PLOT ( XTEMP, YTEMP, 2 ) WRITE ( DUMMY, '(F9.5, '':'', F9.5 )' ) CONFST, CONOLD CALL GTEXT( 0, 0, DUMMY(1:19) ) ENDIF ICOLOR = 1 XTEMP = ICOLOR CALL PLOT ( XTEMP, YCORD, 99) ELSEIF ( CONOLD .LT. CONTOR) THEN IF ( FIRST ) THEN FIRST = .FALSE. CONOLD = CONTOR ENDIF MCONTR = MCONTR + 1 IF ( MCONTR .EQ. INCONT) THEN STEMP = TEKINT( ICOLOR) XTEMP = 1.03 YTEMP = TOPLST - ICOLOR / 25.0 CALL PLOT ( XTEMP, YTEMP, 2 ) WRITE ( DUMMY, '(F9.5, '':'', F9.5 )' ) CONFST, CONOLD CALL GTEXT( 0, 0, DUMMY(1:19) ) IF ( .NOT. MONOC ) ICOLOR = ICOLOR + 1 CONFST = CONTOR IF ( ICOLOR .GT. MAXCOL) ICOLOR = 1 MCONTR = 0 XTEMP = ICOLOR CALL PLOT ( XTEMP, YCORD, 99) ENDIF ELSEIF ( CONOLD .GT. CONTOR) THEN IF ( UPWARD) THEN UPWARD = .FALSE. STEMP = TEKINT( ICOLOR) XTEMP = 1.03 YTEMP = TOPLST - ICOLOR / 25.0 CALL PLOT ( XTEMP, YTEMP, 2 ) WRITE ( DUMMY, '(F9.5, '':'', F9.5 )' ) CONFST, CONOLD CALL GTEXT( 0, 0, DUMMY(1:19) ) CONOLD = CONTOR IF ( .NOT. MONOC ) ICOLOR = ICOLOR + 1 CONFST = CONTOR IF ( ICOLOR .GT. MAXCOL) ICOLOR = 1 MCONTR = 0 XTEMP = ICOLOR CALL PLOT ( XTEMP, YCORD, 99) ENDIF ENDIF IPEN = IPEN + 1 XLAST = XCORD * CSCALE YLAST = YCORD * CSCALE CALL PLOT( XLAST, YLAST, IPEN) CONOLD = CONTOR GOTO 10 ELSE * This is atomic symbol, I hope CALL LCLEAN( DUMMY, DUMMY , .TRUE.) N = INDEX( DUMMY( I:), ' ') - 1 CBCD = DUMMY( I: I+N ) * clear area in black first CALL PLOT ( XTEMP, YTEMP, 4) XTEMP = ( XCORD - 0.005 ) * CSCALE XEND = XTEMP + 0.019 * N YTEMP = ( YCORD - 0.006 ) * CSCALE DO 30 K = 1, 10 YTEMP = YTEMP + .003 CALL PLOT ( XTEMP, YTEMP, 2) CALL PLOT ( XEND, YTEMP, 3) 30 CONTINUE * set color to white XTEMP = 1.0 CALL PLOT ( XTEMP, YCORD, 99) XTEMP = XCORD * CSCALE YTEMP = YCORD * CSCALE ZTEMP = 0.02 THETA = 0.0 CALL SIMBOL ( XTEMP, YTEMP, ZTEMP, CBCD, THETA, N) * set color back to what it was XTEMP = ICOLOR CALL PLOT ( XTEMP, YCORD, 99) * and move back to last point IPEN = 2 CALL PLOT( XLAST, YLAST, IPEN) GOTO 10 ENDIF * 31 WRITE( *,'('' Error in CONTOUR file.'')') IOERR=1 RETURN 99 WRITE ( *, '('' End of CONTOUR file.'')') MORE = .FALSE. RETURN * 100 CONTINUE MORE = .FALSE. RETURN END