C @(#)backly.for 17.1.1.1 (ESO-IPG) 01/25/02 17:16:20 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 program backly implicit none include 'MID_REL_INCL:fit_var.inc' ! keywords coming from line character*80 SPESYS,INPSYS,HISSYS,OUTSYS integer GRASYS INTEGER IDrun(10000) ! ID of the fits to be executed integer ist,i,ijk,iok,nj,j,Nidrun,indx_i,indx_o integer TabID,i1,i2,i3,i4,icol(20) logical la character*80 filnam,sjunk 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 MIDAS SET-UP C!!!!!!! call STSPRO('backly') call STKRDC('SPECTAB',1,1,80,i,SPESYS,ijk,ijk,iok) !Input spectrum if (iok.ne.0) then call ErrMsg('Error in reading keywords: check context..') call STSEPI() stop end if call STKRDC('INPUTC',1,1,20,i,INPSYS,ijk,ijk,iok) ! Input histtab if (iok.ne.0) then call ErrMsg('Error in reading keywords: check context..') call STSEPI() stop end if call STKRDC('OUTTAB',1,1,80,i,OUTSYS,ijk,ijk,iok) !Output results if (iok.ne.0) then call ErrMsg('Error in reading keywords: check context..') call STSEPI() stop end if call STKRDC('HISTAB',1,1,80,i,HISSYS,ijk,ijk,iok) !Output history if (iok.ne.0) then call ErrMsg('Error in reading keywords: check context..') call STSEPI() stop end if call STKRDI('GRAWIN',1,1,i,GRASYS,ijk,ijk,iok) !Graphics if (iok.ne.0) then call ErrMsg('Error in reading keywords: check context..') call STSEPI() stop end if C!!!!!!! C Videata iniziale C!!!!!!! call DisMsg('Loading data...') call DisMsg('Wait please..') C!!!!!!! C Inizializzazione programma C!!!!!!! call AtmRD(ist) !read atompar.dat NPUNTI=NMXSPE call reaspe(SPESYS,NPUNTI) !reads spectrum if (NPUNTI.lt.1) goto 666 ! reads input history to get IDrun indx_i=index(INPSYS,' ') filnam=INPSYS(1:indx_i-1)//PARTBL call TBTOPN(filnam,F_IO_MODE,TabID,ist) !open table call TBLSER(TabID,'ID',icol(1),ist) i1=1 !doesn't stop on errors i2=0 i3=0 call STECNT('PUT',i1,i2,i3) call TBIGET(TABID,i1,i2,i3,i4,nj,ist) !n. of rows j=0 do i=1,nj call TBSGET(TABID,i,la,ist) ! selected? if (la) then call TBERDI(TABID,i,icol(1),j,la,ist) !reads element IDrun(j) = j end if end do call TBTCLO(TABID,ist) Nidrun = j c write(sjunk,*)Nidrun c call sttdis(sjunk,0,ist) c do j=1,Nidrun c write(sjunk,*)idrun(j) c call sttdis(sjunk,0,ist) c end do indx_o=index(HISSYS,' ') !Reads output history filnam=HISSYS(1:indx_o-1)//PARTBL call GETIDN(filnam,IDnum,ist) if (ist.ne.0) then call WrnMsg('Log files not found: starting from scratch') IDnum=0 end if C#### C Main loop : executes minimizations C#### do j=1,Nidrun if (IDrun(j) .ne. 0 ) then !reads from input history files filnam=INPSYS(1:indx_i-1)//PARTBL call f_tblr(filnam,IDrun(j),ist) if (ist.ne.0) then call ErrMsg('Error in reading parameter table') call STSEPI() stop end if filnam=INPSYS(1:indx_i-1)//MINTBL call rminui(filnam,IDrun(j),ist) if (ist.ne.0) then call ErrMsg('Error in reading minuit command table') call STSEPI() stop end if filnam=INPSYS(1:indx_i-1)//LIMTBL call rintvl(filnam,IDrun(j),ist) if (ist.ne.0) then call ErrMsg('Error in reading interval table') call STSEPI() stop end if call f_tblw(PARTBL,1,ist) ! save on standard tables call ssetup(PARTBL,ist) call sminui(MINTBL,1,ist) call sintvl(LIMTBL,1,ist) ! Executes minimization call FitWin(i,iok) ! create data for FCN if (iok.lt.0) then call ErrMsg('Error in initial condition for fit') call STSEPI() stop end if call FCNHd() call MinuHd() call DisMsg('...Done') c write(sjunk,*)i c call sttdis(sjunk,0,ist) write(sjunk,'(a25,i6)')'Number of pixel selected:',i call sttdis(sjunk,0,ist) call DisMsg(sjunk) C Esegue il fit call DisMsg('Executing fitting procedures...') call Minmze() call DisMsg('...Done') C Presenta e salva i risultati call GraMai(iok) call ShoRes C SAVE IDnum=IDNum+1 call SavRes(OUTSYS,ist) !saves on output history file filnam=HISSYS(1:indx_o-1)//PARTBL call f_tblw(filnam,IDNum,ist) filnam=HISSYS(1:indx_o-1)//MINTBL call sminui(filnam,IDNum,ist) filnam=HISSYS(1:indx_o-1)//LIMTBL call sintvl(filnam,IDNum,ist) write(sjunk,'(a17,i6)')'Saved with ID = ',IDnum call DisMsg(sjunk) end if end do 666 continue call STSEPI() end