diff options
Diffstat (limited to 'sys/gio/ncarutil/autograph/agsetp.f')
| -rw-r--r-- | sys/gio/ncarutil/autograph/agsetp.f | 447 |
1 files changed, 447 insertions, 0 deletions
diff --git a/sys/gio/ncarutil/autograph/agsetp.f b/sys/gio/ncarutil/autograph/agsetp.f new file mode 100644 index 00000000..95e98a6d --- /dev/null +++ b/sys/gio/ncarutil/autograph/agsetp.f @@ -0,0 +1,447 @@ +C +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 + SUBROUTINE AGSETP (TPID,FURA,LURA) +C + CHARACTER*(*) TPID + DIMENSION FURA(LURA) +C +C The routine AGSETP stores user-provided values of the AUTOGRAPH +C parameters specified by the parameter identifier TPID. The arguments +C are as follows: +C +C -- TPID is the parameter identifier, a string of keywords separated +C from each other by slashes and followed by a period. +C +C -- FURA is the user array from which parameter values are to be taken. +C +C -- LURA is the length of the user array. +C +C The following common block contains the AUTOGRAPH control parameters, +C all of which are real. If it is changed, all of AUTOGRAPH (especially +C the routine AGSCAN) must be examined for possible side effects. +C + COMMON /AGCONP/ QFRA,QSET,QROW,QIXY,QWND,QBAC , SVAL(2) , + + XLGF,XRGF,YBGF,YTGF , XLGD,XRGD,YBGD,YTGD , SOGD , + + XMIN,XMAX,QLUX,QOVX,QCEX,XLOW,XHGH , + + YMIN,YMAX,QLUY,QOVY,QCEY,YLOW,YHGH , + + QDAX(4),QSPA(4),PING(4),PINU(4),FUNS(4),QBTD(4), + + BASD(4),QMJD(4),QJDP(4),WMJL(4),WMJR(4),QMND(4), + + QNDP(4),WMNL(4),WMNR(4),QLTD(4),QLED(4),QLFD(4), + + QLOF(4),QLOS(4),DNLA(4),WCLM(4),WCLE(4) , + + QODP,QCDP,WOCD,WODQ,QDSH(26) , + + QDLB,QBIM,FLLB(10,8),QBAN , + + QLLN,TCLN,QNIM,FLLN(6,16),QNAN , + + XLGW,XRGW,YBGW,YTGW , XLUW,XRUW,YBUW,YTUW , + + XLCW,XRCW,YBCW,YTCW , WCWP,HCWP,SCWP , + + XBGA(4),YBGA(4),UBGA(4),XNDA(4),YNDA(4),UNDA(4), + + QBTP(4),BASE(4),QMNT(4),QLTP(4),QLEX(4),QLFL(4), + + QCIM(4),QCIE(4),RFNL(4),WNLL(4),WNLR(4),WNLB(4), + + WNLE(4),QLUA(4) , + + RBOX(6),DBOX(6,4),SBOX(6,4) +C +C The following common block contains other AUTOGRAPH variables, both +C real and integer, which are not control parameters. +C + COMMON /AGORIP/ SMRL , ISLD , MWCL,MWCM,MWCE,MDLA,MWCD,MWDQ , + + INIF +C +C The following common block contains other AUTOGRAPH variables, of type +C character. +C + COMMON /AGOCHP/ CHS1,CHS2 +C +c+noao +c CHARACTER*504 CHS1,CHS2 + CHARACTER*500 CHS1,CHS2 +c-noao +C +C Define the array DUMI, which allows access to the control-parameter +C list as an array. +C + DIMENSION DUMI(1) + EQUIVALENCE (QFRA,DUMI) +C +C +NOAO - Make sure common has been initialized. +C + call agdflt +C +C -NOAO +C If initialization has not yet been done, do it. +C + IF (INIF.EQ.0) THEN + CALL AGINIT + END IF +C +C The routine AGSCAN is called to scan the parameter identifier and to +C return three quantities describing the AUTOGRAPH parameters affected. +C + CALL AGSCAN (TPID,LOPA,NIPA,IIPA) +C +C Determine the number of values to transfer. +C + NURA=MAX0(1,MIN0(LURA,NIPA)) +C +C If character-string dash patterns are being replaced by integer dash +C patterns, reclaim the space used in the character-storage arrays. +C + CALL AGSCAN ('DASH/PATT.',LODP,NIDP,IIDP) + IF (LOPA.LE.LODP+NIDP-1.AND.LOPA+NURA-1.GE.LODP) THEN + MINI=MAX0(LOPA,LODP)-LOPA+1 + MAXI=MIN0(LOPA+NURA-1,LODP+NIDP-1)-LOPA+1 + DO 100 I=MINI,MAXI + IF (FURA(I).GT.0.) CALL AGDLCH (IFIX(DUMI(LOPA+I-1))) + 100 CONTINUE + END IF +C +C Save the current values of special values 1 and 2. +C + SVL1=SVAL(1) + SVL2=SVAL(2) +C +C Transfer the user-provided values to the parameter list. +C + IDMI=LOPA-IIPA +C + DO 101 IURA=1,NURA + IDMI=IDMI+IIPA + DUMI(IDMI)=FURA(IURA) + 101 CONTINUE +C +C If a specific item was changed, we may have a bit more work to do; +C otherwise, return to the user. +C + IF (NIPA.NE.1) RETURN +C +C If the specific item was special value 1 or 2, scan the primary list +C of parameters for other occurrences of the special value and change +C them to the new value. +C + IF (SVAL(1).NE.SVL1) THEN + SVLO=SVL1 + SVLN=SVAL(1) + GO TO 102 + END IF +C + IF (SVAL(2).NE.SVL2) THEN + SVLO=SVL2 + SVLN=SVAL(2) + GO TO 102 + END IF +C + GO TO 104 +C + 102 CALL AGSCAN ('PRIM.',LOPR,NIPR,IIPR) +C + IDMI=LOPR-IIPR +C + DO 103 I=1,NIPR + IDMI=IDMI+IIPR + IF (DUMI(IDMI).EQ.SVLO) DUMI(IDMI)=SVLN + 103 CONTINUE +C + RETURN +C +C If the specific item was the label control flag and it was set +C negative, delete all labels and lines. +C + 104 CALL AGSCAN ('LABE/CONT.',LOLC,NILC,IILC) + IF (LOPA.NE.LOLC) GO TO 107 + IF (QDLB.GE.0.) RETURN +C + QBAN=0. + QNAN=0. +C + LBIM=IFIX(QBIM) +C + DO 105 I=1,LBIM + IF (FLLB(1,I).NE.0.) THEN + CALL AGDLCH (IFIX(FLLB(1,I))) + FLLB(1,I)=0. + END IF + 105 CONTINUE +C + LNIM=IFIX(QNIM) +C + DO 106 I=1,LNIM + IF (FLLN(1,I).NE.SVAL(1)) THEN + CALL AGDLCH (IFIX(FLLN(4,I))) + FLLN(1,I)=SVAL(1) + END IF + 106 CONTINUE +C + RETURN +C +C If the specific item was the label name, reset it to an appropriate +C index in the label list, providing initial values if appropriate. +C + 107 CALL AGSCAN ('LABE/NAME.',LOLN,NILN,IILN) + IF (LOPA.NE.LOLN) GO TO 109 +C + LBAN=0 + LBIM=IFIX(QBIM) + QNAN=0. +C + CALL AGGTCH (IFIX(FURA(1)),CHS1,LCS1) +C + DO 108 I=1,LBIM + IF (LBAN.EQ.0.AND.FLLB(1,I).EQ.0.) LBAN=I + CALL AGGTCH (IFIX(FLLB(1,I)),CHS2,LCS2) + IF (LCS1.NE.LCS2) GO TO 108 + IF (CHS1(1:LCS1).NE.CHS2(1:LCS2)) GO TO 108 + QBAN=FLOAT(I) + RETURN + 108 CONTINUE +C + IF (LBAN.EQ.0) GO TO 901 +C + QBAN=FLOAT(LBAN) +C + FLLB( 1,LBAN)=FURA(1) + FLLB( 2,LBAN)=0. + FLLB( 3,LBAN)=.5 + FLLB( 4,LBAN)=.5 + FLLB( 5,LBAN)=0. + FLLB( 6,LBAN)=0. + FLLB( 7,LBAN)=0. + FLLB( 8,LBAN)=0. + FLLB( 9,LBAN)=0. + FLLB(10,LBAN)=0. +C + RETURN +C +C If the label access name is not set, skip. +C + 109 IF (QBAN.LE.0.) GO TO 122 +C + LBAN=IFIX(QBAN) + LBIM=IFIX(QBIM) + LNAN=IFIX(QNAN) + LNIM=IFIX(QNIM) +C +C If the specific item was the suppression flag for the current label +C and it was set negative, delete the label and/or its lines. +C + CALL AGSCAN ('LABE/SUPP.',LOLS,NILS,IILS) + IF (LOPA.NE.LOLS) GO TO 111 + IF (FLLB(2,LBAN).GE.0.) RETURN +C + ITMP=IFIX(FLLB(2,LBAN)) + FLLB(2,LBAN)=0. + FLLB(9,LBAN)=0. + LNIN=IFIX(FLLB(10,LBAN)) + FLLB(10,LBAN)=0. + QNAN=0. + IF (ITMP.EQ.(-1)) GO TO 110 + CALL AGDLCH (IFIX(FLLB(1,LBAN))) + FLLB(1,LBAN)=0. + QBAN=0. +C + 110 IF (LNIN.LT.1.OR.LNIN.GT.LNIM) RETURN + FLLN(1,LNIN)=SVAL(1) + CALL AGDLCH (IFIX(FLLN(4,LNIN))) + LNIN=IFIX(FLLN(6,LNIN)) + GO TO 110 +C +C If the specific item was the line number, reset it to an appropriate +C index in the line list, providing initial values if appropriate. +C + 111 CALL AGSCAN ('LINE/NUMB.',LOLN,NILN,IILN) + IF (LOPA.NE.LOLN) GO TO 118 +C + LNIL=0 + LNIN=IFIX(FLLB(10,LBAN)) +C + 112 IF (LNIN.LT.1.OR.LNIN.GT.LNIM) GO TO 115 + IF (LNAN-IFIX(FLLN(1,LNIN))) 113,114,115 +C + 113 LNIL=LNIN + LNIN=IFIX(FLLN(6,LNIN)) + GO TO 112 +C + 114 QNAN=FLOAT(LNIN) + RETURN +C + 115 DO 116 I=1,LNIM + LNIT=I + IF (FLLN(1,I).EQ.SVAL(1)) GO TO 117 + 116 CONTINUE +C + GO TO 903 +C + 117 CALL AGSTCH (' ',1,ITMP) +C + FLLN(1,LNIT)=FLOAT(LNAN) + FLLN(2,LNIT)=0. + FLLN(3,LNIT)=.015 + FLLN(4,LNIT)=ITMP + FLLN(5,LNIT)=1. + FLLN(6,LNIT)=FLOAT(LNIN) +C + LNAN=LNIT + IF (LNIL.EQ.0) FLLB(10,LBAN)=FLOAT(LNAN) + IF (LNIL.NE.0) FLLN( 6,LNIL)=FLOAT(LNAN) +C + FLLB(9,LBAN)=FLLB(9,LBAN)+1. +C + QNAN=FLOAT(LNAN) + RETURN +C +C If the line access number is not set, skip. +C + 118 IF (LNAN.LE.0) GO TO 122 +C +C If the specific item was the suppression flag for the current line and +C it was set negative, delete the line. +C + CALL AGSCAN ('LINE/SUPP.',LOLS,NILS,IILS) + IF (LOPA.NE.LOLS) GO TO 121 + IF (FLLN(2,LNAN).GE.0.) RETURN +C + LNIL=0 + LNIN=IFIX(FLLB(10,LBAN)) +C + 119 IF (LNIN.LT.1.OR.LNIN.GT.LNIM) RETURN + IF (LNAN.EQ.LNIN) GO TO 120 + LNIL=LNIN + LNIN=IFIX(FLLN(6,LNIN)) + GO TO 119 +C + 120 IF (LNIL.EQ.0) FLLB(10,LBAN)=FLLN(6,LNAN) + IF (LNIL.NE.0) FLLN( 6,LNIL)=FLLN(6,LNAN) + FLLN(1,LNAN)=SVAL(1) + CALL AGDLCH (IFIX(FLLN(4,LNAN))) + QNAN=0. + RETURN +C +C If the specific item was the text of a line, set the length of the +C line, as well. +C + 121 CALL AGSCAN ('LINE/TEXT.',LOLT,NILT,IILT) + IF (LOPA.NE.LOLT) GO TO 123 + CALL AGGTCH (IFIX(FURA(1)),CHS1,LCS1) + FLLN(5,LNAN)=FLOAT(LCS1) + RETURN +C +C See if the user is trying to get at a line of a non-existent label. +C + 122 CALL AGSCAN ('LINE/NUMB.',LOLN,NILN,IILN) + IF (LOPA.EQ.LOLN) GO TO 902 +C +C If the specific item was the background parameter, set up the back- +C ground requested by the user. +C + 123 CALL AGSCAN ('BACK.',LOBG,NIBG,IIBG) + IF (LOPA.NE.LOBG) GO TO 130 +C + QBAC=AMAX1(1.,AMIN1(4.,QBAC)) + IBAC=IFIX(QBAC) + GO TO (124,125,126,127) , IBAC +C +C Perimeter background. +C + 124 QLBC=4. + QRTC=4. + WMJI=.015 + WMNI=.010 + GO TO 128 +C +C Grid background. +C + 125 QLBC=4. + QRTC=-1. + WMJI=1. + WMNI=1. + GO TO 128 +C +C Half-axis background. +C + 126 QLBC=4. + QRTC=0. + WMJI=.015 + WMNI=.010 + GO TO 128 +C +C No background. +C + 127 QLBC=0. + QRTC=0. + WMJI=.015 + WMNI=.010 +C + 128 QDAX(1)=QLBC + QDAX(2)=QRTC + QDAX(3)=QLBC + QDAX(4)=QRTC +C + DO 129 I=1,4 + WMJR(I)=WMJI + WMNR(I)=WMNI + 129 CONTINUE +C + QDLB=FLOAT(2-2*(IBAC/4)) + RETURN +C +C If the specific item was the get-limits-from-last-SET-call parameter, +C do what is necessary. +C + 130 CALL AGSCAN ('SET .',LOSE,NISE,IISE) + IF (LOPA.NE.LOSE) GO TO 131 +C + QSET=SIGN(AMAX1(1.,AMIN1(4.,ABS(QSET))),QSET) +C + XLGD=.15 + XRGD=.95 + YBGD=.15 + YTGD=.95 + SOGD=0. +C + XMIN=SVAL(1) + XMAX=SVAL(1) + QLUX=AMIN1(QLUX,0.) + QOVX=0. + QCEX=-1. + XLOW=SVAL(1) + XHGH=SVAL(1) +C + YMIN=SVAL(1) + YMAX=SVAL(1) + QLUY=AMIN1(QLUY,0.) + QOVY=0. + QCEY=-1. + YLOW=SVAL(1) + YHGH=SVAL(1) +C + RETURN +C +C Return to caller. +C + 131 RETURN +C +C Error exits. +C + 901 CALL AGPPID (TPID) + CALL SETER ('AGSETP - LABEL LIST OVERFLOW - SEE AUTOGRAPH SPECIALI + +ST',15,2) +C + 902 CALL AGPPID (TPID) + CALL SETER ('AGSETP - ATTEMPT TO DEFINE LINE OF NON-EXISTENT LABEL + +',16,2) +C + 903 CALL AGPPID (TPID) + CALL SETER ('AGSETP - LINE LIST OVERFLOW - SEE AUTOGRAPH SPECIALIS + +T',17,2) +C + END |