C @(#)calcul.for 17.1.1.1 (ES0-DMD) 01/25/02 17:15:39 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 C C subroutine CALCUL version 2.4 831007 C A. Kruszewski ESO Garching C C modified by C Ch. Ounnas ESO - GARCHING 831013 C 840523 C 840628 C C modified for FX version 2.5 870303 C A. Kruszewski Obs. de Geneva C C modified for huge images version 4.0 880915 C A. Kruszewski Warsaw U. Obs. C C.KEYWORDS C C classifying parameters, magnitudes, positions, profiles C C.PURPOSE C C for an input list of objects it calculates classifying parameters, C magnitudes, positions, gradients, sizes C C.INPUT/OUTPUT C C input arguments C C IMF integer*4 image file C A real*4 array image frame C JAPY integer*4 array pointers to image lines C NX integer*4 x-dimension of an array A C NY integer*4 y-dimension of an array A C ITOB integer*4 array limits of objects area C IXYU integer*4 array limits of used area C IARR integer*4 array values of integer keywords C RARR real*4 array values of real keywords C ICOL integer*4 array positions of special table columns C M0 integer number of objects C NCAT integer*4 array integer parameters of objects C PMTR real*4 array real parameters of objects C PRCT real*4 array catalog of objects profiles C FPSF real*4 array two-dimensional p.s.f. C IPSF integer*4 array pointers to FPSF C----------------------------------------------------------------------- SUBROUTINE CALCUL(IMF, A, JAPY, NX, NY, ITOB, IXYU, & IARR, RARR, ICOL, M0, NCAT, PMTR, PRCT, & FPSF, IPSF, OUTPSF) C IMPLICIT NONE INCLUDE 'MID_REL_INCL:INVENT.INC/NOLIST' C INTEGER I, IACT, IADR, IARR(32), IAVDIS INTEGER IBUF(4), ICOL(6), ICT, IDLM, IHED, IMF, IOF INTEGER IPF, IPSF(1), ISTAT, ITOB(4) INTEGER IUSD(4), IVRF, IXYU(4) INTEGER J, JAPY(1) INTEGER K, KNUL, KUN INTEGER L, L0, L1, LACT, LDBG INTEGER LI, LL, LL2, LLZ, LM, LPXL INTEGER LSBP, LSTP(LPBUF), LW, LZ INTEGER M, M0, MAXS, MCM(21), MM INTEGER MADRID(1) INTEGER NACT, NAXISP, NBYTE, NCAT(NIPAR,MAXCNT) INTEGER NCOL, NCNT, NCT(NIPAR), NEL, NROW INTEGER NLPB, NP, NPIXP(2), NPRF INTEGER NREG, NTMP, NVAL, NX, NY INTEGER*8 NPNTRP C REAL ADLM REAL A(1), ABGRD, APSF(0:MAXSUB) REAL DIST REAL FPSF(1), FTMP(2) REAL PMT(NRPAR), PMTR(NRPAR,MAXCNT) REAL PRCT(0:MAXSUB,MAXCNT) REAL RARR(64) REAL STPR(MAXSUB) REAL TRSH REAL XCMP, YCMP REAL XOBJ, YOBJ REAL PRC C REAL DUMP(40000) C REAL TEMP C DOUBLE PRECISION START(2), STARTP(2), STEP(2), STEPP(2) C CHARACTER*1 TYPE CHARACTER*48 CUNIT CHARACTER*60 OUTPSF CHARACTER*72 IDENT CHARACTER*80 OUTPUT CHARACTER*60 OUTABL C LOGICAL DONE, TWOD C INCLUDE 'MID_INCLUDE:ST_DEF.INC/NOLIST' COMMON /VMR/MADRID INCLUDE 'MID_INCLUDE:ST_DAT.INC/NOLIST' C C *** Recall often used quantities. C NP = MAXCNT LDBG = IARR(1) IVRF = IARR(4) IHED = IARR(8) LPXL = IARR(20) LSBP = IARR(21) TRSH = RARR(3) ADLM = RARR(42) IDLM = NINT(RARR(42)) + 1 IF (LPXL .GT. 0 .OR. LSBP .GT. 0) THEN TWOD = .TRUE. ELSE TWOD = .FALSE. ENDIF C C ****** Initialize point spread function. C CALL INAPSF(RARR, MAXSUB, APSF) C C *** Find number of lines per buffer NLPB. C NLPB = NY C NLPB = NIBUF /(IXYU(3) - IXYU(1) + 1) C C *** Catalog data is accesible for objects starting C *** with L0+1 and ending with L1. Last object written C *** into scratch file is LW. C L0 = 0 L1 = M0 LW = 0 C C *** ICOL(3) .GT. 0 when background column is present. C *** ICOL(4) .GT. 0 when central intensities are present. C *** ICOL(5) .GT. 0 when isophotal radii are present. C *** Abort when there is no coordinate data. C IF (ICOL(1) .EQ. 0 .OR. ICOL(2) .EQ. 0) THEN WRITE(OUTPUT,'(A)') 'No coordinate data present' CALL STTPUT(OUTPUT, ISTAT) ENDIF C C *** M0 is an original number of objects. M is number of C *** objects at loop start. MM is an actual number of C *** objects, it is updated inside the internal DO WHILE loop. C *** IBUF define limits of image buffer. C IBUF(1) = 1 IBUF(2) = 1 IBUF(3) = NX IBUF(4) = NY C IBUF(1) = 0 C IBUF(2) = 0 C IBUF(3) = 0 C IBUF(4) = 0 C C *** Divide analysed area into regions. C CALL DEFLST(LSTP, ITOB, M0, NREG) C C *** Initialize linked lists of objects in regions. C CALL INILST(LSTP, ITOB, NREG, NCAT, PMTR, PRCT, M0) M = M0 MM = M0 IF (LDBG .GE. 1) THEN WRITE(OUTPUT,'(A,I7,A,I3)') & 'Initial number of objects = ', & M0, ' Number of iterations = ', IARR(2) CALL STTPUT(OUTPUT, ISTAT) ENDIF C C *** Copy input table data into scratch file. C C CALL PARCPY(ITF, ISF, START, STEP, NICOL, M0, C & ITSTRT, ICOL) C LW = M0 C C *** External loop is repeated IARR(2)+1 times. C *** Number of current iteration is kept in NCNT. C NCNT = 0 10 CONTINUE C WRITE (OUTPUT, '(A,I3)') 'Starts iteration', NCNT CALL STTPUT(OUTPUT, ISTAT) NCNT = NCNT + 1 M = MM L = 0 C C *** Calculate average separation between objects. C IAVDIS = (ITOB(3)-ITOB(1)+1) * (ITOB(4)-ITOB(2)+1) IAVDIS = INT(SQRT(FLOAT(IAVDIS / M))) C C *** Start inner loop. 20 CONTINUE C L = L + 1 LM = M / 5 IF (MOD(L, LM) .EQ. 0) THEN WRITE (OUTPUT,'(I5,A)') L,' objects processed' CALL STTPUT(OUTPUT, ISTAT) ENDIF C C *** Check if object is in catalog buffer, C *** and swap buffer if necessary. C C IF (L .GT. L1 .OR. L .LE. L0) THEN C CALL PARFIL(ISF, L0, L1, LW, L,LSTP, NREG, NCAT, C & PMTR, PRCT, NP) C ENDIF C C *** Actual pixel position is designed I,J. C *** Object number in buffer arrays is LZ. C LZ = L - L0 I = NCAT(1,LZ) J = NCAT(2,LZ) C C *** Fill image buffers if necessary. C C IUSD(1) = MAX(I-IHED, IXYU(1)) C IUSD(2) = MAX(J-IHED, IXYU(2)) C IUSD(3) = MIN(I+IHED, IXYU(3)) C IUSD(4) = MIN(J+IHED, IXYU(4)) C IF (IUSD(1).LT.IBUF(1) .OR. IUSD(2).LT.IBUF(2) .OR. C 2 IUSD(3).GT.IBUF(3) .OR. IUSD(4).GT.IBUF(4)) THEN C IF (L.EQ.1) THEN IUSD(1) = IBUF(1) IUSD(2) = IBUF(2) IUSD(3) = IBUF(3) IUSD(4) = IBUF(4) CALL FILBUF(IMF, A, JAPY,NX,IXYU,IUSD,IBUF) ENDIF C C *** Check if object is in investigated area. C IF (I .LT. ITOB(1) .OR. J .LT. ITOB(2) .OR. I .GT. & ITOB(3) .OR. J .GT. ITOB(4)) THEN PMTR(2,L) = 0.0 GOTO 21 ENDIF C IF (LDBG .GE. 2) THEN OUTPUT = ' ' CALL STTPUT(OUTPUT, ISTAT) WRITE(OUTPUT,'(A,I5,A,I5,A,I5)') 'Next object: ID =', 2 L,' I =', I, ' J =', J CALL STTPUT(OUTPUT, ISTAT) ENDIF C C *** Calculate local background if needed. C IF (ICOL(3) .EQ. 0 .AND. NCNT .EQ. 1) THEN CALL SKYMOD(A, JAPY, IBUF, I, J, RARR(39), & IHED, 0, PMTR(1,LZ)) ENDIF C C *** Find distance to nearest other object. C CALL NRDIST(L, L0, L1, IAVDIS, NREG, LSTP, & NCAT, PMTR, PRCT) C C **** Calculate and analyze profile in 8 octants. Results C *** are returned in arrays NCAT, PRCT, PMTR and MCM. C *** NCAT contain integer parameters, PRCT one-dimensional C *** profile, PMTR floating point parameters and MCM C *** contain informations about newly found objects. C CALL PRANLZ(A, JAPY, NX, ITOB, IXYU , & IBUF, L0, L1, LW, L , & M, M0, MM, LSTP, NREG , & IARR, RARR, APSF, FPSF, IPSF , & NCNT, NCAT, PMTR, PRCT , & IAVDIS, MCM) C C *** Check if object is in the frame. C LZ = L - L0 IF (.NOT.(IVRF .EQ. 0 .AND. L .LE. M0)) THEN I = NINT(PMTR(10,LZ)) J = NINT(PMTR(11,LZ)) NCAT(1,LZ) = I NCAT(2,LZ) = J IF ((NCNT.GT.IARR(2)) .AND. 2 (I.LT.IARR(12) .OR. I.GT.IARR(14) .OR. & J.LT.IARR(13) .OR. J .GT. IARR(15))) THEN PMTR(2,LZ) = 0.0 ENDIF IF ((NCNT.LE.IARR(2)) .AND. 2 (I.LT.ITOB(1) .OR. I.GT.ITOB(3) .OR. & J.LT.ITOB(2) .OR. J.GT.ITOB(4))) THEN PMTR(2,LZ) = 0.0 ENDIF ENDIF C C *** Eliminate fainter components of close blends. C IF (IVRF .EQ. 1 .OR. L .GT. M0) THEN LACT = 0 51 CONTINUE CALL GETLST(L, L0, L1, IDLM, NREG , & LSTP, NCAT, PMTR, PRCT, LACT , & NCT, PMT, PRC, DONE) IF (DONE .AND. LACT .LT. L) THEN C C *** Fetch new component central intensity C *** LL2 and positions XCMP and YCMP. C LLZ = LACT - L0 LL2 = PMTR(2,LLZ) XCMP = PMTR(10,LLZ) YCMP = PMTR(11,LLZ) C C *** Final check on component distance. C XOBJ = PMTR(10,LZ) YOBJ = PMTR(11,LZ) DIST = SQRT((XOBJ-XCMP)**2.0 + & (YOBJ-YCMP)**2.0) C C *** Look for another component C *** if that is not close enough. C IF (DIST .GE. ADLM) GOTO 51 C C *** Do not contest objects that C *** are not to be veryfied. C IF (IVRF .EQ. 0 .AND. LACT .LE. M0) THEN C C *** The object with higher number is rejected. C PMTR(2,LZ) = 0.0 GOTO 50 ENDIF C C *** Check which of two objects is brighter. C IF (PMTR(2,LZ) .LE. LL2) THEN PMTR(2,LZ) = 0.0 ELSE PMTR(2,LLZ) = 0.0 ENDIF GOTO 51 ELSE IF (DONE) GOTO 51 ENDIF 50 CONTINUE ENDIF C C *** Calculate additional classifiers. C CALL APPMTR(PRCT(0,LZ), NCAT(5,LZ), IARR(5) , & RARR, APSF, PMTR(1,LZ)) C 21 CONTINUE IF (L .LT. MM) GOTO 20 C IF (LDBG .GT. 0) THEN OUTPUT = ' ' CALL STTPUT(OUTPUT, ISTAT) WRITE (OUTPUT,'(A)') 'PROFILES ANALYSED' CALL STTPUT(OUTPUT, ISTAT) WRITE (OUTPUT,'(A)') '-----------------' CALL STTPUT(OUTPUT, ISTAT) ENDIF C C *** Improve one dimensional point spread function C *** and calculate relative gradients. C L0 = 0 L1 = MM LW = MM CALL PNTSPF(IMF, L0, L1, LW, NREG , & LSTP, FPSF, NCAT, PMTR, PRCT , & IARR, RARR, ABGRD) C C *** Initialize two-dimensional psf. C IF (IARR(2).GT.0 .AND. NCNT.EQ.1 .AND. 2 (LPXL.GT.0 .OR. LSBP.GT.0)) THEN NPRF = NOSP + (2*LSBP+1)**2 CALL DEFPSF(RARR, FPSF, NPRF, IPSF, LPXL, LSBP) ENDIF C C *** Modify two-dimensional point spread function. C IF (NCNT.GT.1 .AND. (LPXL.GT.0 .OR. LSBP.GT.0)) THEN NPRF = NOSP + (2*LSBP+1)**2 CALL MODPSF(RARR, FPSF, NPRF, IPSF, LPXL, LSBP) ENDIF C C *** Calculate stellar magnitudes by convolving C *** one dimensional observed profiles with the C *** one dimensional point spread function. C ICT = NCNT - IARR(2) CALL PRFCNV(L0, L1, LW, NREG, LSTP , & NCAT, PMTR, PRCT, IARR, RARR , & ICT, ABGRD) C C *** Update scratch file. C C IF (L1 .GT. LW) THEN C NPP = L1 - L0 C CALL PARFIL(ISF, L0, L1, LW, L, LSTP, C & NREG, NCAT, PMTR, PRCT, NPP) C ENDIF C C *** Remove objects which are too faint. C CALL RENMBR(L0, L1, LW, NREG, LSTP , & NCAT, PMTR, PRCT, IVRF, TRSH , & M0, MM, M) MM = M WRITE (OUTPUT, '(A,I5)') 'Actual number of objects = ',M CALL STTPUT(OUTPUT, ISTAT) C C *** End of external loop. C IF (NCNT .LE. IARR(2)) GOTO 10 C C *** Write two dimensional psf into descriptor UPROFILE. C IF (TWOD .AND. IARR(2) .GT. 0 .AND. NCNT .GT. IARR(2)) THEN IF (OUTPSF .NE. 'NONE') THEN NTMP = (2*LPXL+1)*(2*LSBP+1) LL = NTMP / 2 NVAL = NTMP*NTMP NAXISP = 2 NPIXP(1) = NTMP NPIXP(2) = NTMP STARTP(1) = 1.0 STARTP(2) = 1.0 STEPP(1) = 1.0 STEPP(2) = 1.0 MAXS = 1 CALL STDRDC(IMF, 'IDENT', 72, 1, 1 , & NACT, IDENT, KUN, KNUL, ISTAT) CALL STDRDC(IMF, 'CUNIT', 48, 1, 1 , & NACT, CUNIT, KUN, KNUL, ISTAT) CALL STIPUT(OUTPSF, D_R4_FORMAT, F_IO_MODE , & F_IMA_TYPE, NAXISP, NPIXP, STARTP , & STEPP, IDENT, CUNIT, NPNTRP, IPF , & ISTAT) IADR = 4 * NVAL + 1 CALL FDTOTD(FPSF(1), FPSF(IADR), LPXL, LSBP, LL) CALL COPYF(FPSF(IADR),MADRID(NPNTRP),NVAL) FTMP(1) = -0.1 FTMP(2) = 1.1 CALL STDWRR(IPF, 'LHCUTS', FTMP, 1, 2, KUN, ISTAT) CALL STFCLO(IPF,ISTAT) ENDIF ENDIF C C *** Display some informations. C IF (LDBG .GE. 1) THEN WRITE(OUTPUT,'(A)') 2 'Logarithmic differential point spread function' CALL STTPUT(OUTPUT, ISTAT) WRITE (OUTPUT,'(8F10.3)') (RARR(L),L=14,21) CALL STTPUT(OUTPUT, ISTAT) WRITE (OUTPUT,'(8F10.3)') (RARR(L),L=22,29) CALL STTPUT(OUTPUT, ISTAT) WRITE (OUTPUT,'(8F10.3)') (RARR(L),L=30,37) CALL STTPUT(OUTPUT, ISTAT) ENDIF C IF (LDBG .GE. 2) THEN DO 30 L = 1, M I = NCAT(1,L) J = NCAT(2,L) IF (I .LT. ITOB(1) .OR. J .LT. ITOB(2) .OR. I .GT. & ITOB(3) .OR. J .GT. ITOB(4)) GOTO 30 OUTPUT = ' ' CALL STTPUT(OUTPUT, ISTAT) WRITE (OUTPUT,'(A)') ' ID X Y'// & ' CLOSEST_N UNBLENDED OBJ_SIZE SATURATED' CALL STTPUT(OUTPUT, ISTAT) WRITE(OUTPUT,'(7I11)') L, (NCAT(LI,L),LI=1,6) CALL STTPUT(OUTPUT, ISTAT) IF (LDBG.EQ.2) THEN WRITE (OUTPUT,'(A)') ' BACKGRND CENTRAL_9 '// & 'REL_GRAD ISOPHOT_MAG CNV_MAG ISOPHOT_RAD'// & ' CLASS' CALL STTPUT(OUTPUT, ISTAT) WRITE(OUTPUT,'(1X,7G11.3)') PMTR(1,L), PMTR(2,L), & PMTR(3,L), PMTR(5,L), PMTR(12,L), & PMTR(15,L), PMTR(21,L) CALL STTPUT(OUTPUT, ISTAT) ENDIF IF (LDBG .GT. 2) THEN WRITE (OUTPUT,'(A)') 'Output parameters' CALL STTPUT(OUTPUT, ISTAT) WRITE(OUTPUT,'(1X,7G11.3)') PMTR(10,L),PMTR(11,L), & PMTR(12,L),PMTR(13,L),PMTR(20,L),PMTR(3,L), & PMTR(4,L) CALL STTPUT(OUTPUT, ISTAT) WRITE(OUTPUT,'(1X,7G11.3)') PMTR(1,L),PMTR(2,L), & PMTR(6,L),PMTR(7,L),PMTR(8,L),PMTR(9,L),PMTR(15,L) CALL STTPUT(OUTPUT, ISTAT) WRITE(OUTPUT,'(1X,6G11.3)') PMTR(16,L),PMTR(17,L), & PMTR(18,L),PMTR(19,L),PMTR(5,L),PMTR(21,L) CALL STTPUT(OUTPUT, ISTAT) WRITE(OUTPUT,*) 'Pixel spaced average profile' CALL STTPUT(OUTPUT, ISTAT) WRITE(OUTPUT,'(1X,7G11.3,2X)') (PRCT(K,L),K=0,6) CALL STTPUT(OUTPUT, ISTAT) WRITE(OUTPUT,'(1X,7G11.3,2X)') (PRCT(K,L),K=7,13) CALL STTPUT(OUTPUT, ISTAT) WRITE(OUTPUT,'(1X,7G11.3,2X)') (PRCT(K,L),K=14,20) CALL STTPUT(OUTPUT, ISTAT) ENDIF 30 CONTINUE ENDIF C C *** Create or update descriptor DPROFILE in an input image C *** frame containing the used point spread function. C CALL STDFND(IMF, 'DPROFILE', TYPE, NEL, NBYTE, ISTAT) IF (TYPE .EQ. 'R' .AND. NEL .GT. 0) THEN IF (IARR(11) .NE. 0) THEN CALL STDWRR(IMF, 'DPROFILE', RARR(14), 1, & ABS(IARR(11)), KUN, ISTAT) ENDIF ELSE CALL STDWRR(IMF, 'DPROFILE', RARR(14), 1, 25, KUN, ISTAT) ENDIF C C *** Quit if output table is not to be written. C IF (IARR(3) .NE. 1) RETURN C C*** Initialize and open output table file. C CALL STKRDC('OUT_A', 1, 1, 60, IACT, OUTABL, KUN, KNUL, ISTAT) IF (IARR(6) .GT. 0) THEN NCOL = 27 + MIN(IARR(6), MAXSUB) ELSE NCOL = 26 ENDIF CALL TBTINI(OUTABL, 0, F_O_MODE, NCOL, NROW, IOF, ISTAT) CALL STDRDD(IMF, 'START', 1, 2, IACT, START, KUN, KNUL, ISTAT) CALL STDRDD(IMF, 'STEP', 1, 2, IACT, STEP, KUN, KNUL, ISTAT) CALL CTABLE(IOF, NCOL, MM, START, STEP, NCAT, PMTR, PRCT, NP) CALL STDWRD(IOF, 'START', START, 1, 2, KUN, ISTAT) CALL STDWRD(IOF, 'STEP', STEP, 1, 2, KUN, ISTAT) C C *** Write descriptors into output table. C DO 75 K = 1, 25 STPR(K) = RARR(13+K) 75 CONTINUE DO 76 K = 26, MAXSUB STPR(K) = RARR(38) 76 CONTINUE CALL STDWRR(IOF, 'DPROFILE', STPR, 1, MAXSUB, KUN, ISTAT) C C ****** Close output table. C CALL TBSINI(IOF, ISTAT) CALL TBTCLO(IOF, ISTAT) C C C DO L=1,M C PMTR(12,L)=AMGN(L)+ZRMG C ICLS(2,L)=INT(PMTR(21,L)) C END DO C C*********************************************************************** C C ***** Two options to choose ***** C C CALL RD_DESCR_R(8,'FLAT_SKY',ABGR,ISTAT) C C CALL GETDSCR_ST(FRAMEA,'FLAT_SKY','REAL',1,8,ABGR,IACT,ISTAT) C C ABGR=1.0 ! If none of options is valid C C*********************************************************************** C C C displays on terminal screen and writes into log file most important C informations C C WRITE(OUTPUT,'(1X,A)') FRAMEA C CALL STTPUT(OUTPUT, ISTAT) C WRITE(OUTPUT,'(1X,A,2F8.2)') 'Low and high cuts = ',RARR(1), C + RARR(2) C CALL STTPUT(OUTPUT, ISTAT) C WRITE(OUTPUT,'(1X,A,I3)') 'Subarray half-edge = ',IHED C CALL STTPUT(OUTPUT, ISTAT) C WRITE(OUTPUT,'(1X,A,F5.3)') 'Limiting threshold = ',TRSH C CALL STTPUT(OUTPUT, ISTAT) C WRITE(OUTPUT,'(1X,A,F7.3)') 'Zero magnitude = ',RARR(11) C CALL STTPUT(OUTPUT, ISTAT) C WRITE(OUTPUT,'(1X,A,2F8.3)')'Aperture sizes in pixels',RARR(12), C + RARR(54) C CALL STTPUT(OUTPUT, ISTAT) C C outputs a list of objects with relevant parameters C C IF (LDBG.GE.1) THEN C DO L=1,M C WRITE (OUTPUT,'(/A)') ' ID X Y'// C + ' CLOSEST_N UNBLENDED OBJ_SIZE SATURATED' C CALL STTPUT(OUTPUT, ISTAT) C WRITE (OUTPUT,'(7I11)') L,(NCAT(LI,L),LI=1,6) C CALL STTPUT(OUTPUT, ISTAT) C IF (LDBG.EQ.2) THEN C WRITE (OUTPUT,'(A)') ' BACKGRND CENTRAL_9 R_GRADIENT'// C + ' ISOPHOT_MAG CNV_MAG ISOPHOT_RAD CLASS' C CALL STTPUT(OUTPUT, ISTAT) C WRITE (OUTPUT,'(1X,7F11.3)') PMTR(1,L),PMTR(2,L), C + PMTR(3,L),PMTR(5,L),PMTR(12,L),PMTR(15,L),PMTR(21,L) C CALL STTPUT(OUTPUT, ISTAT) C END IF C IF (LOUT.GT.2) THEN C WRITE (OUTPUT,'(A)') 'Output parameters' C CALL STTPUT(OUTPUT, ISTAT) C WRITE (OUTPUT,'(1X,8F7.3,3F7.1)') (PMTR(K,L),K=1,11) C CALL STTPUT(OUTPUT, ISTAT) C WRITE (OUTPUT,'(1X,9F7.3,F7.0,F7.1)') (PMTR(K,L),K=12,22) C CALL STTPUT(OUTPUT, ISTAT) C WRITE (OUTPUT,'(A)') 'Pixel spaced average profile' C CALL STTPUT(OUTPUT, ISTAT) C WRITE (OUTPUT,'(10F8.3)') (PRCT(K,L),K=0,19) C CALL STTPUT(OUTPUT, ISTAT) C END IF C END DO C END IF C C **** Writes output table file. C C IF (LTAB.EQ.1) THEN C C **** Reads needed informations from image C C*********************************************************************** C C ***** Two options to choose !!! ***** C C In case of temporary image format C C CALL RD_DESCR_C(8,'IDENT',IDENT,ISTAT) C CALL RD_DESCR_R(8,'STARTX',START(1),ISTAT) C CALL RD_DESCR_R(8,'STARTY',START(2),ISTAT) C CALL RD_DESCR_R(8,'STEPX',STEP(1),ISTAT) C CALL RD_DESCR_R(8,'STEPY',STEP(2),ISTAT) C C In case of Midas image format C C CALL GETDSCR_ST(FRAMEA,'IDENT','CHARACTER',1,72,IACT,IDENT,IS) C CALL GETDSCR_ST(FRAMEA,'START','REAL',1,2,IACT,START,ISTAT) C CALL GETDSCR_ST(FRAMEA,'STEP','REAL',1,2,IACT,STEP,ISTAT) C C*********************************************************************** C C ***** Two options to choose ***** C C In case of temporary table format C C OPEN (11,FILE=TABLE,STATUS='new') C ICOL=22+IPRF C CALL CRTAB(11,IDENT,START,STEP,PMTR,PRCT,ICOL,M,IDP) C write (OUTPUT,*) idp C CALL STTPUT(OUTPUT, ISTAT) C CALL WRDESR(11,IDP,'FLAT_SKY',1,ABGR,ISTAT) C CALL WRDESR(11,IDP,'TRESHOLD',1,TRSH,ISTAT) C CALL WRDESI(11,IDP,'HALFEDGE',1,IHED,ISTAT) C CALL WRDESR(11,IDP,'STMETRIC',2,STMT,ISTAT) C CALL WRDESR(11,IDP,'SPROFILE',25,STPR,ISTAT) C IF (MGCR2.EQ.1) THEN C CALL WRDESR(11,IDP,'EXPRTIME',1,TINT,ISTAT) C END IF C CLOSE(11) C C In case of Midas table format C C CALL CTABLE(TABLE,NCAT,PMTR,PRCT,ICLS,M,START,STEP,IPRF) C I1=INDEX(TABLE//' ',' ')-1 C TABLET=TABLE(1:I1)//'.TBL' C CALL PUTDSCR_ST(TABLET,'NORFRAME','CHARACTER',FRAMEA,1,8, C + ISTAT) C CALL PUTDSCR_ST(TABLET,'FLAT_SKY','REAL',ABGR,1,1,ISTAT) C CALL PUTDSCR_ST(TABLET,'TRESHOLD','REAL',TRSH,1,1,ISTAT) C CALL PUTDSCR_ST(TABLET,'HALFEDGE','INTEGER',IHED,1,1,ISTAT) C CALL PUTDSCR_ST(TABLET,'ZEROMAGN','REAL',ZRMG,1,1,ISTAT) C CALL PUTDSCR_ST(TABLET,'STMETRIC','REAL',STMT,1,2,ISTAT) C CALL PUTDSCR_ST(TABLET,'SPROFILE','REAL',STPR,1,25,ISTAT) C IF (MGCR2.EQ.1) THEN C CALL PUTDSCR_ST(TABLET,'EXPRTIME','REAL',TINT,1,1,ISTAT) C END IF C C*********************************************************************** C C END IF C C writes "LHCUTS" descriptor into an output image frame, adjusted C for inspecting image on DeAnza monitor with lookup table "RAINBOW". C C CUTS(1)=0.7 C CUTS(2)=3.0 C C CALL PUTDSCR_ST(FRAMEA,'LHCUTS','REAL',CUTS,1,2,ISTAT) C RETURN END