C C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C***************************** C** LFN_LIST_PROFS ** C***************************** C CD-Routine: Write Spot Profiles - LFN_LIST_PROFS C This routine is used to write a spot profile or set of spot profiles C calculated by a profile determining pass of the routine LFN_SAINT. CD-end CD-Fortran: SUBROUTINE LFN_LIST_PROFS (IUN, ITERM, IPROF, NPL, MAXLIN, + NSEP, NBLANK, IERR, ERRSTR) CD-end INCLUDE 'implicit_none.finc' C C PURPOSE: Write out profiles calculated by LFN_SAINT C C AUTHOR: J.W. Campbell C C ARGUMENTS: C INTEGER IUN INTEGER ITERM INTEGER IPROF INTEGER NPL INTEGER MAXLIN INTEGER NSEP INTEGER NBLANK INTEGER IERR CHARACTER*(*) ERRSTR CD-Parameters: C IUN i (R) Unit number for listing (0=no printing) C ITERM i (R) =1 output to a terminal, =0 output to a file C IPROF i (R) Bin no. of profile to be listed, 0=all C NPL i (R) No. of profiles to o/p per line (if 0 then will C be calculated from MAXLIN). Will be reduced to C that calculated from MAXLIN if it exceeds that. C (Only relevant if IPROF=0) C MAXLIN i (R) Maximum length for o/p line (up to 132) (note if C the width of a single profile exceeds this then the C line length will also exceed this). C (Only relevant if IPROF=0) C NSEP i (R) No. of separating spaces between profile o/p on C same line (>=1) (Only relevant if IPROF=0) C NBLANK i (R) No. of blank lines between rows of profiles (>=1) C (Only relevant if IPROF=0) C IERR i (W) Error flag =0 OK C =1 Requested profile bin out of range C ERRSTR c (W) Error message string (max 80 chars) set if IERR is C non-zero CD-end C C====== Parameter statements C INCLUDE 'saint_limits.finc' C C====== GLOBALS: C INCLUDE 'lfn_saint.finc' C C====== FUNCTION TYPES: C INTEGER LENSTR C C====== LOCALS: C INTEGER I INTEGER IX INTEGER IY INTEGER IWID INTEGER ISEP INTEGER MXLEN INTEGER NBL INTEGER NPROFS INTEGER NPOSS INTEGER NPERLIN INTEGER NROWS INTEGER IROW INTEGER ICOL INTEGER IPROF_MIN INTEGER IPROF_MAX INTEGER KPROF INTEGER K INTEGER IS INTEGER II INTEGER INUM REAL ANG REAL PFMAX REAL SC_PROF(MAX_PRBIN) CHARACTER*(MAX_PRLIN) LIN CHARACTER*(MAX_PRLIN) STR CHARACTER*1 NUMCH(16) C INTEGER I !Temp/loop variable C INTEGER IX !Loop over 'x' pixels (offsets) C INTEGER IY !Loop over 'y' pixels (offsets) C INTEGER IWID !Width required for o/p of profile C INTEGER ISEP !Separation between profiles on same line C INTEGER MXLEN !Maximum requested line length (max 132) C INTEGER NBL !No. of blank lines between rows of profiles C INTEGER NPROFS !No. of profiles to o/p C INTEGER NPOSS !No. of profiles possible on one line C INTEGER NPERLIN !No. (actual) to o/p per line C INTEGER NROWS !No. of rows of profiles C INTEGER IROW !Loop through rows of profiles C INTEGER ICOL !Loop through columns of profiles C INTEGER IPROF_MIN !Minimum profile no. to o/p C INTEGER IPROF_MAX !Maximum profile no. to o/p C INTEGER KPROF !Current profile number C INTEGER K !Character position in STR C INTEGER IS !Position in o/p line C INTEGER II !Index to profile arrays C INTEGER INUM !Profile value scaled to range 0-15 C REAL ANG !Angle at start/end of profile bin C REAL PFMAX !Maximum value in current profiles C REAL SC_PROF(MAX_PRBIN) !Scale factors to scale profiles in range 0-15 C CHARACTER*(MAX_PRLIN) LIN !Output line C CHARACTER*(MAX_PRLIN) STR !Entry to add to output line C CHARACTER*1 NUMCH(16) !Character equivalents of numbers 0-15 DATA NUMCH/'0','1','2','3','4','5','6','7','8','9', + 'A','B','C','D','E','F'/ C C------------------------------------------------------------------------------- C IERR = 0 ERRSTR = ' ' IF (IUN.LE.0) RETURN IF (IPROF.LT.0.OR.IPROF.GT.NPROF_BIN) THEN IERR = 1 ERRSTR = 'Profile was not calculated for bin' CALL STR_ADDI (ERRSTR, IPROF, 1) RETURN END IF ISEP = NSEP IF (ISEP.LT.1) ISEP = 1 C C====== Get width required for a profile C IWID = 2*NPR_HALF + 1 IF (IWID.LT.13) IWID = 13 MXLEN = MAXLIN IF (MXLEN.GT.132) MXLEN = 132 NPOSS = (MXLEN+ISEP)/(IWID+ISEP) IF (NPOSS.LT.1) NPOSS = 1 NPERLIN = NPOSS IF (NPL.GT.0.AND.NPL.LT.NPOSS) NPERLIN = NPL NPROFS = 1 IF (IPROF.EQ.0) NPROFS = NPROF_BIN NROWS = (NPROFS-1)/NPERLIN + 1 IPROF_MIN = IPROF IPROF_MAX = IPROF IF (IPROF.EQ.0) THEN IPROF_MIN = 1 IPROF_MAX = NPROF_BIN END IF NBL = NBLANK IF (NBL.LT.1) NBL = 1 C C====== Get factors to scale profiles to 15.0 C DO 20 KPROF = IPROF_MIN, IPROF_MAX PFMAX = 0.0 SC_PROF(KPROF) = 1.0 DO 10 I = 1, NUM_IN_PROF IF (PROF(I,KPROF).GT.PFMAX) PFMAX = PROF(I,KPROF) 10 CONTINUE IF (PFMAX.GT.0.0) SC_PROF(KPROF) = 15.0/PFMAX 20 CONTINUE C C====== Loop through no. of rows of profiles C====== ------------------------------------ C DO 200 IROW = 1, NROWS IF (IROW.GT.1) THEN DO 30 I = 1, NBL IF (ITERM.EQ.1) THEN CALL TTSEND (IUN,' ',1) ELSE WRITE(IUN,1001) END IF 30 CONTINUE END IF C C====== Header line C LIN = ' ' DO 100 ICOL = 1, NPERLIN KPROF = IPROF_MIN + (IROW-1)*NPERLIN + ICOL - 1 IF (KPROF.GT.IPROF_MAX) GO TO 100 STR = 'Profile' CALL STR_ADDI (STR, KPROF, 1) IS = (ICOL-1)*(IWID+ISEP) + 1 LIN(IS:) = STR 100 CONTINUE IF (ITERM.EQ.1) THEN CALL TTSEND (IUN,LIN(1:LENSTR(LIN)),1) ELSE WRITE(IUN,1000) LIN(1:LENSTR(LIN)) END IF C C====== Angle ranges line C DO 110 ICOL = 1, NPERLIN KPROF = IPROF_MIN + (IROW-1)*NPERLIN + ICOL - 1 IF (KPROF.GT.IPROF_MAX) GO TO 110 STR = '(' ANG = (KPROF-1)*360.0/FLOAT(NPROF_BIN) CALL STR_ADDF (STR, ANG, 1, 0) CALL STR_ADDS (STR, '-', 0) ANG = KPROF*360.0/FLOAT(NPROF_BIN) CALL STR_ADDF (STR, ANG, 1, 0) CALL STR_ADDS (STR, ')', 0) IS = (ICOL-1)*(IWID+ISEP) + 1 LIN(IS:) = STR 110 CONTINUE IF (ITERM.EQ.1) THEN CALL TTSEND (IUN,LIN(1:LENSTR(LIN)),1) ELSE WRITE(IUN,1000) LIN(1:LENSTR(LIN)) END IF C C====== Profile data lines C DO 150 IY = NPR_HALF, -NPR_HALF, -1 DO 140 ICOL = 1, NPERLIN KPROF = IPROF_MIN + (IROW-1)*NPERLIN + ICOL - 1 IF (KPROF.GT.IPROF_MAX) GO TO 140 STR = ' ' DO 130 IX = -NPR_HALF, NPR_HALF K = IX + NPR_HALF + 1 STR(K:K) = '.' IF (INDXPR(IX,IY).GT.0) THEN II = INDXPR(IX,IY) IF (SHAPE_PROF(II).LT.0) THEN STR(K:K) = '*' ELSE INUM = NINT (SC_PROF(KPROF)*PROF(II,KPROF)) IF (INUM.LT.0) INUM = 0 IF (INUM.GT.15) INUM = 15 STR(K:K) = NUMCH(INUM+1) END IF END IF 130 CONTINUE IS = (ICOL-1)*(IWID+ISEP) + 1 LIN(IS:) = STR 140 CONTINUE IF (ITERM.EQ.1) THEN CALL TTSEND (IUN,LIN(1:LENSTR(LIN)),1) ELSE WRITE(IUN,1000) LIN(1:LENSTR(LIN)) END IF 150 CONTINUE 200 CONTINUE RETURN C C====== Format statements C 1000 FORMAT(A) 1001 FORMAT(' ') END