c23456789012345678901234567890123456789012345678901234567890123456789012 c======================================================================= c B E G I N c P R O G R A M c======================================================================= c Written By : Michelle Chouinard, May 2004 c Purpose : To determine the intrinsic (B-V)o values of observed c stars from given V, (B-V), (U-B) data. Outputs: c V, (B-V), (U-B), (B-V)o, E(B-V),and E(B-V)_BO values c to user-desired file, as well as, outputting it to c screen. c c Necessary c Imformation : c c 1) INPUT c FILE --> A file containing stars' observed data: c Data Source, star's ID#, V, (B-V) and (U-B). Data must c be listed columns with columns ordered as described c above. c c Source = 7 character maximum c ID # = 5 integer maximum (e.g. 21056) c * others are read in as entered. c c c 2) SLOPE: --> The Reddening 'SLOPE' is the [E_(U-B)] / [E_(B-V)] c value. This value will later be corrected by adding a c curvature term of 0.02*E_(B-V). Also, where c (B-V)o > 0.20, the slope varies according to: c c NEW SLOPE = SLOPE(w/ curve term) + 0.325*[(B-V)o - 0.20] c c The SLOPE inputted by user must be valid for all stars c in their corresponding INPUT FILE. c c The (B-V)o values are determined by finding the points of c intersection between the INTRINSIC FUNCTION and a line changing with c respect to the inputted SLOPE. The 'line' is extrapolated from the c DATA POINT read from the INPUT FILE. If there's no intersection and c if the created 'line' passes by an extremum of the intinsic function, c the (B-V)o is recorded as the (B-V) value where the smallest c difference between the 'line' and intrinsic function occurs. c c Variables : slope = Reddening Slope (inputted by user) c source = An abreviated form, with the maximum of 7 c characters, to describe the DATA SOURCE. c ID = A number, with the maximum of 5 integers, to c identify the star. c V = Absolute Magnitude of star (from INPUT FILE) c BVobs = Observed (B-V) values (from INPUT FILE) c UBobs = Observed (U-B) values (from INPUT FILE) c BVo = Intrinsic (B-V) value of star, (B-V)o c UB = (U-B), determined using reddening slope c dBV = Increment value for (B-V) c E_UB = (U-B) extinction; increment value for (U-B) c E_BV = (B-V) extinction, E_(B-V) c E_BV_BO = (B-V) extinction, equivalent to the color excess c of a BO star. c dUB1 = PREVIOUS difference between INTRINSIC FUNCTION C and 'line'. [(U-B)o - (U-B)] c dUB2 = MIDPOINT difference [(U-B)o - (U-B)] c dUB3 = CURRENT difference [(U-B)o - (U-B)] c curvterm = Curvature term c maxmin = MAXIMUM ABSOLUTE (U-B) difference allowed. c Used as a reference check for EXTREMA c dUBmin = Used to find the minimum difference c Compared to previous (U-B) difference, if c condition is met, then saved. c (dwarf stars) c eta = funtion to determine a value later used to c convert E(B-V) to E(B-V)_BO c fofx1 = Intrinsic fuction describing OB dwarf stars c fofx2 = Intrinsic fuction describing AF dwarf stars c fofx3 = Intrinsic fuction describing FGKM dwarf stars c fofx4 = Intrinsic fuction describing GK giant stars c c----------------------------------------------------------------------- c DECLARING VARIABLES: c program intrinsic c implicit none c character*15 infile , outfile character*7 source character*10 startype c logical flag c integer ID , choice real*8 slope , V , BVobs , UBobs , BVo 1 , dUB1 , dUB2 , dUB3 , dBV , E_UB 2 , UB1 , UB2 , UB3 3 , dUBmin 4 , fofx1 , fofx2 , fofx3 , fofx4, fofx5 , fofx6, fofx7 5 , curvterm , maxmin c parameter ( dBV = 0.001d0 ) parameter ( curvterm = dBV*0.020d0 ) c common / values / maxmin data maxmin /20.0d0/ c external fofx1, fofx2, fofx3, fofx4, fofx5, fofx6, fofx7 1 , E_UB, eta c c----------------------------------------------------------------------- c Getting OBSERVED data: SLOPE, INPUT FILE name and OUTPUT FILE name. c write(6,2015) read (5, *) choice 5 if ( choice .eq. 1) then write(6,2020) read (5, *) infile elseif (choice .eq. 2) then write(6,2025) choice = 1 go to 5 else write(6,2030) stop endif c write(6,2035) read (5, *) outfile open (15, file= infile, status= 'unknown') open (25, file= outfile, status= 'unknown') c write(6,2010) read (5, *) slope c write(6 ,2040) write(25,2040) c c - - - - - - - - - - - - - - - - - - - - - - - c Read OBSERVED data point from inputted data file: c 10 continue read(15,*,end = 30) source,ID,V, BVobs, UBobs BVo = BVobs UB2 = UBobs UB1 = UB2 + E_UB(BVo + dBV, slope, curvterm, dBV) dUBmin = maxmin c c - - - - - - - - - - - - - - - - - - - - - - - c Determining the (U-B) values from intrinsic function (UBo) at given c (B-V) value (BVo). Intrinsic function used depends on (B-V) value, c and whether or not star is DWARF or GIANT: c 20 continue UB3 = UB2 - E_UB(BVo + dBV, slope, curvterm, dBV) c if ( BVo .lt. -0.09d0) then ! OB dwarf stars startype = 'V OB' dUB1 = fofx1(BVo+dBV) - UB1 dUB2 = fofx1(BVo) - UB2 dUB3 = fofx1(BVo-dBV) - UB3 call check1( dUB2,dUB3,v, BVobs, UBobs, BVo 1 , source,ID,startype,flag ) endif c if ( BVo .lt. 0.02d0 ) then ! OB giant stars startype = 'III OB' dUB1 = fofx2(BVo+dBV) - UB1 dUB2 = fofx2(BVo) - UB2 dUB3 = fofx2(BVo-dBV) - UB3 call check1( dUB2,dUB3,v, BVobs, UBobs, BVo 1 , source,ID,startype,flag ) endif c if ( BVo .le. 0.05d0 ) then ! OBA supergiant Ib startype = 'Ib OBA' ! stars dUB1 = fofx3(BVo+dBV) - UB1 dUB2 = fofx3(BVo) - UB2 dUB3 = fofx3(BVo-dBV) - UB3 call check1( dUB2,dUB3,v, BVobs, UBobs, BVo 1 , source,ID,startype,flag ) endif c if ( BVo .le. 0.05d0 ) then ! OBA supergiant Ia startype = 'Ia OBA' ! stars dUB1 = fofx4(BVo+dBV) - UB1 dUB2 = fofx4(BVo) - UB2 dUB3 = fofx4(BVo-dBV) - UB3 call check1( dUB2,dUB3,v, BVobs, UBobs, BVo 1 , source,ID,startype,flag ) endif c if ( BVo .ge. -0.09d0 .and. ! AF dwarf stars 1 BVo .lt. 0.45d0 ) then startype = 'V AF' dUB1 = fofx5(BVo+dBV) - UB1 dUB2 = fofx5(BVo) - UB2 dUB3 = fofx5(BVo-dBV) - UB3 call check1( dUB2,dUB3,v, BVobs, UBobs, BVo 1 , source,ID,startype,flag ) if ( flag .eq. .false. ) then call check2( dUB1,dUB2,dUB3,v,BVobs,UBobs,BVo,dUBmin, 1 , source,ID,startype) endif endif c if ( BVo .ge. 0.45d0 .and. 1 BVo .lt. 1.60d0 ) then ! FGKM dwarf stars startype = 'V FGKM' dUB1 = fofx6(BVo+dBV) - UB1 dUB2 = fofx6(BVo) - UB2 dUB3 = fofx6(BVo-dBV) - UB3 call check1( dUB2,dUB3,v, BVobs, UBobs, BVo 1 , source,ID,startype,flag ) if ( flag .eq. .false. ) then call check2(dUB1,dUB2,dUB3,v,BVobs,UBobs,BVo,dUBmin 1 ,source,ID,startype ) endif c endif if ( BVo .ge. 0.55d0 .and. ! GK giant stars 1 BVo .lt. 1.65d0 ) then startype = 'III GK' dUB1 = fofx7(BVo+dBV) - UB1 dUB2 = fofx7(BVo) - UB2 dUB3 = fofx7(BVo-dBV) - UB3 call check1( dUB2,dUB3,v, BVobs, UBobs, BVo 1 , source,ID,startype,flag ) endif c c - - - - - - - - - - - - - - - - - - - - - - - c INCREMENT for next step: Determine new (B-V) value and switch c CURRENT (U-B) differences to PREVIOUS c (U-B)difference. c BVo = BVo - dBV UB1 = UB2 UB2 = UB3 c c - - - - - - - - - - - - - - - - - - - - - - - c IF (B-V) <= -0.33, go to the next star and find intrinsic values. c Otherwise continue with next increment. c if ( BVo .le. -0.33d0) goto 10 goto 20 c 30 continue ! CLOSE FILES close(15) close(25) c----------------------------------------------------------------------- c FORMAT STATEMENTS c----------------------------------------------------------------------- 2010 format('ENTER values: SLOPE' ) 2015 format('Enter corresponding number:'/ 1 '1) Continue and enter INPUT FILE name'/ 2 '2) Look at needed layout for INPUT FILE') 2020 format('ENTER name : INPUT file'/ 1 ' ( MAXIMUM 15 characters )' ) 2025 format('The INPUT should be a table consisting 5 columns:' 1 ,' SOURCE,ID,V,(B-V),and (U-B)'/ 2 ,' SOURCE = An abreviated form, with the maximum of 7'/ 3 ,' characters, to describe the DATA SOURCE.'/ 4 ,' ID = A number, with the maximum of 5 itegers, to'/ 5 ,' identify the star.',/ & ,' * Last 3 columns are real numbers read in as ' & ,'is.',/,' Example:'// 6 ,' SOURCE ID V (B-V) (U-B) <- omit row'/ 7 ,' source1 1 10.0d0 0.80d0 0.30d0'/ 8 ,' source1 2 9.0d0 0.50d0 0.20d0'/ 9 ,' source2 3 8.0d0 0.63d0 0.10d0'/ & ,' source2 4 7.0d0 0.90d0 0.40d0'/ & ,' source3 5 6.0d0 0.80d0 0.10d0'/) 2030 format('Choice entered not previously desribed. Try again' ) 2035 format('ENTER name : OUTPUT file' ) 2040 format(/'SOURCE ',' ID # ',' startype ',' V ',' (B-V) ' 1 ,' (U-B) ',' (B-V)o ',' E(B-V) ','E(B-V)_BO') end c======================================================================= c E N D c P R O G R A M c======================================================================= c c c======================================================================= c B E G I N S U B R O U T I N E c C H E C K 1 c======================================================================= subroutine check1( dUB2,dUB3,v, BVobs, UBobs, BVo 1 , source,ID,startype,flag ) c c Written By : Michelle Chouinard, May 2004 c Purpose: Check for intersection between (U-B) value extrapolated from c reddening SLOPE and (U-B)o value from INTRINSIC functions c (INTERSECTION CONDITION) c----------------------------------------------------------------------- c implicit none c character*7 source character*10 startype logical flag integer ID real*8 dUB2, dUB3, v, BVobs, UBobs, BVo, E_BV, maxmin 1 , eta, E_BV_BO c external eta common / values / maxmin c c----------------------------------------------------------------------- c INTERSECTION CONDITION c flag = .true. if ( dUB3*dUB2 .lt. 0.0d0 ) then E_BV = BVobs - BVo E_BV_BO = E_BV / eta(BVo) write(6 ,2010) source,ID,startype,v,BVobs,UBobs 1 ,BVo,E_BV,E_BV_BO write(25,2010) source,ID,startype,v,BVobs,UBobs 1 ,BVo,E_BV,E_BV_BO else flag = .false. endif c c----------------------------------------------------------------------- c FORMAT STATEMENTS c----------------------------------------------------------------------- c 2010 format(A,I5,4X,A,6f7.2) return end c======================================================================= c E N D S U B R O U T I N E c C H E C K 1 c======================================================================= c c c c======================================================================= c B E G I N S U B R O U T I N E c C H E C K 2 c======================================================================= subroutine check2( dUB1,dUB2,dUB3,v,BVobs,UBobs,BVo,dUBmin 1 , source,ID,startype) c c Written By : Michelle Chouinard, JUNE 2004 c Purpose: If no INTERSECTION occurs, Check for MAXIMUM/MINIMUM value c at EXTREMA. Using the DELTA values; dUB1, dUB2, and dUB3. c Here, dUB2 is the midpoint between dUB1 and DUB3 c (wrt (B-V) values). If dUB1> dUB2 < dUB3 (in regards to c the absolute differences) and dUB1 has same sign as dUB3, c then a EXTREMUM exists. c (MAX/MIN CONDITION) c c----------------------------------------------------------------------- c implicit none c character*7 source character*10 startype integer ID real*8 dUB1, dUB2, dUB3, v, BVobs , UBobs, BVo, E_BV 1 , dUBmin , maxmin, eta, E_BV_BO common / values / maxmin external eta c c----------------------------------------------------------------------- c c MAX/MIN CONDITION c if( ( (abs(dUB1) .gt. abs(dUB2) ) .and. 1 (abs(dUB3) .gt. abs(dUB2) ) ) 2 .and. 3 ( dUB1*dUB3 .gt. 0.0d0) ) then if (dUB2 .lt. dUBmin) then dUBmin = dUB2 E_BV = BVobs - BVo E_BV_BO = E_BV / eta(BVo) write(6 ,3010)source,ID,startype,v,BVobs,UBobs 1 ,BVo,E_BV,E_BV_BO write(25,3010)source,ID,startype,v,BVobs,UBobs 1 ,BVo,E_BV,E_BV_BO endif endif c----------------------------------------------------------------------- c FORMAT STATEMENTS c----------------------------------------------------------------------- c 3010 format(A,I5,4X,A,6f7.2) return end c======================================================================= c E N D S U B R O U T I N E c C H E C K 2 c======================================================================= c c c======================================================================= c FUNCTIONS c======================================================================= c function E_UB ( BVo,slope, curvterm, dBV ) c c Written by: Michelle Chouinard, May 2004 c Purpose: Correcting slope c - Adding on CURVATURE TERM. c - For (B-V)o > 0.20, the inputted slope varies c according to formula below. c c----------------------------------------------------------------------- c implicit none real*8 BVo, E_UB, slope, curvterm, dBV c c----------------------------------------------------------------------- c if ( BVo .gt. 0.20 ) then E_UB = ( slope + curvterm + 0.325d0*( BVo - 0.20d0 ) )*dBV else E_UB = ( slope + curvterm )*dBV endif return end c c======================================================================= c function fofx1 ( BVo ) c c Written by: Michelle Chouinard, May 2004 c purpose: Intrinsic function for OB DWARF stars. c BVo < -0.09 c c----------------------------------------------------------------------- c implicit none real*8 BVo, fofx1 c c----------------------------------------------------------------------- c fofx1 = 0.04181d0 + 3.77241d0*BVo return end c c======================================================================= c function fofx2 ( BVo ) c c Written by: Michelle Chouinard, AUG 2004 c purpose: Intrinsic function for OB gaint stars. c BVo < 0.02 c c----------------------------------------------------------------------- c implicit none real*8 BVo, fofx2 c c----------------------------------------------------------------------- c fofx2 = -0.0257d0 + 3.5918d0*BVo return end c c======================================================================= c function fofx3 ( BVo ) c c Written by: Michelle Chouinard, May 2004 c purpose: Intrinsic function for OB DWARF stars. c BVo < 0.05 c c----------------------------------------------------------------------- c implicit none real*8 BVo, fofx3 c c----------------------------------------------------------------------- c fofx3 = -0.3261d0 + 3.8334d0*BVo + 2.0977d0*(BVo)**2 1 - 5.5971d0*(BVo)**3 return end c c======================================================================= c function fofx4 ( BVo ) c c Written by: Michelle Chouinard, May 2004 c purpose: Intrinsic function for OB DWARF stars. c BVo < 0.05 c c----------------------------------------------------------------------- c implicit none real*8 BVo, fofx4 c c----------------------------------------------------------------------- c fofx4 = -0.4695d0 + 2.751d0*BVo - 1.1934d0*(Bvo)**2 1 + 18.71d0*(BVo)**3 + 202.76d0*(Bvo)**4 + 359.63d0*(BVo)**5 return end c c======================================================================= c function fofx5 ( BVo ) c c Written by: Michelle Chouinard, May 2004 c purpose: Intrinsic function for AF DWARF stars. c -0.09d0 =< BVo < 0.45d0 c c----------------------------------------------------------------------- c implicit none real*8 BVo, fofx5 c c----------------------------------------------------------------------- c fofx5 = 0.0058d0 + 1.8843d0*BVo - 13.5371d0*(BVo)**2 1 + 39.7012d0*(BVo)**3 - 64.9367d0*(BVo)**4 2 + 48.2489d0*(BVo)**5 return end c c======================================================================= c function fofx6 ( BVo ) c c Written by: Michelle Chouinard, May 2004 c purpose: Intrinsic function for FGKM DWARF stars. c 0.45d0 =< BVo < 1.60d0 c c----------------------------------------------------------------------- c implicit none real*8 BVo, fofx6 c c----------------------------------------------------------------------- c fofx6 = 0.2798d0 - 0.4122d0*BVo - 4.8083d0*(BVo)**2 1 + 13.1884*(BVo)**3 - 9.6226d0*(BVo)**4 2 + 2.1707*(BVo)**5 return end c c======================================================================= c function fofx7 ( BVo ) c c Written by: Michelle Chouinard, May 2004 c purpose: Intrinsic function for GK GIANTS stars. c 0.55d0 =< BVo < 1.60d0 c c----------------------------------------------------------------------- c implicit none real*8 BVo, fofx7 c c----------------------------------------------------------------------- c fofx7 = -1.1495d0 + 1.9789d0*BVo return end c c======================================================================= c function eta(BVo) c c Written By: Michelle Chouinard, June 2004 c Purpose: Factor used to divide the previously calculated E_BV by. c This will give the color excess equivalent to a BO star. c c----------------------------------------------------------------------- c implicit none real*8 eta, BVo c c----------------------------------------------------------------------- c eta = 1.0d0 - 0.0726744d0*(BVo + 0.32d0) return end c c=======================================================================