C @(#)rfotanalys.for	19.1 (ES0-DMD) 02/25/03 13:30:13
C===========================================================================
C Copyright (C) 1995 European Southern Observatory (ESO)
C
C This program is free software; you can redistribute it and/or 
C modify it under the terms of the GNU General Public License as 
C published by the Free Software Foundation; either version 2 of 
C the License, or (at your option) any later version.
C
C This program is distributed in the hope that it will be useful,
C but WITHOUT ANY WARRANTY; without even the implied warranty of
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public 
C License along with this program; if not, write to the Free 
C Software Foundation, Inc., 675 Massachusetss Ave, Cambridge, 
C MA 02139, USA.
C
C Corresponding concerning ESO-MIDAS should be addressed as follows:
C	Internet e-mail: midas@eso.org
C	Postal address: European Southern Observatory
C			Data Management Division 
C			Karl-Schwarzschild-Strasse 2
C			D 85748 Garching bei Muenchen 
C			GERMANY
C===========================================================================
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C.IDENTIFICATION: RFOTANALYS
C.PURPOSE:   Select all stars within selected subfield (input mode)
C.           Look at results of fit operation and select results for final
C.           storage (output mode)
C.AUTHOR:    R. Buonanno, G. Buscema, C. Corsi, I. Ferraro, G. Iannicola
C.           Osservatorio Astronomico di Roma
C.           Modified for MIDAS:  Rein. H. Warmels, ESO
C.VERSION    870127  RHW  First implementation in MIDAS
C.VERSION    890425  RHW  Implementation of the ST interfaces
C.VERSION    890425  RHW  Conversion for the Portable MIDAS version
C.NOTES:     This program is a modified version of the orginal Romafot module
C            It consists of a main body and a number of procedures which 
C            correspond which the options the program offers to the user.
C----------------------------------------------------------------------------
       PROGRAM      ANALYS

       IMPLICIT     NONE
       INCLUDE      'MID_REL_INCL:RFOTDECL.INC'
C
       INTEGER      MX1
       INTEGER      MY1
       INTEGER      MX2
       INTEGER      KFD
       INTEGER      MXYF
       INTEGER      MXYR
       INTEGER      MBB
       INTEGER      NCD
       INTEGER      NTB
       INTEGER      NN
       INTEGER      IDP
       INTEGER      IDB
       PARAMETER    (MX1=55)
       PARAMETER    (MY1=MX1)
       PARAMETER    (MX2=110)
       PARAMETER    (KFD=10000) 
       PARAMETER    (MXYF=MX1*3+15) 
       PARAMETER    (MXYR=(MX1*3)*2+30)
       PARAMETER    (MBB=256)
       PARAMETER    (NCD=MBB-18)
       PARAMETER    (NTB=NCD/3)
       PARAMETER    (NN=NCD/6.5)
       PARAMETER    (IDP=(NN*4)+3)
       PARAMETER    (IDB=NTB*3)
C
C *** Procedure names
       INTEGER      ACCSTE,ACSTDA,APPDAT,APPNF,APRKFI
       INTEGER      CONMAT,CANREC,COLFAC,CAMSLO
       INTEGER      DIMMAT,DISAGA,DISISO,DEPM,DEFMAP,DEFR
       INTEGER      DELCMP,DELHOL,FABUC, FINPRO,GRAISO,HELP
       INTEGER      INIFIN,INPDAT,INTEGR,ISOSTE, LEMARA, LEGMAT
       INTEGER      PARLAS,PNONCE,PREMAS
       INTEGER      RICFIL,RESMAT,RIPBUC,RIPFIN,RIPMAS
       INTEGER      RISCOM,RIMANF
       INTEGER      SCRBUC,SPOMAT,SCAPRO,SEREOU,SEREIN
       INTEGER      SMOOTH
       INTEGER      TROLIV,TYPNOM,TYPCOM
       INTEGER      VISMAT,WNDRD,XYMAX,VERREC
C
C ***  MIDAS parameters
       INTEGER      NONS(NN)
       INTEGER      CURDAT(4)
       INTEGER      MADRID(1)
       INTEGER      IVB(KFD)
       INTEGER      IINPUT(10)
       REAL         PB(IDB)
       REAL         RMASK(MX1,MY1)
       REAL         RNY(MY1,MX1)
       REAL         RNF(MY1,MX1)
       REAL         VVV(13)
       REAL         P(IDP)
       REAL         RIA(MX2)
       REAL         USC(NN),USE(NN)
       REAL         RESI(MY1,MX1)
       REAL         RINPUT(10)
       LOGICAL      COND
       LOGICAL      NEXTW
       LOGICAL      KALO
       LOGICAL      LOG23
       CHARACTER    CCOM*1
       CHARACTER    STRING*80
       CHARACTER    DSA*1, RAI*1, IGS*1, IGS2*1, CAR*1, IOD*1
       CHARACTER    SMY*1, INY*1, BBC*1, IAM*1, RFM*1
C
       INTEGER      COOS(2,2),IXYA(2),IXYB(2),MCA,MCB,ISCA,ISCB
       INTEGER      DAZHLD(14),UNI(1),NULO,ENTFLG,GRE
       INTEGER      ED, EC, EL
       INTEGER      FLAGS(2)
       INTEGER      IWND, IDWND, IDWND1
       INTEGER      IRWND1, IRWND2, IRWNDC, IRWNDI
       INTEGER      IDHOL, IDHOL1, IRHOL, IHOL
       INTEGER      IDISIS, IPIANT
       INTEGER      IDCMP, IDCMP1, IRCMP, IROW, ICMP
       INTEGER      INDM, IIST, IGL, ISIT
       INTEGER      I1, I2, I3
       INTEGER      IDN, IFG, IAI
       INTEGER      IAX, IAY
       INTEGER      I, IC, IH, IHS, ICB, IK
       INTEGER      IX, IY
       INTEGER      IX0, IY0
       INTEGER      IHO
       INTEGER      ILX, ILY
       INTEGER      IPX, IPY
       INTEGER      IPXE, IPYE
       INTEGER      IP3
       INTEGER      IPXS, IPYS
       INTEGER      IPXSA, IPYSA
       INTEGER      IPJ1, IPJ2, IPJX, IPJY
       INTEGER      IMF
       INTEGER*8    IPNTR
       INTEGER      IA1, IA2, IA3, IA4, IA5, IA6, IA7, IA8
       INTEGER      IZE, IHE, IFA, IFONDO
       INTEGER      IAC, ISTAT, IAV
       INTEGER      JX, JY
       INTEGER      JFVR
       INTEGER      JIL, JAC, JN, J5, JK
       INTEGER      KK1, KK2 
       INTEGER      K3
       INTEGER      KAUT, K23
       INTEGER      LF4, LFF, LI
       INTEGER      LIV, LLVV
       INTEGER      L, LCHAR
       INTEGER      L2, L3, L4, L5
       INTEGER      L21, L22 
       INTEGER      LLL, LSTA, LSTO
       INTEGER      LJ1, LJ3, LK
       INTEGER      LMB, L78, K1G
       INTEGER      MX, MY
       INTEGER      N1, NOC, NN1, NNI
       INTEGER      NPI, NCI, NWD, NHL, MAXH, NC, NP, NCP, NFINP
       INTEGER      NITER
       INTEGER      NAXIS, NPL, NL
       INTEGER      N1X, N1Y
       INTEGER      NOBJ, NGR
       INTEGER      NSR, NIL, NPN, NCN
       INTEGER      NOCHAN, NSTCAT
       INTEGER      NPI1, NPC1
       INTEGER      NPM, NCM
       INTEGER      NULL
       INTEGER      TIDCAT, TIDINT
       REAL         AMINH
       REAL         AAX, AAY
       REAL         AX, AY
       REAL         BBB, P33
       REAL         AAII, SOSO
       REAL         AM
       REAL         D1, D2, D3, D4, DDD, DELT
       REAL         RMA, RR
       REAL         V, B, U, H
       REAL         FLCO, F78, FAT, FOG, SCAP, FOG1
       REAL         CUU, SIGMA, BETA, SAT, AIN, SIV
       REAL         SAS01, S01, SOAL, SSS
       REAL         VG, ESPO
       REAL         PIXV, PMAX
       REAL         FATSA, FATT1, RABU, ZESI, RL
       REAL         BA1, BA2, BA3, BA4, BA5, BA6
       REAL         DUM1, DUM2, DUM3, DUM4, DUM5 ,DUM6
       REAL         DUM7, DUM8, DUM9, DUM10, DUM11, DUM12, DUM13
       
       INTEGER      KUN, KNUL
       INTEGER      NCCAT, NRCAT, NSCAT, NACCAT, NARCAT
       INTEGER      NCINT, NRINT, NSINT, NACINT, NARINT
       INTEGER      INTNUM(2),CATNUM(2)
       INTEGER      NPIX(3)
       INTEGER      TINULL
       INTEGER      COLERR
       INTEGER      ERRCOD,CHAN

       DOUBLE PRECISION BEGIN(3),STEP(3)
       DOUBLE PRECISION TDNULL,TDTRUE,TDFALS
       REAL         TRNULL,TBLSEL
       CHARACTER    FRAME*60,CATFIL*60,INTFIL*60
       CHARACTER    IDENT*72,CUNIT*72
       CHARACTER*60 GRPREF,IDNREF
       LOGICAL      CATAL
C
       REAL         GALEG
       REAL         GALE2
C
       INCLUDE      'MID_INCLUDE:ST_DEF.INC'
       INCLUDE      'MID_INCLUDE:IDIDEV.INC'
       INCLUDE      'MID_INCLUDE:IDIMEM.INC'
       COMMON       /VMR/MADRID
C
       INTEGER      ICGRP
       INTEGER      ICIDN
       INTEGER      ICGEN(NINTP)
       INTEGER      ICFLG
       INTEGER      ICPAR(NINTC)
C
       INCLUDE      'MID_INCLUDE:ST_DAT.INC'
       DATA         ICGRP/1/
       DATA         ICIDN/2/
       DATA         ICGEN/3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18/
       DATA         ICFLG/19/
       DATA         ICPAR/20,21,22,23,24,25/
C
       DATA         NEXTW/.FALSE./
       DATA         CATAL/.FALSE./
       DATA         GRPREF/':GROUP'/
       DATA         IDNREF/':IDENT'/
       DATA         CHAN/0/
       DATA         SMY/'N'/
       DATA         INY/'N'/
       DATA         CURDAT/100,1,1,2/
       DATA         COOS/-1,-1,-1,-1/
       DATA         FLAGS/1,1/
C
C *** format statements
  30  FORMAT('*** INFO: Number of components to examine: ',I5)

C
C *** Start the program *****************************************************
      CALL STSPRO('ANALYS')
      CALL DTOPEN(1,ERRCOD)
      CALL STKRDI('DAZHOLD',1,14,IAV,DAZHLD,UNI,NULO,ISTAT)
      CALL CONCHA(QDSPNO,QIMCH,0,0)                            ! clear image
      CALL CONCHA(QDSPNO,QOVCH,0,0)                            ! clear graphics
C
      NOC = DAZHLD(1)
      IF (DAZHLD(2).EQ.-1) THEN
         IF (NOC.EQ.2) THEN
            N1  = 0
            NN1 = 0
         ELSE
            N1  = 3
            NN1 = 2
         ENDIF
      ELSE
         N1  = 99
         NN1 = 2
      ENDIF
C
      IF (IDINUM.EQ.11) THEN
         ENTFLG = 1
      ELSE 
         ENTFLG = 2
      ENDIF
      CALL SETCUR(QDSPNO,NOC,N1,NN1,COOS,ISTAT)
C
      CALL TBMNUL(TINULL,TRNULL,TDNULL)
      CALL TBMCON(TBLSEL,TDTRUE,TDFALS)
      NNI = NN 
      LMB = NTB
      MX  = MX1
      MY  = MY1
C
C *** read the frame
      CALL STKRDC('IN_A',1,1,60,IAC,FRAME,KUN,KNUL,ISTAT)
      CALL STIGET(FRAME,D_R4_FORMAT,F_I_MODE,F_IMA_TYPE,3,NAXIS,
     2            NPIX,BEGIN,STEP,IDENT,CUNIT,IPNTR,IMF,ISTAT)
      NPL   = NPIX(1)
      NL    = NPIX(2)
C
C *** read the catalogue file
      CALL STKRDC('IN_B',1,1,60,IAC,CATFIL,KUN,KNUL,ISTAT)     ! catalogue file
C
C *** read the intermediate file
      CALL STKRDC('INPUTC',1,1,60,IAC,INTFIL,KUN,KNUL,ISTAT)     ! interm. file
C
C *** open the catalogue table
      CALL STECNT('GET',EC,ED,EL)
      CALL STECNT('PUT',1,0,0)
      CALL TBTOPN(CATFIL,F_IO_MODE,TIDCAT,ISTAT)
      IF (ISTAT.NE.0) THEN                                       ! problems
         CATAL = .FALSE.
         STRING = '*** INFO: No catalogue table present'
         CALL STTPUT(STRING,ISTAT)

      ELSE                                             ! get catalog table info
         CALL TBIGET(TIDCAT,NCCAT,NRCAT,NSCAT,NACCAT,NARCAT,ISTAT)
         IF (ISTAT.NE.0) THEN
            STRING = '*** FATAL: Problems with getting info for '//
     2               ' catalogue table; Try again ... '
            CALL STTPUT(STRING,ISTAT)
            CALL STSEPI
         ENDIF
C
         IF (NRCAT.EQ.0) THEN
            STRING = '*** FATAL: No data points in catalogue table'
            CALL STTPUT(STRING,ISTAT)
            CALL STSEPI
         ENDIF
C
         CATAL  = .TRUE.                                 ! catalogue is present
         IRWNDC = 1                                    ! and read the catalogue
         CALL CATTRD(TIDCAT,IRWNDC,CUU,VVV(1),VVV(2),VVV(3),VVV(4),
     2                      VVV(5),VVV(6),VVV(7),VVV(8),VVV(9),
     3                      VVV(10),VVV(11),VVV(12),VVV(13))
         CALL TBCSER(TIDCAT,GRPREF,CATNUM(1),ISTAT)     ! CAT column for group
         SIGMA = VVV(9)
         BETA  = VVV(10)
         SAT   = VVV(11)
         AIN   = VVV(12)
         SIV   = VVV(13)
      ENDIF
C
C *** get the intermediate table
      CALL TBTOPN(INTFIL,F_IO_MODE,TIDINT,ISTAT)
      IF (ISTAT.NE.0) THEN                                   ! no interm. table
         IF (.NOT.CATAL) THEN
            STRING = '*** FATAL: You need at least a catalogue or '//
     2                          'an intermediate table ...'
            CALL STTPUT(STRING,ISTAT)
            CALL STSEPI
         ELSE
            STRING = '*** INFO: No intermediate table present '//
     2                          'we will create one'
            CALL STTPUT(STRING,ISTAT)
            CALL INTINI(INTFIL,TIDINT)                   ! create interm. table
            CALL TBCSER(TIDINT,GRPREF,INTNUM(1),ISTAT)   ! column for group 
            CALL TBCSER(TIDINT,IDNREF,INTNUM(2),ISTAT)   ! column for ident
            NGR    = 0                                   ! number of groups
            NOBJ   = 0                                   ! number of objects
            NSR    = 0                                   ! number of iterations
            IRWNDI = 0                                ! point to current group 
            NRINT  = 0                                   ! number of rows
         ENDIF

      ELSE                            !table present; does it contain something
         CALL TBIGET(TIDINT,NCINT,NRINT,NSINT,NACINT,NARINT,ISTAT)
         IF (ISTAT.NE.0) THEN
             STRING = '*** FATAL: Problems with getting info for '//
     2                ' intermediate table; Try again ... '
             CALL STTPUT(STRING,ISTAT)
             CALL STSEPI
         ENDIF
C
         IF (NRINT.EQ.0) THEN
            STRING = '*** FATAL: No data points in intermediate table'
            CALL STTPUT(STRING,ISTAT)
            IF (CATAL) THEN
               NNI    = 5
               NGR    = 0
               NOBJ   = 0
               NSR    = 0
               IRWNDI = 0                           ! pointer to current group 
               NRINT  = 0                                      ! number of rows
               GO TO 50
            ELSE
               CALL STSEPI
            ENDIF
         ENDIF
C                                                       ! read table descriptor
         CALL INTDRD(TIDINT,NGR,NOBJ,NSR,SAT,FAT,SIGMA,BETA,SIV,AIN,FOG)
         CALL TBCSER(TIDINT,GRPREF,INTNUM(1),ISTAT)     ! INT column for group 
         CALL TBCSER(TIDINT,IDNREF,INTNUM(2),ISTAT)      ! INT column for ident
      ENDIF
   50 CONTINUE
C
C ***  
      ASSIGN 50151 TO PARLAS  
      GO TO 50051
50151 CONTINUE

C
C *** do the work !!!
      NOCHAN = 1
      KAUT   = 1
C
      IF (CATAL) THEN
         CALL CATDRD(TIDCAT,NSTCAT,IA1,IA2,BA1,BA2,IA3,IA4,IA5,IA6,
     2                          BA3,BA4,BA5,BA6,IA7,IA8)
      ELSE
         NSTCAT = 0
      ENDIF
      WRITE(STRING,30) NSTCAT
      CALL STTPUT(STRING,ISTAT)
C
      IRWNDI = 0
      IAM    = 'M'
      RAI    = 'M'
      BBC    = 'M'
      IGS    = 'A'
      IZE    = 1
      IHE    = 1
      SAS01  = 0.007
      S01    = SAS01
      NPI    = 23
      NCI    = 23
      DSA    = 'A'
      DDD    = 3.
      K23    = 0
      F78    = 1.
      FATSA  = 4
      FATT1  = FATSA
      ZESI   = -2.
      DO 101 I = 1,NN
         FLGCMP(I) = 1
         FLGHOL(I) = 1
  101 CONTINUE
C
 100  continue
      IF (CAR.EQ.'F') THEN
         CALL INTDWR(TIDINT,NGR,NOBJ,NSR,SAT,FAT,SIGMA,BETA,SIV,AIN,FOG)
         CALL TBSINI(TIDINT,ISTAT)                          ! close the old one
         CALL TBTCLO(TIDINT,ISTAT)                          ! close the old one
         CALL DTCLOS(QDSPNO)
         CALL STSEPI
      ENDIF
C
      KALO = .FALSE.
      CALL UPCAS(CCOM,CCOM)    
      IF (CCOM.EQ.'M') THEN
         CALL STKPRC('Enter option [M]: ',
     2            'INPUTC',1,1,1,IAV,CCOM,KUN,KNUL,ISTAT)
         IF (IAV.EQ.0) THEN
            CCOM = 'M'
         ENDIF

      ELSE
         CALL STKPRC('Enter option [D]: ',
     2            'INPUTC',1,1,1,IAV,CCOM,KUN,KNUL,ISTAT)
         IF (IAV.EQ.0) THEN
            CCOM = 'D'
         ENDIF
      ENDIF

      CALL UPCAS(CCOM,CAR)    
      IF (CAR.EQ.'D' .OR. CAR.EQ.'M') THEN
         KALO = .TRUE.
      ENDIF
C
C *** here come the choises
      IF (CAR.EQ.'A') THEN
         ASSIGN 50101 TO DEFMAP
         GO TO 50001
50101    CONTINUE

      ELSE IF (CAR.EQ.'B') THEN
         ASSIGN 50102 TO SCAPRO
         GO TO 50002
50102    CONTINUE

      ELSE IF (CAR.EQ.'C') THEN
         ASSIGN 50103 TO CANREC
         GO TO 50003
50103    CONTINUE

      ELSE IF ((CAR.EQ.'D') .OR. (KALO.AND.KAUT.EQ.2)) THEN
         ASSIGN 50104 TO CONMAT
         GO TO 50004
50104    CONTINUE

      ELSE IF (CAR.EQ.'E') THEN
         STRING = 'E__Use cursor to pass the hole coordinates'
         CALL STTPUT(STRING,ISTAT)
         CALL CURSIN(QDSPNO,0,NOC,IXYA,MCA,ISCA,IXYB,MCB,ISCB)
         CALL CURSIN(QDSPNO,ENTFLG,NOC,IXYA,MCA,ISCA,IXYB,MCB,ISCB)
         IX = IXYA(1)
         IY = IXYA(2)
         ASSIGN 50105 TO FABUC
         GO TO 50005
50105    CONTINUE

      ELSE IF (CAR.EQ.'F') THEN
         ASSIGN 50106 TO FINPRO
         GO TO 50006
50106    CONTINUE

      ELSE IF (CAR.EQ.'G') THEN
         ASSIGN 50107 TO RIPBUC
         GO TO 50007
50107    CONTINUE

      ELSE IF (CAR.EQ.'H') THEN
         ASSIGN 50108 TO HELP
         GO TO 50008
50108    CONTINUE

      ELSE IF ((CAR.EQ.'I') .OR. (CAR.EQ.'J')) THEN
         ASSIGN 50109 TO INPDAT
         GO TO 50009
50109    CONTINUE

      ELSE IF (CAR.EQ.'K') THEN
         ASSIGN 50111 TO XYMAX
         GO TO 50011
50111    CONTINUE

      ELSE IF (CAR.EQ.'L') THEN
         ASSIGN 50112 TO TROLIV
         GO TO 50012
50112    CONTINUE

      ELSE IF ((CAR.EQ.'M') .OR. (KALO .AND. KAUT.EQ.1)) THEN
         ASSIGN 50113 TO ACCSTE
         GO TO 50013
50113    CONTINUE

      ELSE IF (CAR.EQ.'N') THEN
         ASSIGN 50114 TO ACSTDA
         GO TO 50014
50114    CONTINUE

      ELSE IF (CAR.EQ.'P') THEN
         ASSIGN 50116 TO ISOSTE
         GO TO 50016
50116    CONTINUE

      ELSE IF (CAR.EQ.'Q') THEN
         ASSIGN 50117 TO RIPFIN
         GO TO 50017
50117    CONTINUE

      ELSE IF (CAR.EQ.'R') THEN
         ASSIGN 50118 TO RESMAT
         GO TO 50018
50118    CONTINUE

      ELSE IF (CAR.EQ.'S') THEN
         ASSIGN 50119 TO SPOMAT
         GO TO 50019
50119    CONTINUE

      ELSE IF (CAR.EQ.'T') THEN
         ASSIGN 50120 TO PNONCE
         GO TO 50020
50120    CONTINUE

      ELSE IF (CAR.EQ.'U')THEN
         ASSIGN 50121 TO COLFAC
         GO TO 50021
50121    CONTINUE

      ELSE IF (CAR.EQ.'V') THEN
         ASSIGN 50122 TO APRKFI
         GO TO 50022
50122    CONTINUE

      ELSE IF (CAR.EQ.'W') THEN
         ASSIGN 50123 TO CAMSLO
         GO TO 50023
50123    CONTINUE

      ELSE IF ((CAR.EQ.'X') .OR. (CAR.EQ.'Y')) THEN
         ASSIGN 50124 TO DISISO
         IDISIS = 1
         GO TO 50024
50124    CONTINUE

      ELSE IF (CAR.EQ.'Z') THEN
         ASSIGN 50126 TO DEPM
         GO TO 50026
50126    CONTINUE

      ELSE IF (CAR.EQ.'4') THEN
         ASSIGN 50134 TO SEREOU
         GO TO 50034
50134    CONTINUE

      ELSE IF (CAR.EQ.'5') THEN
         ASSIGN 50135 TO SEREIN
         GO TO 50035
50135    CONTINUE

      ELSE IF (CAR.EQ.'6') THEN
         ASSIGN 50136 TO SMOOTH
         GO TO 50036
50136    CONTINUE

      ELSE IF (CAR.EQ.'7') THEN
         ASSIGN 50137 TO INTEGR
         GO TO 50037
50137    CONTINUE

      ELSE IF (CAR.EQ.' ') THEN
         ASSIGN 50141 TO DISAGA
         GO TO 50041
50141    CONTINUE

      ELSE IF(CAR.EQ.'/') THEN
         ASSIGN 50142 TO DIMMAT
         GO TO 50042
50142    CONTINUE

      ELSE IF (CAR.EQ.'?') THEN
         ASSIGN 50143 TO DEFR
         GO TO 50043
50143    CONTINUE

      ELSE IF (CAR.EQ.'-') THEN
         ASSIGN 50144 TO SCRBUC
         GO TO 50044
50144    CONTINUE

      ELSE IF (CAR.EQ.'@') THEN
         ASSIGN 50145 TO RISCOM
         GO TO 50045
50145    CONTINUE

      ELSE
         CALL STTPUT('*** WARNING: Unknown ANALYSE option, '//
     2               'try again ...',ISTAT)
      END IF
      GO TO 100

C+++
50001  CONTINUE                                        ! Proc. DEFMAP; option A
C---
       IF (IPIANT.EQ.0) THEN
          IPIANT = 1
          CALL STTPUT('*** INFO: Colour map display enabled',ISTAT)
       ELSE
          IPIANT = 0
          CALL STTPUT('/__*** INFO: Contour map display enabled',ISTAT)
       ENDIF
C
       GO TO DEFMAP

C+++
50002  CONTINUE                                        ! Proc. SCAPRO; option B
C---
       CALL STKPRR('B__Enter graphic scale factor: ',
     2             'INPUTR',1,1,IAV,F78,KUN,KNUL,ISTAT)
       GO TO SCAPRO

C+++
50003  CONTINUE                                        ! Proc. CANREC; option C
C---
59003  FORMAT('C__*** INFO: Group',I5,' has ',I3,' component(s)')
58003  FORMAT('C__*** WARNING: Cannot find our component ',I3, 
     2        '; sorry ...')
C
       IF (NCP.GE.1) THEN
          WRITE(STRING,59003) IDWND,NCP                   ! write group  + comp
          CALL STTPUT(STRING,ISTAT)
          CALL STKPRI('C__Enter component to be deleted: ',
     2                'INPUTI',1,1,IAV,IDCMP,KUN,KNUL,ISTAT)
C
          IDCMP1 = IDCMP+100                                   ! ident in table
          CALL TBESRI(TIDINT,INTNUM(2),IDCMP1,COLERR,IRWNDI,
     2                IRCMP,ISTAT)
          IF (IRCMP.LE.0) THEN                           ! can't find component
             WRITE(STRING,58003) IDCMP
             CALL STTPUT(STRING,ISTAT)
             GO TO CANREC                                   ! return to monitor
          ELSE
             ICMP = IRCMP - IRWNDI + 1               ! which component in table
          ENDIF
C
          IF (ICMP.GT.NCP) THEN                             ! in another group 
             WRITE(STRING,58003) IDCMP
             CALL STTPUT(STRING,ISTAT)
             GO TO CANREC                                   ! return to monitor
          ELSE
             GRE = 0
             ASSIGN 50172 TO DELCMP                      ! delete the component
             GO TO 50072
50172        CONTINUE
             ASSIGN 50270 TO WNDRD                          ! reread the group 
             GO TO 50070
50270        CONTINUE
          ENDIF
C
       ELSE
          IF (IDWND.EQ.0) THEN                                ! no group  known
             CALL STTPUT('C__*** INFO: Group disabled or unknown',
     2                   ISTAT)
          ELSE                                                  ! no components
             CALL STTPUT('C__*** INFO: No components in this group  '//
     2                   '; sorry ...',ISTAT)
          ENDIF
       ENDIF
C
       GO TO CANREC

C+++
50004  CONTINUE                                        ! Proc. CONMAT; option D
C---
58004  FORMAT('D__*** WARNING: Sorry, requested group not present')
C
       IOD  = 'D'
       JFVR = 0
C
51004  CONTINUE
       IF (JFVR.NE.0) GO TO 55004
          IF (RAI.EQ.'M') THEN                               ! manual selection
             CALL STKPRI('D__Enter group identification: ',
     2                  'INPUTI',1,1,IAV,IDWND,KUN,KNUL,ISTAT)      ! get ident
             CALL TBESRI(TIDINT,INTNUM(1),IDWND,COLERR,1,
     2                          IRWNDI,ISTAT)                      ! find ident
          ELSE                                                 ! auto selection
             IF (NEXTW) THEN
                IF (IRWNDI.EQ.0 .OR. (NCP+NHL.LE.1)) THEN  ! precaut. for start
                   IRWNDI = IRWNDI+1                              ! next group 
                ELSE
                   IRWNDI = IRWNDI+NCP+NHL                        ! next group 
                ENDIF
             ELSE
                NEXTW = .TRUE.
             ENDIF
          END IF
C
C *** read the object ocmponents and holes
          IF (IRWNDI.LE.NRINT .AND. IRWNDI.GE.1) THEN           ! valid group 
             ASSIGN 50170 TO WNDRD                               ! read group 
             GO TO 50070
50170        CONTINUE
             JFVR  = 0
             IF (RAI.NE.'M' .AND. RAI.NE.'A') THEN       ! manual or automatic
                ASSIGN 50152 TO VERREC
                GO TO 50052
50152           CONTINUE
             ELSE
                JFVR = 1
             END IF

          ELSE                                                ! nonvalid group 
             WRITE(STRING,58004)
             CALL STTPUT(STRING,ISTAT)
             JFVR  = 2
          END IF
          GO TO 51004
C
55004  CONTINUE
       IF (JFVR.EQ.1) THEN
          ASSIGN 50253 TO APPDAT
          GO TO 50053
50253     CONTINUE
          ASSIGN 50158 TO LEMARA
          GO TO 50058
50158     CONTINUE
          ASSIGN 50455 TO RIMANF
          GO TO 50055
50455     CONTINUE
C
          IF (IPIANT.EQ.0) THEN
             L78=200.0 - (P(3)*F78)/3.
             CALL PROFI5(RNF,MX,MY,NP,NC,L78,F78,'Y')
             CALL PIANT5(RNF,MX,MY,NP,NC,MXYF,FATT1,P(3),ZESI)
             CALL PIANT5(RESI,MX,MY,NP,NC,MXYR,FATT1,P(3),ZESI)
             K1G = 1
          ELSE
            ASSIGN 50324 TO DISISO
            GO TO 50024
50324       CONTINUE
          END IF
          CALL DAZVIS(QDSPNO,QIMCH,2,1)                    ! display everything
       END IF
C
       GO TO CONMAT

C+++
50005  CONTINUE                                         ! Proc. FABUC; option E
C---
59005  FORMAT ('E__*** WARNING: Maximum holes number allowed: ',I3)
C
       MAXH = (NCD-NCP*6.5)/3.
       IF (IOD.EQ.'D' .OR. K1G.GT.1) THEN
          INDM = (IX-1)/(MXYF-1)
          IX   = IX-(INDM*(MXYF-1))
       END IF
C
       IF (NHL.LT.MAXH) THEN             ! is there still space for more holes?
          RABU = 0.0
          CALL STKWRR('INPUTR',RABU,1,1,KUN,ISTAT)          ! store the default
          CALL STKPRR('E__Enter radius of the hole: ',
     2                 'INPUTR',1,1,IAV,RABU,KUN,KNUL,ISTAT)     ! get the hole
          IF (RABU.GT.0) THEN                                    ! legal radius
             ASSIGN 50166 TO RIPMAS
             GO TO 50066
50166        CONTINUE
C
C *** write the hole in the table
             PARINT(16) = FLOAT(NHL+1)                       ! increase # holes
             IRWND1     = IRWNDI
             IRWND2     = MAX((IRWNDI),(IRWNDI+NCP+NHL-1))
             DO 51005 IROW = IRWND1,IRWND2             ! update number of holes
                CALL TBEWRR(TIDINT,IROW,18,PARINT(16),ISTAT)
51005        CONTINUE
C
             NHL   = NHL + 1                     ! table contains one more hole
             NRINT = NRINT + 1                   ! table contains one more row
             IF (NHL.EQ.1) THEN
                IDNHOL(NHL) = 201                           ! ident of new hole
             ELSE
                IDNHOL(NHL) = IDNHOL(NHL-1) + 1             ! ident of new hole
             ENDIF
C
             FLGHOL(NHL)         = 1                         ! flag of new hole
             FITHOL((NHL-1)*3+1) = RABU
             FITHOL((NHL-1)*3+2) = (IX-1)/3+1
             FITHOL((NHL-1)*3+3) = (IY-1)/3+1
             CALL INTHWR(TIDINT,NRINT,NHL)
             CALL TBCSRT(TIDINT,2,INTNUM,FLAGS,ISTAT)
             ASSIGN 50870 TO WNDRD
             GO TO 50070
50870        CONTINUE
C
             ASSIGN 50559 TO PREMAS
             GO TO 50059
50559        CONTINUE
C
             GRE    = 0
             IF (IOD.EQ.'M') THEN
                IF (NFINP.EQ.1) THEN
                   NWD = NWD + 1
                ENDIF
                IDWND  = NWD
                NFINP  = 0
             END IF

          ELSE
             CALL STTPUT('E__*** WARNING: Do not know what to do with'//
     2                   ' this number, sorry ...',ISTAT)
          END IF
C
       ELSE
          WRITE(STRING,59005) MAXH
          CALL STTPUT(STRING,ISTAT)
       END IF
C
       GO TO FABUC

C+++
50006  CONTINUE                                        ! Proc. FINPRO; option F
C---
       CAR = 'N'
       CALL STKWRC('INPUTC',1,CAR,1,1,KUN,ISTAT)
       CALL STKPRC('F__Do you really want to finish? [N]: ',
     2             'INPUTC',1,1,1,IAV,CAR,KUN,KNUL,ISTAT)
       CALL UPCAS(CAR,CAR)    
       IF (CAR.EQ.'Y') THEN
          CAR = 'F'
       ELSE
          CAR = 'N'
       ENDIF
C
       GO TO FINPRO

C+++
50007  CONTINUE                                        ! Proc. RIPBUC; option G
C---
58007  FORMAT('G__*** WARNING: Cannot find our hole ',I3, 
     2        '; sorry ...')
C
       IF (NHL.GT.0) THEN
          CALL STKPRI('G___Enter hole identification to be restored: ',
     2                'INPUTI',1,1,IAV,IDHOL,KUN,KNUL,ISTAT)
          IDHOL1 = IDHOL+200
          CALL TBESRI(TIDINT,INTNUM(2),IDHOL1,COLERR,IRWNDI,
     2                IRHOL,ISTAT) 
C
C *** find component
          IF (IRHOL.LE.0) THEN                           ! can't find component
             WRITE(STRING,58007) IDHOL
             CALL STTPUT(STRING,ISTAT)
             GO TO RIPBUC
          ELSE
             IHOL = IRHOL-(IRWNDI+NCP-1)                  ! which hole in table
          ENDIF
C
          IF (IHOL.GT.NHL) THEN                             ! in another group 
             WRITE(STRING,58007) IDHOL
             CALL STTPUT(STRING,ISTAT)
             GO TO RIPBUC
          ELSE
             GRE = 0
             ASSIGN 50173 TO DELHOL                           ! delete the hole
             GO TO 50073
50173        CONTINUE
             ASSIGN 50370 TO WNDRD                          ! reread the group 
             GO TO 50070
50370        CONTINUE
          ENDIF
       
       ELSE
          IF (IDWND.EQ.0) THEN                                ! no group  known
             CALL STTPUT('G__*** INFO: Group disabled or unknown',
     2                   ISTAT)
          ELSE                                                  ! no components
             CALL STTPUT('G__*** INFO: No holes in this group'//
     2                   '; sorry ...',ISTAT)
          ENDIF
       ENDIF

       GO TO RIPBUC

C+++
50008  CONTINUE                                      ! Procedure HELP; option H
C---
50208  FORMAT('A: Display colour or a contour map')
50308  FORMAT('B: Scale intensity projections (data not affected)')
50408  FORMAT('C: Delete a component')
50508  FORMAT('D: Display a group from INTERMEDIATE table ',
     2            '(OUTPUT mode)')
50608  FORMAT('E: Make a hole of given radius at cursor position')
50708  FORMAT('F: Finish up')
50808  FORMAT('G: Restore a hole')
50908  FORMAT('H: Show the help documentation')
51008  FORMAT('I: Add a component at cursor position ',
     *            '(trial height is local maximum)')
51108  FORMAT('J: Add a component at cursor position ',
     *            '(trial height must be entered)')
51208  FORMAT('K: Give coordinates and pixel value at cursor position')
51308  FORMAT('L: Give height above the background at vertical cursor')
51408  FORMAT('M: Display a group of a input CATALOGUE table')
51508  FORMAT('N: Display a group from INTERMEDIATE table ',
     2            '(INPUT mode)')
51608  FORMAT('P: Enter star identification and disable all other',
     2            ' components')
51708  FORMAT('Q: Restore P')
51808  FORMAT('R: Reduce subarray to a particular size in x and y')
51908  FORMAT('S: Move the subarray in x and y')
52008  FORMAT('T: Disable star for display and registration;'
     2            ' undo with T(-n)')
52108  FORMAT('U: Redefine zero point of the colour scale')
52208  FORMAT('V: Close old files and open new ones')
52308  FORMAT('W: Change slope of the colour scale')
52408  FORMAT('X: Display isophotes')
52508  FORMAT('Y: Scale isophotes to an arbitrary threshold')
52608  FORMAT('Z: Give info or display components already considered')
52708  FORMAT('4: OUTPUT mode. Components to examine: A, M or S. ')
52808  FORMAT('   If selective examine only special subarrays: ')
52908  FORMAT('   No conv., height above ..., ',
     2            'more than ... iterations')
53008  FORMAT('5: INPUT mode. Components to examine: A, M or S. ')
53108  FORMAT('   If selective examine only special subarrays: ')
53208  FORMAT('   not grouped by GROUP, height above ...')
53308  FORMAT('6: Enable smoothing')
53408  FORMAT('7: Enable integration')
53508  FORMAT('bar: Repeat last display (with new parameters)')
53608  FORMAT('/: Change window size in x and y')
53708  FORMAT('-: Enable or disable reporting of holes')
53808  FORMAT('?: Enable or disable registration of previously',
     2            ' registrated subarrays')
53908  FORMAT('@: Replace or append one component with the next input')
C
       WRITE(STRING,50208)
       CALL STTPUT(STRING,ISTAT)
       WRITE(STRING,50308)
       CALL STTPUT(STRING,ISTAT)
       WRITE(STRING,50408)
       CALL STTPUT(STRING,ISTAT)
       WRITE(STRING,50508)
       CALL STTPUT(STRING,ISTAT)
       WRITE(STRING,50608)
       CALL STTPUT(STRING,ISTAT)
       WRITE(STRING,50708)
       CALL STTPUT(STRING,ISTAT)
       WRITE(STRING,50808)
       CALL STTPUT(STRING,ISTAT)
       WRITE(STRING,50908)
       CALL STTPUT(STRING,ISTAT)
       WRITE(STRING,51008)
       CALL STTPUT(STRING,ISTAT)
       WRITE(STRING,51108)
       CALL STTPUT(STRING,ISTAT)
       WRITE(STRING,51208)
       CALL STTPUT(STRING,ISTAT)
       WRITE(STRING,51308)
       CALL STTPUT(STRING,ISTAT)
       WRITE(STRING,51408)
       CALL STTPUT(STRING,ISTAT)
       WRITE(STRING,51508)
       CALL STTPUT(STRING,ISTAT)
       CALL STTPUT(' ',ISTAT)
       CALL STKPRC('*** Return for more','INPUTC',1,1,1,
     2             IAV,RFM,KUN,KNUL,ISTAT)

       WRITE(STRING,51608)
       CALL STTPUT(STRING,ISTAT)
       WRITE(STRING,51708)
       CALL STTPUT(STRING,ISTAT)
       WRITE(STRING,51808)
       CALL STTPUT(STRING,ISTAT)
       WRITE(STRING,51908)
       CALL STTPUT(STRING,ISTAT)
       WRITE(STRING,52008)
       CALL STTPUT(STRING,ISTAT)
       WRITE(STRING,52108)
       CALL STTPUT(STRING,ISTAT)
       WRITE(STRING,52208)
       CALL STTPUT(STRING,ISTAT)
       WRITE(STRING,52308)
       CALL STTPUT(STRING,ISTAT)
       WRITE(STRING,52408)
       CALL STTPUT(STRING,ISTAT)
       WRITE(STRING,52508)
       CALL STTPUT(STRING,ISTAT)
       WRITE(STRING,52608)
       CALL STTPUT(STRING,ISTAT)
       WRITE(STRING,52708)
       CALL STTPUT(STRING,ISTAT)
       WRITE(STRING,52808)
       CALL STTPUT(STRING,ISTAT)
       WRITE(STRING,52908)
       CALL STTPUT(STRING,ISTAT)
       CALL STTPUT(' ',ISTAT)
       CALL STKPRC('*** Return for more','INPUTC',1,1,1,
     2             IAV,RFM,KUN,KNUL,ISTAT)

       WRITE(STRING,53008)
       CALL STTPUT(STRING,ISTAT)
       WRITE(STRING,53108)
       CALL STTPUT(STRING,ISTAT)
       WRITE(STRING,53208)
       CALL STTPUT(STRING,ISTAT)
       WRITE(STRING,53308)
       CALL STTPUT(STRING,ISTAT)
       WRITE(STRING,53408)
       CALL STTPUT(STRING,ISTAT)
       WRITE(STRING,53508)
       CALL STTPUT(STRING,ISTAT)
       WRITE(STRING,53608)
       CALL STTPUT(STRING,ISTAT)
       WRITE(STRING,53708)
       CALL STTPUT(STRING,ISTAT)
       WRITE(STRING,53808)
       CALL STTPUT(STRING,ISTAT)
       WRITE(STRING,53908)
       CALL STTPUT(STRING,ISTAT)
       CALL STTPUT(' ',ISTAT)
C
       GO TO HELP

C+++
50009  CONTINUE                                  ! Procedure INPDAT; option I+J
C---
59109  FORMAT('I__Component ',I6,' has been replace')
59209  FORMAT('J__Component ',I6,' has been replace')
58109  FORMAT('I__Component ',I6,' has been added')
58209  FORMAT('J__Component ',I6,' has been added')
57109  FORMAT('I__*** WARNING: Cannot find your component',I6)
57209  FORMAT('J__*** WARNING: Cannot find your component',I6)
56109  FORMAT('I__*** Error: Not more than ',I3,' components allowed')
56209  FORMAT('J__*** Error: Not more than ',I3,' components allowed')
C
       IF (CAR.EQ.'I') THEN
          STRING = 'I__Use cursor to pass the component coordinates'
       ENDIF
       IF (CAR.EQ.'J') THEN
          STRING = 'J__Use cursor to pass the component coordinates'
       ENDIF
       CALL STTPUT(STRING,ISTAT)
       CALL CURSIN(QDSPNO,0,NOC,IXYA,MCA,ISCA,IXYB,MCB,ISCB)
C
59909  CONTINUE
       CALL CURSIN(QDSPNO,ENTFLG,NOC,IXYA,MCA,ISCA,IXYB,MCB,ISCB)
       IF (ISCA.EQ.0) THEN                                  ! return to monitor
          GO TO INPDAT
       ENDIF
C
C *** do the work
       IX = IXYA(1)
       IY = IXYA(2)
       IF (IOD.EQ.'D'. OR. K1G.GT.1) THEN
          INDM = (IX-1)/(MXYF-1)
          IX   = IX-(INDM*(MXYF-1))
       END IF
C
       IF (IX.GE.1 .AND. IX.LE.NPM .AND. 
     2     IY.GE.1 .AND. IY.LE.NCM) THEN
          IF (CATAL .OR. IOD.NE.'M') THEN
             NNI = (NCD-NHL*3)/6.5
             IF (NCP.LT.NNI) THEN
                IPJ1   = (IX-1)/3+1
                IPJ2   = (IY-1)/3+1
C
C *** append a component
                IF (IGS.EQ.'A') THEN                       ! append a component
                   IF (IOD.EQ.'M') THEN
                      CALL TBESRI(TIDINT,INTNUM(1),IDWND,COLERR,1,
     2                            IRWNDI,ISTAT)                   ! find group
                      IF (IRWNDI.GT.0 .AND. IRWNDI.LE.NRINT) THEN       ! known
                         CALL INTWRD(TIDINT,IRWNDI,NCP,NHL)
                         IRWND1     = IRWNDI
                         IRWND2     = MAX(IRWNDI,(IRWNDI+NCP+NHL-1))
                         PARINT(15) = FLOAT(NCP+1)
                         DO 52009 IROW = IRWND1,IRWND2    ! update # components
                            CALL TBEWRR(TIDINT,IROW,17,PARINT(15),ISTAT)
52009                    CONTINUE
                      ELSE
                         NGR        = NGR + 1
                         NCP        = 0
                         NHL        = 0
                         IDNGRP     = IDWND          ! new group to be written
                         PARINT(1)  = FLOAT(IPX)
                         PARINT(2)  = FLOAT(IPY)
                         PARINT(3)  = 0.0
                         PARINT(4)  = 0.0
                         PARINT(5)  = 0.0
                         PARINT(6)  = FLOAT(NP)
                         PARINT(7)  = FLOAT(NC)
                         PARINT(8)  = 0.0
                         PARINT(9)  = 0.0
                         PARINT(10) = P(3)
                         PARINT(11) = BETA
                         PARINT(12) = 0.0
                         PARINT(13) = 0.0
                         PARINT(14) = 0.0
                         PARINT(15) = 1.0
                         PARINT(16) = 0.0
                      ENDIF

                   ELSE                                       ! in D  or N mode
                      IRWND1     = IRWNDI
                      IRWND2     = MAX(IRWNDI,(IRWNDI+NCP+NHL-1))
                      PARINT(15) = FLOAT(NCP+1)
                      DO 53009 IROW = IRWND1,IRWND2       ! update # components
                         CALL TBEWRR(TIDINT,IROW,17,PARINT(15),ISTAT)
53009                 CONTINUE
                   ENDIF
C
C *** get the data into the table
                   NCP    = NCP + 1                        ! one more component
                   NRINT  = NRINT + 1
                   IF (NCP.EQ.1) THEN                          ! identification
                      IDNCMP(NCP) = 101
                   ELSE
                      IDNCMP(NCP) = IDNCMP(NCP-1)+1
                   ENDIF
                   IRCMP               = NRINT     ! add component at end table
                   FLGCMP(NCP)         = 1                       ! flag
                   FITCMP((NCP-1)*6+2) = IPJ1                    ! x coordinate
                   FITCMP((NCP-1)*6+3) = IPJ2                    ! y coordinate
C
C *** get the intensity
                   IF (CAR.EQ.'J') THEN                     ! get the intensity
                      CALL STKPRR('J__Enter the intensity above the '//
     2                              'sky level: ','INPUTR',1,1,IAV,PIXV,
     3                          KUN,KNUL,ISTAT)
                      FITCMP((NCP-1)*6+1) = PIXV
                   ELSE
                      FITCMP((NCP-1)*6+1) = RNY(IPJ2,IPJ1)-P(3)
                   END IF
C 
C *** write the group
                   FITCMP((NCP-1)*6+4) = SIGMA                ! sigma
                   FITCMP((NCP-1)*6+5) = 0.                   ! fit parameters
                   FITCMP((NCP-1)*6+6) = 0.
                   CALL INTCWR(TIDINT,IRCMP,NCP)              ! write component
                   CALL TBCSRT(TIDINT,2,INTNUM,FLAGS,ISTAT)
                   CALL TBESRI(TIDINT,INTNUM(1),IDWND,COLERR,1,
     2                         IRWNDI,ISTAT)                  ! reread group
                   ASSIGN 51070 TO WNDRD
                   GO TO 50070
51070              CONTINUE
C
C *** give info to user
                   IF (CAR.EQ.'I') THEN                     ! get the intensity
                     WRITE(STRING,58109) IDNCMP(NCP)-100           ! write info
                   ELSE
                      WRITE(STRING,58209) IDNCMP(NCP)-100          ! write info
                   ENDIF
                   CALL STTPUT(STRING,ISTAT)
C
C *** option REPLACE: replace the component
                ELSE                                        ! replace component
                   IF (CAR.EQ.'I') THEN
                      CALL STKPRI('I__Enter component to replace: ',
     2                            'INPUTI',1,1,IAV,IDCMP,KUN,KNUL,ISTAT)
                   ELSE
                      CALL STKPRI('J__Enter component to replace: ',
     2                            'INPUTI',1,1,IAV,IDCMP,KUN,KNUL,ISTAT)
                   ENDIF
C
                   IDCMP1 = IDCMP+100                      ! find the component
                   CALL TBESRI(TIDINT,INTNUM(2),IDCMP1,COLERR,IRWNDI,
     2                         IRCMP,ISTAT)                  ! get ident
                   IF (IRCMP.LE.0) THEN                  ! can't find component
                      IF (CAR.EQ.'I') THEN                  ! get the intensity
                         WRITE(STRING,57109) IDCMP                 ! write info
                      ELSE
                         WRITE(STRING,57209) IDCMP                 ! write info
                      ENDIF
                      CALL STTPUT(STRING,ISTAT)
                   ELSE
                      ICMP = IRCMP - IRWNDI + 1          ! relative comp number
                   END IF
C
                   IF (ICMP.GT.NCP) THEN
                      IF (CAR.EQ.'I') THEN                  ! get the intensity
                         WRITE(STRING,57109) IDCMP                 ! write info
                      ELSE  
                         WRITE(STRING,57209) IDCMP                 ! write info
                      ENDIF
                      CALL STTPUT(STRING,ISTAT)
                   ELSE                       ! everything fine, all systems go
                      IF (CAR.EQ.'J') THEN
                         CALL STKPRR('J__Enter the intensity above '//
     2                               'the sky level: ','INPUTR',1,1,IAV,
     3                               PIXV, KUN,KNUL,ISTAT)
                         FITCMP((ICMP-1)*6+1) = PIXV
                         FITCMP((ICMP-1)*6+2) = IPJ1              ! x coordinate
                         FITCMP((ICMP-1)*6+3) = IPJ2              ! y coordinate
                      ELSE
                         FITCMP((ICMP-1)*6+1) = RNY(IPJ2,IPJ1)-P(3)
                         FITCMP((ICMP-1)*6+2) = IPJ1              ! x coordinate
                         FITCMP((ICMP-1)*6+3) = IPJ2              ! y coordinate
                      END IF
                      FITCMP((ICMP-1)*6+5) = 0.0
                      FITCMP((ICMP-1)*6+6) = 0.0 
                      FLGCMP(ICMP)         = 1                   ! flag
                      CALL INTCWR(TIDINT,IRCMP,ICMP)
                      ASSIGN 50970 TO WNDRD
                      GO TO 50070
50970                 CONTINUE
C
                      IF (CAR.EQ.'I') THEN                  ! get the intensity
                         WRITE(STRING,59109) IDCMP                 ! write info
                      ELSE
                         WRITE(STRING,59209) IDCMP                 ! write info
                      ENDIF
                      CALL STTPUT(STRING,ISTAT)
                   ENDIF
                ENDIF
        
                GRE    = 0
                IF (IOD.EQ.'M') THEN
                   IF (NFINP.EQ.1) THEN
                      NWD = NWD + 1
                   ENDIF
                   IDWND  = NWD
                   NFINP  = 0
                END IF
C
                IF (IOD.EQ.'M') THEN
                   IF (CATAL) THEN
                      CALL INTDWR(TIDCAT,NGR,NOBJ,NSR,SAT,FAT,
     2                            SIGMA,BETA,SIV,AIN,FOG)
                      ASSIGN 50165 TO RICFIL
                      GO TO 50065
50165                 CONTINUE
                   END IF
                END IF
C
             ELSE
                IF (CAR.EQ.'I') THEN                        ! get the intensity
                   WRITE(STRING,56109) NNI                         ! write info
                ELSE    
                   WRITE(STRING,56209) NNI                         ! write info
                ENDIF
                CALL STTPUT(STRING,ISTAT)
             END IF
          END IF

       ELSE
          IF (CAR.EQ.'I') THEN
             CALL STTPUT('I__*** WARNING: Cursor outside group',
     2                   ISTAT)
          ELSE
             CALL STTPUT('J__*** WARNING: Cursor outside group',
     2                   ISTAT)
          ENDIF
          CALL STTPUT(STRING,ISTAT)
       END IF
C
       GO TO 59909

C+++
50011  CONTINUE                                      ! Procedure XYMAX; option K
C---
51011  FORMAT ('K__Abs.:',I5,1X,I4,1X,', Rel.:',I3,1X,I2,
     *         1X,', Max:',I6)
52011  FORMAT ('K__Abs.:',I5,1X,I4,1X,', Rel.:',I3,1X,I2,
     *         1X,', Max: ----')

       STRING = 'K__Use cursor to get the coordinates'
       CALL STTPUT(STRING,ISTAT)
       CALL CURSIN(QDSPNO,0,NOC,IXYA,MCA,ISCA,IXYB,MCB,ISCB)
C
53011  CONTINUE
       CALL CURSIN(QDSPNO,ENTFLG,NOC,IXYA,MCA,ISCA,IXYB,MCB,ISCB)
C
       IF (ISCA.EQ.0) THEN
          GO TO XYMAX
       ELSE
          IX = IXYA(1)
          IY = IXYA(2)
C
          IF (IOD.EQ.'D' .OR. K1G.GT.1) THEN
             INDM = (IX-1)/(MXYF-1)
             IX   = IX-(INDM*(MXYF-1))
          END IF
C
          IF (IX.GE.1 .AND. IX.LE.NPM .AND. 
     2        IY.GE.1 .AND. IY.LE.NCM) THEN
             IPJ1 = (IX-1)/3+1
             IPJ2 = (IY-1)/3+1
             IPJX = IPX+IPJ1-1
             IPJY = IPY+IPJ2-1
C
             IF (INDM.EQ.0) THEN
                PMAX = RNY(IPJ2,IPJ1)-P(3)
             ELSE IF (INDM.EQ.1) THEN
                PMAX = RNF(IPJ2,IPJ1)-P(3)
             ELSE IF (INDM.EQ.2) THEN
                PMAX = RESI(IPJ2,IPJ1)-P(3)
             END IF
C
             IF (PMAX.GT.-200000000.) THEN
                WRITE(STRING,51011) IPJX,IPJY,IPJ1,IPJ2,
     2                              INT(PMAX)
             ELSE
                WRITE(STRING,52011) IPJX,IPJY,IPJ1,IPJ2
             END IF
             CALL STTPUT(STRING,ISTAT)

          ELSE
             CALL STTPUT('K__*** WARNING: Cursor position '//
     2                   'outside group',ISTAT)
          END IF

       ENDIF
       GO TO 53011


C+++
50012  CONTINUE                                     ! Procedure TROLIV; option L
C---
51012  FORMAT ('L__Height =',I6)
C
       STRING = 'L__Use cursor to get the coordinates'
       CALL STTPUT(STRING,ISTAT)
       CALL CURSIN(QDSPNO,0,NOC,IXYA,MCA,ISCA,IXYB,MCB,ISCB)
C
52012  CONTINUE
       CALL CURSIN(QDSPNO,1,NOC,IXYA,MCA,ISCA,IXYB,MCB,ISCB)
       IF (ISCA.EQ.0) THEN
          GO TO TROLIV
       ELSE
          IX = IXYA(1)
          IY = IXYA(2)
          LIV = (IY-200)*3/F78
          WRITE(STRING,51012) LIV
          CALL STTPUT(STRING,ISTAT)
       ENDIF
 
       GO TO 52012

C+++
50013  CONTINUE                                     ! Procedure ACCSTE; option M
C---
59013  FORMAT('M__*** WARNING: Group ', I8, ' already examined')
58013  FORMAT('M__*** INFO: Catalogue contains ',I6,' entries; ',
     2               'last group is ',I8)
C
       IF (CATAL) THEN
          NFINP = 1
          IOD   = 'M'
          NP    = NPI
          NC    = NCI
          NCP   = 0
          LLVV  = 0
C
51013     CONTINUE
          IF (LLVV.NE.0) GO TO 52013
             IF (BBC.EQ.'M') THEN
                CALL STKWRI('INPUTI',IDWND,1,1,KUN,ISTAT)
                CALL STKPRI('M__Enter group to display: ',
     2                      'INPUTI',1,1,IAV,IDWND,KUN,KNUL,ISTAT)
             ELSE
                IDWND = IDWND+1
             END IF                                                 !find ident
             CALL TBESRI(TIDCAT,CATNUM(1),IDWND,COLERR,1,IRWNDC,ISTAT)
C
             IF (IRWNDC.LE.NRCAT .AND. IRWNDC.GE.1) THEN
                CALL CATTRD(TIDCAT,IRWNDC,IDWND,D1,D2,RMA,V,B,U,P(3),
     2                      FLCO,BA1,BA2,BA3,BA4,BA5)
                NHL    = 0
                LLVV   = 0
                IF (BBC.NE.'M' .AND. BBC .NE. 'A') THEN
                   IF (ABS(FLCO).LT.2.) THEN
                      IF (BBC.EQ.'R') THEN
                         IF (FLCO.LE.0.0) THEN
                            LLVV = 1
                         ENDIF
                      ELSE IF (BBC.EQ.'H') THEN
                         IF (RMA.GE.SOAL) THEN
                            LLVV = 1
                         ENDIF
                      ELSE
                         IF (FLCO.LE.0.0 .AND. RMA.GE.SOAL) THEN
                            LLVV = 1
                         ENDIF
                      END IF
                   END IF
                ELSE
                   LLVV=1
                END IF
C
                IF (FLCO.EQ.1. .AND. IZE.EQ.1) THEN
                   IF (BBC.EQ.'M') THEN
                      WRITE(STRING,59013) IDWND
                      CALL STTPUT(STRING,ISTAT)
                   ELSE
                      LLVV = 0
                   END IF

                ELSE
                   IF (LLVV.EQ.1) THEN
                      IP3 = 1
                      IF (P(3).LE.0.0001) IP3=0
                      IPY = INT(D2)-NC/2
                      IPX = INT(D1)-NP/2
                      NPM = NP*3
                      NCM = NC*3
                      ASSIGN 50154 TO LEGMAT
                      GO TO 50054
50154                 CONTINUE
                      ASSIGN 50160 TO VISMAT
                      GO TO 50060
50160                 CONTINUE
                      CALL DAZVIS(QDSPNO,QIMCH,2,1)         ! display everything
                   END IF
                END IF
C
             ELSE                           ! no enter found; display last entry
                CALL CATTRD(TIDCAT,NRCAT,IDWND,DUM1,DUM2,DUM3,
     2                      DUM4,DUM5,DUM6,DUM7,DUM8,DUM9,DUM10,
     3                      DUM11,DUM12,DUM13)
                WRITE(STRING,58013) NSTCAT,IDWND
                CALL STTPUT(STRING,ISTAT)
                IDWND  = NRCAT+1
                LLVV   = 2
             END IF
             GO TO 51013
52013     CONTINUE               
C
       ELSE
          CALL STTPUT('M__*** WARNING: Sorry, no catalogue table '//
     2                'present',ISTAT)
       END IF
C
       GO TO ACCSTE

C+++
50014  CONTINUE                                     ! Procedure ACSTDA; option N
C---
59014  FORMAT('N__*** WARNING: Sorry, cannot find group; ',
     2                'try again ...')
C
       CALL STKWRI('INPUTI',IDWND,1,1,KUN,ISTAT)
       CALL STKPRI('N__Enter group identification: ',
     2             'INPUTI',1,1,IAV,IDWND,KUN,KNUL,ISTAT)
       CALL TBESRI(TIDINT,INTNUM(1),IDWND,COLERR,1,IRWNDI,ISTAT)   ! find ident
       IF (IRWNDI.LE.0 .OR. IRWNDI.GT.NRINT) THEN
          WRITE(STRING,59014)
          CALL STTPUT(STRING,ISTAT)
       ENDIF
C
C *** read the group components and holes
       IF (IRWNDI.LE.NRINT .AND. IRWNDI.GE.1) THEN
          ASSIGN 50470 TO WNDRD
          GO TO 50070
50470     CONTINUE
C          
C         IPIANT = 1
          IOD    = 'N'
          IP3    = 1
          IF (P(3).LE.0.0001) THEN
             IP3=0
          ENDIF
C
          ASSIGN 50153 TO APPDAT
          GO TO 50053
50153     CONTINUE
C
          ASSIGN 50254 TO LEGMAT
          GO TO 50054
50254     CONTINUE
C
          ASSIGN 50159 TO PREMAS
          GO TO 50059
50159     CONTINUE
C
          ASSIGN 50260 TO VISMAT
          GO TO 50060
50260     CONTINUE
C
          IF (IPIANT.EQ.1) THEN
             ASSIGN 50164 TO GRAISO
             GO TO 50064
50164        CONTINUE
          END IF
          CALL DAZVIS(QDSPNO,QIMCH,2,1)                     ! display everything
C
       ELSE
            
          WRITE(STRING,59014)
          CALL STTPUT(STRING,ISTAT)
       END IF
C
       GO TO ACSTDA

C+++
50016  CONTINUE                                    ! Procedure ISOSTE; option P
C---
       IF (IOD.EQ.'D') THEN
          CALL STKPRI('P__Enter component to examine: ',
     *                'INPUTI',1,1,IAV,IDCMP,KUN,KNUL,ISTAT)
          IDCMP1 = IDCMP+100
          CALL TBESRI(TIDINT,INTNUM(2),IDCMP1,COLERR,IRWNDI,
     2                IRCMP,ISTAT)                                      ! find
          IF (IRCMP.LE.0) THEN                     ! can't find such component
             WRITE(STRING,58003) IDCMP
             CALL STTPUT(STRING,ISTAT)
          ELSE
             ICMP = IRCMP - IRWNDI + 1             ! which component in table
          ENDIF
C
          IF (ICMP.GT.NCP) THEN                    ! in another group
             WRITE(STRING,58003) IDCMP
             CALL STTPUT(STRING,ISTAT)
          ELSE
             IF (IIST.EQ.1) THEN
                ASSIGN 50217 TO RIPFIN
                GO TO 50017
50217           CONTINUE
             ENDIF
C
             IIST = 1
             IF (ICMP.GE.1) THEN
                DO 51016 NIL= 1,NCP
                   FLGCMP(NIL) = 0
51016           CONTINUE
                FLGCMP(ICMP) = 1
C
                ASSIGN 50255 TO RIMANF
                GO TO 50055
50255           CONTINUE
             ENDIF
          ENDIF
       ENDIF
C
       GO TO ISOSTE

C+++
50017  CONTINUE                                    ! Procedure RIPFIN; option Q
C---
       IF (IOD.EQ.'D') THEN
          IIST = 0
          DO 51017 NIL=1,NCP
             FLGCMP(NIL) = NONS(NIL)
51017     CONTINUE
C
          ASSIGN 50355 TO RIMANF
          GO TO 50055
50355     CONTINUE
       END IF
C
       GO TO RIPFIN

C+++
50018  CONTINUE                                    ! Procedure RESMAT; option R
C---
       IF (IOD.NE.'D') THEN
          CALL STKPRI('R__Enter new size_x,size_y for the group: ',
     *                'INPUTI',1,2,IAV,IINPUT,KUN,KNUL,ISTAT)
          NPN = IINPUT(1)
          NCN = IINPUT(2)
          IF (NPN.GT.MX) NPN=MX
          IF (NPN.LT. 3) NPN= 3
          IF (NCN.GT.MY) NCN=MY
          IF (NCN.LT. 3) NCN= 3
C
          N1X  = NP   - NPN
          N1Y  = NC   - NCN
          IPXS = IPX  + N1X/2
          IPYS = IPY  + N1Y/2
          IPXE = IPXS + NPN-1
          IPYE = IPYS + NCN-1
C
C *** Check if group within boundaries
          IF ((IPXS.LT.1   .OR. IPYS.LT.1) .OR.
     2        (IPXE.GT.NPL .OR. IPYE.GT.NL)) THEN
             STRING = 'R__*** WARNING: Window boundary will fall '//
     2                       'outside frame; resizing NOT done!!'
             CALL STTPUT(STRING,ISTAT)
             GOTO RESMAT
          ENDIF
C
C *** All fine lets do it
          IPX = IPXS
          IPY = IPYS
          NP  = NPN
          NC  = NCN
          JX  = JX + N1X/2
          JY  = JY + N1Y/2
C
          PARINT(1) = IPX
          PARINT(2) = IPY
          PARINT(6) = NP
          PARINT(7) = NC
C
          IF (NCP.GT.0) THEN
             DO 51018 IC = 1,NCP
                FITCMP((IC-1)*6+2) = FITCMP((IC-1)*6+2) - N1X/2
                FITCMP((IC-1)*6+3) = FITCMP((IC-1)*6+3) - N1Y/2
51018        CONTINUE
          ENDIF
C
          IF (NHL.GT.0) THEN
             DO 52018 IH = 1,NHL
                FITHOL((IH-1)*3+2) = FITHOL((IH-1)*3+2) - N1X/2
                FITHOL((IH-1)*3+3) = FITHOL((IH-1)*3+3) - N1Y/2
52018        CONTINUE
          ENDIF
C
          CALL INTWWR(TIDINT,IRWNDI,NCP,NHL)
          ASSIGN 50670 TO WNDRD
          GO TO 50070
50670     CONTINUE
C
          IF (JX+NP-1.GT.MX .OR. JY+NC-1.GT.MY .OR. 
     2       JX.LT.1 .OR. JY.LT.1) THEN
             ASSIGN 50354 TO LEGMAT
             GO TO 50054
50354        CONTINUE

          ELSE
             ASSIGN 50257 TO APPNF
             GO TO 50057
50257        CONTINUE
          END IF

          ASSIGN 50259 TO PREMAS
          GO TO 50059
50259     CONTINUE
C
          ASSIGN 50560 TO VISMAT
          GO TO 50060
50560     CONTINUE
          CALL DAZVIS(QDSPNO,QIMCH,2,1)            ! display everything
       ELSE
C
          STRING = 'R__*** WARNING: In OUTPUT MODE reductions are '//
     *              'NOT allowed (try N)'
          CALL STTPUT(STRING,ISTAT)
       END IF
C
       GO TO RESMAT

C+++
50019  CONTINUE                                    ! Procedure SPOMAT; option S
C---
       IF (IOD.NE.'D') THEN
          CALL STKPRI('S__Enter del_x,del_y for window displacement '//
     2                'in x and y: ','INPUTI',1,2,IAV,IINPUT,
     3                KUN,KNUL,ISTAT)
          ILX  = IINPUT(1)
          ILY  = IINPUT(2)
C
          IPXS = IPX  + ILX
          IPYS = IPY  + ILY
          IPXE = IPXS + NP-1
          IPYE = IPYS + NC-1
C
C *** Check if window within boundaries
          IF ((IPXS.LT.1   .OR. IPYS.LT.1) .or.
     2        (IPXE.GT.NPL .OR. IPYE.GT.NL)) THEN
             STRING = 'S__*** WARNING: Window boundary will fall '//
     2                       'outside frame; shift NOT done!!'
             CALL STTPUT(STRING,ISTAT)
             GOTO SPOMAT
          ENDIF
C
          IPX = IPXS
          IPY = IPYS
          JX  = JX + ILX
          JY  = JY + ILY
C
          PARINT(1) = IPX
          PARINT(2) = IPY
          PARINT(6) = NP
          PARINT(7) = NC
C
          IF (NCP.GT.0) THEN
             DO 51019 IC = 1,NCP
                FITCMP((IC-1)*6+2) = FITCMP((IC-1)*6+2) - ILX
                FITCMP((IC-1)*6+3) = FITCMP((IC-1)*6+3) - ILY
51019        CONTINUE
          ENDIF
          IF (NHL.GT.0) THEN
             DO 52019 IH = 1,NHL
                FITHOL((IH-1)*3+2) = FITHOL((IH-1)*3+2) - ILX
                FITHOL((IH-1)*3+3) = FITHOL((IH-1)*3+3) - ILY
52019        CONTINUE
          ENDIF
C
          CALL INTWWR(TIDINT,IRWNDI,NCP,NHL)
          ASSIGN 50770 TO WNDRD
          GO TO 50070
50770     CONTINUE
C
          IF (JX+NP-1.GT.MX .OR. JY+NC-1.GT.MY .OR. 
     2        JX.LT.1 .OR. JY.LT.1) THEN
             ASSIGN 50454 TO LEGMAT
             GO TO 50054
50454        CONTINUE

          ELSE
             ASSIGN 50357 TO APPNF
             GO TO 50057
50357        CONTINUE
          END IF
C
          ASSIGN 50459 TO PREMAS
          GO TO 50059
50459     CONTINUE
C
          ASSIGN 50660 TO VISMAT
          GO TO 50060
50660     CONTINUE
          CALL DAZVIS(QDSPNO,QIMCH,2,1)            ! display everything
       ELSE
          STRING = 'S__*** WARNING: In OUTPUT MODE displacements are '//
     *             'NOT allowed (try N) '
          CALL STTPUT(STRING,ISTAT)
       END IF

       GO TO SPOMAT

C+++
50020  CONTINUE                                    ! Procedure PNONCE; option T
C---
58020  FORMAT('T__*** WARNING: Cannot find our component ',
     2        I2, ' sorry ...')
C
       IF (IIST.EQ.0 .AND. IOD.EQ.'D') THEN
          CALL STKPRI('T__Enter component to be excluded: ',
     2                'INPUTI',1,1,IAV,IDCMP,KUN,KNUL,ISTAT)
          IDCMP1 = IABS(IDCMP) + 100                           ! find component
          CALL TBESRI(TIDINT,INTNUM(2),IDCMP1,COLERR,IRWNDI,
     2                IRCMP,ISTAT)
C
          IF (IRCMP.LE.0) THEN                     ! can't find component
             WRITE(STRING,58020) IABS(IDCMP)
             CALL STTPUT(STRING,ISTAT)
          ELSE
             ICMP= IRCMP - IRWNDI + 1              ! relative comp number
          ENDIF
C
          IF (ICMP.GT.NCP) THEN                    ! in another group
             WRITE(STRING,58020) IABS(IDCMP)
             CALL STTPUT(STRING,ISTAT)
          ELSE
             IF (IDCMP.LT.0) THEN              
                FLGCMP(ICMP) = 1
                NONS(ICMP)   = 1
             ELSE
                FLGCMP(ICMP) = 0
                NONS(ICMP)   = 0
             END IF
             GRE = 0
             CALL INTCWR(TIDINT,IRCMP,ICMP)
          ENDIF
       END IF

       GO TO PNONCE

C+++
50021  CONTINUE                                    ! Procedure COLFAC; option U
C---
       CALL STKPRR('U__Enter zero level for display: ',
     2             'INPUTR',1,1,IAV,ZESI,KUN,KNUL,ISTAT)
       GO TO COLFAC

C+++
50022  CONTINUE                                    ! Procedure APRKFI; option V
C---
       CALL STKPRC('V__Enter input frame: ','IN_A',1,1,60,IAC,FRAME,
     2             KUN,KNUL,ISTAT)
       CALL STIGET(FRAME,D_R4_FORMAT,F_I_MODE,F_IMA_TYPE,3,NAXIS,
     2            NPIX,BEGIN,STEP,IDENT,CUNIT,IPNTR,IMF,ISTAT)
       IF (ISTAT.NE.0) THEN
          CALL STTPUT('V__*** WARNING: No such frame available, sorry',
     2                ISTAT)
          GO TO APRKFI                             ! back to monitor
       ELSE
          NPL   = NPIX(1)
          NL    = NPIX(2)
       ENDIF
C
C *** get new intermediate file
       CALL STKPRC('U__Enter new intermediate table [no new one]: ',
     2             'INPUTC',1,1,60,IAV,INTFIL,KUN,KNUL,ISTAT)
       IF (IAV.GT.0) THEN                          ! new table given
          CALL TBTCLO(TIDINT,ISTAT)                ! close the old one
          NNI = NN
          IGL = 0
          CALL TBTOPN(INTFIL,F_IO_MODE,TIDINT,ISTAT)  ! and open new one
          IF (ISTAT.NE.0) THEN                     ! no int. table present
             STRING = 'V__*** INFO: No intermediate table present '//
     2                'we will create one'
             CALL STTPUT(STRING,ISTAT)
             CALL INTINI(INTFIL,TIDINT)            ! create intermediate table
             NWD = 0
             NSR = 0

          ELSE                       ! table present; does it contain something
             CALL TBIGET(TIDINT,NCINT,NRINT,NSINT,NACINT,NARINT,ISTAT)
             IF (ISTAT.NE.0) THEN
                 STRING = 'V__*** FATAL: Problems with getting info '//
     2                    'for intermediate table; try again ... '
                 CALL STTPUT(STRING,ISTAT)
                 GO TO APRKFI
             ELSE
                 IF (NRINT.EQ.0) THEN              ! no info in table
                     STRING = 'V__*** FATAL: No data points in '//
     2                        'intermediate table'
                     CALL STTPUT(STRING,ISTAT)
                     NWD = 0
                     NSR = 0
                     NNI = 5
                 ELSE                              ! yes everything ok
                     CALL INTDRD(TIDINT,NGR,NOBJ,NSR,SAT,FAT,
     2                           SIGMA,BETA,SIV,AIN,FOG)
                 ENDIF
             ENDIF
          ENDIF
C
          ASSIGN 50251 TO PARLAS  
          GO TO 50051
50251     CONTINUE
       END IF
       GO TO APRKFI

C+++
50023  CONTINUE                                    ! Procedure CAMSLO; option W
C---
       CALL STKPRR('W__Enter slope of the colour scale: ',
     *             'INPUTR',1,1,IAV,FATT1,KUN,KNUL,ISTAT)
C
       IF (FATT1.EQ.0.) THEN
          CALL STTPUT('W__*** WARNING: Slope 0 not allowed, '//
     2                'slope 0.0001 assumed',ISTAT)
          FATT1=0.0001
       END IF
C
       GO TO CAMSLO

C+++
50024  CONTINUE                                  ! Procedure DISISO; option X+Y
C---
C
       IF (IOD.EQ.'D' .AND. (CAR.EQ.'X' .OR. CAR.EQ.'Y')) THEN
          ASSIGN 50555 TO RIMANF
          GO TO 50055
50555     CONTINUE
       END IF

       IF (CAR.EQ.'Y') THEN
          CALL STKPRR('Y__Enter isophotal threshold: ',
     *                'INPUTR',1,1,IAV,S01,KUN,KNUL,ISTAT)
       END IF

       IF (CAR.NE.' ') THEN
          IF (CAR.NE.'D') THEN
             CALL CONCHA(QDSPNO,QOVCH,0,0)         ! clear graphics
             CALL CONCHA(QDSPNO,QIMCH,0,0)         ! clear image
             CALL STKWRI('DAZIN',CURDAT,1,4,KUN,ISTAT)
             ASSIGN 50361 TO TYPNOM
             GO TO 50061
50361        CONTINUE
             ASSIGN 50362 TO TYPCOM
             GO TO 50062
50362        CONTINUE
             CALL PROFI5(RNY,MX,MY,NP,NC,L78,F78,'Y')
          END IF
C
          IF (NCP.GT.0 .AND. IOD.EQ.'D') THEN
             CALL PROFI5(RNF,MX,MY,NP,NC,L78,F78,'Y')
          END IF
       END IF
C
       ASSIGN 50264 TO GRAISO
       GO TO 50064
50264  CONTINUE
C
       S01=SAS01
       GO TO DISISO


C+++
50026  CONTINUE                                    ! Procedure DEPM; option Z
C---
       IF (IZE.EQ.0) THEN
          IZE = 1
          CALL STTPUT('Z__Examined stars will be displayed',ISTAT)
       ELSE
          IZE = 0
          CALL STTPUT('Z__Examined stars will not be displayed',ISTAT)
       ENDIF 
C
       GO TO DEPM

C+++
50034  CONTINUE                                    ! Procedure SEREOU; option 4
C---
51034  FORMAT('4__Enter group identification to start [',I6,']: ')
52034  FORMAT('4__*** WARNING: Group ',I6,' not available; ',
     2        'start with first group')
C
       KAUT  = 2
       NEXTW = .FALSE.
       RAI   = 'M'
       CALL STKWRC('INPUTC',1,RAI,1,1,KUN,ISTAT)
       CALL STKPRC('4__Enter display mode (A)utomatic, '//
     2             '(S)elective or (M)anual [M]: ','INPUTC',1,1,1,
     3              IAV,RAI,KUN,KNUL,ISTAT)
       CALL UPCAS(RAI,RAI)    
C
       IF (RAI.NE.'M') THEN
          ISIT = 1
          SOAL = 0
          IF (RAI.NE.'A') THEN
             RAI = 'A'
             CALL STKWRC('INPUTC',1,RAI,1,1,KUN,ISTAT)
             CALL STKPRC('4__Enter selection (A)ll, (N)o conv., '//
     2                   '(H)eight, (I)teration or (T)est [A]: ',
     3                    'INPUTC',1,1,1,IAV,RAI,KUN,KNUL,ISTAT)
             IF (IAV.EQ.0) THEN
                RAI = 'A'
             ENDIF
             CALL UPCAS(RAI,RAI)    
C
             IF (RAI.EQ.'H' .OR. RAI.EQ.'A') THEN
                SOAL = 0.0
                CALL STKWRR('INPUTR',SOAL,1,1,KUN,ISTAT)
                CALL STKPRR('Enter threshold level [0.0]: ','INPUTR',
     2                    1,1,IAV,SOAL,KUN,KNUL,ISTAT)
             END IF
C
             IF (RAI.EQ.'I' .OR. RAI.EQ.'A') THEN
                ISIT = 1
                CALL STKWRI('INPUTI',ISIT,1,1,KUN,ISTAT)
                CALL STKPRI('4__Enter number of iterations [1]: ',
     2                      'INPUTI',1,1,IAV,ISIT,KUN,KNUL,ISTAT)
                IF (ISIT.LE.0) ISIT = 1
             END IF
          END IF
C
          IF (NCP+NHL.GT.1) THEN                   ! are there any components
             IRWNDI = IRWNDI+NCP+NHL               ! default with next group
          ELSE                                     ! nothing left
             IRWNDI = IRWNDI+1                     ! increase group by 1
          ENDIF
          CALL TBERDI(TIDINT,IRWNDI,INTNUM(1),IDWND,NULL,ISTAT)    ! group id
          IF (IDWND.LE.0) THEN                     ! group  not known
             IRWNDI = 1                            ! start from begin
             CALL TBERDI(TIDINT,IRWNDI,INTNUM(1),IDWND,NULL,ISTAT) ! group id
          ENDIF
C
          WRITE(STRING,51034) IDWND                ! give info to user
          LCHAR = INDEX(STRING,':')+1               
          CALL STKWRI('INPUTI',IDWND,1,1,KUN,ISTAT)
          CALL STKPRI(STRING(1:LCHAR),'INPUTI',1,1,IAV,IWND,
     2                KUN,KNUL,ISTAT)              ! prompt for ident
          IF (IAV.EQ.0) THEN
             IWND = IDWND
          ENDIF
          CALL TBESRI(TIDINT,INTNUM(1),IWND,COLERR,1,IROW,ISTAT) ! present
          IF (IROW.LE.0) THEN                      ! wrong group
             WRITE(STRING,52034) IWND
             CALL STTPUT(STRING,ISTAT)
             GO TO SEREOU
          ELSE
             IRWNDI = IROW
          ENDIF
       END IF
C        
       GO TO SEREOU

C+++
50035  CONTINUE                                    ! Procedure SEREIN; option 5
C---
51035  FORMAT('5__Enter group identification to start [',I6,']: ')

       KAUT = 1
       BBC  = 'M'
       CALL STKWRC('INPUTC',1,BBC,1,1,KUN,ISTAT)
       CALL STKPRC('5__Enter examining mode (A)utomatic, '//
     2             '(S)elective or (M)anual [M]: ','INPUTC',1,1,1,
     3              IAV,BBC,KUN,KNUL,ISTAT)
       CALL UPCAS(BBC,BBC)    
C
       IF (BBC.NE.'M') THEN
          SOAL = 0
          IF (BBC.NE.'A') THEN
             BBC = 'A'
             CALL STKWRC('INPUTC',1,BBC,1,1,KUN,ISTAT)
             CALL STKPRC('5__Enter selection (A)ll, (R)ejected, or '//
     2                   '(H)eight [A]: ','INPUTC',1,1,1,IAV,BBC,
     3                   KUN,KNUL,ISTAT)
             CALL UPCAS(BBC,BBC)    
             IF (IDWND.LE.0)  THEN
                IDWND = 0
             ENDIF
             IF (BBC.EQ.'H' .OR. BBC.EQ.'A') THEN
                CALL STKPRR('5__Enter intensity threshold: [0.0]: ',
     2                      'INPUTR',1,1,IAV,SOAL,KUN,KNUL,ISTAT)
             END IF
          END IF
C
          IF (IDWND.GE.NRCAT) THEN
             IDWND = 0
          ENDIF
          WRITE(STRING,51035) IDWND+1
          LCHAR = INDEX(STRING,':')+1               
          CALL STKPRI(STRING(1:LCHAR),'INPUTI',1,1,IAV,IDWND1,
     2                KUN,KNUL,ISTAT)
          IF (IDWND1.GT.0) THEN
             IDWND = IDWND1-1
          ENDIF
       END IF
C        
       GO TO SEREIN

C+++
50036  CONTINUE                                    ! Procedure SMOOTH; option 6
C---
       CALL STKPRC('6__Enter "Y" to enable smoothing [Y]: ',
     2             'INPUTC',1,1,1,IAV,SMY,KUN,KNUL,ISTAT)
       CALL UPCAS(SMY,SMY)    
       IF (IAV.EQ.0. OR. SMY.NE.'N') THEN
          SMY='Y'
       ENDIF
C
       GO TO SMOOTH

C+++
50037  CONTINUE                                    ! Procedure INTEGR; option 7
C---
       CALL STKPRC('7__Enter "Y" to enable integration [Y]: ',
     2             'INPUTC',1,1,1,IAV,INY,KUN,KNUL,ISTAT)
       CALL UPCAS(INY,INY)    
       IF (IAV.EQ.0 .OR. INY.NE.'N') THEN
          INY = 'Y'
       ENDIF
C
       GO TO INTEGR

C+++
50041  CONTINUE                                  !Procedure DISAGA; option " "
C---
       ASSIGN 50353 TO APPDAT
       GO TO APPDAT
50353  CONTINUE
       ASSIGN 50258 TO LEMARA
       GO TO 50058
50258  CONTINUE
C
       IF (IOD.EQ.'D') THEN
          ASSIGN 50155 TO RIMANF
          GO TO 50055
50155     CONTINUE
          CALL PROFI5(RNF,MX,MY,NP,NC,L78,F78,'Y')
          IF (IPIANT.EQ.0) THEN
             CALL PIANT5(RNF,MX,MY,NP,NC,MXYF,FATT1,P(3),ZESI)
             CALL PIANT5(RESI,MX,MY,NP,NC,MXYR,FATT1,P(3),ZESI)
             K1G=1
          END IF
       END IF
C
       IF (IPIANT.EQ.1) THEN
          ASSIGN 50224 TO DISISO
          GO TO 50024
50224     CONTINUE
       END IF
       CALL DAZVIS(QDSPNO,QIMCH,2,1)               ! display everything
C
       GO TO DISAGA

C+++
50042  CONTINUE                                    ! Procedure DIMMAT; option /
C---
59042  FORMAT ('/__Enter new window size in x and y [',
     2             I2, ',', I2, ']: ')
C
       WRITE(STRING,59042) NPI,NCI
       IINPUT(1) = NPI
       IINPUT(2) = NCI
       CALL STKWRI('INPUTI',IINPUT,1,2,KUN,ISTAT)
       LCHAR = INDEX(STRING,':')+1               
       CALL STKPRI(STRING(1:LCHAR),
     2            'INPUTI',1,2,IAV,IINPUT,KUN,KNUL,ISTAT)
       NPI1 = IINPUT(1)
       NPC1 = IINPUT(2)
       LOG23 = NPI1.GT.MX .OR. NPC1.GT.MY
       IF (LOG23 .OR. NPI1.LT.1 .OR. NPC1.LT.1) THEN
          CALL STTPUT('/__*** WARNING: Illegal window size;'// 
     2                ' try again ...', ISTAT)
       ELSE
          NPI = NPI1
          NCI = NPC1
       ENDIF
C        
       GO TO DIMMAT

C+++
50043  CONTINUE                                    ! Procedure DEFR; option ?
C---
       IF (IHE.EQ.0) THEN
          IHE = 1
          CALL STTPUT('*** INFO: Multiple registration enabled',ISTAT)
       ELSE 
          IHE = 0
          CALL STTPUT('*** INFO: Multiple registration disabled',ISTAT)
       ENDIF 
C       
       GO TO DEFR

C+++
50044  CONTINUE                                    ! Procedure SCRBUC; option -
C---
       IF (K23.EQ.1) THEN
          K23 = 0
          CALL STTPUT('*** INFO: Holes will not be reported', ISTAT)
       ELSE
          CALL STTPUT('*** INFO: Holes will be reported', ISTAT)
          K23 = 1
          ASSIGN 50161 TO TYPNOM
          GO TO 50061
50161     CONTINUE
          ASSIGN 50162 TO TYPCOM
          GO TO 50062
50162     CONTINUE
       ENDIF
C
       GO TO SCRBUC

C+++
50045  CONTINUE                                    ! Procedure RISCOM; option @
C---
51045  FORMAT ('@__Enter "R" to replace, "A" to append [',
     2          A1,']: ')
C
       IF (IGS.EQ.'A') THEN
          IGS = 'A'
       ELSE
          IGS = 'R'
       END IF
C
       WRITE(STRING,51045) IGS
       LCHAR = INDEX(STRING,':')+1               
       CALL STKPRC(STRING(1:LCHAR),
     2             'INPUTC',1,1,1,IAV,IGS2,KUN,KNUL,ISTAT)
       CALL UPCAS(IGS2,IGS2)    
       IF (IGS2.NE.IGS .AND. IGS2.NE.' ') THEN
          IGS = IGS2
       ENDIF
C
       GO TO RISCOM

C+++
50051  CONTINUE                                    ! Procedure PARLAS
C---
51051  FORMAT('*** INFO: Sigma and saturation used: ',F6.2,',',F7.0)
C
       IF ((SAT.EQ.0.0) .AND. (SIGMA.EQ.0.0)) THEN
          SIGMA = 3.
          SAT   = 12000.
C         BETA  = 4.
       ENDIF
C
       FOG1 = 0.0
       CALL STKRDR('INPUTR',1,2,IAC,RINPUT,KUN,KNUL,ISTAT)
       IF (RINPUT(1).NE.0 .OR. RINPUT(2).NE.0 
     2                    .OR. FOG1.NE.0.0) THEN
          SIGMA = RINPUT(1)
          SAT   = RINPUT(2)
          FOG   = FOG1
       ENDIF
       WRITE(STRING,51051) SIGMA,SAT
       CALL STTPUT(STRING,ISTAT)
       IFA   = 1
C
       GO TO PARLAS

C+++
50052  CONTINUE                                    ! Procedure VERREC
C---
       IF (RAI.EQ.'N' .OR. RAI.EQ.'A') THEN
          IF (GRE.EQ.2) THEN
             JFVR = 1
          ELSE
             JIL = 1
51052        CONTINUE
             IF (JFVR.NE.0 .OR. JIL.GT.NCP) GO TO 52052
                IF (FLGCMP(JIL).GT.2) JFVR = 1
                JIL = JIL+1
                GO TO 51052
52052        CONTINUE
          END IF
       END IF
C
       JAC = 0
       IF (RAI.EQ.'A' .AND. JFVR.EQ.1) THEN
          JAC  = JAC+1
          JFVR = 0
       END IF
C
       IF (RAI.EQ.'I' .OR. RAI.EQ.'A') THEN
          IF (NITER.GE.ISIT) JFVR = 1
       END IF
C
       IF (RAI.EQ.'A' .AND. JFVR.EQ.1) THEN
          JAC  = JAC+1
          JFVR = 0
       END IF
C
       IF (RAI.EQ.'H' .OR. RAI.EQ.'A') THEN
          JIL = 1
53052     CONTINUE
          IF (JFVR.NE.0 .OR. JIL.GT.NCP) GO TO 54052
             IF (FLGCMP(JIL).GE.1) THEN
                IF (P((JIL-1)*4+4).GE.SOAL) JFVR=1
             END IF
             JIL=JIL+1
             GO TO 53052
54052     CONTINUE
       END IF

       IF(RAI.EQ.'A' .AND. JFVR.EQ.1) JAC=JAC+1
       IF (RAI.EQ.'T') THEN
          JIL = 1
55052     CONTINUE
          IF (JFVR.NE.0 .OR. JIL.GT.NCP) GO TO 56052
             IF (FLGCMP(JIL).EQ.2) JFVR = 1
             JIL=JIL+1
             GO TO 55052
56052     CONTINUE
       END IF
C
       IF (RAI.EQ.'A' .AND. JAC.LT.3) THEN
          JFVR = 0
       END IF
C
       GO TO VERREC

C+++
50053  CONTINUE                                    ! Procedure APPDAT
C---
       IPX = INT(D1)
       IPY = INT(D2)
       NP  = INT(D3)
       NC  = INT(D4)
       IF (NP.LE.0)  NP=31
       IF (NC.LE.0)  NC=31
       IF (NP.GT.MX) NP=31
       IF (NC.GT.MY) NC=31
       NPM   = NP*3
       NCM   = NC*3
       MX    = MX1
       MY    = MY1
C
       IF (NCP.GT.0) THEN
          DO 51153 NIL = 1,NCP
             NONS(NIL) = FLGCMP(NIL)
51153     CONTINUE
       END IF
C
       GO TO APPDAT

C+++
50054  CONTINUE                                    ! Procedure LEGMAT
C---
        ASSIGN 50156 TO INIFIN
        GO TO 50056
50156   CONTINUE
        IF (IP3.EQ.0) THEN
           DO 51154 IH = 1,KFD
              IVB(IH) = 0
51154      CONTINUE
        END IF
        DO 52054 IH = IY0,IY0+MY-1
           CALL REALIN(NPL,NL,IH,IX0,MX,MADRID(IPNTR),RIA)
           DO 53054 IHO = 1,MX
              RL = RIA(IHO)-FOG
              L  = RL+.5
              IF (IP3.EQ.0) THEN
                 IF (L.GT.0 .AND. L.LE.KFD) THEN
                    IVB(L)=IVB(L)+1
                 ENDIF
              END IF
              RNF(IH-IY0+1,IHO) = RL
53054      CONTINUE
52054   CONTINUE
C
        IF (IP3.EQ.0) THEN
           IFONDO =0
           DO 55054 IH = 1,KFD
              IF (IVB(IH).GT.IFONDO) THEN
                 IFONDO = IVB(IH)
                 IHS    = IH
              END IF
55054      CONTINUE
           P(3) = IHS
        END IF
C
        IF (CAR.EQ.'M') THEN
           P(1)=0.
           P(2)=0.
        END IF
C
        IF (SMY.NE.'N') THEN
           CALL SMOOT(RNF,MY,MX)
        END IF
C
        ASSIGN 50157 TO APPNF
        GO TO 50057
50157   CONTINUE
C
        GO TO LEGMAT

C+++
50055  CONTINUE                                    ! Procedure RIMANF
C---
        DO 51055 I1 = 1,NC
           AAY = I1-.5
           DO 52055 I2 = 1,NP
              AAX  = I2-.5
              VG   = P(1)*I2+P(2)*I1+P(3)
              DO 53055 I3 = 1,NCP
                 IF (FLGCMP(I3).GE.1) THEN
                    JN   = (I3-1)*4
                    ESPO = ((I2-P(5+JN))**2+(I1-P(6+JN))**2)/
     2                     (P(7+JN)**2)
                    IF (ABS(BETA).LT.1.0E-30) THEN
                       IF (INY.EQ.'N') THEN
                          VG = VG+P(4+JN)*EXP(-ESPO*4*ALOG(2.))
                       ELSE
                          VG = VG+GALEG(3,3,P(4+JN),P(7+JN),AAX,AAY,
     *                         P(5+JN),P(6+JN))
                       END IF
                    ELSE
                       IF (INY.EQ.'N') THEN
                          VG = VG+P(4+JN)*(1+ESPO)**(-BETA)
                       ELSE
                          VG = VG+GALE2(3,3,P(4+JN),P(7+JN),BETA,
     *                         AAX,AAY,P(5+JN),P(6+JN))
                       END IF
                    END IF
                 END IF
53055         CONTINUE
C
              RNF(I1,I2)=VG
              IF (IPIANT.EQ.0) THEN
                 IF (RNY(I1,I2).GT.-2000000000) THEN
                    RESI(I1,I2) = RNY(I1,I2) - RNF(I1,I2)+P(3)
                 ELSE
                    RESI(I1,I2) = -2000000000
                 END IF
              END IF
52055     CONTINUE
51055  CONTINUE
C 
       GO TO RIMANF

C+++
50056  CONTINUE                                    ! Procedure INIFIN
C---
       IPX   = IPX-BEGIN(1)+1
       IPY   = IPY-BEGIN(2)+1
       IPXSA = IPX
       IPYSA = IPY
       JX    = MX/2-NP/2+1
       JY    = MY/2-NC/2+1
       IX0   = IPX-JX+1
       IY0   = IPY-JY+1
C
       IF (IX0.LT.1) THEN
          IX0 = 1
          IF (IPX.LT.1) THEN
             IPX = 1
             ILX = IPX-IPXSA+ILX
             JX  = 1 
          ELSE
             JX = IPX
          END IF
       END IF
C
       IF (IY0.LT.1) THEN
          IY0=1
          IF (IPY.LT.1) THEN
             IPY = 1
             ILY = IPY-IPYSA+ILY
             JY  = 1
          ELSE
             JY  = IPY
          END IF
       END IF
C
       IF (IX0+MX-1.GT.NPL) THEN
          IX0 = NPL-MX+1
          IF (IPX+NP-1.GT.NPL) THEN
             IPX = NPL-NP+1
             ILX = IPX-IPXSA+ILX
          END IF
          JX = IPX-IX0+1
       END IF
C
       IF (IY0+MY-1.GT.NL) THEN
          IY0 = NL-MY+1
          IF (IPY+NC-1.GT.NL) THEN
             IPY = NL-NC+1
             ILY = IPY-IPYSA+ILY
          END IF
          JY = IPY-IY0+1
       END IF
       IPX = IPX+BEGIN(1)-1
       IPY = IPY+BEGIN(2)-1
C
       GO TO INIFIN

C+++
50057  CONTINUE                                    ! Procedure APPNF
C---
       DO 51057 KK1 = JY,JY+NC-1
          DO 52057 KK2 = JX,JX+NP-1
             RNY(KK1-JY+1,KK2-JX+1) = RNF(KK1,KK2)
52057     CONTINUE
51057  CONTINUE
C
       GO TO APPNF

C+++
50058  CONTINUE                                    ! Procedure LEMARA
C---
       LJ1 = IPX-BEGIN(1)+1
       LJ3 = IPY-BEGIN(2)+1
       DO 51058 J5 = LJ3,LJ3+NC-1
          CALL REALIN(NPL,NL,J5,LJ1,NP,MADRID(IPNTR),RIA)
          DO 52058 I = 1,NP
             RIA(I) = RIA(I)-FOG
             IF (RIA(I).GT.SAT) THEN
                RIA(I) = SAT
             ENDIF
             RNY(J5-LJ3+1,I) = RIA(I)
52058     CONTINUE
51058  CONTINUE
C
       IF (SMY.NE.'N') THEN
          CALL SMOOT(RNY,MY,MX)
       END IF
C
       ASSIGN 50359 TO PREMAS
       GO TO 50059
50359  CONTINUE
C
       ASSIGN 50360 TO VISMAT
       GO TO 50060
50360  CONTINUE
C
       GO TO LEMARA

C+++
50059  CONTINUE                                    ! Procedure PREMAS
C---
       IF (NHL.GT.0) THEN
          DO 51059 LI = 1,NHL
             ICB = (LI-1)*3
             RR  = PB(ICB+1)**2
             L4  = AMAX1(1.,PB(ICB+3)-PB(ICB+1))
             L5  = AMIN1(FLOAT(NC),PB(ICB+3)+PB(ICB+1)+.99)
             L21 = AMAX1(1.,PB(ICB+2)-PB(ICB+1))
             L22 = AMIN1(FLOAT(NP),PB(ICB+2)+PB(ICB+1)+.99)
             DO 52059 L2 = L21,L22
                 DO 53059 L3 = L4,L5
                    DELT = (L2-PB(ICB+2))**2+(L3-PB(ICB+3))**2
                    IF (RR.GE.DELT) THEN
                       IF (RNY(L3,L2).GT.-2000000000) THEN
                          IF (L3.GE.1 .AND. L3.LE.MX1) THEN
                             IF (L2.GE.1 .AND. L2.LE.MY1)THEN
                                RMASK(L3,L2) = RNY(L3,L2)
                                RNY(L3,L2)   = -2000000000
                             END IF
                          END IF
                       END IF
                    END IF
53059            CONTINUE
52059         CONTINUE
51059     CONTINUE
       END IF
C
       GO TO PREMAS

C+++
50060  CONTINUE                                    ! Procedure VISMAT
C---
       NPM = 3*NP
       NCM = 3*NC
C
       IF (CAR.EQ.'M') IFG = FLCO
       IF (CAR.EQ.'N' .OR. CAR.EQ.'D') THEN
          IFG = GRE
       ENDIF
C
       CALL CONCHA(QDSPNO,QIMCH,0,0)               ! clear image
       CALL CONCHA(QDSPNO,QOVCH,0,0)               ! clear graphics
       CALL STKWRI('DAZIN',CURDAT,1,4,KUN,ISTAT)
       ASSIGN 50261 TO TYPNOM
       GO TO 50061
50261  CONTINUE
C
       ASSIGN 50262 TO TYPCOM
       GO TO 50062
50262  CONTINUE
C
       L78 = 200.-(P(3)*F78)/3.
       COND = IOD.EQ.'D' .OR. CAR.EQ.'X' .OR. CAR.EQ.'Y'
       IF (COND.OR.(IOD.EQ.'N'.AND.IPIANT.EQ.1)) THEN
          DSA = 'Y'
       ENDIF
       CALL PROFI5(RNY,MX,MY,NP,NC,L78,F78,DSA)
       DSA = 'A'
       IF (IPIANT.EQ.0) THEN
          CALL PIANT5(RNY,MX,MY,NP,NC,1,FATT1,P(3),ZESI)
          K1G = 1
       END IF
C
       GO TO VISMAT

C+++
50061  CONTINUE                                    ! Procedure TYPNOM
C---
51061  FORMAT('   Group: ',I8,'; int=',E10.4,'; x0,y0=',
     2         I4,', ',I4,'; nx,ny=',I2,', ',I2,'; flag=',I2)
52061  FORMAT('   Group: ',I8,'; # comp=',I3,'; x0,y0=',
     2         I4,', ',I4,'; nx,ny=',I2,', ',I2,'; flag=',I2)
C
       IF (IOD.NE.'D') THEN
          WRITE(STRING,51061) IDWND,RMA,IPX,IPY,NP,NC,IFG
       ELSE
          WRITE(STRING,52061) IDWND,NCP,IPX,IPY,NP,NC,IFG
       END IF
       CALL STTPUT(STRING,ISTAT)
C
       IF ((RAI.NE.'M' .OR. IAM.NE.'M') .AND. (IOD.EQ.'O')) THEN
C      IF (RAI.NE.'M' .AND. IOD.EQ.'O') THEN
          IRWNDI = IRWNDI+NCP+NHL                  ! row for next group
       ENDIF
C
       IF ((BBC.NE.'M' .OR. IAM.NE.'M') .AND. (IOD.EQ.'I')) THEN
C      IF (BBC.NE.'M' .AND. IOD.EQ.'I') THEN
          IRWNDI = IRWNDI+NCP+NHL                  ! row for next group
       ENDIF
C
       GO TO TYPNOM

C+++
50062  CONTINUE                                    ! Procedure TYPCOM
C---
59062  FORMAT('   Background:  ', 3(G12.6,2X))
58062  FORMAT('   Component ',I2,': ',4(G12.6,2X),I2)
57062  FORMAT('   Hole      ',I2,': ',3(G12.6,2X))
C
       WRITE(STRING,59062) (P(L),L=1,3)            ! write the background
       CALL STTPUT(STRING,ISTAT)
C
       IF (NCP.GT.0) THEN                          ! write the components
          DO 51062 LLL = 1,NCP
             LSTA = (LLL-1)*4+4
             LSTO = (LLL-1)*4+7
             IDN  = IDNCMP(LLL)-100
             WRITE(STRING,58062) IDN,(P(L),L=LSTA,LSTO),FLGCMP(LLL)
             CALL STTPUT(STRING,ISTAT)
51062     CONTINUE
       END IF
C
       IF (NHL.GT.0. AND. K23.EQ.1) THEN           ! write the holes
          DO 52062 LLL = 1,NHL
              LSTA = (LLL-1)*3+1
              LSTO = (LLL-1)*3+3
              IDN  = IDNHOL(LLL)-200
              WRITE(STRING,57062) IDN,(PB(L),L=LSTA,LSTO)
              CALL STTPUT(STRING,ISTAT)
52062      CONTINUE
       END IF
C
       GO TO TYPCOM

C+++
50064  CONTINUE                                    ! Procedure GRAISO
C---
        AM = 0.
        DO 51064 IK=1,NC
           DO 52064 JK=1,NP
              AM = AMAX1(AM,RNY(IK,JK))
52064      CONTINUE
51064   CONTINUE
C
        AM    = AM-P(3)
        AMINH = P(4)
        DO 50364 LK=1,NCP
           IC = (LK-1)*4+4
           AMINH = AMIN1(AMINH,P(IC))
50364   CONTINUE
C
        K1G = 1
        IF (NC.LT.MY) THEN
           DO 50464 IK=NC+1,MY
              DO 50564 JK=1,MX
                 RNY(IK,JK)=0
                 IF (IOD.EQ.'D') RNF(IK,JK)=0
50564         CONTINUE
50464      CONTINUE
        END IF
C
        IF (NP.LT.MX) THEN
           DO 50664 IK=1,MY
              DO 50764 JK=NP+1,MX
                 RNY(IK,JK)=0
                 IF (IOD.EQ.'D') RNF(IK,JK)=0
50764         CONTINUE
50664      CONTINUE
        END IF
C
        DO 50864  K3=2,9,3
           H = (AM*S01)*K3+P(3)
           IF ((H-P(3)).GT.AMINH.AND.K3.EQ.2.AND.IOD.EQ.'D') THEN
              H = 0.8*AMINH+P(3)
           END IF
           CALL CONTS3(RNY,MY,MY,MX,H,DDD,K1G,MY)
           IF (NCP.GT.0 .AND. IOD.EQ.'D') THEN
              CALL CONTS3(RNF,MY,MY,MX,H,DDD,K1G,MY)
           END IF
           K1G = K1G+MXYF-1
50864  CONTINUE

       GO TO GRAISO

C+++
50065  CONTINUE                                    ! Procedure RICFIL
C---
       IAX = IPJ1+IPX-1
       IAY = IPJ2+IPY-1
       LF4 = 0
       LFF = 0
       IAI = IDWND-1
C
51065  CONTINUE
       IF (LFF.NE.0) GO TO 52065
          IAI = IAI+1
          CALL CATTRD(TIDCAT,IAI,IDWND,AX,AY,RMA,V,B,U,P33,FLCO,
     *                           BBB,SSS,AAII,SOSO,BA1)
          IF (FLCO.LT.1.) THEN
             IF (ABS(IAX-AX).LE.3..AND.ABS(IAY-AY).LE.3.) THEN
                LFF  = 1
                FLCO = 1.
                CALL CATTWR(TIDCAT,IAI,IDWND,AX,AY,RMA,V,B,U,P33,
     2                                 FLCO,BBB,SSS,AAII,SOSO,BA1)
                LF4  = 1
             END IF
          END IF
          IF (ABS(IAY-AY).GT.NC.OR.IAI.GE.NSTCAT) THEN
             LFF = 1
          ENDIF
          GO TO 51065
52065  CONTINUE 
C
       CALL CATTRD(TIDCAT,IRWNDC,IDWND,DUM1,DUM2,DUM3,DUM4,DUM5,DUM6,
     2              DUM7,DUM8,DUM9,DUM10,DUM11,DUM12,DUM13)
       GO TO RICFIL

C+++
50066  CONTINUE                                    ! Procedure RIPMAS
C---
       IF (NHL.GT.0) THEN
          DO 51066 LI=1,NHL
             ICB = (LI-1)*3
             RR  = PB(ICB+1)**2
             L4  = AMAX1(1.,PB(ICB+3)-PB(ICB+1))
             L5  = AMIN1(FLOAT(NC),PB(ICB+3)+PB(ICB+1)+.99)
             L21 = AMAX1(1.,PB(ICB+2)-PB(ICB+1))
             L22 = AMIN1(FLOAT(NP),PB(ICB+2)+PB(ICB+1)+.99)
             DO 52066 L2 = L21,L22
                DO 53066 L3 = L4,L5
                   DELT = (L2-PB(ICB+2))**2+(L3-PB(ICB+3))**2
                   IF (RR.GE.DELT) THEN
                      IF (L3.GE.1 .AND. L3.LE.MX1) THEN
                         IF (L2.GE.1 .AND. L2.LE.MY1)THEN
                            RNY(L3,L2) = RMASK(L3,L2)
                         END IF
                      END IF
                   END IF
53066           CONTINUE
52066        CONTINUE
51066     CONTINUE
       END IF
C
       GO TO RIPMAS

C+++
50070  CONTINUE                                    ! Procedure WNDRD
C---
       CALL INTWRD(TIDINT,IRWNDI,NCP,NHL)
       IDWND  = IDNGRP
       D1     = PARINT(1)
       D2     = PARINT(2)
       V      = PARINT(3)
       B      = PARINT(4)
       U      = PARINT(5)
       D3     = PARINT(6)
       D4     = PARINT(7)
       P(1)   = PARINT(8)
       P(2)   = PARINT(9)
       P(3)   = PARINT(10)
       BETA   = PARINT(11)
       SCAP   = PARINT(12)
       NITER  = PARINT(13)
       GRE    = PARINT(14)
C
       IF (NCP.GT.0) THEN
          DO 52070 IC = 1,NCP                      ! loop through components
             P((IC-1)*4+4)  = FITCMP((IC-1)*6+1)   ! intensity
             P((IC-1)*4+5)  = FITCMP((IC-1)*6+2)   ! x coord
             P((IC-1)*4+6)  = FITCMP((IC-1)*6+3)   ! y coord
             P((IC-1)*4+7)  = FITCMP((IC-1)*6+4)
             USC(IC)        = FITCMP((IC-1)*6+5)
             USE(IC)        = FITCMP((IC-1)*6+6)
52070    CONTINUE
       ENDIF
C
       IF (NHL.GT.0) THEN
          DO 53070 IH = 1,NHL                      ! loop through holes
             PB((IH-1)*3+1) =  FITHOL((IH-1)*3+1)
             PB((IH-1)*3+2) =  FITHOL((IH-1)*3+2)
             PB((IH-1)*3+3) =  FITHOL((IH-1)*3+3)
53070    CONTINUE
       ENDIF

       GO TO WNDRD

C+++
50072  CONTINUE                                    ! Procedure DELCMP
C---
57072  FORMAT('C__Component ',I3,' has been deleted')
58072  FORMAT('C__Last component ',I3,' has been deleted;',
     2                                ' group is empty now.')
C
       PARINT(15) =  FLOAT(NCP-1)                  ! reduce # comps
       DO 51072 IROW = IRWNDI,IRWNDI+NCP+NHL-1     ! update # components
          CALL TBEWRR(TIDINT,IROW,17,PARINT(15),ISTAT)
51072  CONTINUE
C
       IF (NCP.EQ.1 .AND. NHL.EQ.0) THEN           ! last component
          NGR                  = NGR  - 1
C         IDNCMP(ICMP)         = IDNCMP(ICMP) + 1000
          FLGCMP(ICMP)         = 0
          FITCMP((ICMP-1)*6+1) = TRNULL
          FITCMP((ICMP-1)*6+2) = TRNULL
          FITCMP((ICMP-1)*6+3) = TRNULL
          FITCMP((ICMP-1)*6+4) = TRNULL
          FITCMP((ICMP-1)*6+5) = TRNULL
          FITCMP((ICMP-1)*6+6) = TRNULL
          CALL INTCWR(TIDINT,IRCMP,ICMP)
          CALL TBCSRT(TIDINT,2,INTNUM,FLAGS,ISTAT)
          WRITE(STRING,58072) IDCMP
          CALL STTPUT(STRING,ISTAT)
       ELSE
          CALL TBRDEL(TIDINT,IRCMP,ISTAT)
          CALL TBCSRT(TIDINT,2,INTNUM,FLAGS,ISTAT)
          WRITE(STRING,57072) IDCMP
          CALL STTPUT(STRING,ISTAT)
       ENDIF
C
       GO TO DELCMP
C

C+++
50073  CONTINUE                                    ! Procedure DELHOL
C---
59073  FORMAT('G__hole ',I3,' has been deleted')
58073  FORMAT('G__Last hole ',I3,' has been deleted;',
     2                           ' group is empty now.')
C
       PARINT(16) = FLOAT(NHL-1)                   ! reduce # holes
       DO 51073 IROW = IRWNDI,IRWNDI+NCP+NHL-1     ! update number of holes
          CALL TBEWRR(TIDINT,IROW,18,PARINT(16),ISTAT)
51073  CONTINUE
C
       IF (NHL.EQ.1 .AND. NCP.EQ.0) THEN           ! last hole
          NGR                  = NGR - 1           ! one group less
C         IDNHOL(IHOL)         = IDNHOL(IHOL) + 1000
          FLGHOL(IHOL)         = 0
          FITHOL((IHOL-1)*3+1) = TRNULL
          FITHOL((IHOL-1)*3+2) = TRNULL
          FITHOL((IHOL-1)*3+3) = TRNULL
          CALL INTHWR(TIDINT,IRHOL,IHOL)
          CALL TBCSRT(TIDINT,2,INTNUM,FLAGS,ISTAT)
          WRITE(STRING,58073) IDHOL
          CALL STTPUT(STRING,ISTAT)
       ELSE
          CALL TBRDEL(TIDINT,IRHOL,ISTAT)
          CALL TBCSRT(TIDINT,2,INTNUM,FLAGS,ISTAT)
          WRITE(STRING,59073) IDHOL
          CALL STTPUT(STRING,ISTAT)
       ENDIF
C
       GO TO DELHOL
C
C *** finish up
       END
