C @(#)fit_gen.for 10.5 (ESO-IPG) 2/9/96 12:10: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&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& SUBROUTINE GetIDN(TblNam,inum,iok) C C Reads the highest IDnumer in a table "TblNam" C iok=0 if ok C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& implicit none character*(*)TblNam integer iok,inum include 'MID_REL_INCL:fit_var.inc' integer TabID,ist,icol integer i,j,k1,k2,n,in,i1,i2,i3 logical inull,isel INTEGER MADRID(1) INCLUDE 'MID_INCLUDE:ST_DEF.INC' COMMON/VMR/MADRID INCLUDE 'MID_INCLUDE:ST_DAT.INC' i1=1 !doesn't stop on errors i2=0 i3=0 call STECNT('PUT',i1,i2,i3) call TBTOPN(TblNam,F_IO_MODE,TabID,ist) !open if (ist.ne.0) then iok=1 return end if call TBLSER(TabID,'ID',icol,ist) call TBCSRT(TabID,1,icol,1,ist) ! sort call TBIGET(TabID,I,J,K1,k2,n,ist) !n. of written rows do j=n,1,-1 call TBSGET(TabID,j,isel,ist) ! checks selection call TBERDI(TabID,j,icol,in,inull,ist) if (ist.ne.0) then iok=1 return end if if (.not.inull.and.isel) then inum=in CALL TBTCLO(TabID,ist) i1=0 !doesn't stop on errors i2=2 i3=1 call STECNT('PUT',i1,i2,i3) return end if end do CALL TBTCLO(TabID,ist) i1=0 !doesn't stop on errors i2=2 i3=1 call STECNT('PUT',i1,i2,i3) return end C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& SUBROUTINE SavRes(TblNam,iok) C C Saves the results on the output table "TblNam" C iok=0 if ok C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& character*(*)TblNam integer iok include 'MID_REL_INCL:fit_var.inc' integer j,i1,i2,i3,i,k1,k2,n integer TabID,ist integer icol(25) integer itot logical inull INTEGER MADRID(1) INCLUDE 'MID_INCLUDE:ST_DEF.INC' COMMON/VMR/MADRID INCLUDE 'MID_INCLUDE:ST_DAT.INC' C!!!!!!! C Creates/opens the table and reads the column numbers C!!!!!!! i1=1 !doesn't stop on errors i2=0 i3=0 call STECNT('PUT',i1,i2,i3) call TBTOPN(TblNam,F_IO_MODE,TabID,ist) !open if (ist.ne.0) then !not found, creates call TBTINI(TblNam,F_TRANS,F_O_MODE,21,1,TabID,ist) call TBCINI(TabID,D_C_FORMAT,14,'A14',' ','Element',icol(1),i) call TBCINI(TabID,D_R8_FORMAT,1,'F7.2',' ','LamCen',icol(2),i) call TBCINI(TabID,D_R8_FORMAT,1,'F7.2',' ','Dlam',icol(3),i) call TBCINI(TabID,D_R8_FORMAT,1,'F9.7',' ','Redshift',icol(22) 1 ,i) call TBCINI(TabID,D_R8_FORMAT,1,'F7.2',' ','ColDen',icol(4),i) call TBCINI(TabID,D_R8_FORMAT,1,'F7.2',' ','DCol',icol(5),i) call TBCINI(TabID,D_R8_FORMAT,1,'F7.2',' ','B',icol(6),i) call TBCINI(TabID,D_R8_FORMAT,1,'F7.2',' ','DB',icol(7),i) call TBCINI(TabID,D_R8_FORMAT,1,'F7.2',' ','BTur',icol(8),i) call TBCINI(TabID,D_R8_FORMAT,1,'F7.2',' ','DBtur',icol(9),i) call TBCINI(TabID,D_R8_FORMAT,1,'F7.0',' ','Temperature', 1 icol(23),i) call TBCINI(TabID,D_R8_FORMAT,1,'F8.2',' ','Eq_Width',icol(10), 1 i) call TBCINI(TabID,D_R8_FORMAT,1,'F7.2',' ','chi2',icol(11),i) call TBCINI(TabID,D_R8_FORMAT,1,'F7.2',' ','Prob', 1 icol(12) ,i) call TBCINI(TabID,D_R8_FORMAT,1,'F7.2',' ','Dlam_p',icol(13),i) call TBCINI(TabID,D_R8_FORMAT,1,'F7.2',' ','Dlam_n',icol(14),i) call TBCINI(TabID,D_R8_FORMAT,1,'F7.2',' ','DCol_p',icol(15),i) call TBCINI(TabID,D_R8_FORMAT,1,'F7.2',' ','DCol_n',icol(16),i) call TBCINI(TabID,D_R8_FORMAT,1,'F7.2',' ','DB_p',icol(17),i) call TBCINI(TabID,D_R8_FORMAT,1,'F7.2',' ','DB_n',icol(18),i) call TBCINI(TabID,D_R8_FORMAT,1,'F7.2',' ','DBTur_p',icol(19) 1 ,i) call TBCINI(TabID,D_R8_FORMAT,1,'F7.2',' ','DBTur_n',icol(20), 1 i) call TBCINI(TabID,D_I4_FORMAT,1,'I5',' ','ID',icol(21),i) else call TBLSER(TabID,'Element',icol(1),ist) call TBLSER(TabID,'LamCen',icol(2),ist) call TBLSER(TabID,'DLam',icol(3),ist) call TBLSER(TabID,'Redshift',icol(22),ist) if (icol(22).eq.-1) then call TBCINI(TabID,D_R8_FORMAT,1,'F9.7',' ', 1 'Redshift',icol(22),i) end if call TBLSER(TabID,'ColDen',icol(4),ist) call TBLSER(TabID,'DCol',icol(5),ist) call TBLSER(TabID,'B',icol(6),ist) call TBLSER(TabID,'DB',icol(7),ist) call TBLSER(TabID,'BTur',icol(8),ist) call TBLSER(TabID,'DBTur',icol(9),ist) call TBLSER(TabID,'Temperature',icol(23),ist) if (icol(23).eq.-1) then call TBCINI(TabID,D_R8_FORMAT,1,'F7.0',' ', 1 'Temperature',icol(23),i) end if call TBLSER(TabID,'Eq_Width',icol(10),ist) call TBLSER(TabID,'chi2',icol(11),ist) call TBLSER(TabID,'Prob',icol(12),ist) call TBLSER(TabID,'Dlam_p',icol(13),ist) call TBLSER(TabID,'Dlam_n',icol(14),ist) call TBLSER(TabID,'DCol_p',icol(15),ist) call TBLSER(TabID,'DCol_n',icol(16),ist) call TBLSER(TabID,'DB_p',icol(17),ist) call TBLSER(TabID,'DB_n',icol(18),ist) call TBLSER(TabID,'DBtur_p',icol(19),ist) call TBLSER(TabID,'DBtur_n',icol(20),ist) call TBLSER(TabID,'ID',icol(21),ist) call TBIGET(TabID,I,J,K1,k2,n,ist) !n. of written rows itot=0 do j=1,n call TBERDI(TabID,j,icol(21),i,inull,ist) if (.not.inull) itot=itot+1 end do end if C!!!!!!! C Writes the variables C!!!!!!! IF (NROWS.GT.0) THEN do j=itot+1,itot+nrows call TBEWRC(TabID,j,icol(1),ElmtNm(j-itot),ist) call TBEWRR(TabID,j,icol(2),LamCen(j-itot),ist) call TBEWRR(TabID,j,icol(3),ErLaPa(j-itot),ist) call TBEWRR(TabID,j,icol(22),Redshi(j-itot),ist) call TBEWRR(TabID,j,icol(4),NHfit(j-itot),ist) call TBEWRR(TabID,j,icol(5),ErNnPa(j-itot),ist) call TBEWRR(TabID,j,icol(6),BDopp(j-itot),ist) call TBEWRR(TabID,j,icol(7),ErBbPa(j-itot),ist) call TBEWRR(TabID,j,icol(8),BTur(j-itot),ist) call TBEWRR(TabID,j,icol(9),ErBtPa(j-itot),ist) call TBEWRR(TabID,j,icol(23),Temper(j-itot),ist) call TBEWRR(TabID,j,icol(10),w(j-itot),ist) call TBEWRR(TabID,j,icol(11),chi,ist) call TBEWRR(TabID,j,icol(12),prob,ist) call TBEWRR(TabID,j,icol(13),ErLaPo(j-itot),ist) call TBEWRR(TabID,j,icol(14),ErLaNe(j-itot),ist) call TBEWRR(TabID,j,icol(15),ErNnPo(j-itot),ist) call TBEWRR(TabID,j,icol(16),ErNnNe(j-itot),ist) call TBEWRR(TabID,j,icol(17),ErBbPo(j-itot),ist) call TBEWRR(TabID,j,icol(18),ErBbNe(j-itot),ist) call TBEWRR(TabID,j,icol(19),ErBtPo(j-itot),ist) call TBEWRR(TabID,j,icol(20),ErBtNe(j-itot),ist) call TBEWRI(TabID,j,icol(21),IDnum,ist) end do END IF CALL TBTCLO(TabID,ist) i1=0 !doesn't stop on errors i2=2 i3=1 call STECNT('PUT',i1,i2,i3) return end C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& SUBROUTINE FitWin(nconv,iflag) C C Calcola la finestra su cui eseguire il fit, C e salva la porzione corrispondente dello spettro C sul file 'fdummy.spe' C C C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& IMPLICIT NONE integer nconv,iflag INCLUDE 'MID_REL_INCL:fit_var.inc' integer ind_low,ind_up,old_up integer ij,ik,is real xmin,xmax,var real fwhmth ! threshold in FWHM!!!!! INTEGER MADRID(1) INCLUDE 'MID_INCLUDE:ST_DEF.INC' COMMON/VMR/MADRID INCLUDE 'MID_INCLUDE:ST_DAT.INC' fwhmth=8. iflag=0 ! default: no error nconv=0 old_up=1 c!!!!!!! C Apre file fdummy.spe C!!!!!!! open(10,file='fdummy.spe',status='old',iostat=is) ! close(10,status='DELETE') open(10,file='fdummy.spe',status='new',iostat=is) ! if (is.ne.0) then call ErrMsg('Error in opening fdummy.spe') iflag=-1 return end if do ij = 1,NINTFT C!!!!!!! C Cerca gli indici del primo ed ultimo punto della finestra ij-esima C!!!!!!! xmin=FITMIN(ij) xmax=FITMAX(ij) do ik=1,NPUNTI if (XLAMBD(ik).gt.xmin) goto 100 end do 100 ind_low=ik ! indice inferiore do ik=ind_low,NPUNTI if (XLAMBD(ik).gt.xmax) goto 200 end do 200 ind_up=ik ! indice superiore xmin = FITMIN(ij) - fwhmth * FWHM(ind_low) xmax = FITMAX(ij) + fwhmth * FWHM(ind_up) do ik=1,NPUNTI if (XLAMBD(ik).gt.xmin) goto 300 end do 300 ind_low=ik ! indice inferiore do ik=ind_low,NPUNTI if (XLAMBD(ik).gt.xmax) goto 400 end do 400 ind_up=ik ! indice superiore if (ind_low.lt.old_up) then ind_low = old_up + 1 end if c old_up = ind_low old_up = ind_up if (ind_low.lt.ind_up) then do ik = ind_low,ind_up var=SIGNOI(ik)*SIGNOI(ik) write(10,'(5G20.12)')XLAMBD(ik),PIXSIZ(ik),SPECTR(ik), + var,FWHM(ik) c write(10,'(5G20.12)')XLAMBD(ik),SPECTR(ik),var,FWHM(ik) nconv = nconv +1 end do if (nconv.gt.NMXWRK) then iflag=-1 return end if end if end do close(10) return end C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& SUBROUTINE SMINUI(TblNam,nrun,IER) C C C Saves the MINUIT INSTRUCTIONS on a table. C nrun is the IDNumber of the run. If nrun=1 a new table C is created. C On error in creating the table, ier=1 C otherwise ier=0 C C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& implicit none character*(*) TblNam integer ier,nrun include 'MID_REL_INCL:fit_var.inc' integer j,i1,i2,i3,i4,nlines integer TabID,ist integer icol(2) C include 'MID_REL_INCL:fit_mid.inc' INTEGER MADRID(1) INCLUDE 'MID_INCLUDE:ST_DEF.INC' COMMON/VMR/MADRID INCLUDE 'MID_INCLUDE:ST_DAT.INC' i1=1 !doesn't stop at errors.. i2=0 i3=0 call STECNT('PUT',i1,i2,i3) if (nrun.lt.1) then ier=-1 return end if if (nrun.gt.1) then call TBTOPN(TblNam,F_IO_MODE,TabID,ist) !open if (ist .ne. 0 ) then ! if it doesn't exist, create call TBTINI(TblNam,F_TRANS,F_O_MODE,1,10,TabID,ist) if (ist .ne. 0 ) then ier=1 return end if call TBCINI(TabID,D_C_FORMAT,50,'A50',' ','MINUIT' 1 ,icol(1),ist) call TBCINI(TabID,D_I4_FORMAT,1,'i9',' ','ID', 1 icol(2),ist) end if end if if (nrun.eq.1) then call TBTINI(TblNam,F_TRANS,F_O_MODE,1,10,TabID,ist) if (ist .ne. 0 ) then ier=1 return end if call TBCINI(TabID,D_C_FORMAT,50,'A50',' ','MINUIT',icol(1) 1 ,ist) call TBCINI(TabID,D_I4_FORMAT,1,'i9',' ','ID',icol(2) 1 ,ist) end if call TBIGET(TabID,i1,nlines,i3,i4,i2,ist) !n. of written lines do j=1+nlines,NMINCM+nlines call TBEWRC(TabID,j,icol(1),MINCOM(j-nlines),ist) call TBEWRI(TabID,j,icol(2),nrun,ist) end do CALL TBTCLO(TabID,ist) i1=0 !reset standard values.. i2=2 i3=1 call STECNT('PUT',i1,i2,i3) return end C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& SUBROUTINE RMINUI(TblNam,nrun,IER) C C C Reads the MINUIT INSTRUCTIONS from a table. C Onerror in reading the table, ier=1 C otherwise ier=0 C C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& implicit none character*(*) TblNam integer ier,nrun include 'MID_REL_INCL:fit_var.inc' logical inull,isel integer i,j,i1,i2,i3,i4,ntest,in integer TabID,ist integer icol(2) character*50 ctest INTEGER MADRID(1) INCLUDE 'MID_INCLUDE:ST_DEF.INC' COMMON/VMR/MADRID INCLUDE 'MID_INCLUDE:ST_DAT.INC' if (nrun.lt.1) then ier=-1 return end if do i=1,NMXLIN MINCOM(i)=' ' end do NMINCM=0 if (TblNam.eq.'SCRATCH') return i1=1 !doesn't stop at errors.. i2=0 i3=0 call STECNT('PUT',i1,i2,i3) call TBTOPN(TblNam,F_IO_MODE,TabID,ist) !open if (ist .ne. 0 ) then ! if it doesn't exist, return err call seterr('ON') ier=1 return end if call TBLSER(TabID,'MINUIT',icol(1),ist) call TBLSER(TabID,'ID',icol(2),ist) call TBIGET(TabID,i1,i2,i3,i4,ntest,ist) i=0 do j=1,ntest call TBSGET(TabID,j,isel,ist) ! checks selection call TBERDI(TabID,j,icol(2),in,inull,ist) if (ist.ne.0) then ier=1 return end if if (.not.inull.and.isel) then if (in.eq.nrun) then call TBERDC(TabID,j,icol(1),ctest,inull,ist) i = i +1 MINCOM(i)=ctest end if end if end do NMINCM=i CALL TBTCLO(TabID,ist) i1=0 !reset standard values.. i2=2 i3=1 call STECNT('PUT',i1,i2,i3) return end C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& SUBROUTINE SINTVL(TblNam,nrun,IER) C C C Saves the intervals for the fit on a table. C Onerror in creating the table, ier=1 C otherwise ier=0 C C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& implicit none character*(*) TblNam integer ier,nrun include 'MID_REL_INCL:fit_var.inc' integer j,i1,i2,i3,i4,nlines integer TabID,ist integer icol(3) C include 'MID_REL_INCL:fit_mid.inc' INTEGER MADRID(1) INCLUDE 'MID_INCLUDE:ST_DEF.INC' COMMON/VMR/MADRID INCLUDE 'MID_INCLUDE:ST_DAT.INC' i1=1 !reset standard values.. i2=0 i3=0 call STECNT('PUT',i1,i2,i3) if (nrun.lt.1) then ier=-1 return end if C C opens or creates... C if (nrun.gt.1) then call TBTOPN(TblNam,F_IO_MODE,TabID,ist) !open if (ist .ne. 0 ) then ! if it doesn't exist, create call TBTINI(TblNam,F_TRANS,F_O_MODE,2,10,TabID,ist) if (ist .ne. 0 ) then ier=1 return end if call TBCINI(TabID,D_R8_FORMAT,1,'F8.2',' ','FITMIN' 1 ,icol(1),ist) call TBCINI(TabID,D_R8_FORMAT,1,'F8.2',' ','FITMAX' 1 ,icol(2),ist) call TBCINI(TabID,D_I4_FORMAT,1,'i9',' ','ID', 1 icol(3),ist) end if end if if (nrun.eq.1) then call TBTINI(TblNam,F_TRANS,F_O_MODE,1,10,TabID,ist) if (ist .ne. 0 ) then ier=1 return end if call TBCINI(TabID,D_R8_FORMAT,1,'F8.2',' ','FITMIN' 1 ,icol(1),ist) call TBCINI(TabID,D_R8_FORMAT,1,'F8.2',' ','FITMAX' 1 ,icol(2),ist) call TBCINI(TabID,D_I4_FORMAT,1,'i9',' ','ID', 1 icol(3),ist) end if call TBIGET(TabID,i1,nlines,i3,i4,i2,ist) !n. of written lines c c writes.. c do j=1+nlines,NINTFT+nlines call TBEWRD(TabID,j,icol(1),FITMIN(j-nlines),ist) call TBEWRD(TabID,j,icol(2),FITMAX(j-nlines),ist) call TBEWRI(TabID,j,icol(3),nrun,ist) end do CALL TBTCLO(TabID,ist) i1=0 !reset standard values.. i2=2 i3=1 call STECNT('PUT',i1,i2,i3) return end C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& SUBROUTINE RINTVL(TblNam,nrun,IER) C C C Reads the intervals for the fit from a table. C Onerror in reading the table, ier=1 C otherwise ier=0 C C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& implicit none character*(*) TblNam integer ier,nrun include 'MID_REL_INCL:fit_var.inc' logical inull,isel integer i,j,i1,i2,i3,i4,ntest integer TabID,ist,in integer icol(3) C include 'MID_REL_INCL:fit_mid.inc' INTEGER MADRID(1) INCLUDE 'MID_INCLUDE:ST_DEF.INC' COMMON/VMR/MADRID INCLUDE 'MID_INCLUDE:ST_DAT.INC' if (nrun.lt.1) then ier=-1 return end if do i=1,NMXLIN FITMIN(i)=0. FITMAX(i)=0. end do NINTFT=0 if (TblNam.eq.'SCRATCH') return call seterr('OFF') call TBTOPN(TblNam,F_IO_MODE,TabID,ist) !open if (ist .ne. 0 ) then ! if it doesn't exist, return err call seterr('ON') ier=1 return end if call TBLSER(TabID,'FITMIN',icol(1),ist) call TBLSER(TabID,'FITMAX',icol(2),ist) call TBLSER(TabID,'ID',icol(3),ist) call TBIGET(TabID,i1,i2,i3,i4,ntest,ist) i=0 do j=1,ntest call TBSGET(TabID,j,isel,ist) ! checks selection call TBERDI(TabID,j,icol(3),in,inull,ist) if (ist.ne.0) then ier=1 return end if if (.not.inull.and.isel) then if (in.eq.nrun) then i = i +1 call TBERDD(TabID,j,icol(1),FITMIN(i),inull,ist) call TBERDD(TabID,j,icol(2),FITMAX(i),inull,ist) if (ist.ne.0) then ier=1 return end if end if end if end do NINTFT=i CALL TBTCLO(TabID,ist) call seterr('ON') return end C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& SUBROUTINE F_TBLR(TblNam,nrun,ier) C C C Reads the "lypar" table and store the values in the C COMMON variables C On error then ier =-1 C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& implicit none character*(*) TblNam integer ier,nrun include 'MID_REL_INCL:fit_var.inc' logical inull,isel integer i,j,k,itest integer TabID,ist integer icol(COLTBL) integer i1,i2,i3 C include 'MID_REL_INCL:fit_mid.inc' INTEGER MADRID(1) INCLUDE 'MID_INCLUDE:ST_DEF.INC' COMMON/VMR/MADRID INCLUDE 'MID_INCLUDE:ST_DAT.INC' ier = 0 C!!!!!!! C reset the variables to defaults C!!!!!!! do i=1,NMXLIN ElmtNm(i)=' ' LamIni(i)=0. BIni(i)=0. BtuIni(i)=0. NIni(i)=0. CPAR(1,i)=' ' CPAR(2,i)=' ' CPAR(3,i)=' ' CPAR(4,i)=' ' LamMin(i)=0. LamMax(i)=0. BMin(i)=0. BMax(i)=0. BtuMin(i)=0. BtuMax(i)=0. NMin(i)=0. NMax(i)=0. LamSte(i)=0.005 BSte(i)=0.01 BtuSte(i)=0.01 NSte(i)=0.01 CoefL(i)=0. CoefB(i)=0. CoefN(i)=0. CoefBT(i)=0. Class(i)=' ' grID(i)=0 AtmLam(i)=0. AtmFos(i)=0. AtmGam(i)=0. AtmMas(i)=0. end do NROWS=0 if (TblNam.eq.'SCRATCH') return C!!!!!!! C Opens the tables and reads the column numbers C!!!!!!! i1=1 !doesn't stop at errors.. i2=0 i3=0 call STECNT('PUT',i1,i2,i3) call TBTOPN(TblNam,F_IO_MODE,TabID,ist) !open if (ist .ne. 0 ) then ! if it doesn't exist, create ier=-1 return end if call TBIGET(TabID,I,J,K,k,nrows,ist) !n. of rows call TBLSER(TabID,'Element',icol(1),ist) call TBLSER(TabID,'L_ini',icol(2),ist) call TBLSER(TabID,'P_l',icol(3),ist) call TBLSER(TabID,'N_ini',icol(4),ist) call TBLSER(TabID,'P_n',icol(5),ist) call TBLSER(TabID,'b_ini',icol(6),ist) call TBLSER(TabID,'P_b',icol(7),ist) call TBLSER(TabID,'bt_ini',icol(8),ist) call TBLSER(TabID,'P_bt',icol(9),ist) call TBLSER(TabID,'L_min',icol(10),ist) call TBLSER(TabID,'L_max',icol(11),ist) call TBLSER(TabID,'N_min',icol(12),ist) call TBLSER(TabID,'N_max',icol(13),ist) call TBLSER(TabID,'b_min',icol(14),ist) call TBLSER(TabID,'b_max',icol(15),ist) call TBLSER(TabID,'bt_min',icol(16),ist) call TBLSER(TabID,'bt_max',icol(17),ist) call TBLSER(TabID,'L_step',icol(18),ist) call TBLSER(TabID,'n_step',icol(19),ist) call TBLSER(TabID,'b_step',icol(20),ist) call TBLSER(TabID,'bt_step',icol(21),ist) call TBLSER(TabID,'Coef_l',icol(22),ist) call TBLSER(TabID,'Coef_n',icol(23),ist) call TBLSER(TabID,'Coef_b',icol(24),ist) call TBLSER(TabID,'Coef_bt',icol(25),ist) call TBLSER(TabID,'Class',icol(26),ist) call TBLSER(TabID,'grp',icol(27),ist) call TBLSER(TabID,'atm_lam',icol(28),ist) call TBLSER(TabID,'atm_fos',icol(29),ist) call TBLSER(TabID,'atm_gam',icol(30),ist) call TBLSER(TabID,'atm_mas',icol(31),ist) call TBLSER(TabID,'ID',icol(32),ist) C!!!!!!! C Reads the variables C!!!!!!! i=0 do j=1,nrows call TBSGET(TabID,j,isel,ist) ! checks selection call TBERDI(TabID,j,icol(32),itest,inull,ist) if (.not.inull.and.isel) then if (itest.eq.nrun) then i = i +1 call TBERDC(TabID,j,icol(1),ElmtNm(i),inull,ist) call TBERDD(TabID,j,icol(2),LamIni(i),inull,ist) call TBERDC(TabID,j,icol(3),CPar(1,i),inull,ist) call TBERDD(TabID,j,icol(4),NIni(i),inull,ist) call TBERDC(TabID,j,icol(5),CPar(2,i),inull,ist) call TBERDD(TabID,j,icol(6),BIni(i),inull,ist) call TBERDC(TabID,j,icol(7),CPar(3,i),inull,ist) call TBERDD(TabID,j,icol(8),BtuIni(i),inull,ist) call TBERDC(TabID,j,icol(9),CPar(4,i),inull,ist) call TBERDD(TabID,j,icol(10),LamMin(i),inull,ist) call TBERDD(TabID,j,icol(11),LamMax(i),inull,ist) call TBERDD(TabID,j,icol(12),NMin(i),inull,ist) call TBERDD(TabID,j,icol(13),NMax(i),inull,ist) call TBERDD(TabID,j,icol(14),BMin(i),inull,ist) call TBERDD(TabID,j,icol(15),BMax(i),inull,ist) call TBERDD(TabID,j,icol(16),BtuMin(i),inull,ist) call TBERDD(TabID,j,icol(17),BtuMax(i),inull,ist) call TBERDD(TabID,j,icol(18),LamSte(i),inull,ist) call TBERDD(TabID,j,icol(19),NSte(i),inull,ist) call TBERDD(TabID,j,icol(20),BSte(i),inull,ist) call TBERDD(TabID,j,icol(21),BtuSte(i),inull,ist) call TBERDD(TabID,j,icol(22),CoefL(i),inull,ist) call TBERDD(TabID,j,icol(23),CoefN(i),inull,ist) call TBERDD(TabID,j,icol(24),CoefB(i),inull,ist) call TBERDD(TabID,j,icol(25),CoefBt(i),inull,ist) call TBERDC(TabID,j,icol(26),Class(i),inull,ist) call TBERDI(TabID,j,icol(27),grID(i),inull,ist) call TBERDD(TabID,j,icol(28),AtmLam(i),inull,ist) call TBERDD(TabID,j,icol(29),AtmFos(i),inull,ist) call TBERDD(TabID,j,icol(30),AtmGam(i),inull,ist) call TBERDD(TabID,j,icol(31),AtmMas(i),inull,ist) end if end if end do nrows=i CALL TBTCLO(TabID,ist) i1=0 !stop on errors i2=2 i3=1 call STECNT('PUT',i1,i2,i3) return end C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& SUBROUTINE ShPar1(header) C C C Prints on the screen the content of lypar.tbl more C frequently accessed by the user. C C if header = 'NORMAL" the columns are well explained; C if header = 'EDITPARAM" only column symbols are written C C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& implicit none character*(*) header include 'MID_REL_INCL:fit_var.inc' integer ifound(NMXLIN) integer i,ist,j,ni,is character a character*80 strout character*9Parcar(4,NMXLIN) C include 'MID_REL_INCL:fit_mid.inc' INTEGER MADRID(1) INCLUDE 'MID_INCLUDE:ST_DEF.INC' COMMON/VMR/MADRID INCLUDE 'MID_INCLUDE:ST_DAT.INC' do i=1,NMXLIN ifound(i)=0 end do do i=1,4 do j=1,NROWS call CnvrtP(CPar(i,j),ni,a,is) if (ifound(ni).eq.0.and.a.ne.'Z'.and.a.ne.'T') then !never found yet nor constrained ifound(ni) =1 if(i.eq.1) write(ParCar(i,j),97) ' ',LamIni(j),' ' if(i.eq.2) write(ParCar(i,j),98) ' ',NIni(j),' ' if(i.eq.3) write(ParCar(i,j),99) ' ',BIni(j),' ' if(i.eq.4) write(ParCar(i,j),99) ' ',BtuIni(j),' ' else if(i.eq.1) write(ParCar(i,j),97) '(',LamIni(j) ,')' if(i.eq.2) write(ParCar(i,j),98) ' (',NIni(j),')' if(i.eq.3) write(ParCar(i,j),99) ' (',BIni(j),')' if(i.eq.4) write(ParCar(i,j),99) ' (',BtuIni(j),')' end if 97 format(a1,f7.2,a1) 98 format(a2,f6.3,a1) 99 format(a2,f6.2,a1) end do end do call sttdis(' ',0,ist) write(strout,'(25x,a30)')'** Current Parameter Table **' call sttdis(strout,0,ist) call sttdis(' ',0,ist) c write(strout,*)' # ',' Element ' if (header.eq.'NORMAL') then write(strout,*)' #', ' Element ',' lambda' 1 ,' ',' column',' den. ',' b ', 2 ' ',' bT ',' ' end if if (header.eq.'EDITPARAM') then write(strout,*)' #', ' E ',' L ' 1 ,' PL ',' N ',' PN ',' B ', 2 ' PB ',' BT ',' PT ' end if call sttdis(strout,0,ist) call sttdis(' ',0,ist) do i=1,nrows write(strout,100)i,ElmtNm(i),ParCar(1,i),CPar(1,i), 1 ParCar(2,i),CPar(2,i),ParCar(3,i),CPar(3,i),ParCar(4,i) 2 ,CPar(4,i) call sttdis(strout,0,ist) end do 100 format (i3,1x,A14,A9,'[',A4,']',A9,'[',A4,']', 1 A9,'[',A4,']',A9,'[',A4,']') return end C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& SUBROUTINE F_TBLW(TblNam,nrun,ier) C C C Writes the initial parameters on a table C C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& implicit none character*(*) TblNam integer ier,nrun include 'MID_REL_INCL:fit_var.inc' integer j,i,i1,i2,i3,k1,k2,nlines integer TabID,ist integer icol(COLTBL) C include 'MID_REL_INCL:fit_mid.inc' INTEGER MADRID(1) INCLUDE 'MID_INCLUDE:ST_DEF.INC' COMMON/VMR/MADRID INCLUDE 'MID_INCLUDE:ST_DAT.INC' C!!!!!!! C Creates the table and reads the column numbers C!!!!!!! i1=1 !doesn't stop on errors i2=0 i3=0 call STECNT('PUT',i1,i2,i3) if (nrun.lt.1) then ier=-1 return end if if (nrun.gt.1) then call TBTOPN(TblNam,F_IO_MODE,TabID,ist) !open end if if (ist.ne.0.or.nrun.eq.1) then call TBTINI(TblNam,F_TRANS,F_O_MODE,COLTBL,1,TabID,ist) if (ist.ne.0) then ier=1 return end if call TBCINI(TabID,D_C_FORMAT,14,'A14',' ','Element',icol(1),i) call TBCINI(TabID,D_R8_FORMAT,1,'F7.2',' ','L_ini',icol(2),i) call TBCINI(TabID,D_C_FORMAT,4,'A4',' ','P_l',icol(3),i) call TBCINI(TabID,D_R8_FORMAT,1,'F5.2',' ','N_ini',icol(4),i) call TBCINI(TabID,D_C_FORMAT,4,'A4',' ','P_n',icol(5),i) call TBCINI(TabID,D_R8_FORMAT,1,'F6.2',' ','b_ini',icol(6),i) call TBCINI(TabID,D_C_FORMAT,4,'A4',' ','P_b',icol(7),i) call TBCINI(TabID,D_R8_FORMAT,1,'F6.2',' ','bt_ini',icol(8),i) call TBCINI(TabID,D_C_FORMAT,4,'A4',' ','P_bt',icol(9),i) call TBCINI(TabID,D_R8_FORMAT,1,'F7.2',' ','l_min',icol(10),i) call TBCINI(TabID,D_R8_FORMAT,1,'F7.2',' ','l_max',icol(11),i) call TBCINI(TabID,D_R8_FORMAT,1,'F5.2',' ','N_min',icol(12),i) call TBCINI(TabID,D_R8_FORMAT,1,'F5.2',' ','N_max',icol(13),i) call TBCINI(TabID,D_R8_FORMAT,1,'F6.2',' ','b_min',icol(14),i) call TBCINI(TabID,D_R8_FORMAT,1,'F6.2',' ','B_max',icol(15),i) call TBCINI(TabID,D_R8_FORMAT,1,'F6.2',' ','bt_min',icol(16),i) call TBCINI(TabID,D_R8_FORMAT,1,'F6.2',' ','bt_max',icol(17),i) call TBCINI(TabID,D_R8_FORMAT,1,'F7.3',' ','l_step',icol(18),i) call TBCINI(TabID,D_R8_FORMAT,1,'F6.3',' ','n_step',icol(19),i) call TBCINI(TabID,D_R8_FORMAT,1,'F6.3',' ','b_step',icol(20),i) call TBCINI(TabID,D_R8_FORMAT,1,'F7.3',' ', 1 'bt_step',icol(21),i) call TBCINI(TabID,D_R8_FORMAT,1,'E12.6',' ','Coef_l', 1 icol(22),i) call TBCINI(TabID,D_R8_FORMAT,1,'F3.1',' ','Coef_n',icol(23),i) call TBCINI(TabID,D_R8_FORMAT,1,'E12.6',' ','Coef_b', 1 icol(24),i) call TBCINI(TabID,D_R8_FORMAT,1,'F3.1',' ','Coef_bt', 1 icol(25),i) call TBCINI(TabID,D_C_FORMAT,1,'A1',' ','Class',icol(26),i) call TBCINI(TabID,D_I4_FORMAT,1,'I2',' ','grp',icol(27),i) call TBCINI(TabID,D_R8_FORMAT,1,'F10.4',' ', 1 'atm_lam',icol(28),i) call TBCINI(TabID,D_R8_FORMAT,1,'F7.5',' ', 1 'atm_fos',icol(29),i) call TBCINI(TabID,D_R8_FORMAT,1,'E10.5',' ', 1 'atm_gam',icol(30),i) call TBCINI(TabID,D_R8_FORMAT,1,'F7.5',' ', 1 'atm_mas',icol(31),i) call TBCINI(TabID,D_I4_FORMAT,1,'i9',' ','ID', 1 icol(32),ist) else call TBLSER(TabID,'Element',icol(1),ist) call TBLSER(TabID,'L_ini',icol(2),ist) call TBLSER(TabID,'P_l',icol(3),ist) call TBLSER(TabID,'N_ini',icol(4),ist) call TBLSER(TabID,'P_n',icol(5),ist) call TBLSER(TabID,'b_ini',icol(6),ist) call TBLSER(TabID,'P_b',icol(7),ist) call TBLSER(TabID,'bt_ini',icol(8),ist) call TBLSER(TabID,'P_bt',icol(9),ist) call TBLSER(TabID,'L_min',icol(10),ist) call TBLSER(TabID,'L_max',icol(11),ist) call TBLSER(TabID,'N_min',icol(12),ist) call TBLSER(TabID,'N_max',icol(13),ist) call TBLSER(TabID,'b_min',icol(14),ist) call TBLSER(TabID,'b_max',icol(15),ist) call TBLSER(TabID,'bt_min',icol(16),ist) call TBLSER(TabID,'bt_max',icol(17),ist) call TBLSER(TabID,'L_step',icol(18),ist) call TBLSER(TabID,'n_step',icol(19),ist) call TBLSER(TabID,'b_step',icol(20),ist) call TBLSER(TabID,'bt_step',icol(21),ist) call TBLSER(TabID,'Coef_l',icol(22),ist) call TBLSER(TabID,'Coef_n',icol(23),ist) call TBLSER(TabID,'Coef_b',icol(24),ist) call TBLSER(TabID,'Coef_bt',icol(25),ist) call TBLSER(TabID,'Class',icol(26),ist) call TBLSER(TabID,'grp',icol(27),ist) call TBLSER(TabID,'atm_lam',icol(28),ist) call TBLSER(TabID,'atm_fos',icol(29),ist) call TBLSER(TabID,'atm_gam',icol(30),ist) call TBLSER(TabID,'atm_mas',icol(31),ist) call TBLSER(TabID,'ID',icol(32),ist) c if (nrun.eq.1) then ! delete all rows c call TBIGET(TabID,I,j,K1,k2,nlines,ist) !n. of rows c do j=1,nlines c call TBRDEL(TabID,j,ist) c call TBSPUT(TabID,j,.false.,ist) c end do c end if end if call TBIGET(TabID,I,nlines,K1,k2,j,ist) !n. of rows C!!!!!!! C Writes the variables C!!!!!!! IF (NROWS.GT.0) THEN do j=1+nlines,nrows+nlines call TBEWRC(TabID,j,icol(1),ElmtNm(j-nlines),ist) call TBEWRD(TabID,j,icol(2),LamIni(j-nlines),ist) call TBEWRC(TabID,j,icol(3),CPar(1,j-nlines),ist) call TBEWRD(TabID,j,icol(4),NIni(j-nlines),ist) call TBEWRC(TabID,j,icol(5),CPar(2,j-nlines),ist) call TBEWRD(TabID,j,icol(6),BIni(j-nlines),ist) call TBEWRC(TabID,j,icol(7),CPar(3,j-nlines),ist) call TBEWRD(TabID,j,icol(8),BtuIni(j-nlines),ist) call TBEWRC(TabID,j,icol(9),CPar(4,j-nlines),ist) call TBEWRD(TabID,j,icol(10),LamMin(j-nlines),ist) call TBEWRD(TabID,j,icol(11),LamMax(j-nlines),ist) call TBEWRD(TabID,j,icol(12),NMin(j-nlines),ist) call TBEWRD(TabID,j,icol(13),NMax(j-nlines),ist) call TBEWRD(TabID,j,icol(14),BMin(j-nlines),ist) call TBEWRD(TabID,j,icol(15),BMax(j-nlines),ist) call TBEWRD(TabID,j,icol(16),BtuMin(j-nlines),ist) call TBEWRD(TabID,j,icol(17),BtuMax(j-nlines),ist) call TBEWRD(TabID,j,icol(18),LamSte(j-nlines),ist) call TBEWRD(TabID,j,icol(19),NSte(j-nlines),ist) call TBEWRD(TabID,j,icol(20),BSte(j-nlines),ist) call TBEWRD(TabID,j,icol(21),BtuSte(j-nlines),ist) call TBEWRD(TabID,j,icol(22),CoefL(j-nlines),ist) call TBEWRD(TabID,j,icol(23),CoefN(j-nlines),ist) call TBEWRD(TabID,j,icol(24),CoefB(j-nlines),ist) call TBEWRD(TabID,j,icol(25),CoefBt(j-nlines),ist) call TBEWRC(TabID,j,icol(26),Class(j-nlines),ist) call TBEWRI(TabID,j,icol(27),grID(j-nlines),ist) call TBEWRD(TabID,j,icol(28),AtmLam(j-nlines),ist) call TBEWRD(TabID,j,icol(29),AtmFos(j-nlines),ist) call TBEWRD(TabID,j,icol(30),AtmGam(j-nlines),ist) call TBEWRD(TabID,j,icol(31),AtmMas(j-nlines),ist) call TBEWRI(TabID,j,icol(32),nrun,ist) end do END IF CALL TBTCLO(TabID,ist) i1=0 !stop on errors i2=2 i3=1 call STECNT('PUT',i1,i2,i3) return end C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& SUBROUTINE CnvrtP(PmtCar,PmtInt,Link,ist) C (ConvertParameter) C C Analizes a Parameter definition (char*4) and returns C the relative parameter number, the kind of link C converted to uppercase (if it exists), C and sets ist=1 if link exists, 0 if it doesn't C -1 if any error occurs C C PmtCar IN Parameter character (e.g. 10.T) C PmtInt OUT Parameter number (e.g. 10) C Link OUT link (if exists) (e.g. T) C ist OUT Exists the link?(Y=1)(e.g. 1) C (N=0) C (err=-1) C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& implicit none character*4 PmtCar integer PmtInt,ist character Link character*4 App integer idx ist=0 Link=' ' idx=index(PmtCar,'.T') if (idx.ne.0) then App=PmtCar App(idx:idx+1)=' ' read(App,'(I4)')PmtInt Link='T' ist=1 return end if idx=index(PmtCar,'.t') if (idx.ne.0) then App=PmtCar App(idx:idx+1)=' ' read(App,'(I4)')PmtInt Link='T' ist=1 return end if idx=index(PmtCar,'.Z') if (idx.ne.0) then App=PmtCar App(idx:idx+1)=' ' read(App,'(I4)')PmtInt Link='Z' ist=1 return end if idx=index(PmtCar,'.z') if (idx.ne.0) then App=PmtCar App(idx:idx+1)=' ' read(App,'(I4)')PmtInt Link='Z' ist=1 return end if idx=index(PmtCar,'.F') if (idx.ne.0) then App=PmtCar App(idx:idx+1)=' ' read(App,'(I4)')PmtInt Link='F' ist=1 return end if idx=index(PmtCar,'.f') if (idx.ne.0) then App=PmtCar App(idx:idx+1)=' ' read(App,'(I4)')PmtInt Link='F' ist=1 return end if if (ist.ne.1) then read(PmtCar,'(I4)',err=100)PmtInt return ! RETURN OK end if 100 ist=-1 return end C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& SUBROUTINE ChkPar(ErrMsg,ist) c C Checks the consistency of the parameter definition C stored in memory. First looks for unrecoverable (SEVERE) C errors (ist=1), then for recoverable errors (ist=2) C or general warnings (ist=2) C and tries to correct them. C In case of severe errors returns a message in ErrMsg; C in case of recoverable messages displays a warning. C C Kind and classification of errors investigated: C C Severe: 1- Unidentified symbols (e.g. 10.j, or 10T, or 10.) C 2- Same parameter number in different columns C (e.g. parm. n. 10 is both a wavelength and a b-value. C 3- Wrong parameter link (e.g. 10.T on a wave. col.) C 4- Prameter number negative C 5- Parameter numbers not contiguous C C Recover:1- Parameters fixed only sometimes (10 and 10.F) C 2- C 3 C C Warning:1- C C Further actions: if TURBLN.eq.0 writes the correct CPar(4,j) C C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& character*(*) ErrMsg integer ist include 'MID_REL_INCL:fit_var.inc' integer IPar(4,NMXLIN) integer i,j,is,np(NMXFRE),fp(NMXFRE),ni,nmx character a C include 'MID_REL_INCL:fit_mid.inc' INTEGER MADRID(1) INCLUDE 'MID_INCLUDE:ST_DEF.INC' COMMON/VMR/MADRID INCLUDE 'MID_INCLUDE:ST_DAT.INC' ist=0 ErrMsg=' ' C!!!!!!! C ** 1 SEVERE ERROR: Unidentified symbols (meanwhile C converts parameter definition in parameter numbers) C!!!!!!! do i=1,4 do j=1,NROWS call CnvrtP(CPar(i,j),IPar(i,j),a,is) if (is.eq.-1) then write(ErrMsg,101)CPar(i,j),i,j ist=1 return end if end do end do 101 format('SEVERE ERROR: UNIDENTIFIED SYMBOL ',A4,i3,i3) C!!!!!!! C ** 2 SEVERE ERROR: same par. number in different columns C!!!!!!! do j=1,NROWS do i=1,NROWS if (IPar(1,j).eq.IPar(2,i).and.(j.ne.i)) then write(ErrMsg,102)IPar(1,j) ist=1 return end if END DO end do 102 format('SEVERE ERROR: PARAMETER ',I3,' 1 DEFINED ON MORE COLUMNS') C!!!!!!! C ** 3 SEVERE ERROR: Wrong parameter constraint on columns C!!!!!!! ! Column of wavelengths do j=1,NROWS call CnvrtP(CPar(1,j),i,a,is) if (is .eq.1) then if (a.ne.'Z'.and.a.ne.'F') then write(ErrMsg,103)CPar(1,j) ist=1 return end if end if end do ! Column of Column densities do j=1,NROWS call CnvrtP(CPar(2,j),i,a,is) if (is .eq.1) then if (a.ne.'F') then write(ErrMsg,103)CPar(2,j) ist=1 return end if end if end do ! Column of b-values do j=1,NROWS call CnvrtP(CPar(3,j),i,a,is) if (is .eq.1) then if (a.ne.'T'.and.a.ne.'F') then write(ErrMsg,103)CPar(3,j) ist=1 return end if end if end do ! Column of b-turbolence values do j=1,NROWS call CnvrtP(CPar(4,j),i,a,is) if (is .eq.1) then if (a.ne.'F') then write(ErrMsg,103)CPar(4,j) ist=1 return end if end if end do 103 format('SEVERE ERROR: WRONG CONSTRAINT ON PARAMETER ',A4) C!!!!!!! C ** 4 SEVERE ERROR: parameter number < 1 C!!!!!!! do i=1,4 do j=1,NROWS if (IPar(i,j).lt. 1) then write(ErrMsg,104)CPar(i,j) ist=1 return end if end do end do 104 format('SEVERE ERROR: PARAMETER NUMBER: ',A4,' IS LESS THAN 0') C!!!!!!! C ** 5 SEVERE ERROR: parameter numbers not contiguous C (BYPRODUCT: total parameter number nmx, vector of C parameter numbers np() and parameter links cp()) C!!!!!!! do i=1,NMXFRE np(i)=0 end do nmx=0 do i=1,4 do j=1,NROWS call CnvrtP(CPar(i,j),ni,a,is) np(ni)=ni if (ni.gt.nmx) nmx=ni end do end do do i=1,nmx if (np(i).eq.0) then write(ErrMsg,105)i ist=1 return end if end do 105 format('SEVERE ERROR: PARAMETER',I3,' MISSING') C!!!!!!! C ** 1 RECOVERABLE ERROR: parameter fixed only sometimes C!!!!!!! do i=1,NMXFRE fp(i)=0 end do do i=1,4 ! Looks for fixed param do j=1,NROWS call CnvrtP(CPar(i,j),ni,a,is) if (is .eq.1 .and. a.eq.'F') fp(ni)=1 end do end do do i=1,4 ! writes .F on the fixed param do j=1,NROWS call CnvrtP(CPar(i,j),ni,a,is) if (fp(ni).eq.1 .and. is.eq.0) then write(ErrMsg,201)ni,i,j call sttdis(ErrMsg,0,is) write(CPar(i,j),202)ni end if end do end do 201 format('WARNING: PARAMETER ',I3,' FIXED AT POSITION ',I3,I3) 202 format(I2,'.F') NTOTPA=nmx C!!!!!!! C ** 1 FURTHER ACTIONS: WRITES the correct CPar(4,j) if TURBLN=0 C!!!!!!! if (TURBLN.eq.0) then do j=1,NROWS if(IPar(4,j).eq.0) write(CPar(4,j),'(i2,a2)')nmx+1,'.F' end do end if return end C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& SUBROUTINE AddAtP(ist) C C Uses the element name of the table to fill C the columns of the atomic parameters. C Atompar must have already been read!! C C Ist (OUT) =1 if error (wrong paramname), otherwise 0 C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& implicit none include 'MID_REL_INCL:fit_var.inc' integer ist,i,j,iflag C include 'MID_REL_INCL:fit_mid.inc' INTEGER MADRID(1) INCLUDE 'MID_INCLUDE:ST_DEF.INC' COMMON/VMR/MADRID INCLUDE 'MID_INCLUDE:ST_DAT.INC' ist=0 do i=1,NROWS iflag=0 do j=1,AT_N if (ElmtNm(i).eq.AT_NAM(j)) then iflag=1 AtmLam(i)=AT_LAM(j) AtmFos(i)=AT_FOS(j) AtmGam(i)=AT_GAM(j) AtmMas(i)=AT_MAS(j) end if end do if (iflag.eq.0) then ist=1 return end if end do return end C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& SUBROUTINE AtmRD(Iflag) C C Legge il file atompar.tbl C C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& implicit none integer iflag,i,TABID,icol(5),i1,i2,i3,i4,nj,ist logical la INCLUDE 'MID_REL_INCL:fit_var.inc' INTEGER MADRID(1) INCLUDE 'MID_INCLUDE:ST_DEF.INC' COMMON/VMR/MADRID INCLUDE 'MID_INCLUDE:ST_DAT.INC' C&&&&&&& C& Legge il file atompar.tbl con i parametri atomici C&&&&&&& call seterr('OFF') call TBTOPN('atompar',F_IO_MODE,TABID,i) if (i.ne.0) then iflag=1 call ERRMSG('FATAL: atompar.tbl not found') return end if call TBLSER(TABID,'transition',icol(1),i) if (i.ne.0) then iflag=1 call ERRMSG('FATAL: :TRANSITION not found in atompar.tbl') return end if call TBLSER(TABID,'lambda',icol(2),i) if (i.ne.0) then iflag=1 call ERRMSG('FATAL: column LAMBDA not found in atompar.tbl') return end if call TBLSER(TABID,'gamma',icol(3),i) if (i.ne.0) then iflag=1 call ERRMSG('FATAL: column GAMMA not found in atompar.tbl') return end if call TBLSER(TABID,'fosc',icol(4),i) if (i.ne.0) then iflag=1 call ERRMSG('FATAL: column FOSC not found in atompar.tbl') return end if call TBLSER(TABID,'mass',icol(5),i) if (i.ne.0) then iflag=1 call ERRMSG('FATAL: column MASS not found in atompar.tbl') return end if call TBIGET(TABID,i1,i2,i3,i4,nj,ist) !n. of rows call seterr('ON') do i=1,nj call TBERDC(TABID,i,icol(1),AT_NAM(i),la,ist) call TBERDD(TABID,i,icol(2),AT_LAM(i),la,ist) call TBERDD(TABID,i,icol(3),AT_GAM(i),la,ist) call TBERDD(TABID,i,icol(4),AT_FOS(i),la,ist) call TBERDD(TABID,i,icol(5),AT_MAS(i),la,ist) end do call TBTCLO(TABID,ist) AT_N=nj iflag=0 return end C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& SUBROUTINE AtmRDold(Iflag) C C Legge il file atompar.tbl C C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& implicit none INCLUDE 'MID_REL_INCL:fit_var.inc' character*14 intestazione,app integer iflag,i real a,b,c,d C&&&&&&& C& Legge il file atompar.dat con i parametri atomici C&&&&&&& open(12,file='atompar.dat',status='old',iostat=iflag) if (iflag.ne.0) then iflag=1 c call ERRORMSG('FATAL: atompar.dat not found') call sttdis('FATAL: atompar.dat not found',0,i) return end if i=1 read(12,'(a14)')Intestazione 99 read(12,'(1x,a14,5x,f9.4,3x,f7.5,4x,e7.3)',end=100)App,a,b,c,d AT_LAM(i)= a AT_FOS(i)=b AT_GAM(i)=c AT_NAM(i)=App AT_MAS(I)=d i=i+1 goto 99 100 continue close(12) AT_N=i-1 iflag=0 return end C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& SUBROUTINE AdPLim C C Adds the internal limits on the parameters. C C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& implicit none include 'MID_REL_INCL:fit_var.inc' integer i C include 'MID_REL_INCL:fit_mid.inc' INTEGER MADRID(1) INCLUDE 'MID_INCLUDE:ST_DEF.INC' COMMON/VMR/MADRID INCLUDE 'MID_INCLUDE:ST_DAT.INC' do i=1,NROWS if (LAMLIM(1).eq.0) then LamMin(i)=0.0 else LamMin(i)=LamIni(i) - LAMLIM(1) end if if (LAMLIM(2).eq.0) then LamMax(i)=0.0 else LamMax(i)=LamIni(i) + LAMLIM(2) end if BMin(i)=BLIM(1) BMax(i)=BLIM(2) BtuMin(i)=BTULIM(1) BtuMax(i)=BTULIM(2) NMin(i)=NLIM(1) NMax(i)=NLIM(2) LamSte(i)=LAMLIM(3) BSte(i)=BLIM(3) BtuSte(i)=BTULIM(3) NSte(i)=NLIM(3) end do return end C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& SUBROUTINE MinuHd C C Writes an ascii file with the header instruction C for minuit (i.e. parameter definition and fix) C using lypar values as stored in memory C and lymin values as stored in memory C C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& implicit none include 'MID_REL_INCL:fit_var.inc' integer ifound(NMXLIN),ifix(NMXLIN),ix(NMXLIN),jx(NMXLIN) integer i,j,ni,is,nmx,ista character a character*5 suffix(4) character*20 name real valmin,valmax,valini,valste C include 'MID_REL_INCL:fit_mid.inc' INTEGER MADRID(1) INCLUDE 'MID_INCLUDE:ST_DEF.INC' COMMON/VMR/MADRID INCLUDE 'MID_INCLUDE:ST_DAT.INC' suffix(1)='''lam[' suffix(3)=''' b[' suffix(2)=''' N[' suffix(4)='''btu[' do i=1,NMXLIN ifound(i)=0 ifix(i)=0 ix(i)=0 jx(i)=0 end do nmx=0 do i=1,4 do j=1,NROWS call CnvrtP(CPar(i,j),ni,a,is) if (ifound(ni).eq.0.and.a.ne.'Z'.and.a.ne.'T') then !never found yet nor constrained ifound(ni) =1 ix(ni)=i jx(ni)=j end if if(a.eq.'F') ifix(ni)=1 ! in any case if fixed.. if (ni.gt.nmx) nmx=ni end do end do C!!!!!!! C Apre il file fdummy.MIN cancellando il vecchio C!!!!!!! 40 continue open(20,file='fdummy.min',status='old',iostat=ista) close(20,status='delete') open(20,file='fdummy.min',status='new',iostat=ista) C!!!!!!! C Comincia a scrivere C!!!!!!! write(20,'(A34)')'FITLYMAN Minimization - ESO Midas' do i=1,nmx write(name,'(A5,i2,A2)')suffix(ix(i)),jx(i),']'' ' if (ix(i).eq.1) valini = LamIni(jx(i)) if (ix(i).eq.3) valini = BIni(jx(i)) if (ix(i).eq.2) valini = NIni(jx(i)) if (ix(i).eq.4) valini = BtuIni(jx(i)) if (ix(i).eq.1) valste = LamSte(jx(i)) if (ix(i).eq.3) valste = BSte(jx(i)) if (ix(i).eq.2) valste = NSte(jx(i)) if (ix(i).eq.4) valste = BtuSte(jx(i)) if (ix(i).eq.1) valmin = LamMin(jx(i)) if (ix(i).eq.3) valmin = BMin(jx(i)) if (ix(i).eq.2) valmin = NMin(jx(i)) if (ix(i).eq.4) valmin = BtuMin(jx(i)) if (ix(i).eq.1) valmax = LamMax(jx(i)) if (ix(i).eq.3) valmax = BMax(jx(i)) if (ix(i).eq.2) valmax = NMax(jx(i)) if (ix(i).eq.4) valmax = BtuMax(jx(i)) if (ifix(i).eq.1) then write(20,101)i,name,valini ! parameter fixed else if (valmin.lt.1e-5.or.valmax.lt.1e-5) then write(20,102)i,name,valini,valste ! parameter free else write(20,103)i,name,valini,valste,valmin,valmax end if end if end do 101 format(I3,3x,A10,G14.7) 102 format(I3,3x,A10,2G14.7) 103 format(I3,3x,A10,4G14.7) write(20,*) !! IMPORTANT: END OF HEADER IMINOS=0 do i=1,NMINCM write(20,*)MINCOM(i) if (MINCOM(i).eq.'MINOS') IMINOS=1 end do close(20) return end C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& SUBROUTINE AdCoef C C Using the values of lypar.tbl loaded in memory, C computes the coefficients of proportionality for C constrained parameters. Now working only C on lambda and b parameters. (N not constrained!! C C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& implicit none include 'MID_REL_INCL:fit_var.inc' integer ifound(NMXLIN),ix(NMXLIN),jx(NMXLIN) integer i,j,ni,is character a C include 'MID_REL_INCL:fit_mid.inc' INTEGER MADRID(1) INCLUDE 'MID_INCLUDE:ST_DEF.INC' COMMON/VMR/MADRID INCLUDE 'MID_INCLUDE:ST_DAT.INC' do i=1,NMXLIN ifound(i)=0 ix(i)=0 jx(i)=0 CoefL(i)=1. CoefN(i)=1. CoefB(i)=1. CoefBt(i)=1. end do i=1 ! Lambda do j=1,NROWS call CnvrtP(CPar(i,j),ni,a,is) if (ifound(ni).eq.0.and.a.ne.'Z'.and.a.ne.'T') then !never found yet nor constrained ifound(ni) =1 ix(ni)=i jx(ni)=j end if end do do j=1,NROWS call CnvrtP(CPar(i,j),ni,a,is) if (a.eq.'Z') CoefL(j)=AtmLam(j)/AtmLam(jx(ni)) end do i=3 ! b-values do j=1,NROWS call CnvrtP(CPar(i,j),ni,a,is) if (ifound(ni).eq.0.and.a.ne.'Z'.and.a.ne.'T') then !never found yet nor constrained ifound(ni) =1 ix(ni)=i jx(ni)=j end if end do do j=1,NROWS call CnvrtP(CPar(i,j),ni,a,is) if (a.eq.'T') Coefb(j)=sqrt(AtmMas(jx(ni))/AtmMas(j)) end do return end C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& SUBROUTINE AddInP C C Computes the values of the initial constrained parameters C using the values of lypar.tbl loaded in memory, C and the coefficients of proportionality C C C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& implicit none include 'MID_REL_INCL:fit_var.inc' integer ifound(NMXLIN),ix(NMXLIN),jx(NMXLIN) integer IPar(4,NMXLIN) integer i,j,ni,is character a C include 'MID_REL_INCL:fit_mid.inc' INTEGER MADRID(1) INCLUDE 'MID_INCLUDE:ST_DEF.INC' COMMON/VMR/MADRID INCLUDE 'MID_INCLUDE:ST_DAT.INC' do i=1,NMXLIN ifound(i)=0 ix(i)=0 jx(i)=0 do j=1,4 IPar(j,i)=0 end do end do do i=1,4 do j=1,NROWS call CnvrtP(CPar(i,j),IPar(i,j),a,is) ni=IPar(i,j) if (ifound(ni).eq.0.and.a.ne.'Z'.and.a.ne.'T') then !never found yet nor constrained ifound(ni) =1 jx(ni)=j end if end do end do do j=1,NROWS LamIni(j)=LamIni(jx(IPar(1,j)))*CoefL(j) NIni(j)=NIni(jx(IPar(2,j)))*CoefN(j) BIni(j)=BIni(jx(IPar(3,j)))*CoefB(j) BtuIni(j)=BtuIni(jx(IPar(4,j)))*CoefBt(j) end do return end C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& SUBROUTINE FCNHd C C Writes an ascii file 'fdummy.fcn' C with the information required C by FCN to convert MINUIT parameters into line C parameters. C C C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& implicit none include 'MID_REL_INCL:fit_var.inc' integer i,j,Ipar(4,NMXLIN),ista character a C include 'MID_REL_INCL:fit_mid.inc' INTEGER MADRID(1) INCLUDE 'MID_INCLUDE:ST_DEF.INC' COMMON/VMR/MADRID INCLUDE 'MID_INCLUDE:ST_DAT.INC' C!!!!!!! C gets parameter numbers C!!!!!!! do i=1,4 do j=1,NROWS call CnvrtP(CPar(i,j),IPar(i,j),a,ista) end do end do C!!!!!!! C Apre il file fdummy.fcn cancellando il vecchio C!!!!!!! 40 continue open(20,file='fdummy.fcn',status='old',iostat=ista) close(20,status='delete') open(20,file='fdummy.fcn',status='new',iostat=ista) write(20,*)NROWS do j=1,NROWS write(20,101)(IPar(i,j),i=1,4),CoefL(j),CoefN(j),CoefB(j), 1 CoefBt(j),AtmLam(j),AtmFos(j),AtmGam(j) end do write(20,*)NINTFT do j=1,NINTFT write(20,*)FITMIN(j),FITMAX(j) end do close(20) c 101 format(4I3,x2,G16.8,x2,F4.1,x2,G16.8E2,x2,F4.1,x2,F11.4,x2, c 1 F9.5,x2,G13.5) 101 format(4I3,7G16.8) return end C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& SUBROUTINE SETERR(choice) c c sets error behaviour c c choice: ON C OFF C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& character*(*) choice integer i1,i2,i3 if (choice.eq.'OFF') then i1=1 !doesn't stop on errors i2=0 i3=0 call STECNT('PUT',i1,i2,i3) endif if (choice.eq.'ON') then i1=0 !stop on errors i2=2 i3=1 call STECNT('PUT',i1,i2,i3) endif return end