C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C FIDFIT - FID fitting in the time domain C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C This is a modified version of the program DECAYSBN with operation C as described in: C C J.Haekel and H.Mader, "Determination of Spectral Parameters in Microwave C Spectroscopy by Analysis of Time-Domain Signals" C Z.Naturforsch. 43a,203-206(1988) C C DECAYSBN was written by Juergen Haekel, a PhD student of Heinrich Mader C at the Institut fur Physikalische Chemie of the University of Kiel, Germany. C C The program allows line by line fitting of Microwave Fourier Transform C data directly in the time-domain. There are many uses, such as removal of C strong lines from the spectrum or the determination of the relaxation parameter C T2 with statistics. C C C FIDFIT keeps the internal workings of DECAYSBN unchanged, while bringing it C into the XXIst century. Binary spectral files are in the standard used C by the VKIEL program, which can be used to inspect/modify the results of FIDFIT. C C original DECAYSBN code, ca 1990 ----- Juergen HAEKEL ----- C FIDFIT v.30.VII.2019 ----- Zbigniew KISIEL ----- C C C __________________________________________________ C | Institute of Physics, Polish Academy of Sciences | C | Al.Lotnikow 32/46, Warszawa, POLAND | C | kisiel@ifpan.edu.pl | C | http://info.ifpan.edu.pl/~kisiel/prospe.htm | C_________________________/-------------------------------------------------- C C C Modifications made in resurrecting DECAYSBN: C C - Code brought together by concatenation of the fortran files: C DECAYSBN.FOR IO4.FOR SUB5.FOR S1N.FOR C as found on the KIEL_CD of legacy KIEL laboratory data, in directory DISKS C C - Changes in routine EIN and AUS to read the I*4 rather than R*8 data points in C binary input/output C C - Parameter IN in all AUS and EIN routines (and in DOPP) changed to INpfil C since IN is now a reserved specifier for the FORTRAN-90 INTENT construct C C - Obsolete FORTRAN5 keywords removed (those were already commented out) C C - Tabs converted to spaces, more commenting and cleaning up of code layout C C------------------------------------------------------------------------------- C c Modification history: c C 30.07.19: Creation C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C HAEKEL 07.01.1986 VARIATION MIT COMPLEXEN ZAHLEN C C HAEKEL 20.03.1986 VARIATION FUER LINMAX LINIEN C C HAEKEL 26.03.1986 UMGESCHRIEBEN ZUM HAUPTPROGRAMM C C HAEKEL 25.04.1986 AUSGABE AUCH AUF FILES C C HAEKEL 2.10.1986 UMBAU FUER PC (GEKUERZT U. ERW.) C C DATEN VON INTEGER*2 AUF REAL*8 UMFORMATIERT C C ' DECAYFIT 1' C C HAEKEL 4.12.1986 TEXT UEBERARBEITET C C HAEKEL 26.02.1987 DECAY 3.01: FUER 4K MESSPUNKTE UND C C AUSGABE DES MESSPROGRAMMS FUER DIE PC'S C C HAEKEL 27.01.1989 DECAYSBN 1: C C HAEKEL 12.05.1989 DECAYSBN 2: KORREKTUR DER BERECHNETEN C C AMPLITUDEN- U. PHASENKORREKTUREN (SIEHE DOKTORARB.) C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C UNTERPROGRAMME: C C C C IO4: INPUT/OUTPUT VON DATENSAETZEN MIT: C C EINGABE C C EIN : KURZFORMAT C C EINA : ASCII-FILES C C EINAB: ASCII-FILES MIT `BESTMANN`-PROGRAMM GEMESSEN C C EINAR: MESSFILES ZUR BESTIMMUNG VON RELAXATIONSZEITEN C C AUSGABE DER RESIDUEN: C C AUS : KURZFORMAT C C AUSA : ASCII-FILE C C C C SUB5: SONSTIGE UNTERPROGRAMME: C C ABL5 : BERECHNUNG DER MATRIX FUER DIE FITROUTINE UEBER C C DIE ABLEITUNGEN NACH DEN FITPARAMETERN. C C FIT6 : FITROUTINE C C ACHTUNG(!): NICHT DIE STANDARDFITROUTINE: C C EIN TEIL DER BERECHNUNGEN MUESSEN IM HAUPTPROGRAMM C ODER IN ANDEREN UNTERPROGRAMMEN DURCHGEFUERT C C WERDEN, DA SONST ZU GROSSE ARRAYS ANGELEGT C C WERDEN MUESSTEN. C C SIM2 : SIMULATION EINES DECAYS UND ADDITION ZU ODER C C SUBTRAKTION VON EINEM ANDEREN DECAY. BERECHNUNG C C DES STANDARDABWEICHUNGSQUDRATS. C C DOPP : DOPPLERKORREKTUR,BASELINEKORREKTUR,BERECHNUNG C C VON STARTWERTEN FUER PHASE UND AMPLITUDE C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C FIT NACH DEM PRINZIP DES KLEINSTEN FEHLERQUADRATS AN: C C DATEN(I)=A*COS(FREQ*IS*I+PHASE)* C C *EXP(-IS*I*(T2+((T22+DOPPL)*(2*DELAY+IS*I)))) C C FITPARAMETER: AMPLITUDE:A C C PHASE :PHASE C C FREQUENZ :FREQ C C 1/RELAXATIONSZEIT:T2 C C d(1/RELAXATIONSZEIT)/d(IS*I):T22 C C KONSTANTEN: IS=SAMPLEINTERVALL IN NS C C I=DATENPUNKTNUMMER C C DELAY=ZEIT ZWISCHEN PULSENDE UND MESSBEGINN C C DOPPL=BERECHNETER WERT FUER DOPPLERVERBREITERUNG C C (SIEHE SUBROUTINE DOPP) C C BIS ZU 30 LINIEN GLEICHZEITIG FITBAR; DABEI WIRD IMMER NUR C C EINE LINIE ZUR ZEIT GEFITTET D.H. MIT HILFE DER ERSTEN C C ABLEITUNGEN NACH DEN FITPARAMETERN WERDEN KORREKTURWERTE C C BERECHNET. ERGIBT EINE KORREKTUR DER PARAMETER EINE AB- C C WEICHUNGSQUADRATSUMME, DIE NICHT UM EINEN BESTIMMTEN FAKTOR C C KLEINER IST ALS DIE VORHERIGE, SO WIRD EINE KORREKTUR MIT C C HALBIERTEN KORREKTURWERTEN VERSUCHT. NACH 4-MALIGER C C (4=ICORMX-1) HALBIERUNG WIRD DER FIT OHNE KORREKTUR C C BEENDET. ES IST MOEGLICH EINE LINIE MEHR ALS EINMAL ZU FITTEN, C WAS BEI STARKEN LINIEN NEBEN SCHWACHEN SINNVOLL SEIN KANN, C C DA DIE KORREKTUR JA NUR AUF DEN ERSTEN ABLEITUNGEN BERUHT. C C DER SO BERECHNETE DECAY DER LINIE WIRD VOM GEMESSENEN DECAY C C ABGEZOGEN UND DIE NAECHSTE LINIE ANGEPASST. SIND SO ALLE C C LINIEN EINMAL ANGEPASST UND IHRE SIMULIERTEN DECAYS VOM C C GEMESSENEN DECAY ABGEZOGEN, SO WIRD DER SIMULIERTE DECAY C C DER ERSTEN LINIE ZUM RESTDECAY (=RESIDUUM) ADDIERT UND DIE C C ERSTE LINIE NOCH EINMAL ANGEPASST UND EIN NEUER SIMULIERTER C C DECAY WIEDER ABGEZOGEN. ENTSPRECHEND WIRD MIT ALLEN LINIEN C C VERFAHREN UND DIE PROZEDUR WIRD MEHRFACH WIEDERHOLT. C C DADURCH WIRD DER FEHLER IN DER ANPASSUNG DER EINZELLINIEN, C C DER DURCH DIE ANDEREN LINIEN HERVORGERUFEN WIRD, SUCZESSIVE C C VERRINGERT. DAS RESIDUUM WIRD AUF WUNSCH NACH DEM FIT ALS C C DATENFILE AUSGEGEBEN. C C C C MASSNAHMEN UM AUCH MIT NICHT SO GUTEN STARTWERTEN FITTEN ZU C C KOENNEN: C C IN DEN ERSTEN BEIDENSUPERZYKLEN WERDEN NUR DIE PHASEN UND C C DIE AMPLITUDEN ANGEPASST. DIE AENDERUNGEN DER FREQUENZ UND C C DER RELAXATIONSZEIT IN EINEM EIN-LINIEN-FIT DARF EINEN C C MAXIMALWERT NICHT UEBERSCHREITEN. C C C C ZYKLEN=ZAHL DER ANPASSUNGEN EINER LINIE BEVOR IHR SIMULIERTER C DECAY ABGEZOGEN WIRD. (STANDARD=1) C C SUPERZYKLEN=ZAHL WIE OFT DER FIT UEBER ALLE LINIEN C C MAXIMAL WIEDERHOLT WIRD. (STANDARD=100) C C WIRD IN EINEM SUPERZYKLUS KEIN PARAMETER MEHR C C KORRIGIERT, SO WIRD NUR NOCH DER LETZTE SUPERZYKLUS C C DURCHGEFUEHRT, UM DIE ENDERGEBNISSE ABSPEICHERN ZU C C KOENNEN. C C " IQ " ERMOEGLICHT ES, EINZELNE FITPARAMETER AUS DEM FIT C C HERAUSZUNEHMEN. SIE BLEIBEN DANN KONSTANT. C C RESIDUEN: GEMESSENE - BERECHNETE DATEN C C C C SIEHE AUCH: BESCHREIBUNG DER STEUERPARAMETER C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C IMPLICIT INTEGER*2 (I-N) IMPLICIT REAL*8(A-H,O-Z) INTEGER*4 KPPI COMMON/DAT/DATENN(4096),AVGSUM(16),IKAVG REAL*8 U(6),V(6),SE(6),CO(6,6),VCOR(6),DNF(6),ARRAY(6,6), X DATEN(4096),DMF(6),AR(6,6) REAL*8 FREQE(30),FREQS(30),T2S(30),AS(30),PHASES(30) X ,RPAR(24),TE(30),AE(30),PE(30),TA2(30),TB2(30),TD2(30) X ,TDP2(30),FDP(30),T22(30),OM2(30),AVGS(16) INTEGER*2 IPAR(32),OUT,OUTA,OUTD,IQ(16),KQ(7),IDQ(7) X ,IQEIN(7),IFSTP(30),IQH(5) C ,IQR(7) INTEGER*4 IERR,hhflag COMPLEX*16 C1,C11 CHARACTER*24 FILND,FILNST,FILAR,FILBLK CHARACTER*2 DATE(3),APAR(128) CHARACTER*10 KENN,KENNA,SYS CHARACTER FRAG EQUIVALENCE(KENNA,APAR(24)) EQUIVALENCE(SYS,APAR(1)) C KENN='DECAYSBN2B' 1001 FORMAT(' ') c C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C INITIALISIEREN C C C Initialisation C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC c C PARAMETER AUF NULL SETZEN DO 1707 I=1,128 APAR(I)=' ' 1707 CONTINUE DO 1705 I=1,32 IPAR(I)=0 1705 CONTINUE DO 1706 I=1,24 RPAR(I)=0. 1706 CONTINUE c C "NOTKENNUNG" SYS='$$SYSD3.02' C " FFT:1K" IPAR(4)=512 C AUSGABE BILDSCHIRM OUT=6 IOUT=OUT C EINGABE TASTATUR INPAR=5 C BLOCKFILE IBLK=93 C ARRAY-FILE:FILAR OUTA=94 C STEUERFILE:FILNST INSTF=95 C EINLESEN MESSDATEN INFILE=96 C AUSGABE RESIDUEN ('RESTSPEKTREN') IOFILE=97 C AUSGABE PROTOKOLLFILE OUTD=99 C NRFILE=0 ISTFF=0 PI=2.D+00*DASIN(1.D+00) PI2=2.D+00*PI GOTO 117 c C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C STEUERUNG FUER: WEITERE DATENFILES C C C Control for: more data files C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C 22 CONTINUE IF(ISTEUER.EQ.1) GOTO 44 CLOSE(IOFILE) CLOSE(OUTD) WRITE(OUT,1111) 1111 FORMAT(' NEUER DATENFILE(Y=1)') READ(INPAR,'(BN,I4)') INDS user_input write(*,*) inds IF(INDS.EQ.1) GOTO 7117 STOP c C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C DATEN AUS STEUERFILE EINLESEN ALS OB SIE VOM BILDSCHIRM KAEMEN C C C Read data from control file as if it was from the screen C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C 117 WRITE(*,'(1x//)') WRITE(*,6002) 6002 FORMAT(' ',76(1H_)/' |',T79,'|'/ * ' | F I D F I T - FID FITting in the time domain',T79,'|'/ * ' |',T79,'|'/ * ' | Modification of the program DECAYSBN', * ' written by',T79,'|'/ * ' | Juergen HAEKEL (ca 1990, for operation see:', * T79,'|'/ * ' | J.Haekel and H.Mader, Z.Naturforsch. 43a,', * ' 203-206 (1988)',T79,'|'/ * ' |',76(1H_),'|'/' version 30.VII.2019',T64,'Zbigniew KISIEL'//) c WRITE(OUT,'(3X,A10)') KENN WRITE(OUT,7317) 7317 FORMAT(' AUSGABEFILES: NAME . NR DES DATENSATZES ') WRITE(OUT,1307) 1307 FORMAT(/,' STEUERFILE?(Y=1)',/) READ(INPAR,'(BN,I4)') ISTFF user_input write(*,*) istff IF(ISTFF.NE.1) GOTO 110 WRITE(OUT,1308) 1308 FORMAT( ' STEUERFILE: ',/ ) READ(INPAR,'(A24)') FILNST user_input write(*,*) filnst OPEN(INSTF,FILE=FILNST,IOSTAT=IERR) IF(IERR.NE.0)THEN WRITE(OUT,1400)IERR GOTO 117 ENDIF INPAR=INSTF c C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C PROTOKOLL-FILE EROEFFNEN C C C Open data file C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C 110 CONTINUE WRITE(OUT,1253) 1253 FORMAT(' ASCII-FILE:1,RELAX-FILE:2,BESTM.-ASCII-FILE:3,' X ,/,' KURZFORMAT:0 ') READ(INPAR,'(BN,I4)') IMUELL user_input write(*,*) imuell WRITE(OUT,1300) 1300 FORMAT( ' DATENAUSGABE FILE: ',/ ) READ(INPAR,'(A24)') FILND user_input write(*,*) filnd c JQ=21 DO 9010 I=1,20 FRAG=FILND(I:I) IF (FRAG.EQ.'.') JQ=I 9010 CONTINUE FILND(JQ:JQ)='.' JQ=JQ+1 7117 CONTINUE C******************** NRFILE=NRFILE+1 NQQ=NRFILE/100 NQQ1=(NRFILE-NQQ*100)/10 NQQ2=NRFILE-NQQ*100-NQQ1*10 FILND(JQ:JQ)=CHAR(NQQ+48) FILND(JQ+1:JQ+1)=CHAR(NQQ1+48) FILND(JQ+2:JQ+2)=CHAR(NQQ2+48) NRFILE=NRFILE-1 C******************** OPEN(OUTD,FILE=FILND,IOSTAT=IERR) IF(IERR.NE.0)THEN WRITE(OUT,1400)IERR 1400 FORMAT(' OPEN FILE ERROR ',I4) GOTO 110 ENDIF WRITE(OUTD,14001) FILND 14001 FORMAT(' PROTOKOLLFILE:',A24) WRITE(OUTD,'(A10)') KENN C WRITE(OUTD,7814) C 7814 FORMAT(' DIE ANGEGEBENEN STANDARDFEHLER GELTEN NUR' C X ,/,' FUER ISOLIERTE LINIEN UND GIBT AUCH DORT NICHT' C X ,/,' UNBEDINGT DIE REPRODUZIERBARKEIT DER MESSUNG WIEDER') C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C INITIALISIEREN C C C Initialise C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C INEUFT=0 PNULL=0. IFITS=0 IBITF=0 IAUS=1 ISTAUS=0 ILA=0 IT2TST=0 IT2TS2=1 IT2TS3=0 BASESUM=0. TEMP=0. DELAY=0. DELAYI=0. IRLXA=0 IPA=1 LINES=1024 INDS=0 LINMAX=30 IZYKLEN=1 IZSUPM=100 IZPHAM=2 IZPHAA=IZPHAM IZPHAS=2 T2START=.1 RKL1=0.99998 RKL2=1.D+00 DT2M=0.5 DFREQM=20. ICORMX=5 LINJH=30 IMHZ=0 IPH=0 INF=0 ISTF=0 IDK=0 IKDOP=0 IKAVG=1 IFPAR=0 IT2G=0 IRLXA=0 IZS=0 IIQ=0 IDA=0 IDAS=0 T2MAXW=100. T2MINW=0. DO 1 I=8,16 IQ(I)=0 1 CONTINUE IQ(1)=4 IQ(2)=1 IQ(3)=2 IQ(4)=3 IQ(5)=4 IQ(6)=0 IQ(7)=5 C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C STEUERPARAMETER EINLESEN C C C Read control parameters C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C WRITE(OUT,1302) 1302 FORMAT( ' RESIDUEN ABSPEICHERN,WEITERE PARAMETER' X ,' ,SONDERFIT,DATENBLOCK(Y=1)',/) READ(INPAR,'(BN,4I4)') IRES,INF,IFITS,IBLOCK user_input C write(*,*) IRES,INF,IFITS,IBLOCK c IF(IBLOCK.EQ.1) THEN CLOSE(IBLK) WRITE(OUT,*) ' BLOCKFILE' READ(INPAR,'(A24)') FILBLK user_input OPEN(IBLK,FILE=FILBLK) ENDIF c IF(IRES.EQ.1) THEN WRITE(OUT,1753) 1753 FORMAT(' RESIDUEN: ASCII-FILE:1,KURZFORMAT:0 ') READ(INPAR,'(BN,I4)') IMUEL2 user_input write(*,*) imuel2 ENDIF C IF(INF.EQ.1) THEN WRITE(OUT,13021) 13021 FORMAT(' STOERUNG FITTEN,DECAY KUERZEN,', X ' DOPPLERKORREKTUR,' X ,/,' AVERAGERKORR.', X ' (1=BESTM.,2= 20 ns KLEIB./AND.,4=10 ns KLEIB./AND.,),' X ,/,' ALLE EINGEGEBENEN LINIEN VOR FITBEGINN ABZIEHEN,' X ,/,' KEINE AUSFUEHRLICHE BILDSCHIRMAUSGABE,' X ,/,' BITFEHLER KORRIGIEREN(Y=1)') READ(INPAR,'(BN,7I4)') ISTF,IDK,IKDOP, user_input * IKAVG,ILA,IAUS,IBITF write(*,*) ISTF,IDK,IKDOP,IKAVG,ILA,IAUS,IBITF IKAVG=IKAVG*4 IF(IKAVG.LE.0) IKAVG=1 ENDIF c IF(IAUS.EQ.1) THEN IAUS=0 ELSE IAUS=1 ENDIF C IF(IDK.EQ.1) THEN WRITE(OUT,1303) 1303 FORMAT(' ERSTER,LETZTER DATENPUNKT:') READ(INPAR,'(BN,2I8)') IPA,LINES user_input write(*,*) IPA,LINES ENDIF C IF(IBITF.EQ.1) THEN WRITE(OUT,1316) 1316 FORMAT(' FAKTOR (INTEGER) UM DEN BITFEHLER', X ' UEBER DEM RAUSCHEN:') READ(INPAR,'(BN,I8)') IBITFP user_input ENDIF C IF(INF.EQ.1) THEN WRITE(OUT,1699) 1699 FORMAT(' DIVERSE FITPARAMETER,1/T2-GRENZEN,',/ X ,' AUSGABE FUER RELAX.-MESS.,ZYKLEN SETZEN,',/ X ,' IQ NEU SETZEN,DRUCKABH. PARAMETER,',/ X ,' ZUSAETZLICHER 1/T22 FIT(Y=1)',/) READ(INPAR,'(BN,7I4)') IFPAR,IT2G,IRLXA, user_input * IZS,IIQ,IDA,IT2TST write(*,*) IFPAR,IT2G,IRLXA,IZS,IIQ,IDA,IT2TST IF(IRLXA.EQ.1) RKL1=.9999998 IF(IT2TST.GE.1) THEN WRITE(OUT,1325) 1325 FORMAT(' ZAHL DER 1/T22-FITS:') READ(INPAR,'(BN,I8)') IT2TSI user_input ENDIF C IF(IIQ.NE.1) GOTO 11703 WRITE(OUT,1700) 1700 FORMAT(' EINGABE IQ(1-6),STANDARD=4,1,2,3,4,0' X ,/,' STEUERPARAMETER FUER DEN FIT DER LINIE' X ,/,' IQ(2-5)=0, WENN ZUGEHOERIGER PARAMETER NICHT' X ,/,' GEFITTET WERDEN SOLL, SONST GANZE ZAHL, BEI 1' X ,/,' BEGINNEND IN AUFSTEIGENDER REIHENFOLGE' X ,/,' IQ(1)= ZAHL DER PARAMETER,IQ(2)=AMPL,IQ(3)=1/T2,' X ,/,' IQ(4)=PHASE,IQ(5)=FREQ,IQ(6)=d(1/T2)/dt' X ,/,' z.B.: EINGABE FUER " PHASE SOLL NICHT GEFITTET' X ,/,' WERDEN": 3,1,2,0,3,0',/) READ(INPAR,'(BN,6I4)') (IQ(I),I=1,6) user_input IF(IQ(1).LE.0) THEN IQ(1)=4 IQ(2)=1 IQ(3)=2 IQ(4)=3 IQ(5)=4 IQ(6)=0 ENDIF IQ(7)=IQ(1)+1 11703 CONTINUE C IF(IFPAR.NE.1) GOTO 11704 WRITE(OUT,7003) 7003 FORMAT(' ICORMX,RKL1,RKL2,DT2M,DFREQM,T2START',/ X ,' STANDARD:5,0.99998,1.,0.5,20.,.1',/ X ,' ICORMX: ZAHL WIE OFT KORREKTURWERTE MAXIMAL HALBIERT WERDEN', X /,' RKL1: FAKTOR DER ERZWINGT,DASS DIE SUMME DER ABWEICHUNGS-',/ X ,' QUADRATE BEI JEDEM FIT KLEINER WERDEN MUSS. DIE',/ X ,' ALTE SUMME MAL RKL1 MUSS KLEINER/GEICH DER NEUEN',/ X ,' SUMME SEIN.',/ X ,' RKL2: RKL1 FUER LETZTEN SUPERZYKLUS',/ X ,' DT2M,DFREQM:2*MAXIMALE AENDERUNG VON 1/T2 UND DER ',/ X ,' FREQUENZ[KHZ]!! IN EINEM FITZYKLUS',/ X ,' T2START: STARTWERT:1/T2',/) READ(INPAR,'(BN,I4,5F20.14)') ICORMX,RKL1,RKL2 user_input X ,DT2M,DFREQM,T2START 11704 CONTINUE C IF(IT2G.NE.1) GOTO 11705 WRITE(OUT,1704) 1704 FORMAT(' OBERE GRENZE,UNTERE GRENZE FUER 1/T2',/, X ' (VORSCHLAG:0.1,0.0)',/) READ(INPAR,'(BN,2E16.9)') T2MAXW,T2MINW user_input T2MAXW=T2MAXW/1000. T2MINW=T2MINW/1000. 11705 CONTINUE ENDIF C IF(ISTF.EQ.1) THEN WRITE(OUT,1771) 1771 FORMAT(' EINGABE IDQ(1-6),STANDARD=2,1,0,2,0,0' X ,/,' STEUERPARAMETER FUER DEN FIT DER STOERUNG' X ,//,' IDQ(2-5)=0, WENN ZUGEHOERIGER PARAMETER NICHT' X ,/,' GEFITTET WERDEN SOLL, SONST GANZE ZAHL, BEI 1' X ,/,' BEGINNEND IN AUFSTEIGENDER REIHENFOLGE' X ,/,' IDQ(1)= ZAHL DER PARAMETER,IDQ(2)=AMPL,IDQ(3)=1/T2,' X ,/,' IDQ(4)=PHASE,IDQ(5)=FREQ' X ,/,' z.B.: EINGABE FUER " PHASE SOLL NICHT GEFITTET' X ,/,' WERDEN": 3,1,2,0,3,0',/) READ(INPAR,'(BN,6I4)') (IDQ(I),I=1,6) user_input IF(IDQ(1).LE.0) THEN IDQ(1)=2 IDQ(2)=1 IDQ(3)=0 IDQ(4)=2 IDQ(5)=0 IDQ(6)=0 ENDIF IDQ(7)=IDQ(1)+1 WRITE(OUT,1318) 1318 FORMAT(' ZAHL DER LINIEN (OHNE STOERUNGEN):') READ(INPAR,'(BN,I4)') LINJH user_input WRITE(OUT,1378) 1378 FORMAT(' DIE STOERUNGEN MUESSEN NACH DEN EIGENTLICHEN LINIEN' X ,/,' WIE LINIEN EINGEGEBEN WERDEN. LINIENZAHL=LINIEN+STOERUNGEN') IF(LINJH.LE.0) LINJH=1 ENDIF C IF(IRLXA.EQ.1) THEN 1397 WRITE(OUT,1387) 1387 FORMAT( ' ARRAY-FILE: ',/ ) READ(INPAR,'(A24)') FILAR user_input OPEN(OUTA,FILE=FILAR,STATUS='NEW',IOSTAT=IERR) IF(IERR.NE.0)THEN WRITE(OUT,1400)IERR GOTO 1397 ENDIF ENDIF C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C ZYKLEN SETZEN C C C Set cycles C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C IF(IZS.EQ.1) THEN WRITE(OUT,6363) READ(INPAR,'(BN,3I8)') INSUPM,INYKLEN,IZPHAM user_input IZPHAA=IZPHAM 6363 FORMAT(' SUPERZYKLEN,ZYKLEN,SUPERZYKLEN ' X ,' FUER PHASENKORR.',/, X ' STANDARD:100,1,2',/, X ' ZYKLEN:FITZYKLEN FUER EINE EINZELNE LINIE',/, X ' SUPERZYKLEN:FITZYKLEN UEBER ALLE LINIEN',/) IF(INSUPM.GT.0) IZSUPM=INSUPM IF(INYKLEN.GT.0) IZYKLEN=INYKLEN ENDIF C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C SONDERFIT C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C IF(IFITS.EQ.1) THEN WRITE(OUT,1343) 1343 FORMAT(' FIT FUER ALLE LINIEN GLEICHZEITIG:',/, X ' DELAY,PHASE BEI PULSENDE,RELAXATIONSZEIT(Y=1)',/) READ(INPAR,'(3I4)') (IQH(I),I=4,2,-1) user_input IQH(1)=IQH(2)+IQH(3)+IQH(4) IQH(3)=IQH(3)*(IQH(2)+1) IQH(4)=IQH(4)*(IQH(3)+1) IQH(5)=IQH(1)+1 WRITE(OUT,1344) 1344 FORMAT(' STARTWERTE:DELAY[NS],PHASE AM PULSENDE,1/T2', X /,' NUR DELAY UNBEDINGT NOETIG') READ(INPAR,'(3F20.6)') DELAYI,PNULLI,T2ALLI user_input IF((IDA.EQ.1).AND.(IQH(2).GE.1)) THEN IDA=0 IDAS=1 WRITE(OUT,13431) 13431 FORMAT(' RELAXATIONSZEIT:ACHSENABSCHNITT,STEIGUNG') READ(INPAR,'(2E20.10)') TAALLI,TBALLI user_input ENDIF IF(IQH(2).EQ.1) THEN DO 13441 I=1,7 IQ(I)=IQ(I)-1 13441 CONTINUE IQ(2)=IQ(2)+1 IQ(3)=0 ENDIF IF((IQH(3).GT.0).OR.(IQH(4).GT.0)) THEN IZPHAM=IZPHAS+IZPHAM IQ(1)=IQ(1)-1 IQ(5)=IQ(5)-1 IQ(6)=IQ(6)-1 IQ(7)=IQ(7)-1 IQ(4)=0 ENDIF DO 13442 I=1,7 IF(IQ(I).LT.0) IQ(I)=0 13442 CONTINUE ENDIF c C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C EINGABE DER STARTPARAMETER C C C Input of starting parameters C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C 33 WRITE(OUT,61) DOMEGM=DFREQM*2.*PI/(1000.*1000.) DT2ME=DT2M/1000. 61 FORMAT(' LINIENZAHL:',/) no of lines C ZYKLEN:FITZYKLEN FUER EINE EINZELNE LINIE C SUPERZYKLEN: >1 NUR SINNVOLL WENN WICHTUNG ODER MEHRERE LINIEN C GIBT AN,WIE OFT DIE FITPROZEDUR UEBER ALLE LINIEN C WIEDERHOLT WIRD 62 FORMAT(I4,' . FREQUENZ(MHZ),1/T2,AMPLITUDE,PHASE',/ X ,' NUR FREQUENZ UNBEDINGT NOETIG',/) 63 FORMAT(' TA2,TB2,TD2,TDP2,FDP ',/) READ(INPAR,'(BN,I4)') LINM user_input IF(LINJH.GT.LINM) LINJH=LINM IZPHA1=IZPHAM+1 IF((IAUS.EQ.1).OR.(IZSUP.EQ.IZSUPM)) WRITE(OUT,1001) IF(LINM.GT.0) LINMAX=LINM c DO 7 I=1,LINMAX WRITE(OUT,62) I READ(INPAR,'(4F16.6)') FREQE(I),TE(I),AE(I),PE(I) user_input write(*,*) FREQE(I),TE(I),AE(I),PE(I) IF(TE(I).NE.0) TE(I)=TE(I)/1000. PE(I)=PE(I)*2.*PI/360. IF(IDA.EQ.1) THEN WRITE(OUT,63) READ(INPAR,'(5F16.10)') TA2(I),TB2(I),TD2(I), user_input * TDP2(I),FDP(I) TA2(I)=TA2(I)/1000. TB2(I)=TB2(I)/1000. TD2(I)=TD2(I)/1.E+06 TDP2(I)=TDP2(I)/1.E+06 ENDIF IF((IAUS.EQ.1).OR.(IZSUP.EQ.IZSUPM)) WRITE(OUT,1001) 7 CONTINUE c CCC EINSCHUB CCCC DO 9527 I=1,7 IQEIN(I)=IQ(I) 9527 CONTINUE IKYKLEN=IZYKLEN c C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C EINLESEN DES DATENSATZES C C C Input of spectral data C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C 44 CONTINUE DO 95277 I=1,7 IQ(I)=IQEIN(I) KQ(I)=IQ(I) 95277 CONTINUE c IF(IMUELL.EQ.1)THEN ASCII file CALL EINA(OUTD,IOUT,INPAR,INFILE,ISTEUER,DATEN,APAR,IPAR,RPAR) IF(IDK.NE.1) LINES=IPAR(5) ELSE IF(IMUELL.EQ.3)THEN Bestmann ASCII file CALL EINAB(OUTD,IOUT,INPAR,INFILE,ISTEUER,DATEN,APAR,IPAR,RPAR) ELSE IF(IMUELL.EQ.2)THEN Binary relaxation file CALL EINAR(OUTD,IOUT,INPAR,INFILE,ISTEUER,DATEN,APAR,IPAR,RPAR) ELSE CALL EIN(OUTD,IOUT,INPAR,INFILE,ISTEUER,DATEN,APAR,IPAR,RPAR) Short format = binary spectral file IF(IDK.NE.1) LINES=IPAR(5) ENDIF ENDIF ENDIF c IF(ISTEUER.EQ.2) THEN ISTEUER=0 GOTO 22 ENDIF c IF(IFITS.EQ.1) INEUFT=1 ILAA=0 write(*,*) 'ipar(5) ',ipar(5) DO 9175 I=1,IPAR(5) DATENN(I)=DATEN(I) 9175 CONTINUE DO 7813 I=1,16 AVGSUM(I)=0. 7813 CONTINUE DELAY=0. IF(IBITF.EQ.2) IBITF=1 IS=IPAR(1) IF(IPA.LE.0) IPA=1 IF(LINES.LE.0) LINES=IPAR(5) WRITE(OUT,'(2(A,I4))') X ' AUSGEWERTET: DATENPUNKTE',IPA,' - ',LINES WRITE(OUTD,'(2(A,I4))') X ' AUSGEWERTET: DATENPUNKT',IPA,' - ',LINES C DATENFILE ZUENDE C BEARBEITUNG DES NEU EINGELESENEN DATENSATZES NRFILE=NRFILE+1 WRITE(OUTD,1112) NRFILE WRITE(OUT,1112) NRFILE 1112 FORMAT(' DATENSATZ NR.',I4) DELAY=DELAY*1000. FREQ=FREQE(1) c C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C INITIALISIEREN DES SONDERFITS C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C IF(IFITS.EQ.1) THEN IF(IQH(2).GT.0) THEN IF(IDAS.EQ.1) THEN T2ALLI=TAALLI+RPAR(6)*TBALLI ENDIF IF(T2ALLI.NE.0.) THEN T2ALL=T2ALLI/1000. T2START=T2ALLI ELSE T2ALL=T2START/1000. ENDIF ENDIF PNULL=PNULLI*PI/180. IF(DELAYI.NE.0.) DELAY=DELAYI ENDIF c C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C DOPPLER- + BASELINEKORREKTUR AMPL.+PHASENBEST. C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C IF(IRLXA.EQ.1) THEN WRITE(OUT,1579) RPAR(6) WRITE(OUTD,1579) RPAR(6) 1579 FORMAT(' DRUCK:',F6.2) ENDIF CALL DOPP(OUTD,INPAR,IPA,LINES,IKDOP,DATEN,APAR,IPAR,RPAR, <----- X FREQ,PHASE,A,TEMP,RMOL,DOPPL,DELAY) DOPPLS=0.D+00 IF(IDQ(3).NE.0) DOPPLS=DOPPL c C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C BESTIMMUNG DER STANDARDABWEICHUNG DES C C C UNGEFITTETEN DATENSATZES C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC c AVSUM=0. DO 77 I=IPA,LINES AVSUM=DATEN(I)*DATEN(I)+AVSUM 77 CONTINUE ASUM=AVSUM/DBLE(LINES-IPA+1) ASUM=DSQRT(ASUM) WRITE(OUT,1007) ASUM WRITE(OUTD,1007) ASUM 1007 FORMAT(' STANDARDABWEICHUNG VON DER NULLINIE:',11X,F16.4) ASUMALT=ASUM BSUM=ASUM c C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C INITIALISIEREN DES FITS C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C IT2TS3=IT2TSI DO 6 I=1,LINMAX IF(IPH.NE.1) PHASES(I)=PHASE FREQS(I)=FREQE(I) AS(I)=A/LINMAX T2S(I)=T2START/1000. IF((LINJH.LT.I).AND.(IDQ(3).EQ.0)) T2S(I)=0. IF(IDA.EQ.1) THEN T2S(I)=TA2(I)+RPAR(6)*TB2(I) ENDIF IF(TE(I).NE.0.) T2S(I)=TE(I) IF(AE(I).NE.0.) AS(I)=AE(I) IF(PE(I).NE.0.) PHASES(I)=PE(I) 6 CONTINUE IF(IDA.EQ.1) THEN DO 606 I=1,LINMAX T22(I)=TDP2(I)*RPAR(6)+TD2(I) OM2(I)=FDP(I)*RPAR(6)*2.*PI IF(I.GT.LINJH) THEN T22(I)=0. OM2(I)=0. ENDIF 606 CONTINUE ENDIF IF((IDA.EQ.0).AND.(IKDOP.EQ.1)) THEN DO 607 I=1,LINMAX T22(I)=0. OM2(I)=0. 607 CONTINUE ENDIF C CCCC EINSCHUB ENDE CCCC IFITSP=0 CCCCCCCCC ALLE EINGEGEBENEN LINIEN VOR FITBEGINN ABZIEHEN CCCCCCCCC IF(ILA.EQ.1) THEN DO 1125 LIN=1,LINMAX c C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C BESTIMMUNG DER JEWEILIGEN STARTWERTE C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC c T22F=T22(LIN) T2=T2S(LIN) FREQ=FREQS(LIN) A=AS(LIN) PHASE=PHASES(LIN) C C UMRECHNUNG FREQ->OMEGA OMEGA=FREQ*2.*PI/1000. FAK=-1.D+00 IF((LIN.GT.LINJH).AND.(IDQ(3).EQ.0)) THEN DOPPLI=0. ELSE DOPPLI=DOPPL ENDIF CALL SIM2(DATEN,PHASE,T2,OMEGA,A,IS,IPA, <----- X LINES,DELAY,T22F,OM2(LIN),FAK,VSUM,0,DOPPLI) 1125 CONTINUE ENDIF c C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C BEGINN FITSCHLEIFE SUPERZYKLEN C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C 9521 DO 952 IZSUP=1,IZSUPM C IF(IAUS.NE.1) WRITE(*,'(I8)') IZSUP IF(IZSUP.LE.IZPHA1) IFITSP=0 IF((IFITSP.EQ.1).AND.(IZSUP.LT.IZSUPM) X .AND.(IBITF.NE.1)) GOTO 952 CCCC EINSCHUB CCCCC IF(IZSUP.LE.IZPHAA) THEN IQ(1)=2 IQ(2)=1 IQ(3)=0 IQ(4)=2 IQ(5)=0 IQ(6)=0 IQ(7)=3 C IZYKLEN=3 IF((IFITS.EQ.1).AND.((IQH(3).GT.0).OR.(IQH(4).GT.0)).AND. X (IZSUP.GT.IZPHAA)) THEN IQ(1)=1 IQ(7)=2 IQ(4)=0 IZYKLEN=1 ENDIF ELSE DO 9528 I=1,7 IQ(I)=KQ(I) 9528 CONTINUE IZYKLEN=IKYKLEN ENDIF CCC EINSCHUB ENDE CCCCC DO 211 I=1,5 V(I)=0. SE(I)=0. 211 CONTINUE IF((IAUS.EQ.1).OR.(IZSUP.EQ.IZSUPM)) WRITE(OUT,1001) c C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C BEGINN FITSCHLEIFE UEBER ALLE LINIEN C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C 9511 DO 951 LIN=1,LINMAX IF(ISTF.EQ.1) THEN IF(IZSUP.LE.IZPHAM) THEN IQ(1)=2 IQ(2)=1 IQ(3)=0 IQ(4)=2 IQ(5)=0 IQ(6)=0 IQ(7)=3 IZYKLEN=3 IF(IZSUP.GT.1) IZYKLEN=1 IF((IFITS.EQ.1).AND.((IQH(3).GT.0).OR.(IQH(4).GT.0)).AND. X (IZSUP.GT.(IZPHAM-IZPHAS))) THEN IQ(1)=1 IQ(7)=2 IQ(4)=0 ENDIF ELSE IF(LIN.LE.LINJH) THEN DO 10203 I=1,7 IQ(I)=KQ(I) 10203 CONTINUE ELSE DO 10204 I=1,7 IQ(I)=IDQ(I) 10204 CONTINUE ENDIF IZYKLEN=IKYKLEN ENDIF ENDIF c C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C KORREKTUR DES DATEN-ARRAYS C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C IF((LIN.NE.1).OR.(IZSUP.NE.1)) THEN IF(NFAIL.NE.0) GOTO 5 FAK=-1.D+00 IF(((LIN.GT.LINJH+1).OR.((LIN.EQ.1).AND.(LINMAX.GT.LINJH))) X .AND.(IDQ(3).EQ.0)) THEN DOPPLI=0. IF((IAUS.EQ.1).OR.(IZSUP.EQ.IZSUPM)) WRITE(OUT,1718) IF((IZSUP.EQ.IZSUPM).AND.(LIN.NE.1)) X WRITE(OUTD,1718) 1718 FORMAT(' LETZTE LINIE OHNE DOPPLERKORR.') ELSE DOPPLI=DOPPL ENDIF CALL SIM2(DATEN,PHASE,T2,OMEGA,A,IS,IPA, <----- X LINES,DELAY,T22F,OM2(LIN),FAK,VSUM,0,DOPPLI) ENDIF 5 CONTINUE CCCC BASELINEKORREKTUR ODER SPEICHERKORREKTUR CCCC IF(LIN.EQ.1) THEN DO 9733 L=1,16 AVGS(L)=0. 9733 CONTINUE DO 9731 I=IPA-1,LINES-1,IKAVG DO 9732 L=1,IKAVG IF((I+L).LE.LINES) X AVGS(L)=AVGS(L)+DATEN(I+L) 9732 CONTINUE 9731 CONTINUE DO 9737 L=1,IKAVG AVGS(L)=AVGS(L)*DFLOAT(IKAVG)/DBLE(LINES-IPA+1) 9737 CONTINUE IF(IAUS.EQ.1) WRITE(OUT,9734) (AVGS(L),L=1,IKAVG) 9734 FORMAT(' SPEICHERKORR.:',4E12.4) DO 9738 L=1,IKAVG AVGSUM(L)=AVGSUM(L)+AVGS(L) 9738 CONTINUE IF(IZSUP.EQ.IZSUPM)WRITE(OUT,9739) (AVGSUM(L),L=1,IKAVG) 9739 FORMAT(' SPEICHERKORR. IN ALLEN SZ:',4E12.4) DO 9735 I=IPA-1,LINES-1,IKAVG DO 9736 L=1,IKAVG IF((I+L).LE.LINES) X DATEN(I+L)=DATEN(I+L)-AVGS(L) 9736 CONTINUE 9735 CONTINUE ENDIF CCCCCC ENDE BASELINE- ODER SPEICHERKORREKTUR CCCCCC c IF((IZSUP.EQ.IZSUPM).AND.(LIN.EQ.1).AND.(IFITS.NE.1)) THEN c C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C SUBTRAKTION DER AVERAGERKORR. UND DER LINIEN C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC c WRITE(*,*) ' RUECKGRIFF AUF ORIGINALDATEN' DO 97361 I=IPA-1,LINES-1,IKAVG DO 97361 L=1,IKAVG IF((I+L).LE.LINES) X DATEN(I+L)=DATENN(I+L)-AVGSUM(L) 97361 CONTINUE FAK=-1.D+00 DO 6731 LIN2=1,LINMAX OMEGA=FREQS(LIN2)*2.*PI/1000. A=AS(LIN2) T2=T2S(LIN2) PHASE=PHASES(LIN2) IF(LIN2.GT.LINJH) THEN DOPPLI=DOPPLS ELSE DOPPLI=DOPPL ENDIF CALL SIM2(DATEN,PHASE,T2,OMEGA,A,IS,IPA, <----- X LINES,DELAY,T22F,OM2(LIN2),FAK,VSUM,0,DOPPLI) 6731 CONTINUE ENDIF C IF(((IAUS.EQ.1).OR.(IZSUP.EQ.IZSUPM)).AND.(LIN.EQ.1)) X WRITE(OUT,1001) c C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C BITFEHLER KORRIGIEREN C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C IF((IFITSP.EQ.1).AND.(IBITF.EQ.1)) THEN IFITSP=0 IBITF=2 BITFP=ASUM*IBITFP DO 1317 I=IPA,LINES IF(ABS(DATEN(I)).GT.BITFP) THEN WRITE(OUT,1319) I,DATEN(I) WRITE(OUTD,1319) I,DATEN(I) 1319 FORMAT(' BITFEHLER IN DATENPUNKT ',I6,' KORRIGIERT', X ' VORHER:', F12.4) DATEN(I)=0. ENDIF 1317 CONTINUE ENDIF C IF(IZSUP.LE.IZPHAM-IZPHAS) GOTO 19371 c C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C SONDERFIT C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C IF((LIN.EQ.1).AND.(IFITS.EQ.1)) THEN IF((PNULL.EQ.0.).AND.(INEUFT.EQ.1)) THEN DO 134 LLIN=1,LINJH PMERK=PHASES(LLIN)-FREQS(LLIN)*DELAY*PI/500.D+00 PMERK=PMERK-2.D+00*PI*(DINT(PMERK/(2.D+00*PI))-1.D+00) IF(LLIN.EQ.1) THEN IPMERK=0 IF(PMERK.GT.4.5) IPMERK=1 IF(PMERK.LT.1.5) IPMERK=-1 ELSE IF((IPMERK.EQ.1).AND.(PMERK.LT.1.5)) PMERK=PMERK+PI2 IF((IPMERK.EQ.-1).AND.(PMERK.GT.4.5)) PMERK=PMERK-PI2 ENDIF PNULL=PNULL+PMERK 134 CONTINUE PNULL=PNULL/DFLOAT(LINJH) ENDIF IF(BSUM.GT.ASUM) BSUM=ASUM CALL S1N(DATEN,PHASES,T2S,FREQS,AS,IS,IPA, <----- X LINES,DELAY,T22,OM2,ARRAY,DNF,DOPPL,LINJH,IQH,PI, X IFSTPL,T2ALL,PNULL,OUT,IZSUP,IZYKLEN,ICORMX,IZSUPM, X RKL1,DT2ME,T2MAXW,T2MINW,AVSUM,IAUS,OUTD, X INEUFT,T2OUTF,LINMAX,DOPPLS) ILAA=1 INEUFT=0 ENDIF 19371 CONTINUE c C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C BESTIMMUNG DER JEWEILIGEN STARTWERTE C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C T22F=T22(LIN) T2=T2S(LIN) FREQ=FREQS(LIN) A=AS(LIN) PHASE=PHASES(LIN) C C UMRECHNUNG FREQ->OMEGA OMEGA=FREQ*2.*PI/1000. IF((A.LT.0.).AND.(IFITS.NE.1)) THEN A=-1*A PHASE=PHASE+PI2/2. ENDIF IF(PHASE.GT.PI2) PHASE=PHASE-PI2 IF(PHASE.LT.0.) PHASE=PHASE+PI2 IF(IZSUP.EQ.1) AVSUM=0. c C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C ADDITION DES ALTEN BERECHNETEN DECAYS C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C IF((IZSUP.NE.1).OR.(IZPHAM.LE.0).OR. X (ILA.EQ.1).OR.(ILAA.EQ.1)) THEN FAK=+1.D+00 IF((LIN.GT.LINJH).AND.(IDQ(3).EQ.0)) THEN DOPPLI=0. ELSE DOPPLI=DOPPL ENDIF CALL SIM2(DATEN,PHASE,T2,OMEGA,A,IS,IPA, <----- X LINES,DELAY,T22F,OM2(LIN),FAK,VSUM,0,DOPPLI) ENDIF c C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C BEGINN FITSCHLEIFE FUER EINE LINIE C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C DO 90 KZYKLEN=1,IZYKLEN CCCCCCCC INITIALISIEREN CCCCCCCCCCCCCCCC DO 8 K1=1,6 DNF(K1)=0. DMF(K1)=0. ARRAY(K1,K1)=1.D+00 AR(K1,K1)=1.D+00 NK1=K1+1.D+00 DO 9 K2=NK1,6 ARRAY(K1,K2)=0. AR(K1,K2)=0. 9 CONTINUE 8 CONTINUE CCCCC BERECHNUNG ARRAY,DNF MIT U(1)-U(5) CCCCCC IF((LIN.GT.LINJH).AND.(IDQ(3).EQ.0)) THEN DOPPLI=0. ELSE DOPPLI=DOPPL ENDIF IF(IQ(1).EQ.1) THEN DO 1275 I12=2,6 IF(IQ(I12).EQ.1) IMERK=I12-1 1275 CONTINUE ELSE IMERK=0 ENDIF IPKOPP=0 IF((IFITS.EQ.1).AND.(INEUFT.NE.1).AND.(IQH(4)+IQH(3).GT.0) X .AND.(LIN.LE.LINJH)) IPKOPP=1 CALL ABL5(DATEN,PHASE,T2,OMEGA,A,IS,IPA,IPKOPP, <----- X LINES,DELAY,T22F,OM2(LIN),ARRAY,DNF,DOPPLI, X IQ(1),IMERK,SOUT) IF((KZYKLEN.EQ.1).AND.(IZSUP.EQ.1)) X AVSUM=DNF(6) IF(IQ(1).NE.1) GOTO 95842 c C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C EINPARAMETERFIT C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C V(1)=ARRAY(IMERK,6)/DNF(IMERK) SE(1)=1.D+00/DSQRT(SOUT/(LINES-IPA)) GOTO 12751 c C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C ENDE EINPARAMETERFIT C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C 95842 CONTINUE DO 16 K1=1,6 DNF(K1)=1.D+00/DSQRT(DNF(K1)) 16 CONTINUE DO 14 IK1=1,5 NK1=IK1+1.D+00 DO 15 IK2=NK1,6 IF(IQ(IK1+1).EQ.0) THEN GOTO 14 ELSE K1=IQ(IK1+1) ENDIF IF(IQ(IK2+1).EQ.0) THEN GOTO 15 ELSE K2=IQ(IK2+1) ENDIF DMF(K1)=DNF(IK1) AR(K1,K2)=ARRAY(IK1,IK2)*DNF(IK1)*DNF(IK2) 15 CONTINUE 14 CONTINUE DMF(IQ(7))=DNF(6) DO 114 K1=1,5 NK1=K1+1 DO 115 K2=1,6 AR(K2,K1)=AR(K1,K2) 115 CONTINUE 114 CONTINUE NFAIL=0 CCCCCCCCCCC CALL FIT CCCCCCCCCCCC NVAR=IQ(1) NVAR1=NVAR+1 LINESM=LINES+1-IPA CALL FIT6(DMF,AR,V,NVAR,NVAR1,1024,LINESM,SE,CO,NFAIL) <----- IF(NFAIL.NE.0) THEN WRITE(OUT,1000) NFAIL 1000 FORMAT(' FIT NICHT OK,NFAIL=',I4) STOP ENDIF 12751 CONTINUE XCOR=2. CCCCCCCCCCC SICHERN DER ALTEN WERTE CCCCCCCCCCCCCCC AA=A AT2=T2 APHASE=PHASE AOMEGA=OMEGA AT22=T22F DO 50 IV=1,5 IF(IQ(IV+1).EQ.0) THEN VCOR(IV)=0. ELSE VCOR(IV)=V(IQ(IV+1))*2. ENDIF 50 CONTINUE ICOR=0 C PRO FITZYKLUS NUR FREQUENZAENDERUNGEN VON 50 KHZ C UND RELAXATIONSZEITAENDERUNGEN VON 0.5 MOEGLICH IF(VCOR(4).GT.DOMEGM) VCOR(4)=DOMEGM ROMEGM=-1.D+00*DOMEGM IF(VCOR(4).LT.ROMEGM) VCOR(4)=ROMEGM IF(VCOR(2).GT.DT2ME) VCOR(2)=DT2ME RT2M=-2.*DT2ME IF(VCOR(2).LT.RT2M) VCOR(2)=RT2M CCCC SCHLEIFE MIT FEHLERQUADRAT SOLL KLEINER WERDEN CCC IF(IPKOPP.EQ.1) VCOR(3)=VCOR(4)*DELAY 600 CONTINUE ICOR=ICOR+1 7001 continue IF ((ICOR.GE.ICORMX).or.(hhflag.eq.1)) THEN if (hhflag.eq.1) goto 700 A=AA T2=AT2 PHASE=APHASE OMEGA=AOMEGA T22F=AT22 700 CONTINUE hhflag=0 IF(KZYKLEN.EQ.1) THEN IFSTP(LIN)=1 ELSE IFSTP(LIN)=0 ENDIF IF(LIN.EQ.LINMAX) THEN IFITSP=1 IF(IFITS.EQ.1) IFITSP=IFSTPL DO 10501 I=1,LINMAX IFITSP=IFITSP*IFSTP(I) 10501 CONTINUE IF((IFITSP.EQ.1).AND.(IZSUP.LT.IZSUPM) X .AND.(IBITF.NE.1)) THEN CCCCCCCCCCC IF((IT2TST.GE.1).AND.(IT2TS2.GE.0).AND.(IT2TS3.GT.0) X .AND.(IZSUP.GT.IZPHA1)) THEN IFITSP=0 IT2TS3=IT2TS3-1 IT2TS2=-1 C DO 11511 I=1,7 C IQR(I)=IQ(I) C11511 CONTINUE KQ(1)=2 KQ(2)=0 KQ(3)=1 KQ(4)=0 KQ(5)=0 KQ(6)=2 KQ(7)=3 ELSE IF((IZSUP.GT.IZPHA1).AND.(IT2TST.GE.1)) THEN IF(IT2TS3.GE.1) IFITSP=0 IT2TS2=1 DO 11512 I=1,7 KQ(I)=IQEIN(I) C IQR(I) 11512 CONTINUE IF((IT2TST.GE.1).AND.(IT2TS3.LE.0)) THEN KQ(1)=KQ(1)+1 KQ(7)=KQ(7)+1 KQ(6)=KQ(1) IZYKA=IKYKLEN IKYKLEN=3 IZSUPPE=IZSUP ENDIF ELSE IZSUPPE=IZSUP ENDIF ENDIF ENDIF ENDIF GOTO 95 ENDIF DO 60 IV=1,5 IF(VCOR(IV).NE.0.) VCOR(IV)=VCOR(IV)/XCOR 60 CONTINUE T2=AT2+VCOR(2) IF(IT2G.EQ.1) THEN IF(T2.GT.T2MAXW) T2=T2MAXW IF(T2.LT.T2MINW) T2=T2MINW ENDIF IF((IFITS.EQ.1).AND.(A.LT.10.)) A=10. IF((VCOR(1).NE.0.0).AND.(VCOR(3).NE.0.0) X .AND.(IPKOPP.NE.1)) THEN DPMERK=DATAN((AA*VCOR(3))/(AA+VCOR(1))) PHASE=APHASE+DPMERK A=(AA+VCOR(1))/DCOS(DPMERK) ELSE A=AA+VCOR(1) PHASE=APHASE+VCOR(3) ENDIF OMEGA=AOMEGA+VCOR(4) T22F=AT22+VCOR(5) C WRITE(OUT,'(5E12.6)') A,T2,PHASE,OMEGA,T22F VSUM=0. FAK=+1.D+00 IF((LIN.GT.LINJH).AND.(IDQ(3).EQ.0)) THEN DOPPLI=0. ELSE DOPPLI=DOPPL ENDIF IF(A.LT.0.) THEN IF(IPKOPP.EQ.1) THEN A=10. ELSE A=-A PHASE=PHASE+PI ENDIF ENDIF CALL SIM2(DATEN,PHASE,T2,OMEGA,A,IS,IPA, <----- X LINES,DELAY,T22F,OM2(LIN),FAK,VSUM,1,DOPPLI) C FEHLERQUADRAT SOLL KLEINER WERDEN C WRITE(OUT,*) ' VSUM',VSUM,'AVSUM',AVSUM IF(VSUM.GT.AVSUM) GOTO 600 AVALT=AVSUM BSUM=AVSUM/DBLE(LINES-IPA+1) BSUM=DSQRT(BSUM) AVSUM=VSUM hhflag=0 IF(IZSUP.LT.IZSUPM) THEN IF (VSUM.GT.RKL1*AVALT) hhflag=1 ELSE IF (VSUM.GT.RKL2*AVALT) hhflag=1 ENDIF if (hhflag.eq.1) then write (*,*) hhflag goto 7001 end if IFSTP(LIN)=0 C IF(XCOR.LT.0.) GOTO 200 90 CONTINUE 95 CONTINUE ASUM=VSUM/DBLE(LINES-IPA+1) ASUM=DSQRT(ASUM) IC=ICOR-1 300 CONTINUE KZYK1=KZYKLEN-1 C FREQ=OMEGA*159.155 FREQ=OMEGA*1000./(2.*PI) c C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C SICHERUNG DER FITERGEBNISSE C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C KPPI=DINT(PHASE/PI2) IF(KPPI.NE.0) PHASE=PHASE-KPPI*PI2 FREQS(LIN)=FREQ T2S(LIN)=T2 AS(LIN)=A PHASES(LIN)=PHASE T22(LIN)=T22F c C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C AUSGABE DER FITERGEBNISSE C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C IF((IAUS.NE.1).AND.(IZSUP.NE.IZSUPM)) GOTO 951 T2OUT=T2*1000. PHAS=360.*PHASES(LIN)/PI2 T22OUT=T22F*1.E6 C DO 19174 IRI=5,1,-1 IF(IQ(IRI+1).GT.0) THEN SE(IRI)=SE(IQ(IRI+1)) C22.8 VCOR(IRI)=V(IQ(IRI+1)) ELSE SE(IRI)=0. C22.8 VCOR(IRI)=0. ENDIF 19174 CONTINUE C SE(5)=SE(5)*1.E6 SE(4)=SE(4)*1000./(2.*PI) SE(3)=360.*SE(3)/PI2 SE(2)=SE(2)*1000. VCOR(4)=VCOR(4)*1000./(2.*PI) VCOR(2)=VCOR(2)*1000. VCOR(3)=360.*VCOR(3)/PI2 VCOR(5)=VCOR(5)*1.E6 CCCCCCC AUSGABEFORMATE CCCCCCCCCCCC 9004 FORMAT(' SZ Z K FREQUENZ 1/T2(MHZ) AMPLITUDE PHASE', X ' d(1/T2)/dt STDABW. NEU/ALT') 19002 FORMAT(' FEHLER ',F10.6,F10.6,F10.2,F10.4,F10.6,F12.4) 19001 FORMAT(' LETZTE KORR. ',F8.6,F10.6,F10.2,F10.4,F10.6) C 29004 FORMAT(' SZ Z K FREQUENZ 1/T2(MHZ) AMPLITUDE PHASE', X ' STDABW. NEU/ALT') 29002 FORMAT(' FEHLER ',F10.6,F10.6,F10.2,F10.4,F12.4) 29001 FORMAT(' LETZTE KORR. ',F8.6,F10.6,F10.2,F10.4) c C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C UNTERSCHIEDLICHE AUSGABE FUER FITS C C C MIT UND OHNE DELAYABHAENGIGKEIT VON 1/T2 C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C IF(IT2TST.EQ.1) THEN CCCCCCCCCC AUSGABE DER ERGEBNISSE AUF DEN BILDSCHIRM CCCCCCCC IF((LIN.EQ.1).AND.((IAUS.EQ.1).OR.(IZSUP.EQ.1))) X WRITE(OUT,9004) IF(IFITSP.NE.1) IZSUPPE=IZSUP WRITE(OUT,'(3I4,F10.6,F10.6,F10.2,F10.4,F10.6,F12.4)') X IZSUPPE,KZYK1,IC,FREQS(LIN),T2OUT,AS(LIN),PHAS,T22OUT,ASUM WRITE(OUT,19002) SE(4),SE(2),SE(1),SE(3),SE(5),BSUM WRITE(OUT,19001) VCOR(4),VCOR(2),VCOR(1),VCOR(3),VCOR(5) CCCCCCCC AUSGABE DER ENDERGEBNISSE AUF FILES CCCCCCCCCCC IF((LIN.EQ.1).AND.(IZSUP.EQ.IZSUPM)) X WRITE(OUTD,9004) IF(IZSUP.EQ.IZSUPM) THEN WRITE(OUTD,'(3I4,F10.6,F10.6,F10.2,F10.4,F10.6,F12.4)') X IZSUPPE,KZYK1,IC,FREQS(LIN),T2OUT,AS(LIN),PHAS,T22OUT,ASUM WRITE(OUTD,19002) SE(4),SE(2),SE(1),SE(3),SE(5),BSUM WRITE(OUTD,19001) VCOR(4),VCOR(2),VCOR(1),VCOR(3),VCOR(5) IF((LIN.LE.LINJH).AND.(IRLXA.EQ.1)) THEN IF((SE(2).EQ.0.).AND.(IFITS.EQ.1).AND.(IQH(2).GT.0.)) X SE(2)=T2OUTF WRITE(OUTA,'(F12.4,F12.4,F12.8,F12.8,F16.8, X F12.8,F12.6,F12.6,F12.8,F12.8)') X RPAR(6),RPAR(4),T2OUT,SE(2),FREQS(LIN), X SE(4),PHAS,SE(3),T22OUT,SE(5) ENDIF ENDIF ELSE CCCCCCCCCC AUSGABE DER ERGEBNISSE AUF DEN BILDSCHIRM CCCCCCCC IF((LIN.EQ.1).AND.((IAUS.EQ.1).OR.(IZSUP.EQ.1))) X WRITE(OUT,29004) IF(IFITSP.NE.1) IZSUPPE=IZSUP WRITE(OUT,'(3I4,F10.6,F10.6,F10.2,F10.4,F12.4)') X IZSUPPE,KZYK1,IC,FREQS(LIN),T2OUT,AS(LIN),PHAS,ASUM WRITE(OUT,29002) SE(4),SE(2),SE(1),SE(3),BSUM WRITE(OUT,29001) VCOR(4),VCOR(2),VCOR(1),VCOR(3) CCCCCCCC AUSGABE DER ENDERGEBNISSE AUF FILES CCCCCCCCCCC IF((LIN.EQ.1).AND.(IZSUP.EQ.IZSUPM)) X WRITE(OUTD,29004) IF(IZSUP.EQ.IZSUPM) THEN IF(IBLOCK.EQ.1) X WRITE(IBLK,'(4F16.6)') X FREQS(LIN),T2OUT,AS(LIN),PHAS C WRITE(OUTD,'(3I4,F10.6,F10.6,F10.2,F10.4,F12.4)') X IZSUPPE,KZYK1,IC,FREQS(LIN),T2OUT,AS(LIN),PHAS,ASUM WRITE(OUTD,29002) SE(4),SE(2),SE(1),SE(3),BSUM WRITE(OUTD,29001) VCOR(4),VCOR(2),VCOR(1),VCOR(3) IF((LIN.LE.LINJH).AND.(IRLXA.EQ.1)) THEN IF((SE(2).EQ.0.).AND.(IFITS.EQ.1).AND.(IQH(2).GT.0.)) X SE(2)=T2OUTF WRITE(OUTA,'(F12.4,F12.4,F12.8,F12.8,F16.8, X F12.8,F12.6,F12.6,F12.8,F12.8)') X RPAR(6),RPAR(4),T2OUT,SE(2),FREQS(LIN), X SE(4),PHAS,SE(3),T22OUT,SE(5) ENDIF ENDIF ENDIF 951 CONTINUE 952 CONTINUE IF(IT2TST.GE.1) THEN DO 11513 I=1,7 KQ(I)=IQEIN(I) C IQR(I) 11513 CONTINUE IZYKLEN=IZYKA IKYKLEN=IZYKA ENDIF c C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C KORREKTUR DES DATEN-ARRAYS C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C FAK=-1.D+00 LIN=LINMAX IF((LIN.GT.LINJH).AND.(IDQ(3).EQ.0)) THEN DOPPLI=0. WRITE(OUTD,1718) ELSE DOPPLI=DOPPL ENDIF CALL SIM2(DATEN,PHASE,T2,OMEGA,A,IS,IPA, <----- X LINES,DELAY,T22F,OM2(LIN),FAK,VSUM,0,DOPPLI) WRITE(OUTD,9739) (AVGSUM(L),L=1,IKAVG) C IF(IS.NE.10) GOTO 81 c C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C AUSGABE DER MIKROWELLEN-FREQUENZEN IN ERGEBNIS-FILE C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C WRITE(OUTD,*) ' MW-FREQUENZEN NUR FUER 10 NS AUFNAHMEN RICHTIG' 29010 FORMAT(//,' MIKROWELLEN-FREQUENZEN IN MHz: ',/) 29015 FORMAT(' LINIE ZF-FREQUENZ MW-FREQUENZ ',/) 29020 FORMAT(' ',I4,F16.6,F18.6) IF (IPAR(1).EQ.10) THEN WRITE(OUTD,29010) WRITE(OUTD,29015) DO 80 LIN=1,LINMAX FRQMW=RPAR(1)-(IPAR(8)*30.0)+(IPAR(8)*FREQS(LIN)) WRITE(OUTD,29020) LIN,FREQS(LIN),FRQMW 80 CONTINUE ENDIF IF (IPAR(1).EQ.20) THEN WRITE(OUTD,29010) WRITE(OUTD,29015) DO 82 LIN=1,LINMAX FRQMW=RPAR(1)-(IPAR(8)*20.0)+(IPAR(8)*FREQS(LIN)) WRITE(OUTD,29020) LIN,FREQS(LIN),FRQMW 82 CONTINUE ENDIF CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 81 CONTINUE C IF(IRES.NE.1) GOTO 22 IF(IPA.GT.2) THEN DO 54 I=1,IPA-1 DATEN(I)=0 54 CONTINUE ENDIF IF(LINES.LT.1023) THEN DO 541 I=LINES+1,1024 DATEN(I)=0 541 CONTINUE ENDIF ASUM=DSQRT(ASUM/DBLE(LINES-IPA+1)) C KENNA=KENN IF(IMUEL2.EQ.1) THEN CALL AUSA(OUTD,IOUT,INPAR,IOFILE,ISTAUS,DATEN,APAR,IPAR,RPAR) <----- ASCII residual output ELSE CALL AUS(OUTD,IOUT,INPAR,IOFILE,ISTAUS,DATEN,APAR,IPAR,RPAR) <----- binary residual output ENDIF GOTO 22 back to input END C C------------------------------------------------------------------------------- C Input/output routines copied from file IO4.FOR (ZK 26.07.2019) C------------------------------------------------------------------------------- c C C==================================================================== C SUBROUTINE EIN (Kurzformat = short format) | C==================================================================== C C This is close to the binary Kiel spectrometer format written by c the MWFTSBI program of the 8-18GHz spectrometer with the file header: c @ SYS 5 @MWFTSBI 1.0 C C The difference is that the data points are expected to be in R*8 C and not the later more economic I*4 format so a conversion is made C ZK C SUBROUTINE EIN(IOUTD,IOUT,INpfil,INFILE,ISTEUER,DATEN,APAR, X IPAR,RPAR) IMPLICIT REAL*8 (A-H,O-Z) IMPLICIT INTEGER*2 (I-M) CHARACTER*2 APAR(128) CHARACTER*24 FILN REAL*8 DATEN(4096),RPAR(24) integer*4 idaten(4096) ZK INTEGER*2 IPAR(32),IOUT,INpfil,INFILE,ISTEUER,RECLN INTEGER*4 IERR IF(ISTEUER.EQ.1) GOTO 500 c C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C DATENEINLESEN VOM FILE C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C WRITE(IOUT,1300) 1300 FORMAT( ' MESSDATENFILE (EIN): ' ) READ(INpfil,'(A)') FILN user_input 919 CONTINUE WRITE(IOUTD,'(A)') FILN c c OPEN(INFILE,ACCESS='DIRECT', c X FILE=FILN,STATUS='OLD',IOSTAT=IERR) c OPEN(INFILE,FORM='BINARY', this is now required X FILE=FILN,STATUS='OLD',IOSTAT=IERR) for binary input (ZK) c IF(IERR.NE.0)THEN WRITE(IOUT,1400)IERR 1400 FORMAT(' OPEN FILE ERROR ',I4) ISTEUER=3 WRITE(*,1300) READ(*,'(A)')FILN GOTO 919 ENDIF 500 CONTINUE c READ(INFILE,ERR=777) (APAR(I),I=1,128) c X ,(IPAR(I),I=1,32),(RPAR(I),I=1,24) READ(INFILE,ERR=777,end=777) (APAR(I),I=1,128) ZK X ,(IPAR(I),I=1,32),(RPAR(I),I=1,24) write(*,*) (APAR(I),I=1,128) X ,(IPAR(I),I=1,32),(RPAR(I),I=1,24) ISTEUER=IPAR(9) c c DO 123 I=1,IPAR(5),64 c READ(INFILE,ERR=777)(DATEN(K),K=I,I+63) c write(*,*)(DATEN(K),K=I,I+63) c 123 CONTINUE c DO 123 I=1,IPAR(5) ZK READ(INFILE,ERR=777,end=777)idaten(i) ZK daten(i)=dble(idaten(i))*0.001d0 ZK convert to mV 123 CONTINUE ZK write(*,'(/'' Data points echoed to file: FIDPOINTS.TXT''/)') ZK open(66,file='FIDPOINTS.TXT',status='unknown') ZK do 501 i=1,ipar(5),8 ZK write(66,'(1x,1p8E12.4)')(DATEN(K),K=I,I+7) ZK 501 continue ZK close(66) ZK c IF(ISTEUER.NE.1) CLOSE(INFILE) GOTO 999 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 777 CONTINUE IF(ISTEUER.EQ.1) THEN WRITE(IOUT,7001) 7001 FORMAT(' FILE ZUENDE') ISTEUER=2 CLOSE(INFILE) GOTO 999 ELSE WRITE(IOUT,7002) 7002 FORMAT(' DATENFILE NICHT IN ORDNUNG') ISTEUER=3 GOTO 999 ENDIF 999 RETURN END c c C==================================================================== C SUBROUTINE EINA = ASCII file | C==================================================================== SUBROUTINE EINA(IOUTD,IOUT,INpfil,INFILE,ISTEUER,DATEN,APAR, X IPAR,RPAR) IMPLICIT REAL*8 (A-H,O-Z) IMPLICIT INTEGER*2 (I-M) CHARACTER*2 APAR(128) CHARACTER*24 FILN integer*4 ierr REAL*8 DATEN(4096),RPAR(24) INTEGER*2 IPAR(32),IOUT,INpfil,INFILE,ISTEUER IF(ISTEUER.EQ.1) GOTO 500 c C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C DATENEINLESEN VOM FILE C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC c WRITE(IOUT,1300) 1300 FORMAT( ' MESSDATENFILE (eina): ' ) READ(INpfil,'(A)')FILN user_input 919 CONTINUE WRITE(IOUTD,'(A)') FILN OPEN(INFILE,FILE=FILN,STATUS='OLD',IOSTAT=IERR) IF(IERR.NE.0)THEN WRITE(IOUT,1400)IERR 1400 FORMAT(' OPEN FILE ERROR ',I4) ISTEUER=3 WRITE(*,1300) READ(*,'(A)')FILN GOTO 919 ENDIF 500 CONTINUE READ(INFILE,'(BN,4I8,2E16.9,A2)',END=777,ERR=500) IPAR(1) X ,IPAR(6),IPAR(5),IPAR(8),RPAR(1),RPAR(10) write(*,*) IPAR(1) X ,IPAR(6),IPAR(5),IPAR(8),RPAR(1),RPAR(10) IF(IPAR(6).NE.0) GOTO 777 C IF(IPAR(5).GT.1024) IPAR(5)=1024 READ(INFILE,'(5E16.9)') (DATEN(I),I=1,IPAR(5)) c DO ihh=1, ipar(5) c write(*,*) daten(ihh) c end do ISTEUER=IPAR(9) IF(ISTEUER.NE.1) CLOSE(INFILE) GOTO 999 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 777 CONTINUE IF(ISTEUER.EQ.1) THEN WRITE(IOUT,7001) 7001 FORMAT(' FILE ZUENDE') ISTEUER=2 CLOSE(INFILE) GOTO 999 ELSE WRITE(IOUT,7002) 7002 FORMAT(' DATENFILE NICHT IN ORDNUNG') ISTEUER=3 GOTO 999 ENDIF 999 RETURN END c c C==================================================================== C SUBROUTINE EINAB ASCII/BESTMANN | C==================================================================== SUBROUTINE EINAB(IOUTD,IOUT,INpfil,INFILE,ISTEUER,DATEN,APAR, X IPAR,RPAR) IMPLICIT REAL*8 (A-H,O-Z) IMPLICIT INTEGER*2 (I-M) CHARACTER*2 APAR(128) CHARACTER*24 FILN integer*4 ierr REAL*8 DATEN(4096),RPAR(24) INTEGER*2 IPAR(32),IOUT,INpfil,INFILE,ISTEUER,IDAT(1024) IF(ISTEUER.EQ.1) GOTO 500 c C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C DATENEINLESEN VOM FILE C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC c WRITE(IOUT,1300) 1300 FORMAT( ' MESSDATENFILE: ' ) READ(INpfil,'(A24)')FILN user_input 919 CONTINUE WRITE(IOUTD,'(A24)') FILN OPEN(INFILE,FILE=FILN,STATUS='OLD',IOSTAT=IERR) IF(IERR.NE.0)THEN WRITE(IOUT,1400)IERR 1400 FORMAT(' OPEN FILE ERROR ',I4) ISTEUER=3 WRITE(*,1300) READ(*,'(A24)')FILN GOTO 919 ENDIF 500 CONTINUE READ(INFILE,'(4I8,2E16.9,A2)',END=777,ERR=500) IPAR(1),IPAR(6) X ,IPAR(5),IPAR(8),RPAR(1) RPAR(10)=50. IF(IPAR(6).NE.0) GOTO 777 IF(IPAR(5).GT.1024) IPAR(5)=1024 READ(INFILE,'(10I8)') (IDAT(I),I=1,IPAR(5)) ISTEUER=IPAR(9) DO 77 I=1,IPAR(5) DATEN(I)=IDAT(I) 77 CONTINUE IF(ISTEUER.NE.1) CLOSE(INFILE) GOTO 999 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 777 CONTINUE IF(ISTEUER.EQ.1) THEN WRITE(IOUT,7001) 7001 FORMAT(' FILE ZUENDE') ISTEUER=2 CLOSE(INFILE) GOTO 999 ELSE WRITE(IOUT,7002) 7002 FORMAT(' DATENFILE NICHT IN ORDNUNG') ISTEUER=3 GOTO 999 ENDIF 999 RETURN END c c C==================================================================== C SUBROUTINE EINAR = FID (relaxation) file (ASCII) | C==================================================================== SUBROUTINE EINAR(IOUTD,IOUT,INpfil,INFILE,ISTEUER,DATEN,APAR, X IPAR,RPAR) IMPLICIT REAL*8 (A-H,O-Z) IMPLICIT INTEGER*2 (I-M) CHARACTER*2 APAR(128) CHARACTER*24 FILN CHARACTER*44 TEXT integer*4 ierr REAL*8 DATEN(4096),RPAR(24) INTEGER*2 IPAR(32),IOUT,INpfil,INFILE,ISTEUER,IDAT(1024) IF(ISTEUER.EQ.1) GOTO 500 c C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C DATENEINLESEN VOM FILE C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC c WRITE(IOUT,1300) 1300 FORMAT( ' MESSDATENFILE: ' ) READ(INpfil,'(A24)')FILN user_input 919 CONTINUE WRITE(IOUTD,'(A24)') FILN OPEN(INFILE,FILE=FILN,STATUS='OLD',IOSTAT=IERR) IF(IERR.NE.0)THEN WRITE(IOUT,1400)IERR 1400 FORMAT(' OPEN FILE ERROR ',I4) ISTEUER=3 WRITE(*,1300) READ(*,'(A24)')FILN GOTO 919 ENDIF 500 CONTINUE c READ(INFILE,'(4I8,2E16.9,A2)',END=777,ERR=500) IPAR(1),IPAR(6) X ,IPAR(5),IPAR(8),RPAR(1) IF(IPAR(1).LE.0) IPAR(1)=10 RPAR(1)=RPAR(1)*1000. RPAR(10)=50. IF(IPAR(6).NE.0) GOTO 777 IF(IPAR(5).GT.1024) IPAR(5)=1024 READ(INFILE,'(5E16.9)') RPAR(6),RPAR(7),RPAR(4),RPAR(5) IPAR(9)=1 READ(INFILE,'(A44)') TEXT WRITE(IOUTD,'(A44)') TEXT WRITE(IOUT,'(A44)') TEXT READ(INFILE,'(10I8)') (IDAT(I),I=1,IPAR(5)) DO 77 I=1,IPAR(5) DATEN(I)=FLOAT(IDAT(I)) 77 CONTINUE ISTEUER=IPAR(9) IF(ISTEUER.NE.1) CLOSE(INFILE) GOTO 999 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 777 CONTINUE IF(ISTEUER.EQ.1) THEN WRITE(IOUT,7001) 7001 FORMAT(' FILE ZUENDE') ISTEUER=2 CLOSE(INFILE) GOTO 999 ELSE WRITE(IOUT,7002) 7002 FORMAT(' DATENFILE NICHT IN ORDNUNG') ISTEUER=3 GOTO 999 ENDIF 999 RETURN END c c C==================================================================== C SUBROUTINE AUS = binary spectral file output | C==================================================================== SUBROUTINE AUS(IOUTD,IOUT,INpfil,INFILE,ISTEUER,DATEN, X APAR,IPAR,RPAR) IMPLICIT REAL*8 (A-H,O-Z) IMPLICIT INTEGER*2 (I-M) CHARACTER*2 APAR(128) CHARACTER*24 FILN c integer*4,ierr integer*4 ierr ZK correction integer*4 idaten(4096) ZK REAL*8 DATEN(4096),RPAR(24) INTEGER*2 IPAR(32),IOUT,INpfil,INFILE,ISTEUER,IOUTD IF(ISTEUER.EQ.1) GOTO 500 C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C DATENAUSLESEN AUF FILE C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C 919 CONTINUE WRITE(IOUT,1300) 1300 FORMAT( ' RESIDUENFILE: ' ) READ(INpfil,'(A24)')FILN user_input WRITE(IOUTD,'(A24)') FILN c c OPEN(INFILE,ACCESS='DIRECT',RECL=512, c X FILE=FILN,STATUS='NEW',IOSTAT=IERR) c OPEN(INFILE,FORM='BINARY',RECL=512, contemporary X FILE=FILN,STATUS='UNKNOWN',IOSTAT=IERR) parameters (ZK) c IF(IERR.NE.0)THEN WRITE(IOUT,1400)IERR 1400 FORMAT(' OPEN FILE ERROR ',I4) c c OPEN(INFILE,ACCESS='DIRECT',RECL=512, c X FILE=' ZUVIEL.RES',IOSTAT=IERR) c OPEN(INFILE,FORM='BINARY',RECL=512, contemporary X FILE=' ZUVIEL.RES',IOSTAT=IERR) parameters (ZK) c WRITE(IOUTD,*)' FILE SCHON VORHANDEN:RESIDUUM IN ZUVIEL.RES' WRITE(*,*)' FILE SCHON VORHANDEN:RESIDUUM IN ZUVIEL.RES' IF(IERR.NE.0) STOP ENDIF 500 CONTINUE IPAR(10)=IPAR(10)+1 c WRITE(INFILE) (APAR(I),I=1,128) X ,(IPAR(I),I=1,32),(RPAR(I),I=1,24) c c DO 123 I=1,IPAR(5),64 c WRITE(INFILE) (DATEN(K),K=I,I+63) c 123 CONTINUE c do 123 i=1,ipar(5) ZK I*4 data points idaten(i)=1000.d0*daten(i) ZK write(infile) idaten(i) ZK 123 continue ZK ISTEUER=IPAR(9) 999 RETURN END c c C==================================================================== C SUBROUTINE AUSA = ASCII output | C==================================================================== SUBROUTINE AUSA(IOUTD,IOUT,INpfil,INFILE,ISTEUER,DATEN, X APAR,IPAR,RPAR) IMPLICIT REAL*8 (A-H,O-Z) IMPLICIT INTEGER*2 (I-M) CHARACTER*2 APAR(128) CHARACTER*24 FILN integer*4 ierr REAL*8 DATEN(4096),RPAR(24) INTEGER*2 IPAR(32),IOUT,INpfil,INFILE,ISTEUER IF(ISTEUER.EQ.1) GOTO 500 C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C DATENEINLESEN VOM FILE C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C 919 CONTINUE WRITE(IOUT,1300) 1300 FORMAT( ' RESIDUENFILE: ' ) READ(INpfil,'(A24)')FILN user_input WRITE(IOUTD,'(A24)') FILN OPEN(INFILE,FILE=FILN,STATUS='NEW',IOSTAT=IERR) IF(IERR.NE.0)THEN WRITE(IOUT,1400)IERR 1400 FORMAT(' OPEN FILE ERROR ',I4) OPEN(INFILE,FILE=' ZUVIEL.RES',IOSTAT=IERR) WRITE(IOUTD,*)' FILE SCHON VORHANDEN:RESIDUUM IN ZUVIEL.RES' WRITE(*,*)' FILE SCHON VORHANDEN:RESIDUUM IN ZUVIEL.RES' IF(IERR.NE.0) STOP ENDIF 500 CONTINUE IPAR(10)=IPAR(10)+1 WRITE(INFILE,'(4I8,2E16.9,A2)') IPAR(1),IPAR(6),IPAR(5) X ,IPAR(8),RPAR(1),RPAR(10) WRITE(INFILE,'(5E16.9)') (DATEN(I),I=1,IPAR(5)) ISTEUER=IPAR(9) 999 RETURN END C C C------------------------------------------------------------------------------- C Routines DOPP,SIM2,ABL5,FIT6 copied from file SUB5.FOR (ZK 26.07.2019) C------------------------------------------------------------------------------- C C==================================================================== SUBROUTINE ABL5(DATEN,PHASE,T2,OMEGA,A,IS,IPA,IPKOPP, X LINES,DELAY,T22,OM2,ARRAY,DNF,DOPPL,IQ1, x IMERK,SOUT) IMPLICIT REAL*8 (A-H,O-Z) IMPLICIT INTEGER*2 (I-N) REAL*8 DATEN(4096),DNF(6),ARRAY(6,6),U(6) C AM=-1.*A DO 10 I=IPA,LINES X=IS*I WE=DEXP(-1.*X*(T2+(T22+DOPPL)*(2.*DELAY+X))) ARG=PHASE+(OMEGA+OM2*X)*X U(1)=DCOS(ARG)*WE U(2)=AM*X*U(1) U(3)=AM*DSIN(ARG)*WE IF(IPKOPP.EQ.1) THEN U(4)=(X+DELAY)*U(3) ELSE U(4)=X*U(3) ENDIF U(5)=(X+2*DELAY)*U(2) U(6)=DATEN(I)-A*U(1) DO 11 K1=1,6 DNF(K1)=DNF(K1)+U(K1)*U(K1) 11 CONTINUE IF(IQ1.EQ.1) X SOUT=SOUT+(U(IMERK)/U(6))**2 DO 12 K1=1,5 NK1=K1+1 DO 13 K2=NK1,6 ARRAY(K1,K2)=ARRAY(K1,K2)+U(K1)*U(K2) 13 CONTINUE 12 CONTINUE 10 CONTINUE RETURN END c c C==================================================================== C FIT6 C==================================================================== C SUBROUTINE .FIT VERSION 1 24.9.80 C VERSION 2:HAEKEL SCHON VOR FIT:U(LINE,NVAR1)=V(LINE) C AUFRUF: CALL FIT(U,V,NVAR,NVAR1,LENGTH,LINES,SE,CO,NFAIL) C U=U(LENGTH,NVAR1) FUNKTIONALDETERMINANTE C V=V(LENGTH) NAEHERUNGSFEHLER C NVAR ANZAHL DER ANPASSPARAMETER C NVAR1 NVAR+1 C LENGTH MAXIMALES DATENFELD C LINES AKTUELLES DATENFELD C SE=SE(NVAR) STANDARDFEHLER DES FIT C CO=CO(NVAR,NVAR) KORRELATIONSMATRIX C NFAIL 0:FIT OK 1:FIT HAT SINGULARITAET C SUBROUTINE FIT6(DNF,A,V,NVAR,NVAR1,LENGTH,LINES,SE,CO,NFAIL) IMPLICIT REAL*8 (A-H,O-Z) IMPLICIT INTEGER*2 (I-N) C DIMENSION V(6),SE(6), X SR(6),A(6,6),C(6,6),R(6,6),X(6),DNF(6),CO(6,6) C C N1=NVAR1 Z0=1./DNF(N1) C C C DET=1. DO 53 M=1,NVAR N2=M-1 DO 52 J=M,N1 Z2=0. IF(M.EQ.1)GOTO 43 DO 42 K=1,N2 Z2=R(K,M)*R(K,J)+Z2 42 CONTINUE 43 Z2=A(M,J)-Z2 IF(J.NE.M)GOTO 50 DET=DET*Z2 IF(Z2-1.E-15.GT.0.)GOTO 44 GOTO 99 44 R(M,M)=DSQRT(Z2) GOTO 52 50 R(M,J)=Z2/R(M,M) 52 CONTINUE 53 CONTINUE IT=1 C C C Z2=0. Z3=0. M=NVAR 60 X(M)=(R(M,N1)-Z2)/R(M,M) V(M)=X(M)*DNF(M)*Z0 Z3=X(M)*A(M,N1)+Z3 IF(M.EQ.1)GOTO 70 Z2=0. DO 61 J=M,NVAR Z2=R(M-1,J)*X(J)+Z2 61 CONTINUE M=M-1 GOTO 60 70 Z3=(1.-Z3)*Z0*Z0/DBLE(LINES-NVAR) C WRITE(*,'(2E12.4,2I4)') Z3,Z0,LINES,NVAR IF(Z3.LT.0.)Z3=0. SIGMA=DSQRT(Z3) C IT=2 C C K=N1 71 I=K K=K-1 C(K,K)=0. 72 N2=I I=I-1 Z2=0. IF(I.EQ.NVAR)GOTO 76 IT=3 DO 75 N=N2,NVAR Z2=R(I,N)*C(N,K)+Z2 75 CONTINUE C(I,K)=-Z2/R(I,I) 76 CONTINUE IF(I.EQ.K)C(I,I)=C(I,I)+1./(R(I,I)*R(I,I)) C(K,I)=C(I,K) IF(I.GT.1)GOTO 72 IF(K.GT.1)GOTO 71 C C C ZDIAG=0. ZOFF=0. IT=5 DO 33 I=1,NVAR Z2=C(I,I) SR(I)=DSQRT(Z2) Z2=DNF(I) SE(I)=Z2*SR(I)*SIGMA SR(I)=1./SR(I) DO 32 K=I,NVAR ZCHECK=0. DO 30 L=1,NVAR ZCHECK=ZCHECK+A(I,L)*C(L,K) 30 CONTINUE IF(I.EQ.K)GOTO 31 ZABS=ABS(ZCHECK) IF(ZOFF.GT.ZABS)GOTO 32 ZOFF=ZABS GOTO 32 31 ZABS=ABS(ZCHECK-1.) IF(ZDIAG.GT.ZABS)GOTO 32 ZDIAG=ZABS 32 CONTINUE 33 CONTINUE DO 102 I=1,NVAR DO 101 K=1,I Z2=C(I,K) CO(I,K)=Z2*SR(I)*SR(K) 101 CONTINUE 102 CONTINUE IT=4 NFAIL=0 RETURN 99 NFAIL=1 RETURN END c c C==================================================================== C SIM2 C==================================================================== c SUBROUTINE SIM2(DATEN,PHASE,T2,OMEGA,A,IS,IPA, X LINES,DELAY,T22,OM2,FAK,VSUM,IVSUM,DOPPL) IMPLICIT REAL*8 (A-H,O-Z) IMPLICIT INTEGER*2 (I-N) REAL*8 DATEN(4096) c IF(IVSUM.EQ.1) GOTO 120 DO 10 I=IPA,LINES X=IS*I WERT=FAK*A*DCOS(PHASE+X*(OMEGA+OM2*X)) X *DEXP(-1.*X*(T2+(T22+DOPPL)*(2*DELAY+X))) DATEN(I)=DATEN(I)+WERT 10 CONTINUE RETURN c CCCCCCCCCCCCCCCCCCCCCCCCCC c 120 CONTINUE VSUM=0. DO 20 I=IPA,LINES X=IS*I WERT=A*DCOS(PHASE+X*(OMEGA+OM2*X)) X *DEXP(-1.*X*(T2+(T22+DOPPL)*(2*DELAY+X))) ABW=DATEN(I)-WERT VSUM=VSUM+ABW*ABW 20 CONTINUE c RETURN END C C C==================================================================== C DOPP C==================================================================== C SUBROUTINE DOPP(IOUT,INpfil,IPA,LINES,IKDOP,DATEN,APAR,IPAR, X RPAR,FREQ,PHASE,AMPL,TEMP,MOL,DOPPL,DELAY) IMPLICIT REAL*8 (A-H,O-Z) IMPLICIT INTEGER*2 (I-M) REAL*8 DATEN(4096),RPAR(24) INTEGER*2 IPAR(32) CHARACTER*2 APAR(128) C INTEGER*2 OUT REAL*8 MOL OUT=IOUT IS=IPAR(1) C C C BASELINEKORREKTUR+BERECHNUNG DER AMPLITUDE BMAX=DATEN(1) BMIN=DATEN(1) C DSUM=0. DO 5 I=IPA,LINES IF(DATEN(I).LT.BMIN) BMIN=DATEN(I) IF(DATEN(I).GT.BMAX) IPHASE=I IF(DATEN(I).GT.BMAX) BMAX=DATEN(I) C DSUM=DSUM+DATEN(I) 5 CONTINUE CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C BASELINE C BASELINE=DSUM/FLOAT(LINES-IPA+1) BASELINE=0.0D+00 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C PHASE C IF(PHASE.EQ.0.) THEN PHASE=-1.*IS*IPHASE*FREQ/159.155 KPHASE=-1*IDINT(PHASE/6.2831853) PHASE=PHASE+(KPHASE+1)*6.2831853 C ENDIF CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C DOPPLERKORREKTUR CCCCCCCC IF(IKDOP.EQ.1) THEN MOL=RPAR(5) IF(DELAY.EQ.0.) DELAY=RPAR(4)*1000. TEMP=RPAR(7) GHZFRQ=RPAR(1)/1000. WRITE(*,1704) MOL,DELAY,TEMP,GHZFRQ 1704 FORMAT(' MOLGEW.:',F12.2,' DELAY:',F12.4,/, X ' TEMPERATUR:',F12.2,' FREQ[GHZ]:',F12.6) IF(MOL.LE.0.5) DOPPL=0. IF(MOL.LE.0.5) GOTO 819 C BERECHNUNG DER DOPPLERBREITE 7371 DOPPL=GHZFRQ*GHZFRQ*1.826E-12*TEMP/MOL 819 IF(DOPPL.LE.0.) THEN WRITE(0,1305) 1305 FORMAT(' MOLGEW.(AMU),TEMP(K),DELAY(NS)', X ' (ALLES REAL)',/) READ(INpfil,*,ERR=819) MOL,TEMP,DELAY user_input GOTO 7371 ENDIF DOPPL2=SQRT(DOPPL)*1000. DOPPL3=DOPPL2*265. WRITE(OUT,5001) DOPPL2,DOPPL3,BASELINE WRITE(*,5001) DOPPL2,DOPPL3,BASELINE WRITE(OUT,1704) MOL,DELAY,TEMP,GHZFRQ 5001 FORMAT(' DOPPLERBREITE:',F8.6,' =',F8.2, X ' KHZ BASELINEKORR.:',F10.2,/) ELSE DOPPL=0. ENDIF C DO 52 I=IPA,LINES C DATEN(I)=(DATEN(I)-BASELINE) C 52 CONTINUE AMPL=(BMAX-BMIN)/2. RETURN END C C C------------------------------------------------------------------------------- C Routine S1N copied from file S1N.FOR (ZK 26.07.2019) C------------------------------------------------------------------------------- C C C==================================================================== C S1N C==================================================================== c SUBROUTINE S1N(DATEN,PHASES,T2S,FREQS,AS,IS,IPA, X LINES,DELAY,T22,OM2,ARRAY,DNF,DOPPL,LINJH,IQH,PI, X IFSTPL,T2ALL,PNULL,OUT,IZSUP,IZYKLEN,ICORMX, X IZSUPM,RKL,DT2ME,T2MAXW,T2MINW,AVSUM,IAUS,OUTD, X INEUFT,T2OUTF,LINMAX,DOPPLS) IMPLICIT REAL*8 (A-H,O-Z) IMPLICIT INTEGER*2 (I-N) COMMON/DAT/DATENN(4096),AVGSUM(16),IKAVG REAL*8 DATEN(4096),DNF(6),ARRAY(6,6),U(6), X PHASES(30),T2S(30),FREQS(30),AS(30),OM2(30), X AR(6,6),CO(6,6),DMF(6),SE(6), X V(6),VCOR(6) INTEGER*2 IQH(5),OUT,OUTD C 111 CONTINUE IFSTPL=0 T22F=0.D+00 C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C SUBTRAKTION DER AVERAGERKORR. UND DER STOERUNGEN C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C DO 9736 I=IPA-1,LINES-1,IKAVG DO 9736 L=1,IKAVG IF((I+L).LE.LINES) X DATEN(I+L)=DATENN(I+L)-AVGSUM(L) 9736 CONTINUE IF (LINJH.LT.LINMAX) THEN FAK=-1.D+00 DO 6731 LIN=LINJH+1,LINMAX OMEGA=FREQS(LIN)*2.D+00*PI/1000.D+00 A=AS(LIN) T2=T2S(LIN) PHASE=PHASES(LIN) CALL SIM2(DATEN,PHASE,T2,OMEGA,A,IS,IPA, <----- X LINES,DELAY,T22F,OM2(LIN),FAK,VSUM,0,DOPPLS) 6731 CONTINUE ENDIF CCCCCCCC BEGINN FITSCHLEIFE CCCCCCCCCCCC DO 90 KZYKLEN=1,IZYKLEN IF(INEUFT.EQ.1) THEN DO 901 I=1,3 VCOR(I)=0.D+00 901 CONTINUE ICOR=0 AT2ALL=T2ALL APNULL=PNULL ADELAY=DELAY GOTO 600 ENDIF CCCCCCCC INITIALISIEREN CCCCCCCCCCCCCCCC DO 8 K1=1,4 DNF(K1)=0.D+00 DMF(K1)=0.D+00 ARRAY(K1,K1)=1.D+00 AR(K1,K1)=1.D+00 NK1=K1+1.D+00 DO 9 K2=NK1,4 ARRAY(K1,K2)=0.D+00 AR(K1,K2)=0.D+00 9 CONTINUE 8 CONTINUE IF(IQH(1).EQ.1) THEN DO 1275 I12=2,4 IF(IQH(I12).EQ.1) IMERK=I12-1 1275 CONTINUE ELSE IMERK=0 ENDIF CALL ABLS(DATEN,PHASES,T2S,FREQS,AS,IS,IPA, <----- X LINES,DELAY,T22,OM2,ARRAY,DNF,DOPPL,LINJH, X IQH,PI,SOUT,IMERK) C IF(IQH(1).NE.1) GOTO 95842 C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C EINPARAMETERFIT C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C V(1)=ARRAY(IMERK,4)/DNF(IMERK) SE(1)=1.D+00/DSQRT(SOUT/(LINES-IPA)) GOTO 12751 C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C ENDE EINPARAMETERFIT C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C 95842 CONTINUE DO 16 K1=1,4 DNF(K1)=1.D+00/DSQRT(DNF(K1)) 16 CONTINUE DO 14 IK1=1,3 NK1=IK1+1.D+00 DO 15 IK2=NK1,4 IF(IQH(IK1+1).EQ.0) THEN GOTO 14 ELSE K1=IQH(IK1+1) ENDIF IF(IQH(IK2+1).EQ.0) THEN GOTO 15 ELSE K2=IQH(IK2+1) ENDIF DMF(K1)=DNF(IK1) AR(K1,K2)=ARRAY(IK1,IK2)*DNF(IK1)*DNF(IK2) 15 CONTINUE 14 CONTINUE DMF(IQH(1)+1)=DNF(4) DO 114 K1=1,3 NK1=K1+1 DO 115 K2=1,4 AR(K2,K1)=AR(K1,K2) 115 CONTINUE 114 CONTINUE NFAIL=0 CCCCCCCCCCC CALL FIT CCCCCCCCCCCC NVAR=IQH(1) NVAR1=NVAR+1 LINESM=LINES+1-IPA CALL FIT6(DMF,AR,V,NVAR,NVAR1,1024,LINESM,SE,CO,NFAIL) <----- C IF(NFAIL.NE.0) THEN WRITE(OUT,1000) NFAIL 1000 FORMAT(' FIT NICHT OK,NFAIL=',I4) ICOR=ICORMX+10 GOTO 610 ENDIF C 12751 CONTINUE XCOR=2.D+00 CCCCCCCCCCC SICHERN DER ALTEN WERTE CCCCCCCCCCCCCCC AT2ALL=T2ALL APNULL=PNULL ADELAY=DELAY DO 50 IV=1,3 IF(IQH(IV+1).EQ.0) THEN VCOR(IV)=0.D+00 ELSE VCOR(IV)=V(IQH(IV+1))*2.D+00 ENDIF 50 CONTINUE ICOR=0 C PRO FITZYKLUS NUR RELAXATIONSZEITAENDERUNGEN VON 0.5 MOEGLICH IF(VCOR(1).GT.DT2ME) VCOR(1)=DT2ME RT2M=-2.D+00*DT2ME IF(VCOR(1).LT.RT2M) VCOR(1)=RT2M CC PRO FITZYKLUS PHASENAENDERUNGEN VON MAXIMAL PI/2 MOEGLICH C IF(VCOR(2).GT.PI) VCOR(2)=PI C IF(VCOR(2).LT.(-1.D+00*PI)) VCOR(2)=-1.D+00*PI CC PRO FITZYKLUS MAXIMAL DELAYAENDERUNGEN VON 200 NS MOEGLICH C IF(VCOR(3).GT.400.) VCOR(3)=400.D+00 C IF(VCOR(3).LT.-400.) VCOR(3)=-400.D+00 CC PRO FITZYKLUS MAXIMAL DELAYAENDERUNGEN VON 150NS MOEGLICH 1627 CONTINUE IF(ABS(VCOR(3)).GT.150.) THEN VCOR(2)=VCOR(2)/2.D+00 VCOR(3)=VCOR(3)/2.D+00 GOTO 1627 ENDIF CCCC SCHLEIFE MIT FEHLERQUADRAT SOLL KLEINER WERDEN CCC 600 CONTINUE ICOR=ICOR+1 C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C EINSCHUB FUER FIT NICHT ERFOLGREICH C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C IF(ICOR.GE.ICORMX) THEN WRITE(*,*)' VERWENDE WIEDER ALTE PARAMETER' T2ALL=AT2ALL PNULL=APNULL DELAY=ADELAY ENDIF 610 CONTINUE IF(ICOR.GE.ICORMX) THEN C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C SUBTRAKTION DER ALTEN BERECHNETEN DECAYS C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C FAK=-1.D+00 DO 732 LIN=1,LINJH OMEGA=FREQS(LIN)*PI/500.D+00 A=AS(LIN) IF(IQH(2).EQ.1) T2S(LIN)=T2ALL IF((IQH(3)+IQH(4)).GT.0) X PHASES(LIN)=PNULL+DELAY*OMEGA IF(PHASES(LIN).GT.2.D+00*PI) PHASES(LIN)=PHASES(LIN)- X 2.D+00*PI*DINT(PHASES(LIN)/(2.D+00*PI)) T2=T2S(LIN) PHASE=PHASES(LIN) CALL SIM2(DATEN,PHASE,T2,OMEGA,A,IS,IPA, <----- X LINES,DELAY,T22F,OM2(LIN),FAK,VSUM,0,DOPPL) 732 CONTINUE C ENDIF VSUM=0.D+00 DO 7818 I=IPA,LINES VSUM=VSUM+DATEN(I)*DATEN(I) 7818 CONTINUE BSUM=DSQRT(VSUM/DBLE(LINES-IPA+1)) ASUM=DSQRT(AVSUM/DBLE(LINES-IPA+1)) WRITE(*,'(2(A,F14.4))') ' STDABW. NEU',BSUM,' ALT',ASUM GOTO 95 ENDIF C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C ENDE EINSCHUB FUER FIT NICHT ERFOLGREICH C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C DO 60 IV=1,3 IF(VCOR(IV).NE.0.) VCOR(IV)=VCOR(IV)/XCOR 60 CONTINUE T2ALL=AT2ALL+VCOR(1) IF(IT2G.EQ.1) THEN IF(T2ALL.GT.T2MAXW) T2ALL=T2MAXW IF(T2ALL.LT.T2MINW) T2ALL=T2MINW ENDIF PNULL=APNULL+VCOR(2) DELAY=ADELAY+VCOR(3) FAK=-1.D+00 DO 717 LIN=1,LINJH OMEGA=FREQS(LIN)*PI/500.D+00 A=AS(LIN) IF(IQH(2).EQ.1) THEN T2=T2ALL ELSE T2=T2S(LIN) ENDIF IF((IQH(3)+IQH(4)).GT.0) THEN PHASE=PNULL+DELAY*OMEGA ELSE PHASE=PHASES(LIN) ENDIF CALL SIM2(DATEN,PHASE,T2,OMEGA,A,IS,IPA, <----- X LINES,DELAY,T22F,OM2(LIN),FAK,VSUM,0,DOPPL) 717 CONTINUE VSUM=0.D+00 DO 818 I=IPA,LINES VSUM=VSUM+DATEN(I)*DATEN(I) 818 CONTINUE C FEHLERQUADRAT SOLL KLEINER WERDEN C WRITE(OUT,'(2E20.10)') VSUM,AVSUM IF((VSUM.GT.RKL*AVSUM).AND.(INEUFT.NE.1)) THEN IFSTPL=1 ELSE IFSTPL=0 ENDIF CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC IF((VSUM.GT.AVSUM).AND.(INEUFT.NE.1)) THEN C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C SUBTRAKTION DER AVERAGERKORR. UND DER STOERUNGEN C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C DO 9737 I=IPA-1,LINES-1,IKAVG DO 9737 L=1,IKAVG IF((I+L).LE.LINES) X DATEN(I+L)=DATENN(I+L)-AVGSUM(L) 9737 CONTINUE IF (LINJH.LT.LINMAX) THEN FAK=-1.D+00 DO 7731 LIN=LINJH+1,LINMAX OMEGA=FREQS(LIN)*PI/500.D+00 A=AS(LIN) T2=T2S(LIN) PHASE=PHASES(LIN) CALL SIM2(DATEN,PHASE,T2,OMEGA,A,IS,IPA, <----- X LINES,DELAY,T22F,OM2(LIN),FAK,VSUM,0,DOPPLS) 7731 CONTINUE ENDIF GOTO 600 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ENDIF ASUM=DSQRT(AVSUM/DBLE(LINES-IPA+1)) BSUM=DSQRT(VSUM/DBLE(LINES-IPA+1)) AVSUM=VSUM WRITE(*,'(2(A,F14.4))') ' STDABW. NEU',BSUM,' ALT',ASUM 90 CONTINUE 95 CONTINUE DO 727 LIN=1,LINJH IF(IQH(2).EQ.1) T2S(LIN)=T2ALL OMEGA=FREQS(LIN)*PI/500.D+00 IF((IQH(3)+IQH(4)).GT.0) X PHASES(LIN)=PNULL+DELAY*OMEGA IF(PHASES(LIN).GT.2.D+00*PI) PHASES(LIN)=PHASES(LIN)- X 2.D+00*PI*DINT(PHASES(LIN)/(2.D+00*PI)) 727 CONTINUE IF(PNULL.GT.(PI*2.)) PNULL=PNULL-2.D+00*PI IF(PNULL.LT.0.) PNULL=PNULL+2.D+00*PI C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C AUSGABE C C C Output C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C IF((IZSUP.EQ.IZSUPM).OR.(IAUS.EQ.1)) THEN IOUT=OUT 1234 CONTINUE WRITE(IOUT,12341) 12341 FORMAT(/,22X,' WERT FEHLER LETZTE KORR.') IF(IQH(2).GT.0 ) THEN T2ALLA=T2ALL*1000.D+00 T2OUTF=SE(IQH(2))*1000.D+00 VCORA=VCOR(1)*1000.D+00 WRITE(IOUT,12342) X T2ALLA,T2OUTF,VCORA 12342 FORMAT(13X,' 1/T2:',3F12.6) ENDIF IF(IQH(3).GT.0 ) THEN PNULLA=PNULL*180.D+00/PI SEA=SE(IQH(3))*180.D+00/PI VCORA=VCOR(2)*180.D+00/PI WRITE(IOUT,12343) X PNULLA,SEA,VCORA 12343 FORMAT(' PHASE AM PULSENDE:',3F12.6) ENDIF IF(IQH(4).GT.0) WRITE(IOUT,12344) X DELAY,SE(IQH(4)),VCOR(3) 12344 FORMAT(12X,' DELAY:'3F12.6) WRITE(IOUT,12345) 12345 FORMAT(' ') IF((IZSUP.EQ.IZSUPM).AND.(IOUT.NE.OUTD)) THEN IOUT=OUTD GOTO 1234 ENDIF ENDIF IF(INEUFT.EQ.1) THEN INEUFT=0 GOTO 111 ENDIF RETURN END C C C==================================================================== C ABLS C==================================================================== SUBROUTINE ABLS(DATEN,PHASES,T2S,FREQS,AS,IS,IPA, X LINES,DELAY,T22,OM2,ARRAY,DNF,DOPPL,LINJH,IQH, X PI,SOUT,IMERK) IMPLICIT REAL*8 (A-H,O-Z) IMPLICIT INTEGER*2 (I-N) REAL*8 DATEN(4096),DNF(6),ARRAY(6,6),U(6), X PHASES(30),T2S(30),FREQS(30),AS(30),US(4) INTEGER*2 IQH(5) C SOUT=0.D+00 DO 10 I=IPA,LINES DSUM=0.D+00 US(1)=0.D+00 US(2)=0.D+00 US(3)=0.D+00 DO 9 LIN=1,LINJH PHASE=PHASES(LIN) T2=T2S(LIN) A=AS(LIN) FREQ=FREQS(LIN) OMEGA=FREQ*2.D+00*PI/1000.D+00 AM=-1.D+00*A X=IS*DFLOAT(I) WE=DEXP(-1.D+00*X*(T2+(T22+DOPPL)*(2*DELAY+X))) ARG=PHASE+(OMEGA+OM2*X)*X Z=DCOS(ARG)*WE DSUM=A*Z+DSUM U(1)=AM*X*Z Z2=U(1)*(T22+DOPPL)*2.D+00 U(2)=AM*DSIN(ARG)*WE U(3)=U(2)*OMEGA+Z2 US(1)=US(1)+U(1) US(2)=US(2)+U(2) US(3)=US(3)+U(3) 9 CONTINUE US(4)=DATEN(I)-DSUM DO 11 K1=1,4 DNF(K1)=DNF(K1)+US(K1)*US(K1) 11 CONTINUE IF(IQH(1).EQ.1) X SOUT=SOUT+(US(IMERK)/US(4))**2 DO 12 K1=1,3 NK1=K1+1 DO 13 K2=NK1,4 ARRAY(K1,K2)=ARRAY(K1,K2)+US(K1)*US(K2) 13 CONTINUE 12 CONTINUE 10 CONTINUE RETURN END C C------------------------------------------------------------------------------- C-------------------------------------------------------------------------------