C A CODE FOR EXTRACTION OF A MODEL OR SIMPLE LINEAR INTERPOLATION C IN THE NEW KURUCZ MODEL GRID c c authors: J. Budaj c contact: budaj@ta3.sk c published: http://www.ta3.sk/~budaj/software c special requirements: c non original routins: c input: keyboard + file with grid of models + intkur3.in c output: file c PARAMETER(NMAX=72,NQUANT=7) IMPLICIT DOUBLE PRECISION (A-H,O-Z) CHARACTER*30 IN,IN1,IN2,IN3,IN4,OUT CHARACTER*100 ACHAR,ACHAR1,ACHAR2,ACHAR3 DIMENSION A(NMAX,NQUANT),B(NMAX,NQUANT),C(NMAX,NQUANT) P ,D(NMAX,NQUANT),E(NMAX,NQUANT),E1(NMAX,NQUANT),E2(NMAX,NQUANT) C C WARNING: MODELS ARE NOT INTERPOLATED TO THE SAME DEPTH SCALE C AND USING SUCH SIMPLE INTERPOLATION MAY SOMETIMES INTRODUCE C LARGER ERROR THAN USING A CLOSEST MODEL FROM THE GRID C WRITE(*,*)' PARAMETERS OF THE INTERPOLATED MODEL (T,LOG G)' WRITE(*,*)' MUST BE BETWEEN 2 COUPLES OF KURUCZ DISCRETE MODELS' WRITE(*,*)' AND EACH COUPLE MUST HAVE THE SAME LOG G' WRITE(*,*)' FIRST WE INTERPOLATE IN TEMPERATURE THEN IN LOG G' C C T2>T1 | A(40,4) C T2>T1 | B(40,4) C C | E1(40,4) E(40,4) E2(40,4) C C T1 | C(40,4) D(40,4) C-----------|-------------------------------------------------- C | G1 G2>G1 C OPEN(9,FILE='intkur3.in',STATUS='OLD') WRITE(*,*)' Reading from inkur3.in:' WRITE(*,*)' Extraction=0, Interpolation=1 ' READ(9,*) READ(9,*)IVOL WRITE(*,*)' Teff and LOG G of required model' READ(9,*) READ(9,*)ETEFF,ELOGG WRITE(*,*)' Teff and LOG G of the model with higher temperature P and lower log g' READ(9,*) READ(9,*)ATEFF,ALOGG WRITE(*,*)' Teff and LOG G of the model with higher temperature P and higher log g' READ(9,*) READ(9,*)BTEFF,BLOGG WRITE(*,*)' Teff and LOG G of the model with lower temperature P and lower log g' READ(9,*) READ(9,*)CTEFF,CLOGG WRITE(*,*)' Teff and LOG G of the model with lower temperature P and higher log g' READ(9,*) READ(9,*)DTEFF,DLOGG WRITE(*,*)' Number of depth points' READ(9,*) READ(9,*)NBOD WRITE(*,*) WRITE(*,*)' input file with the whole grid of Kurucz models:' READ(*,22)IN WRITE(*,*)' output file' READ(*,22)OUT OPEN(7,FILE=OUT,STATUS='UNKNOWN') 22 FORMAT(A30) IF(IVOL.EQ.0)THEN CALL RDAT(ETEFF,ELOGG,E,NBOD,IN,2,ETEFF,ELOGG,E) GOTO 100 ENDIF CALL RDAT(ATEFF,ALOGG,A,NBOD,IN,0,ETEFF,ELOGG,E) CALL RDAT(BTEFF,BLOGG,B,NBOD,IN,0,ETEFF,ELOGG,E) CALL RDAT(CTEFF,CLOGG,C,NBOD,IN,0,ETEFF,ELOGG,E) CALL RDAT(DTEFF,DLOGG,D,NBOD,IN,0,ETEFF,ELOGG,E) DO 70 J=1,NQUANT DO 60 I=1,NBOD E1(I,J)=(A(I,J)-C(I,J))*(ETEFF-CTEFF)/(ATEFF-CTEFF)+C(I,J) E2(I,J)=(B(I,J)-D(I,J))*(ETEFF-DTEFF)/(BTEFF-DTEFF)+D(I,J) 60 CONTINUE 70 CONTINUE DO 90 J=1,NQUANT DO 80 I=1,NBOD E(I,J)=(E2(I,J)-E1(I,J))*(ELOGG-CLOGG)/(DLOGG-CLOGG)+E1(I,J) 80 CONTINUE 90 CONTINUE CALL RDAT(DTEFF,DLOGG,D,NBOD,IN,1,ETEFF,ELOGG,E) 100 CLOSE(7) CLOSE(9) STOP END C----------------------------------------------------------------------- SUBROUTINE RDAT(ATEFF,ALOGG,A,NBOD,IN,ILAST,ETEFF,ELOGG,E) C ILAST=0 READING C ILAST=1 READING+WRITING C ILAST=2 EXTRACTION=READING+WRITING PARAMETER(NMAX=72,NQUANT=7) IMPLICIT DOUBLE PRECISION (A-H,O-Z) CHARACTER*30 IN CHARACTER*100 ACHAR,ACHAR1,ACHAR2,ACHAR3 DIMENSION A(NMAX,NQUANT),E(NMAX,NQUANT) OPEN(8,FILE=IN,STATUS='OLD') 10 READ(8,20,END=100)ACHAR 20 FORMAT(1X,A4) IF(ACHAR.EQ.'EGIN')GOTO 30 GOTO 10 30 CONTINUE READ(8,40)ACHAR1,ATE,ACHAR2,ALO,ACHAR3 40 FORMAT(A4,F8.0,A9,F8.5,A4) IF(ATE.NE.ATEFF.OR.ALO.NE.ALOGG)GOTO 10 IF(ILAST.GE.1) WRITE(7,40)ACHAR1,ETEFF,ACHAR2,ELOGG,ACHAR3 DO 50 I=1,21 READ(8,60)ACHAR IF(ILAST.GE.1) WRITE(7,60)ACHAR 50 CONTINUE 60 FORMAT(A100) READ(8,65)ACHAR1,NBODA,ACHAR2 65 FORMAT(A10,I3,A100) IF(ILAST.GE.1) WRITE(7,65)ACHAR1,NBODA,ACHAR2 IF(NBODA.NE.NBOD.AND.ILAST.NE.2)THEN WRITE(7,'(A)')' INCONSITENT NUMBER OF DEPTH POINTS' WRITE(*,'(A)')' INCONSITENT NUMBER OF DEPTH POINTS' GOTO 100 ENDIF DO 70 I=1,NBODA READ(8,*)(A(I,J),J=1,NQUANT) IF(ILAST.EQ.1)WRITE(7,80)(E(I,J),J=1,NQUANT) IF(ILAST.EQ.2)WRITE(7,80)(A(I,J),J=1,NQUANT) 70 CONTINUE 80 FORMAT(E16.9,F9.1,10E11.4) DO 90 I=1,2 READ(8,60)ACHAR IF(ILAST.GE.1)WRITE(7,60)ACHAR 90 CONTINUE CLOSE(8) 100 RETURN END