SUBROUTINE ZRIPPL * * Module number: 13.12 * * Module name: zrippl * * Keyphrase: * ---------- * Echelle Blaze * * Description: * ------------ * This routine computes the echelle ripple correction coefficients * a and b from the theoritical ripple function computed using * the grating constants. * A non-linear least squares fit is performed to the equation * c * sinc( aX + b) * where X is computed from the grating coefficients. * The fit computes values for a,b and c. c is only a normalization * parameter and is not retained. * The Numerical Recipe routine MRQMIN is used to perform the least * squares fit. * * FORTRAN name: zrippl.for * * Keywords of accessed files and tables: * -------------------------------------- * Name I/O Description / Comments * input1 I Input table containing columns * wavelength * order - spectral orders * carpos - carrousel position * ratio - unfit ripple value * input2 I table containing HRS echelle ripple * non-interpolation constants (CZCCRAR). * output1 O table containing HRS echelle ripple * interpolation constatns(CZCCR9R) * output2 O copy of input table, INPUT, with an * additional column, fit, containing * the fitted values * carpos1 I first carrousel position for which * calibration is applicable * carpos2 I last carrousel position * m1 I first order number for which the * calibration is applicable for. * m2 I last order number * niter I Number of iterations for non-linear * fit routine. * a,b I initial guess for fit routine * aout,bout O results of fit routine * * Subroutines Called: * ------------------- * CDBS: * * SDAS: * uclgs*,uttopn,utcfnd,utcgt*,uthgtt,utrgt* * uttcre,uttclo,utcpt*,umsput * * Others: * zfsinc, zrip1, zrip2 * * * History: * -------- * Version Date Author Description * 1 Sept 87 D. Lindler Designed and Coded * 1.1 Jan 92 S. Hulbert New grating values *------------------------------------------------------------------------------- C INCLUDE FILE FOR THE IRAF77 FORTRAN INTERFACE TO THE IRAF VOS C C C FILE I/O ACCESS MODES C INTEGER RDONLY PARAMETER (RDONLY = 1) INTEGER RDWRIT PARAMETER (RDWRIT = 2) INTEGER WRONLY PARAMETER (WRONLY = 3) INTEGER APPEND PARAMETER (APPEND = 4) C C CODES FOR DATA TYPES C INTEGER TYBOOL PARAMETER (TYBOOL = 1) INTEGER TYCHAR PARAMETER (TYCHAR = 2) INTEGER TYINT PARAMETER (TYINT = 4) INTEGER TYREAL PARAMETER (TYREAL = 6) INTEGER TYDOUB PARAMETER (TYDOUB = 7) C C UMSPUT DESTINATIONS -- CB, DAO, 4-SEP-87 C INTEGER STDOUT PARAMETER (STDOUT = 1) INTEGER STDERR PARAMETER (STDERR = 2) C C UHDAS HEADER PARM TYPES -- CB, DAO, 5-SEP-87 C INTEGER GENHDR PARAMETER (GENHDR = 0) INTEGER IMSPEC PARAMETER (IMSPEC = 1) C C THIS SECTION IS FOR PARAMETERS RELEVANT TO TABLE I/O. C C THESE MAY BE SET BY UTPPTI AND/OR READ BY UTPGTI: C C LENGTH OF ROW (UNIT = SIZE OF REAL) INTEGER TBRLEN PARAMETER (TBRLEN = 1) C INCREASE ROW LENGTH INTEGER TBIRLN PARAMETER (TBIRLN = 2) C NUMBER OF ROWS TO ALLOCATE INTEGER TBALLR PARAMETER (TBALLR = 3) C INCREASE ALLOC NUM OF ROWS INTEGER TBIALR PARAMETER (TBIALR = 4) C WHICH TYPE OF TABLE? (ROW OR COLUMN) INTEGER TBWTYP PARAMETER (TBWTYP = 5) C MAXIMUM NUMBER OF USER PARAMETERS INTEGER TBMXPR PARAMETER (TBMXPR = 6) C MAXIMUM NUMBER OF COLUMNS INTEGER TBMXCL PARAMETER (TBMXCL = 7) C TYPE = ROW-ORDERED TABLE INTEGER TBTYPR PARAMETER (TBTYPR = 11) C TYPE = COLUMN-ORDERED TABLE INTEGER TBTYPC PARAMETER (TBTYPC = 12) C C THESE MAY BE READ BY UTPGTI BUT MAY NOT BE SET: C C NUMBER OF ROWS WRITTEN TO INTEGER TBNROW PARAMETER (TBNROW = 21) C C END IRAF77.INC C C LOCAL VARIABLES C C INPUT/OUTPUT CL PARAMETERS C DOUBLE PRECISION BETA,DELTA INTEGER CARPS(2),M1,M2,NITER,R0 C C TABLE FILE NAMES AND DESCRIPTORS C CHARACTER*64 INPUT1,INPUT2,OUTPT1,OUTPT2 INTEGER IDIN,IDOUT C C VECTORS TO HOLD TABLE COLUMNS C DOUBLE PRECISION RATIO(1000),FIT(1000) INTEGER CARPOS(1000),ORDER(1000) LOGICAL NULLS(1000) C C COLUMN IDS AND NUMBER OF COLUMNS C INTEGER COLID1,COLID2,COLID3,COLID4,COLID5,N,NROWS C C VARIABLES NEEDED BY FIT ROUTINE C DOUBLE PRECISION X(1000),SIG(1000),A(3) C C OTHER LOCAL SCRATCH VARIABLES C INTEGER I,MINPOS,MAXPOS,IROW,J,K,NUMC C C ERROR PROCESSING PARAMETERS C INTEGER ISTAT,ISTATS(20) CHARACTER*130 CONTXT CHARACTER*5 GRAT,GMODE(1) C C----------------------------------------------------------------------------- C C READ INPUT PARAMETERS C CONTXT='Error reading CL parameter' CALL UCLGST('input1',INPUT1,ISTATS(1)) CALL UCLGST('input2',INPUT2,ISTATS(2)) CALL UCLGST('output1',OUTPT1,ISTATS(3)) CALL UCLGST('output2',OUTPT2,ISTATS(4)) CALL UCLGSI('m1',M1,ISTATS(5)) CALL UCLGSI('m2',M2,ISTATS(6)) CALL UCLGSI('carpos1',CARPS(1),ISTATS(7)) CALL UCLGSI('carpos2',CARPS(2),ISTATS(8)) CALL UCLGSI('niter',NITER,ISTATS(9)) CALL UCLGSD('a',A(1),ISTATS(10)) CALL UCLGSD('b',A(2),ISTATS(11)) DO 10 I=1,11 IF(ISTATS(I).GT.0) GO TO 999 10 CONTINUE C C READ INPUT TABLE C CONTXT='Error reading input1 table file' CALL UTTOPN(INPUT1,RDONLY,IDIN,ISTAT) IF(ISTAT.NE.0) GO TO 999 CALL UTPGTI(IDIN,TBNROW,N,ISTATS(1)) IF(N.GT.1000)N=1000 CALL UTCFND(IDIN,'ORDER',1,COLID1,ISTATS(2)) CALL UTCFND(IDIN,'CARPOS',1,COLID2,ISTATS(3)) CALL UTCFND(IDIN,'VALUE',1,COLID3,ISTATS(4)) CALL UTCGTI(IDIN,COLID1,1,N,ORDER,NULLS,ISTATS(5)) CALL UTCGTI(IDIN,COLID2,1,N,CARPOS,NULLS,ISTATS(6)) CALL UTCGTD(IDIN,COLID3,1,N,RATIO,NULLS,ISTATS(7)) DO 20 I=1,7 IF(ISTATS(I).NE.0) GO TO 999 20 CONTINUE C C GET GRATING MODE C CALL UTHGTT(IDIN,'grating',GRAT,ISTAT) IF(ISTAT.NE.0)THEN CONTXT='Error reading grating name from input table' GO TO 999 ENDIF C C READ VALUES OF GRATING CONSTANTS FROM SECOND INPUT TABLE C CONTXT='Error reading input2 table file' CALL UTTOPN(INPUT2,RDONLY,IDIN,ISTAT) IF(ISTAT.NE.0) GO TO 999 CALL UTPGTI(IDIN,TBNROW,NROWS,ISTAT) IF(ISTAT.NE.0) GO TO 999 C C FIND ENTRY WITH CORRECT GRATING MODE C CONTXT='Unable to read specified column from input2 table' CALL UTCFND(IDIN,'GRATING',1,COLID1,ISTAT) IF(ISTAT.NE.0) GO TO 999 DO 5 I=1,NROWS CALL UTRGTT(IDIN,COLID1,1,I,GMODE,NULLS,ISTAT) IF(ISTAT.NE.0) GO TO 999 IF(GMODE(1).EQ.GRAT)GO TO 7 5 CONTINUE C C IF WE MADE IT HERE WE DID NOT FIND CORRECT GRATING MODE C CONTXT='Input2 does not have row with grating mode for input1' GO TO 999 C C EXTRACT GRATING PARAMETERS C 7 CONTXT='Error reading input2 table' CALL UTCFND(IDIN,'BETA',1,COLID1,ISTATS(1)) CALL UTCFND(IDIN,'DELTA',1,COLID2,ISTATS(2)) CALL UTCFND(IDIN,'R0',1,COLID3,ISTATS(3)) CALL UTRGTD(IDIN,COLID1,1,I,BETA,NULLS,ISTATS(4)) CALL UTRGTD(IDIN,COLID2,1,I,DELTA,NULLS,ISTATS(5)) CALL UTRGTI(IDIN,COLID3,1,I,R0,NULLS,ISTATS(6)) DO 9 I=1,6 IF(ISTATS(I).NE.0) GO TO 999 9 CONTINUE C C ******* WE ARE NOW READY TO DO SOME REAL WORK ****** C C COMPUTE VALUES OF X C CALL ZRIP1(ORDER,CARPOS,RATIO,N,BETA,DELTA,R0,X) C C PERFORM FIT DO 50 I=1,N SIG(I)=1.0 50 CONTINUE CALL ZFSINC(X,RATIO,SIG,N,NITER,A,FIT,ISTAT) IF(ISTAT.NE.0) THEN CONTXT='unable to perform ripple fit' GO TO 999 ENDIF C C PRINT RESULTS OF FIT C CALL ZRIP2(ORDER,CARPOS,RATIO,FIT,N,A) C C WRITE COEFFICIENTS BACK TO CL PAR C CONTXT='Error writing to cl parameter aout or bout' CALL UCLPSD('aout',A(1),ISTAT) IF(ISTAT.NE.0) GO TO 999 CALL UCLPSD('bout',A(2),ISTAT) IF(ISTAT.NE.0) GO TO 999 C C DETERMINE RANGE OF ORDERS AND CARPOS THIS IS VALID FOR C IF(M1.EQ.0) CALL MINMAX(ORDER,N,M1,MINPOS,M2,MAXPOS) IF(CARPS(1).EQ.0) CALL MINMAX(CARPOS,N,CARPS(1),MINPOS, * CARPS(2),MAXPOS) NUMC=2 IF(CARPS(1).EQ.CARPS(2))NUMC=1 C C WRITE FIRST OUTPUT TABLE ----------------------------------------------- C CONTXT='Error creating table output1' CALL UTTINN(OUTPT1,IDOUT,ISTATS(1)) CALL UTPPTI(IDOUT,TBRLEN,10,ISTATS(2)) CALL UTPPTI(IDOUT,TBMXCL,5,ISTATS(3)) CALL UTPPTI(IDOUT,TBIRLN,2,ISTATS(4)) CALL UTPPTI(IDOUT,TBMXPR,10,ISTATS(5)) CALL UTTCRE(IDOUT,ISTATS(6)) C C CREATE COLUMNS C CALL UTCDEF(IDOUT,'GRATING',' ','A4',-3,1,COLID1,ISTATS(7)) CALL UTCDEF(IDOUT,'CARPOS',' ','I8',TYINT,1,COLID2,ISTATS(8)) CALL UTCDEF(IDOUT,'SPORDER',' ','I5',TYINT,1,COLID3,ISTATS(9)) CALL UTCDEF(IDOUT,'A',' ','F12.6',TYDOUB,1,COLID4,ISTATS(10)) CALL UTCDEF(IDOUT,'B',' ',' ',TYDOUB,1,COLID5,ISTATS(11)) DO 60 I=1,11 IF(ISTATS(I).NE.0) GO TO 999 60 CONTINUE C C WRITE ROWS FOR EACH ORDER AND CARROUSEL POSITION C CONTXT='Error writing to outout1 table' IROW=1 DO 100 I=1,NUMC DO 100 J=M1,M2 CALL UTRPTT(IDOUT,COLID1,1,IROW,GRAT,ISTATS(1)) CALL UTRPTI(IDOUT,COLID2,1,IROW,CARPS(I),ISTATS(2)) CALL UTRPTI(IDOUT,COLID3,1,IROW,J,ISTATS(3)) CALL UTRPTD(IDOUT,COLID4,1,IROW,A(1),ISTATS(4)) CALL UTRPTD(IDOUT,COLID5,1,IROW,A(2),ISTATS(5)) DO 90 K=1,5 IF(ISTATS(I).NE.0) GO TO 999 90 CONTINUE IROW=IROW+1 100 CONTINUE CALL UTTCLO(IDOUT,ISTAT) IF(ISTAT.NE.0) THEN CONTXT='Error closing output1 table' GO TO 999 ENDIF C C WRITE TABLE WITH FITTED RIPPLE PARAMETERS C CONTXT='Error writing output2 table' CALL UTTINN(OUTPT2,IDOUT,ISTATS(1)) CALL UTPPTI(IDOUT,TBRLEN,12,ISTATS(2)) CALL UTPPTI(IDOUT,TBMXCL,5,ISTATS(3)) C C CREATE COLUMNS C CALL UTCDEF(IDOUT,'CARPOS',' ','I7',TYINT,1,COLID1,ISTATS(4)) CALL UTCDEF(IDOUT,'ORDER',' ','I5',TYINT,1,COLID2,ISTATS(5)) CALL UTCDEF(IDOUT,'RATIO',' ',' ',TYDOUB,1,COLID3,ISTATS(6)) CALL UTCDEF(IDOUT,'FIT',' ',' ',TYDOUB,1,COLID4,ISTATS(7)) C C OPEN TABLE AND WRITE COLUMNS C CALL UTTCRE(IDOUT,ISTATS(8)) CALL UTCPTI(IDOUT,COLID1,1,N,CARPOS,ISTATS(8)) CALL UTCPTI(IDOUT,COLID2,1,N,ORDER,ISTATS(9)) CALL UTCPTD(IDOUT,COLID3,1,N,RATIO,ISTATS(10)) CALL UTCPTD(IDOUT,COLID4,1,N,FIT,ISTATS(11)) C C PLACE GRATING MODE IN PARAMETER BLOCK C CALL UTHADT(IDOUT,'grating',GRAT,ISTATS(12)) CALL UTTCLO(IDOUT,ISTATS(13)) DO 200 I=1,13 IF(ISTATS(I).NE.0) GO TO 999 200 CONTINUE C C DONE C GO TO 1000 999 CALL UMSPUT(CONTXT,STDOUT+STDERR,0,ISTAT) 1000 RETURN END