C @(#)rfotanalys.for 17.1.1.1 (ES0-DMD) 01/25/02 17:18:15 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