path: root/sys/gio/ncarutil/autograph/agsetp.f

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