OV-GSO-DC / dustem-wrapper_idl

Commit 52a3cc3763899252a6931205aee6325e78a7f2e6

Authored by Annie Hughes
1 parent 11afdcd2
Exists in master

First commit of IAS routines

Showing 11 changed files with 1963 additions and 0 deletions   Show diff stats
Inline Side-by-side
src/idl/dustem_add_inst.pro 0 → 100644
  Diff comments   View file @52a3cc3
@@ -0,0 +1,30 @@ @@ -0,0 +1,30 @@
  1 +FUNCTION DUSTEM_ADD_INST, sf, tag, nsz, ntrans=ntrans
  2 +; fills in data for existing instruments in SMDAT structure
  3 +; or add a new instrument to SMDAT structure
  4 +;
  5 +; SF (I): SMDAT input structure
  6 +; TAG (I): name of instrument to add in
  7 +; NSZ (I): array(2) of sizes [nr of data pts, nr of grain types]
  8 +; NTRANS (I): nr of points for transmission (bad flux data)
  9 +
  10 + stag = TAG_NAMES(sf)
  11 + ntag = N_TAGS(sf)
  12 + tag = STRUPCASE('I_'+STRTRIM(tag,2))
  13 + itg = WHERE( stag EQ tag, ctg )
  14 + if n_elements(nsz) EQ 2 then begin
  15 + nx = nsz(0) & ntype = nsz(1)
  16 + endif else begin
  17 + print,'(F) DUSTEM_ADD_INST: array of sizes must be 2D'
  18 + endelse
  19 + if ctg EQ 0 then begin
  20 + if n_elements(ntrans) EQ 0 then st = CREATE_STRUCT( tag, DUSTEM_STR_INST(nx,n2=ntype) ) $
  21 + else st = CREATE_STRUCT( tag, DUSTEM_STR_INST(nx,n2=ntype,n3=ntrans) )
  22 + sf = CREATE_STRUCT( sf, st )
  23 + stag = TAG_NAMES(sf)
  24 + itg = WHERE( stag EQ tag )
  25 + sf.(itg).isel = intarr(nx) + 1
  26 + endif else begin
  27 + print,'(F) DUSTEM_ADD_INST: INST already exists in structure'
  28 + endelse
  29 + return,sf
  30 +END
src/idl/dustem_add_mod.pro 0 → 100644
  Diff comments   View file @52a3cc3
@@ -0,0 +1,54 @@ @@ -0,0 +1,54 @@
  1 +FUNCTION DUSTEM_ADD_MOD, sf, tag, nsz, unit=unit
  2 +; adds a model tag to a existing SMDAT structure
  3 +; SF (I): input SMDAT structure
  4 +; TAG (I): tag of model to be added
  5 +; NSZ (I): int array(2) of sizes [nr of data pts, nr of grain types]
  6 +
  7 + tag = STRLOWCASE(STRTRIM(tag,2))
  8 + if n_elements(nsz) GT 1 then begin
  9 + n1 = nsz(0) & n2 = nsz(1)
  10 + if n_elements(nsz) EQ 3 then n3 = nsz(2) else n3 = 0
  11 + endif else begin
  12 + print,'(F) ADD_MOD: array of sizes must > 1D'
  13 + endelse
  14 + if TAG EQ 'emis' then begin
  15 + if n_elements(unit) EQ 0 then unit='x(microns) SED(erg/s/cm2/sr)'
  16 + s1 = { UNIT : unit, $
  17 + X : dblarr(n1), $ ; wave
  18 + Y : dblarr(n1,n2), $ ; SED(wave, grain type) (index ntype is total)
  19 + YP : dblarr(n1,n2) } ; polarized SED(wave, grain type) (index ntype is total)
  20 + ENDIF else if TAG EQ 'ext' then begin
  21 + if n_elements(unit) EQ 0 then unit='x(microns) sigma(cm2/H)'
  22 + s1 = {UNIT : unit, $
  23 + X : dblarr(n1), $ ; wave
  24 + Y : dblarr(n1,n2), $ ; sigma_ext(wave, grain type) (index ntype is total)
  25 + ABS : dblarr(n1,n2), $ ; sigma_abs(wave, grain type)
  26 + SCA : dblarr(n1,n2), $ ; sigma_sca(wave, grain type)
  27 + ABS_P : dblarr(n1,n2), $ ; absorption sigma_pol(wave, grain type)
  28 + SCA_P : dblarr(n1,n2), $ ; scattering sigma_pol(wave, grain type)
  29 + ALB : dblarr(n1,n2), $ ; alb(wave, grain type)
  30 + XR : 0d, $ ; ref wave
  31 + YR_ABS : dblarr(n2), $ ; tau_abs/NH @ XR
  32 + YR_SCA : dblarr(n2), $ ; tau_sca/NH @ XR
  33 + RV : 0d }
  34 +; ENDIF else if TAG EQ 'pol' then begin
  35 +; if n_elements(unit) EQ 0 then unit='x(microns) SED(erg/s/cm2/sr)'
  36 +; s1 = {UNIT : unit, $
  37 +; X: dblarr(n1), $ ; wave
  38 +; Y: dblarr(n1,n2), $ ; polarized SED(wave, grain type) (index ntype is total)
  39 +; POL: dblarr(n1,n2) } ; sigma_pol(wave, grain type) (ABS + SCAT)
  40 + ENDIF else if tag EQ 'sdist' then begin
  41 + if n3 EQ 0 then begin
  42 + print,'(F) ADD_MOD: 3d dimension missing '
  43 + return,0
  44 + endif
  45 + if n_elements(unit) EQ 0 then unit='x(cm) a^4*dn/da(cm3/H)'
  46 + s1 = {UNIT : unit, $
  47 + XTOT : dblarr(n1), $ ; grain size
  48 + YTOT : dblarr(n1,n2), $ ; size distribution
  49 + XI : dblarr(n3,n2), $ ; grain size per type
  50 + YI : dblarr(n3,n2) } ; grain size dist per type
  51 + ENDIF
  52 + sm = CREATE_STRUCT( CREATE_STRUCT('M_'+tag,s1), sf )
  53 + return, sm
  54 +END
src/idl/dustem_band_cc.pro 0 → 100644
  Diff comments   View file @52a3cc3
@@ -0,0 +1,101 @@ @@ -0,0 +1,101 @@
  1 +FUNCTION dustem_BAND_CC, w0, xs, ys, xt, yt, y0=y0, cc=cc, rr=rr, nint=nint
  2 +; returns flux in given instrument band (erg/cm2/sr)
  3 +; W0 (I): centroid of filter (any unit)
  4 +; XS (I): input x-grid for SED (same unit as W0)
  5 +; YS (I): input SED in erg/cm2/sr
  6 +; XT (I/O): x-grid of filter (same unit as W0)
  7 +; YT (I/O): filter transmission (arb. unit)
  8 +; RR (O): undersampling ratio: dx(SED)/dx(filt), usually 1.
  9 +; If RR<1 filter oversampled in flux integration
  10 +; Y0 (O): SED at band center
  11 +; CC (O): color correction
  12 +; NINT (O): nr of points in band integration
  13 +
  14 + vlow = 1d-5
  15 +
  16 +; remove bad and multiple values in filter
  17 + xtt=xt & ytt=yt
  18 + iq = UNIQ(xtt,sort(xtt))
  19 + xtt = xtt(iq) & ytt = ytt(iq)
  20 + in = where( (xtt GT 0d) AND (ytt GT 0d), cn )
  21 + if cn GT 0 then begin
  22 + xtt = xtt(in)
  23 + ytt = ytt(in)
  24 + endif else begin
  25 +; if no good point in filter, band flux and the rest is 0
  26 + sed=0d & rr=0d & y0=0d & cc=0d & nint=n_elements(xt)
  27 + return,sed
  28 + endelse
  29 + nfilt = n_elements(xtt)
  30 +
  31 +; sort arrays
  32 + ix = SORT(xtt)
  33 + xtt = xtt(ix) & ytt = ytt(ix)
  34 + ytt = ytt / MAX(ytt)
  35 + ix = SORT(xs)
  36 + xss = xs(ix) & yss = ys(ix)
  37 + xt=xtt & yt=ytt
  38 +
  39 +; shrink SED array
  40 + ix = WHERE( xss GE MIN(xtt) AND xss LE MAX(xtt), cx)
  41 + if cx GT 0 then begin
  42 +; add points at edges for interpolation
  43 + i1 = 0
  44 + if ix(0) GT i1 then i1 = ix(0)-1
  45 + i2 = n_elements(xss)-1
  46 + if ix(cx-1) LT i2 then i2 = ix(cx-1)+1
  47 + xss = xss(i1:i2)
  48 + yss = yss(i1:i2)
  49 + endif else begin
  50 +; if no good point in SED, band flux and the rest is 0
  51 + sed=0d & rr=0d & y0=0d & cc=0d & nint=n_elements(xt)
  52 + return,sed
  53 + endelse
  54 + nsed = n_elements(xss)
  55 +
  56 +; get filter sampling f_res = dx(filt)
  57 + ix = WHERE( ytt/MAX(ytt) GT vlow, cx )
  58 + f_res = ABS( MEDIAN( xtt(ix(1:cx-1))-xtt(ix(0:cx-2)) ) )
  59 +
  60 +; Interpolate to compute integration
  61 + IF NFILT GE NSED THEN BEGIN
  62 +; finer filter grid: integrate band flux on filter x-grid
  63 + xi = xtt
  64 + rr = 1d ; SED sampling is filter sampling
  65 + yi = INTERPOL(yss,xss,xi)
  66 + filt = ytt
  67 + ENDIF ELSE BEGIN
  68 +; finer SED grid: integrate band flux on SED x-grid
  69 + xi = xss & yi = yss
  70 +; get SED sampling: s_res = dx(SED) and sampling ratio
  71 + s_res = ABS( MEDIAN( xi(1:nsed-1)-xi(0:nsed-2) ) )
  72 + rr = s_res / f_res
  73 + filt = INTERPOL(ytt, xtt, xi)
  74 + io = WHERE( xi GT MAX(xtt) OR xi LT MIN(xtt), co)
  75 + if co GT 0 then filt(io) = 0d
  76 + in = where( filt LT 0d, cn)
  77 + if cn GT 0 then filt(in) = 0d
  78 + ENDELSE
  79 + xt=xi & yt=filt
  80 +
  81 +; Integrate on filter bandpass (log-grid)
  82 +; trapezium safe and accurate enough -
  83 + np = n_elements(xi)
  84 + nint = np
  85 + dx = xi(1:np-1) - xi(0:np-2)
  86 + yint = yi*filt/xi
  87 +; a1 = INT_TABULATED(xi,yint, /double)
  88 + yint = (yint(0:np-2) + yint(1:np-1)) / 2d0
  89 + a1 = TOTAL( yint*dx )
  90 + yint = filt/xi
  91 +; a2 = INT_TABULATED(xi,yint, /double)
  92 + yint = (yint(0:np-2) + yint(1:np-1)) / 2d0
  93 + a2 = TOTAL( yint*dx )
  94 +
  95 +; get color correction, color corrected band flux and sed
  96 + y0 = INTERPOL( yi, xi, w0)
  97 + cc = a1/a2/y0
  98 + sed = y0*cc
  99 +
  100 + RETURN, sed
  101 +END
src/idl/dustem_blackbody.pro 0 → 100644
  Diff comments   View file @52a3cc3
@@ -0,0 +1,152 @@ @@ -0,0 +1,152 @@
  1 +FUNCTION DUSTEM_BLACKBODY, x, temp, unit=unit, wdil=wdil, check=check, g0=g0, chi=chi, $
  2 + bb_to_hab=bb_to_hab, NORM=norm
  3 + if n_params() EQ 0 then begin
  4 + print,'------------------------------------------------------------------------------------------'
  5 + print,'FUNCTION DUSTEM_BLACKBODY, x, temp, unit=unit, wdil=wdil, NORM=norm, check=check, g0=g0, chi=chi'
  6 + print,'------------------------------------------------------------------------------------------'
  7 + print,' computes a (or a sum of) blackbody brightness(es) B(x,T) in W/m2/(x unit)/sr '
  8 + print,' X (I): blackbody abscissa in cm-1, GHz, microns or eV'
  9 + print,' TEMP (I): blackbody temperature (can be an array)'
  10 + print,' WDIL (I): dilution factor for each TEMP. [Default=1].'
  11 + print,' UNIT (I): blackbody x unit ''K'' is B_nu (W/m2/cm-1/sr), x in cm-1 '
  12 + print,' ''F'' is B_nu (W/m2/Hz/sr), x in GHz [default]'
  13 + print,' ''W'' is B_lambda (W/m2/um/sr), x in microns.'
  14 + print,' ''E'' is B_E (W/m2/eV/sr), x in eV'
  15 + print,' NORM (I): overall normalizing factor, returns NORM*BB/MAX(BB)'
  16 + print,' CHECK (O): check energy conservation for the BB (power is sigma*T^4)'
  17 + print,' CHI (O): scaling factor @ 1000 A in ISRF unit (1.6e-3 erg/cm2/s)'
  18 + print,' G0 (O): scaling factor for integrated 5-13.6 eV flux in ISRF unit.'
  19 + print,''
  20 + print,' Created 2001, L Verstraete IAS'
  21 + print,' More units and checks, Oct 2010 LV'
  22 + print,'---------------------------------------------------------------------------------------'
  23 + return,0
  24 + endif
  25 + nx = n_elements( X )
  26 + nt = n_elements( TEMP )
  27 + nw = n_elements( WDIL )
  28 + if nw EQ 0 then begin
  29 + wdil = dblarr(nt) + 1.
  30 + endif else begin
  31 + if nw LT nt then begin
  32 + print,'DUSTEM_BLACKBODY (F): WDIL and TEMP have different sizes'
  33 + return, 0
  34 + endif
  35 + endelse
  36 +
  37 + if n_elements( UNIT ) EQ 0 then unit='F' $
  38 + else begin
  39 + unit = strupcase(strcompress(unit,/rem))
  40 + if unit NE 'K' AND unit NE 'F' AND unit NE 'W' AND unit NE 'E' then begin
  41 + print,'DUSTEM_BLACKBODY (W): not a valid BB unit --> make a B_nu'
  42 + unit = 'F'
  43 + endif
  44 + endelse
  45 +
  46 + if n_elements( CHECK ) GT 1 then check = 0
  47 +
  48 + x = double(x)
  49 + temp = double(temp)
  50 + wdil = double(wdil)
  51 +
  52 + xpi = 3.1415926535897932385d
  53 + clight = 2.9979246d08 ; m/s
  54 + kb = 1.3806503d-23
  55 + hp = 6.62606876d-34
  56 + hck = hp*clight / kb
  57 + ze = 1.60217653d-19 ; electron charge
  58 + hev = hp/ze ; h in eV unit
  59 +
  60 + xly = 12.4
  61 + isrf0 = 1.6d-6 ; 4*pi*nu*I_nu (W/m2) in solar neighborhood
  62 +
  63 +;
  64 +; loop on temperatures
  65 +;
  66 + bbt = dblarr(nx)
  67 + acheck = 0.
  68 +
  69 + FOR j = 0, nt-1 do begin
  70 +
  71 + xi = [6., 13.6]
  72 +
  73 + CASE UNIT OF
  74 +
  75 + 'K': begin
  76 + be = exp( -(1d2*x) * hck / temp(j) )
  77 + bb = be * (1d2*x)^3 / (1.d0 - be)
  78 + bb = bb * 2d0 * hp * clight^2
  79 + bb = bb * 1d2 ; m-1 to cm-1
  80 + xi = xi / hev/clight/1d2
  81 + x1 = xly / hev/clight/1d2
  82 + end
  83 +
  84 + 'F': begin
  85 + be = exp( -(1d9*x) * hp/kb/ temp(j) )
  86 + bb = be * (1d9*x)^3 / (1.d0 - be)
  87 + bb = bb * 2d0 * hp / clight^2
  88 + xi = xi / hev / 1d9
  89 + x1 = xly / hev / 1d9
  90 + end
  91 +
  92 + 'W': begin
  93 + be = exp( -hp*clight/kb/ (1d-6*x) / temp(j) )
  94 + bb = be / (1d-6*x)^5 / (1.d0 - be)
  95 + bb = bb * 2d0 * hp * clight^2
  96 + bb = 1d-6 * bb ; m-1 to micron-1
  97 + xi = hev*clight*1d6 / xi
  98 + x1 = hev*clight*1d6 / xly
  99 + end
  100 +
  101 + 'E': begin
  102 + be = exp( -(ze*x)/kb / temp(j) )
  103 + bb = be * (ze*x)^3 / (1.d0 - be)
  104 + bb = bb * 2d0 / hp^3 / clight^2
  105 + bb = bb * ze ; J-1 to eV-1
  106 + xi = xi
  107 + x1 = xly
  108 + end
  109 +
  110 + ENDCASE
  111 +
  112 + ck = 0.
  113 + for jx = 1L,nx-1 do $
  114 + ck = ck + ( bb(jx)+bb(jx-1) )*( x(jx)-x(jx-1) ) / 2.d0
  115 + ck = xpi* ck / 5.6697d-8 / temp(j)^4
  116 +
  117 + if n_elements( CHECK ) NE 0 then begin
  118 + if check EQ 1 then $
  119 + print,'DUSTEM_BLACKBODY (W): integrated BB('+strtrim(temp(j),2)+$
  120 + ' K) is '+ strtrim(ck,2)+ ' times Sigma*T^4'
  121 + endif
  122 + acheck = [ acheck, ck ]
  123 +
  124 + bbt = bbt + bb*wdil(j)
  125 +
  126 + ENDFOR
  127 +
  128 + check = acheck(1:*)
  129 +
  130 +; get G0
  131 + ig = where( x GE MIN(xi) AND x LE MAX(xi), cg)
  132 + if cg GT 0 then begin
  133 + xx=x(ig)
  134 + yy=xpi*x(ig)*bbt(ig)
  135 + s1 = TOTAL( (yy(1:cg-1)+yy(0:cg-2))*(xx(1:cg-1)-xx(0:cg-2))/2.D0 )
  136 + g0 = s1/isrf0
  137 + endif else g0 = 0.d0
  138 +
  139 +; get chi
  140 + ig = where( abs(2.*(x-x1)/(x+x1)) LE 1.d-1, cg)
  141 + if cg GT 0 then begin
  142 + tmp = min( abs(x(ig)-x1), i_min )
  143 + ig = ig(i_min)
  144 + ig = ig(0)
  145 + chi = xpi * x(ig) * bbt(ig) / isrf0
  146 + endif else chi = 0
  147 +
  148 + if n_elements( NORM ) NE 0 then bbt = norm * bbt/max(bbt)
  149 +
  150 +the_end:
  151 + RETURN, BBT
  152 +END ;FUNCTION BLACKBODY
src/idl/dustem_chi2.pro 0 → 100644
  Diff comments   View file @52a3cc3
@@ -0,0 +1,17 @@ @@ -0,0 +1,17 @@
  1 +FUNCTION DUSTEM_CHI2, y, model, npar, err=err
  2 +; returns the chi-square value of fit MODEL to data Y
  3 +;
  4 +; NPAR (I): nr of parameters in the fit
  5 +; ERR (I): error of each data point. Default is ERR=0.1*Y
  6 +
  7 + ny = n_elements(y)
  8 + if n_elements(err) EQ 0 OR TOTAL(err) EQ 0 then begin
  9 + err = 0.1*y
  10 + print,'(W) CHI2: error missing, set to 10 %'
  11 + endif
  12 + ndof = ny - npar ; nr of degrees of freedom
  13 + chi = TOTAL( ((y-model)/err)^2 )
  14 + if ndof GT 0 then chi = chi / ndof
  15 +
  16 + return, chi
  17 +END
src/idl/dustem_create_rfield.pro 0 → 100755
  Diff comments   View file @52a3cc3
@@ -0,0 +1,230 @@ @@ -0,0 +1,230 @@
  1 +FUNCTION HABING_FIELD, x, unit=unit
  2 +; computes the Habing interstellar radiation field SED (ISRF)
  3 +; in W/m2 (4*!pi*nu*I_nu)
  4 +; (from Draine & Bertoldi 1996)
  5 +; X (I): X-grid for the ISRF
  6 +; UNIT (I): unit of the ISRF. Choices are
  7 +; 'W': wave in um [Default]
  8 +; 'F': frequency in cm-1
  9 +; 'E': energy in eV
  10 +
  11 + if n_elements( UNIT ) EQ 0 then unit = 'W' $
  12 + else unit = strupcase( strcompress( unit,/rem) )
  13 +
  14 + x = double( x )
  15 +
  16 + CASE unit of
  17 +
  18 + 'W': x3 = 1.d1 * x
  19 +
  20 + 'F': x3 = 1.d5 / x
  21 +
  22 + 'E': x3 = 12.4 / x
  23 +
  24 + ENDCASE
  25 +
  26 + field = - x3^3*4.1667 + x3^2*12.5 - x3*4.3333
  27 + field = 1.d-1 * 3.d8 * 1.d-14 * field
  28 +
  29 + i_neg = where( field LT 0.d0, c_neg )
  30 + field( i_neg ) = 0.d0
  31 +
  32 + RETURN, field
  33 +END ;FUNCTION HABING_FIELD
  34 +
  35 +
  36 +FUNCTION MATHIS_FIELD, x, unit=unit
  37 +; computes the Mathis interstellar radiation field SED (ISRF)
  38 +; in W/m2 (4*!pi*nu*I_nu)
  39 +; from Mathis et al. 1983, A&A 128, 212
  40 +; X (I): X-grid for the ISRF
  41 +; UNIT (I): unit of the ISRF. Choices are
  42 +; 'W': wave in um [Default]
  43 +; 'F': frequency in cm-1
  44 +; 'E': energy in eV
  45 +
  46 + if n_elements( UNIT ) EQ 0 then unit = 'W' $
  47 + else unit = strupcase( strcompress( unit,/rem) )
  48 +
  49 + ly_limit = 9.11267101235d-2
  50 +
  51 + x = double( x )
  52 +
  53 +;
  54 +; visible part
  55 +;
  56 + wdil = 4.d0 * [ 4.d-13, 1.d-13, 1.d-14] ; Mathis definition
  57 + ; 4*!pi*Wdil*B_nu
  58 + field = !pi * x * BLACKBODY( x, [ 3.d3, 4.d3, 7.5d3 ], wdil=wdil, unit=unit )
  59 +
  60 +;
  61 +; UV part
  62 +;
  63 +
  64 +; first convert to (lambda / 1e3 AA)
  65 + CASE unit of
  66 +
  67 + 'W': x3 = 1.d1 * x
  68 +
  69 + 'F': x3 = 1.d5 / x
  70 +
  71 + 'E': x3 = 12.4 / x
  72 +
  73 + ENDCASE
  74 +
  75 + il = where( x3 LE 2.46, cl )
  76 + if cl GT 0 then field(il) = 0.D0
  77 +
  78 + il = where( x3 GE 1d1*ly_limit AND x3 LT 1.11, cl )
  79 + if cl GT 0 then field(il) = 1.4817d-6 * x3(il)^(4.4172)
  80 + il = where( x3 GE 1.11 AND x3 LT 1.34, cl )
  81 + if cl GT 0 then field(il) = 2.0456d-6 * x3(il)
  82 + il = where( x3 GE 1.34 AND x3 LT 2.46, cl )
  83 + if cl GT 0 then field(il) = 3.3105d-6 * x3(il)^(-0.6678)
  84 +
  85 +
  86 + RETURN, field
  87 +END ;FUNCTION MATHIS_FIELD
  88 +
  89 +
  90 +FUNCTION CREATE_RFIELD, temp, x=x, isrf=isrf, wdil=wdil, wcut=wcut, g0=g0, chi=chi, fname=fname
  91 +
  92 + if N_PARAMS() LT 1 then begin
  93 + print,'------------------------------------------------------------------------------------------------------'
  94 + print,'FUNCTION CREATE_RFIELD, temp, x=x, isrf=isrf, wdil=wdil, wcut=wcut, g0=g0, chi=chi, fname=fname'
  95 + print,'------------------------------------------------------------------------------------------------------'
  96 + print,''
  97 + print,' generates the radiation field for DUSTEM (ISRF.DAT)'
  98 + print,' in erg/cm2/s/Hz (4*!pi*I_nu)'
  99 + print,' RFIELD = ISRF + WDIL*PI*BB(TEMP) '
  100 + print,' ISRF from Mathis et al. 1983, A&A 128, 212'
  101 + print,' NB: if blackbody is isotropic set WDIL to 4 (to get 4*!pi factor)'
  102 + print,''
  103 + print,' TEMP (I): blackbody temperature (can be an array). If 0 only ISRF.'
  104 + print,' X (I): X-grid for the ISRF in microns. Default is 200 pts over 0.01-10^5 microns.'
  105 + print,' (including WCUT point). You want to include WCUT for accurate edges.'
  106 + print,' ISRF (I): if set to 0 no ISRF is added, 1 is Mathis (default), 2 is Habing'
  107 + print,' WDIL (I): blackbody dilution factor (can be an array)'
  108 + print,' FNAME(I): filename for ISRF.DAT'
  109 + print,' WCUT (I): for wave < wcut radiation field is 0 '
  110 + print,' G0 (O): factor flux(6-13.6eV) wrt. Mathis field '
  111 + print,' CHI (O): scaling factor at 100nm wrt. Mathis field'
  112 + print,''
  113 + print,'Example: tt = create_rfield([2d4,5d4],wdil=[1.d-14,1.d-16],x=x,fname=''ISRF.DAT'')'
  114 + print,''
  115 + print,' Created Aug. 2009, L. Verstraete, IAS'
  116 + print,' Force the WCUT point, May 2011, LV'
  117 + print,''
  118 + print,'------------------------------------------------------------------------------------------------------'
  119 + RETURN,0
  120 + endif
  121 +
  122 +; inits
  123 + unit='W'
  124 + ly_limit = 9.11267101235d-2
  125 + xi = [ ly_limit, 2.07d-1 ] ; for G0 6-13.6 eV in microns
  126 + x1 = 1.d-1 ; for CHI
  127 +
  128 + if n_elements(WCUT) EQ 0 then wcut=ly_limit
  129 + if n_elements(x) EQ 0 then begin
  130 + nx = 199
  131 + xb = [ 1.d-2, 1.d5 ] ; wave boundaries in microns
  132 + dx = (alog(xb(1))-alog(xb(0))) / (nx-1)
  133 + x = alog(xb(0)) + dindgen(nx)*dx
  134 + x = exp(x)
  135 + x = [x, wcut] ; add wcut to avoid coarse edge
  136 + x = x(UNIQ(x,SORT(x)))
  137 + nx = n_elements(x)
  138 + if x(nx-1) NE xb(1) then x(nx-1)=xb(1) ; check rounding
  139 + endif else begin
  140 + print,'(W) CREATE-RFIELD : using input wave x'
  141 + x = double(x)
  142 + nx = n_elements(x)
  143 + ix = WHERE( ABS(x-wcut)/x LE 0.01, cx )
  144 + if cx EQ 0 then begin
  145 + print,'(W) CREATE_RFIELD: your x-grid does not contain wcut.'
  146 + print,' Should be included if radiation is 0 below wcut.'
  147 + endif
  148 + endelse
  149 +
  150 + rfield = dblarr(nx)
  151 +; get Habing for normalization
  152 + rhabing = HABING_FIELD(x,unit=unit)
  153 + rhabing = 1.d3*x*rhabing/3.d14 ; erg/cm2/s/Hz
  154 +
  155 +; get isrf
  156 + rmathis = MATHIS_FIELD(x,unit=unit)
  157 + rmathis = 1.d3*x*rmathis/3.d14 ; erg/cm2/s/Hz
  158 +
  159 + if n_elements(ISRF) EQ 0 then ISRF=1
  160 + if ISRF EQ 1 then begin
  161 + print,'(W) CREATE_RFIELD : adding Mathis ISRF'
  162 + rfield = rmathis
  163 + endif else if ISRF EQ 2 then begin
  164 + print,'(W) CREATE_RFIELD : adding Habing ISRF'
  165 + rfield = rhabing
  166 + endif
  167 +
  168 +; get blackbody
  169 + ntemp = n_elements(TEMP)
  170 + if ntemp GT 0 then begin
  171 + bb = BLACKBODY( x, temp, unit=unit, wdil=wdil )
  172 + bb = bb * 1.d3 * !pi * x^2 / 3.d14 ; erg/cm2/s/Hz
  173 + print,'(W) CREATE_RFIELD : adding BB with T= ',temp, format='(A38,10(1E10.4,1x))'
  174 + print,' dilution factor wdil= ',wdil, format='(A38,10(1E10.4,1x))'
  175 + endif else bb=0.D0
  176 + rfield = rfield + bb
  177 +
  178 +; apply cut
  179 + ix = WHERE( x LT WCUT, cx )
  180 + if cx GT 0 then rfield(ix)=0.d0
  181 +
  182 +; get G0
  183 + ig = where( x GE xi(0) AND x LE xi(1), cg)
  184 + if cg GT 0 then begin
  185 + xx=x(ig)
  186 + yy=rfield(ig)
  187 + rr=rmathis(ig)
  188 + s1 = TOTAL( (yy(1:cg-1)+yy(0:cg-2))*(xx(1:cg-1)-xx(0:cg-2))/2.D0 )
  189 + s2 = TOTAL( (rr(1:cg-1)+rr(0:cg-2))*(xx(1:cg-1)-xx(0:cg-2))/2.D0 )
  190 + g0 = s1/s2
  191 + endif else g0 = 0.d0
  192 + print,'(W) CREATE_RFIELD : G0 =',g0
  193 +
  194 +; get chi
  195 + ig = where( abs(2.*(x-x1)/(x+x1)) LE 1.d-1, cg)
  196 + if cg GT 0 then begin
  197 + tmp = min( abs(x(ig)-x1), i_min )
  198 + ig = ig(i_min)
  199 + ig = ig(0)
  200 + chi = rfield(ig) / rmathis(ig)
  201 + endif else chi = 0
  202 + print,'(W) CREATE_RFIELD : chi =',chi
  203 +
  204 +; write file
  205 + if n_elements(FNAME) NE 0 then begin
  206 + OPENW, iu, fname, /get_lun
  207 + printf, iu, '# DUSTEM: exciting radiation field featuring '
  208 + if ISRF EQ 1 then printf, iu, '# Mathis ISRF'
  209 + if NTEMP GT 0 then begin
  210 + a = '# Blackbody with T='
  211 + a1 = '# dilution factor wdil='
  212 + for i = 0, ntemp - 1 do begin
  213 + a = a + string( format='(2x,1E11.4)', temp(i) )
  214 + a1 = a1 + string( format='(2x,1E11.4)', wdil(i) )
  215 + endfor
  216 + printf, iu, a
  217 + printf, iu, a1
  218 + endif
  219 + printf, iu, '# Nbr of points'
  220 + printf, iu, '# wave (microns), 4*pi*Inu (erg/cm2/s/Hz)'
  221 + printf, iu, nx, format='(i4)'
  222 + for i=0,nx-1 do begin
  223 + printf, iu, x(i), rfield(i), format='(2(1E13.6,2x))'
  224 + endfor
  225 + FREE_LUN, iu
  226 + print,'(W) CREATE_RFIELD: radiation field written in ', strtrim(fname,2)
  227 + ENDIF
  228 +
  229 + RETURN, RFIELD
  230 +END
src/idl/dustem_create_vdist.pro 0 → 100755
  Diff comments   View file @52a3cc3
@@ -0,0 +1,224 @@ @@ -0,0 +1,224 @@
  1 +FUNCTION PLAW, x, par
  2 +; generates a volume normalized power law x^par(0)
  3 +; returns distribution in nr of grains : dn/da
  4 +; x : grain size
  5 +; par(0) : power law index
  6 +; par(1) : VOLUME normalization
  7 +; par(2) : curvature parameter beta
  8 +; par(3) : large size threshold At
  9 +
  10 + np = n_elements(x)
  11 + y = x^par(0)
  12 +; curvature term
  13 + if ((par(2) NE 0) AND (par(3) NE 0)) then begin
  14 + psgn = par(2)/ABS(par(2))
  15 + y = y * ( 1.d0 + ABS(par(2))*x/par(3) )^psgn
  16 + endif
  17 + vy = x^4 * y
  18 + dx = ALOG(x(1:np-1)) - ALOG(x(0:np-2))
  19 + yi = TOTAL( (vy(1:np-1) + vy(0:np-2))*0.5*dx )
  20 + y = par(1) * y / yi
  21 +RETURN, y
  22 +END
  23 +
  24 +
  25 +FUNCTION LOGN, x, par
  26 +; generates a volume normalized log-normal law
  27 +; returns distribution in nr of grains : dn/da
  28 +; x : grain size
  29 +; par(0) : centroid of log-normal
  30 +; par(1) : sigma of log-normal
  31 +; par(2) : VOLUME normalization
  32 +
  33 + np = n_elements(x)
  34 + x0 = par(0)
  35 + sigma = par(1)
  36 + y = exp(- 0.5 * ( alog(x/x0) / sigma )^2 ) / x
  37 + vy = x^4 * y
  38 + xm = par(0) * exp( -par(1)^2 ) ; x of max in dn/da
  39 + print,'(W) LOGN: dn/da max @',xm*1e7,' nm'
  40 + dx = alog(x(1:np-1)) - alog(x(0:np-2))
  41 + yi = TOTAL( (vy(1:np-1) + vy(0:np-2))*0.5*dx )
  42 + y = par(2) * y / yi
  43 +RETURN, y
  44 +END
  45 +
  46 +FUNCTION CUT_OFF, x, par
  47 +; generates the large size cut-off
  48 +; from Weingartner & Draine 2001
  49 +; x : grain size
  50 +; par(0) : threshold for cut-off (At)
  51 +; par(1) : shape As (roughly the size where cut_off=0.5)
  52 +
  53 + y = 0.d0*x + 1.d0
  54 + ix = WHERE( x GT par(0), cnt )
  55 + if CNT GT 0 then begin
  56 + y(ix) = exp( -( (x(ix)-par(0)) / par(1))^3. )
  57 + endif else begin
  58 + print,'(W) CUT_OFF: no size larger than At found'
  59 + endelse
  60 +RETURN, y
  61 +END
  62 +
  63 +
  64 +FUNCTION CREATE_VDIST, ar, rho, fv=fv, mfrac=mfrac, ag=ag, ns=ns, slaw=slaw, par=par, cutof=cutof, $
  65 + norm=norm, fname=fname, C_WD=C_WD
  66 +
  67 +;
  68 +; Doc
  69 +;
  70 + if N_PARAMS() LT 1 then begin
  71 + print,'----------------------------------------------------------------------------------------------------'
  72 + print,'FUNCTION CREATE_VDIST, ar, rho, fv=fv, mfrac=mfrac, ag=ag, ns=ns, slaw=slaw, par=par, cutof=cutof, $'
  73 + print,' norm=norm, fname=fname, C_WD=C_WD'
  74 + print,'----------------------------------------------------------------------------------------------------'
  75 + print,''
  76 + print,'generates a dust size distribution in volume normalized to 1 or norm'
  77 + print,'uses power law or log-normal component'
  78 + print,''
  79 + print,' AR (I): array(2) size range in cm '
  80 + print,' RHO (I): density (g/cm3) of grain type (array if composite)'
  81 + print,' FV (I): volume fractions if composite'
  82 + print,' MFRAC(I): mass fraction if composite'
  83 + print,' AG (O): size grid in cm (output)'
  84 + print,' NS (I): nr of sizes [Default = 10]'
  85 + print,' SLAW (I): array of size dist. law of grains ''PLAW'' or ''LOGN'''
  86 + print,' [Default = ''PLAW'' with index -3.5]'
  87 + print,' PAR (I): array(nlaw,npar) parameters for the size dist law: '
  88 + print,' [index,integral,beta,At] for PLAW and [center,width,integral] for LOGN'
  89 + print,' CUTOF(I): parameters for large size cut-off in microns. Default is [0.0107,0428].'
  90 + print,' NORM (I): normalization for the size distribution'
  91 + print,' FNAME(I): file name to write size dist. in'
  92 + print,' C_WD (I): keyword to generate a C dust size dist WD01 style'
  93 + print,' ( PAH, VSG as log-normal+power law a^(-2.54) ) '
  94 + print,''
  95 + print,' Example 1: a power-law'
  96 + print,' par=dblarr(1,4) & par(0,0)=-3.21 & par(0,1)=1. & par(0,2)=0.3 & par(0,3)=0.164e-4'
  97 + print,' sd = CREATE_VDIST( [3.e-8,2.5e-5], 3.3, slaw=''plaw'', par=par )'
  98 + print,''
  99 + print,' Example 2: a log-normal'
  100 + print,' par=dblarr(1,3) & par(0,0)=4.d-8 & par(0,1)=0.2 & par(0,2)=0.3 '
  101 + print,' sd = CREATE_VDIST( [3.e-8,2.5e-5], 2.25, slaw=''logn'', par=par )'
  102 + print,''
  103 + print,' Created March 2009, L. Verstraete, IAS'
  104 + print,''
  105 + print,'----------------------------------------------------------------------------------------------------'
  106 + RETURN, 0
  107 + endif
  108 +
  109 +; inits
  110 + if n_elements( AR ) EQ 0 then begin
  111 + print,'(F) CREATE_VDIST: you must define a size range'
  112 + RETURN,0
  113 + endif
  114 + if n_elements( RHO ) EQ 0 then begin
  115 + print,'(F) CREATE_VDIST: you must define a grain mass density'
  116 + RETURN,0
  117 + endif
  118 + if n_elements( NS ) EQ 0 then ns=10
  119 + if n_elements(slaw) EQ 0 then begin
  120 + slaw=['PLAW']
  121 + par = dblarr(1,4)
  122 + par(0) = -3.5
  123 + par(1) = 1.d0
  124 + endif else begin
  125 + slaw=[ strupcase(strtrim(slaw,2)) ]
  126 + for i=0,n_elements( slaw )-1 do begin
  127 + if (SLAW(i) NE 'PLAW') AND (SLAW(i) NE 'LOGN') then begin
  128 + print,'(F) CREATE_VDIST: undefined law ',slaw(i)
  129 + print,' only ''PLAW'' and ''LOGN'' '
  130 + return,0
  131 + endif
  132 + endfor
  133 + endelse
  134 + nmat = n_elements( RHO ) ; nr of bulk material in composite
  135 + if n_elements( FV ) EQ 0 then begin
  136 + if NMAT EQ 1 then fv = [1.] else $
  137 + fv = (fltarr(nmat)+1.) / nmat
  138 + mfrac = fv
  139 + endif
  140 + if n_elements( CUTOF ) EQ 0 then cutof = [ 0.0107, 0.428] * 1.d-4
  141 + if n_elements( NORM ) EQ 0 then norm = 1.d0
  142 +
  143 +; WD01 style for carbon adapted to match cirrus emission
  144 + if keyword_set( C_WD ) then begin
  145 + slaw = [ 'LOGN', 'LOGN', 'PLAW' ]
  146 + par = dblarr(3,4)
  147 + if TOTAL(CUTOF) NE 0 then cutof = [ 0.0107, 0.170 ] * 1.d-4
  148 +
  149 +; PAH log-normal
  150 + par(0,0) = 4.d-8
  151 + par(0,1) = 0.2
  152 + par(0,2) = 0.30
  153 +
  154 +; VSG log-normal
  155 + par(1,0) = 7.d-8
  156 + par(1,1) = 0.4
  157 + par(1,2) = 0.08
  158 +
  159 +; BG power law
  160 + par(2,0) = -2.54
  161 + par(2,1) = 2.e-5
  162 + par(2,2) = 0.0 ;-0.165
  163 + par(2,3) = 0.0107e-4
  164 + endif
  165 + nlaw = n_elements( SLAW )
  166 +
  167 +; define size grid (log)
  168 + lar = alog(ar)
  169 + da = (lar(1)-lar(0)) / (ns-1)
  170 + a = lar(0) + dindgen(ns)*da
  171 + a(ns-1) = lar(1) ; roundup error
  172 + ag = exp(a)
  173 +
  174 +; volume distribution
  175 + if n_elements( PAR ) EQ 0 then begin
  176 + print,'(F) CREATE_VDIST: PAR array not defined'
  177 + RETURN, 0
  178 + endif
  179 + vdist = 0.d0
  180 + for i = 0, nlaw-1 do begin
  181 + pp = REFORM( par(i,*), n_elements(par(i,*)) )
  182 + vdist = vdist + ag^(4.d0) * CALL_FUNCTION( slaw(i),ag,pp )
  183 + endfor
  184 + if TOTAL(CUTOF) NE 0 then begin
  185 + print,'(W) CREATE_VDIST : cut-off applied, size and scale are ',cutof
  186 + vdist = vdist * CUT_OFF(ag, cutof)
  187 + endif
  188 +
  189 +; normalize
  190 + fac = TOTAL( vdist(1:ns-1)+vdist(0:ns-2) ) * 0.5 * da
  191 + vdist = norm * vdist / fac
  192 + print,'(W) CREATE_VDIST: normalization factor ',fac / norm
  193 + yr = [1.d-4,1] * max(vdist)
  194 + plot_oo,1.e7*ag,vdist,xtit='a (nm)',yr=yr,ytit='Normalized a!u4!ndn/da', ps=-1
  195 +
  196 +; effective density
  197 + rho_eff = TOTAL( fv*rho )
  198 + print,'(W) CREATE_VDIST : effective mass density ',rho_eff,' g/cm3'
  199 +
  200 +; write in fname
  201 + if n_elements(fname) NE 0 then begin
  202 + OPENW, iu, fname, /get_lun
  203 + printf, iu, '# Size distribution of grain species'
  204 + printf, iu, '#'
  205 + printf, iu, '# Nbr of bulk materials'
  206 + printf, iu, '# Bulk densities in g/cm3 '
  207 + printf, iu, '# Mass fractions for each bulk'
  208 + printf, iu, '# Nbr of size bins'
  209 + printf, iu, '# [ a (cm), dloga, a^4*dn/da, rho_eff, fv ] '
  210 + printf, iu, '# fv: volume fraction of bulks, rho_eff: volume mean density'
  211 + printf, iu, '#'
  212 + printf, iu, nmat, format='(i2)'
  213 + printf, iu, rho, format='(10(e11.4,1x))'
  214 + printf, iu, mfrac, format='(10(e11.4,1x))'
  215 + printf, iu, ns, format='(i2,1x,e11.4)'
  216 + for i=0,ns-1 do begin
  217 + printf, iu, ag(i), da, vdist(i,*), rho_eff, fv, format='(20(e11.4,1x))'
  218 + endfor
  219 + FREE_LUN, iu
  220 + print,'(W) CREATE_VDIST: mass distribution written in ', strtrim(fname,2)
  221 + endif
  222 +
  223 +RETURN, vdist
  224 +END
src/idl/dustem_fil_chi2.pro 0 → 100644
  Diff comments   View file @52a3cc3
@@ -0,0 +1,36 @@ @@ -0,0 +1,36 @@
  1 +FUNCTION DUSTEM_FIL_CHI2, sf, ntype=ntype
  2 +; fills in the Chi-square fields of an input SMDAT structure
  3 +; (see format in DUSTEM_GET_BAND_FLUX)
  4 +;
  5 +; SF (I): input SMDAT structure
  6 +; NTYPE (I): index of SED to be used
  7 +
  8 + if ntype EQ 0 then begin
  9 + tt = SIZE(sf.sed.y)
  10 + ntype = tt(2)
  11 + endif
  12 + ntag = N_TAGS(sf)
  13 + stag = TAG_NAMES(sf)
  14 + itg = WHERE( STRPOS(stag,'I_') GE 0, ctg )
  15 + if ctg EQ 0 then begin
  16 + print,'(F) DUSTEM_FIL_CHI2: no instrument to fill in'
  17 + return,0
  18 + endif
  19 + yy=0d & mm=0d & ee=0d & ift=0
  20 + for k = 0, ctg-1 do begin
  21 + i1 = WHERE( sf.(itg(k)).isel EQ 1 AND sf.(itg(k)).err GT 0, c1)
  22 + if c1 GT 0 then begin
  23 + sf.(itg(k)).chi2 = $
  24 + DUSTEM_CHI2(sf.(itg(k)).yd(i1), sf.(itg(k)).ym(i1,ntype-1), sf.(itg(k)).npar, err=sf.(itg(k)).err(i1))
  25 + endif
  26 + yy = [ yy, sf.(itg(k)).yd ]
  27 + ee = [ ee, sf.(itg(k)).err]
  28 + mm = [ mm, sf.(itg(k)).ym(*,ntype-1) ]
  29 + ift = [ ift, sf.(itg(k)).isel ]
  30 + endfor
  31 + yy=yy(1:*) & ee=ee(1:*) & mm=mm(1:*) & ift=ift(1:*)
  32 + it = WHERE( ift EQ 1 AND ee GT 0, ct)
  33 + if ct GT 0 then sf.chi2 = DUSTEM_CHI2( yy(it), mm(it), sf.npar, err=ee(it))
  34 +
  35 + return, sf
  36 +END
src/idl/dustem_serkowski.pro 0 → 100644
  Diff comments   View file @52a3cc3
@@ -0,0 +1,22 @@ @@ -0,0 +1,22 @@
  1 +FUNCTION DUSTEM_SERKOWSKI, x, ka=ka, xmax=xmax, pmax=pmax
  2 + IF N_PARAMS() EQ 0 THEN BEGIN
  3 + print,'FUNCTION SERKOWSKI, x, ka=ka, xmax=xmax, pmax=pmax '
  4 + print,' computes the Serkowski law (Draine & Fraisse 2009)'
  5 + print,''
  6 + print,' X (I): array(n_qabs) inverse wavenumber in 1/microns'
  7 + print,' KA (I): K factor'
  8 + print,' XMAX (I): x-position of max'
  9 + print,' PMAX (I): max polar. fraction'
  10 + ENDIF
  11 + IF n_elements(KA) EQ 0 THEN ka = 0.92 ; Draine & Fraisse (2009)
  12 + IF n_elements(XMAX) EQ 0 THEN xmax = 1.82
  13 + IF n_elements(pMAX) EQ 0 THEN pmax = 0.03
  14 +
  15 + yy = pmax * EXP( -ka * ALOG(xmax/x)^2 )
  16 + x0 = 1/1.39
  17 + y0 = pmax * EXP( -ka * ALOG(xmax/x0)^2 )
  18 + ix = WHERE( x LE x0, cx )
  19 + IF cx GT 0 THEN yy(ix) = y0 * (x(ix)/x0)^1.7
  20 +
  21 + RETURN, yy
  22 +END
src/idl/dustem_show_fortran.pro 0 → 100644
  Diff comments   View file @52a3cc3
@@ -0,0 +1,1061 @@ @@ -0,0 +1,1061 @@
  1 +PRO dustem_show_fortran, model=model, data_dir=data_dir,dustem_dir=dustem_dir,nh=nh, fsed=fsed, sw=sw, inst=inst, smdat=smdat, com=com, wref=wref, bbpar=bbpar, wext=wext, $
  2 + xr=xr, yr=yr, tit=tit, CMB=cmb, COSMO=COSMO, DATA=data, SHOW=show, wn=wn, HARD=hard
  3 +
  4 +;+
  5 +; NAME:
  6 +; dustem_show_fortran
  7 +; PURPOSE:
  8 +; shows differents results of the DUSTEM fortran calculations,
  9 +; overlaid on fiducial diffuse ISM dust observables
  10 +; CATEGORY:
  11 +; DustEM, Distributed, User-Example
  12 +; CALLING SEQUENCE:
  13 +; dustem_show_results
  14 +; INPUTS:
  15 +; DATA_DIR : path to directory containing fiducial observational
  16 +; SED files. Defaults to Data/EXAMPLE_OBSDATA/ subdirectory.
  17 +; DUSTEM_DIR : path to directory containing DustEM data files. Default
  18 +; is the !dustem_dat directory (which is defined in
  19 +; a user's idl_startup file)
  20 +; model = specifies the interstellar dust mixture used by DustEM
  21 +; 'MC10' model from Compiegne et al 2010 (default)
  22 +; 'DBP90' model from Desert et al 1990
  23 +; 'DL01' model from Draine & Li 2001
  24 +; 'WD01_RV5p5B' model from Weingartner & Draine 2002 with Rv=5.5
  25 +; 'DL07' model from Draine & Li 2007
  26 +; 'J13' model from Jones et al 2013, as updated in
  27 +; Koehler et al 2014
  28 +; 'G17_ModelA' model A from Guillet et al (2018). Includes
  29 +; polarisation. See Tables 2 and 3 of that paper for details.
  30 +; 'G17_ModelB' model B from Guillet et al (2018)
  31 +; 'G17_ModelC' model C from Guillet et al (2018)
  32 +; 'G17_ModelD' model A from Guillet et al (2018)
  33 +; NH : float, fiducial column density for emission [Default is 1e20 cm-2]'
  34 +; FSED : string, read SED from the file FSED
  35 +; SW : integer, width of window to SMOOTH the PAH emission
  36 +; INST : string array, instruments to be shown. Default is ['DIRBE','FIRAS','HFI','WMAP']
  37 +; COM : string to describe SMDAT structure
  38 +; WEXT : normalize the UV-extinction to be 1 at wavelength WEXT (in microns). Also applied to IR-extinction
  39 +; WREF : get the dust cross-section per H at wavelength WREF (in microns)
  40 +; BBPAR : float tuple, T and beta for modified BB to get dust opacity from FIRAS
  41 +; XR,YR : plot ranges
  42 +; TIT : title for SMDAT and plots
  43 +; CMB : keyword to overlay the CMB
  44 +; COSMO : keyword to plot long wavelengths
  45 +; DATA : if DATA=0, only the model spectrum is shown
  46 +; if DATA=1, only the observational SED is shown
  47 +; if DATA=2, both the model and data are shown
  48 +; both are shown (default)'
  49 +; SHOW : string array, defines what to plot display. Possible
  50 +; options include
  51 +; ''emis'', ''extuv'', ''extir'', ''alb'', ''sdist'', ''polext'', ''polsed'', ''align''
  52 +; Default is [''emis'']. SHOW=0 no plot
  53 +; WN : array of window numbers for plots
  54 +; HARD : array (as show) or keyword (/HARD) for hardcopy or filename of ps files, emission'
  55 +; extinction albedo and size dist.
  56 +; Default = [''show.ps'']
  57 +;
  58 +; OPTIONAL INPUT PARAMETERS:
  59 +; None
  60 +; OUTPUTS:
  61 +; OPTIONAL OUTPUT PARAMETERS:
  62 +; SMDAT : from DUSTEM_GET_BAND_FLUX (see format there), structure containing model projected on data points: I_INST field in SMDAT.
  63 +; SMDAT also contains model direct outputs in M_EMIS, M_EXT fields (see format in ADD_MOD.pro )
  64 +; ACCEPTED KEY-WORDS:
  65 +; help = If set, print this help
  66 +; restart = If set, reinitialise DustEMWrap and use a new
  67 +; wavelength vector for integration.
  68 +; COMMON BLOCKS:
  69 +; None
  70 +; SIDE EFFECTS:
  71 +; None
  72 +; RESTRICTIONS:
  73 +; The DustEM fortran code must be installed
  74 +; The DustEMWrap IDL code must be installed
  75 +; PROCEDURES AND SUBROUTINES USED:
  76 +; *** COMMENT AH --> is this really NONE? ****
  77 +; EXAMPLES
  78 + ;; print,' Examples:'
  79 + ;; print,' path=''/Users/lverstra/DUSTEM_LOCAL/dustem4.0/'''
  80 + ;; print,' to show SED only: show_dustem,path'
  81 + ;; print,' SED+UV-extinction: show_dustem,path,show=''extuv'' '
  82 + ;; print,' SED+IR extinction+size dist.: show_dustem,path,show=[''extir'',''sdist''] '
  83 + ;; print,' ps files with default names: show_dustem,path,show=[''extir'',''alb''],/hard '
  84 + ;; print,' ps files with given names: show_dustem,path,show=[''extir'',''sdist''],hard=[''f1.ps'',''f2.ps''] '
  85 + ;; print,' no plot : show_dustem,path,show=0'
  86 + ;; print,' to get band fluxes in structure SM: show_dustem,path,smdat=sm'
  87 + ;; print,' see structure SM (overall): help,/str,sm'
  88 + ;; print,' see structure SM model field: help,/str,sm.m_emis'
  89 + ;; print,' see structure SM inst field: help,/str,sm.i_dirbe'
  90 + ;; print,' see structure SM inst flux field: help,/str,sm.i_dirbe.flx'
  91 + ;; print,' array(i,j+1) i:index of inst band, j:index of grain type (ntype+1 is total SED) '
  92 + ;; print,' to select or add instrument field(s): show_dustem,path,smdat=sm,inst=[''spire''] (on existing SM to add instrumentx) '
  93 +; MODIFICATION HISTORY:
  94 +; Written by L Verstraete and M Compiegne, Spring 2010
  95 +; Modified by LV : change to cgs, add band fluxes in SMDAT, 2011
  96 +; Modified by LV & V Guillet : add polarization part, 2017
  97 +; Further evolution details on the DustEMWrap gitlab.
  98 +; See http://dustemwrap.irap.omp.eu/ for FAQ and help.
  99 +
  100 +
  101 +if keyword_set(help) then begin
  102 + doc_library,'dustem_show_fortran'
  103 + goto,the_end
  104 +END
  105 +
  106 +; specify the grain model
  107 +IF keyword_set(model) THEN BEGIN
  108 + use_model=strupcase(model)
  109 +ENDIF ELSE BEGIN
  110 + use_model='MC10' ;Default is the Compiegne et al 2010 model
  111 +ENDELSE
  112 +
  113 +; run the fortran via the wrapper once
  114 +dustem_init,model=use_model
  115 +st_model=dustem_read_all(!dustem_soft_dir)
  116 +dustem_write_all,st_model,!dustem_dat
  117 +st=dustem_run()
  118 +
  119 +
  120 +data_path = !dustem_wrap_soft_dir+'/Data/'
  121 +fortran_path = !dustem_dat
  122 +if keyword_set(dustem_data_dir) then fortran_path = dustem_data_dir
  123 +if keyword_set(data_dir) then data_path = data_dir
  124 +
  125 + if n_elements(NH) EQ 0 then nh = 1.d20
  126 + if n_elements(INST) EQ 0 then begin
  127 + inst = ['DIRBE','FIRAS','HFI','WMAP']
  128 + endif else begin
  129 + inst = strupcase(inst)
  130 + inst = inst(UNIQ(inst, SORT(inst)))
  131 + endelse
  132 + n_inst = n_elements(inst)
  133 + if n_elements(WREF) EQ 0 then wref = 2.5d2
  134 + if n_elements(BBPAR) EQ 0 then BBPAR = [17.75d, 1.8d0]
  135 + if n_elements(SW) EQ 0 then sw = 0
  136 + if n_elements(TIT) EQ 0 then tit = 'DustEM'
  137 + if n_elements(COM) EQ 0 then com = tit
  138 + if n_elements(WN) EQ 0 then wn = [0, 2, 1, 3, 6, 4, 5, 7, 8, 9, 10, 11, 12, 13] ; absolute display
  139 + if n_elements( XR ) NE 2 then begin
  140 + if keyword_set( COSMO ) then xr = [1., 1.e5] else xr = [ 1, 1.e3 ]
  141 + endif else xr = [min(xr),max(xr)]
  142 + if n_elements( YR ) NE 2 then begin
  143 + if keyword_set( COSMO ) then yr = [1.e-12, 1.e-3] else yr = [1e-8, 1e-4]
  144 + endif else yr = [min(yr),max(yr)]
  145 + if n_elements( DATA ) EQ 0 then data = 0
  146 + if n_elements( SHOW ) EQ 0 THEN BEGIN
  147 + show = ['emis']
  148 + ENDIF ELSE BEGIN
  149 + show = [STRLOWCASE(STRTRIM(STRING(show),2))]
  150 + IF SHOW(0) NE '0' THEN BEGIN
  151 + show = ['emis',show] ; always show the SED
  152 + show = show(UNIQ(show))
  153 + ENDIF
  154 + ENDELSE
  155 + pgrid = [ 'emis', 'extuv', 'extir', 'alb', 'sdist','polext', 'polsed', 'align' ]
  156 + nplots = n_elements( SHOW ) ; nr of plots
  157 + nhard = n_elements( HARD )
  158 + if nhard EQ 0 OR show(0) EQ '0' THEN hard=['0']
  159 + if nhard GT 0 then hard = [STRLOWCASE(STRTRIM(STRING(hard),2))]
  160 + if ((nhard GT 0) AND (nhard LT nplots)) OR (hard(0) EQ '1') then begin
  161 + ig = INTARR( nplots )
  162 + for i = 1, nplots-1 do begin
  163 + ig(i) = WHERE( pgrid EQ show(i))
  164 + endfor
  165 + hard = pgrid(ig(sort(ig))) + REPLICATE('.ps',nplots)
  166 + endif
  167 + hard = strtrim(hard,2)
  168 + nhard = n_elements( HARD )
  169 +
  170 +
  171 +; constants
  172 + na = 6.02d23
  173 + clight = 2.9979246d10 ; cm/s
  174 +
  175 +;
  176 +; plot inits
  177 +;
  178 +; set the rgb colors
  179 + red =[0,1,1,0,0,1]
  180 + green=[0,1,0,1,0,1]
  181 + blue =[0,1,0,0,1,0]
  182 + tvlct,255*red, 255*green, 255*blue
  183 + ls = [ [ 0,3,1,4,5 ], [ 0,3,1,4,5 ] ]
  184 + ihard = 0
  185 +
  186 +;
  187 +; get the SED data
  188 +;
  189 +; New FarIR-mm SED from FBoulanger
  190 + RESTORE, data_path+'/EXAMPLE_OBSDATA/filters_ref_wave.xdr'
  191 + fact_em = 0.77 ; to account for 20% of H to be in ionized form + 3% H2
  192 + to_sed_20 = 1d-17 * (1d20/1.82d18) ; MJy/sr->erg/s/cm2/sr and normalization to NH = 10^20 H/cm2
  193 +
  194 +; FIRAS
  195 + READCOL, data_path+'/EXAMPLE_OBSDATA/diffuse_ISM_SED.dat', wfirasf, firasf, ufirasf, skipline=5, numline=156, /sil
  196 + nufirasf = clight/(wfirasf*1.d-4)
  197 + firasf = firasf * nufirasf * fact_em * to_sed_20
  198 + ufirasf = ufirasf * nufirasf * to_sed_20 ; error
  199 +
  200 +; DIRBE 60 --> 240 microns
  201 + READCOL, data_path+'/EXAMPLE_OBSDATA/diffuse_ISM_SED.dat', wdirbef, dirbef, udirbef, skipline=162, numline=4, /sil
  202 + nudirbef = clight/ (wdirbef*1.d-4)
  203 + dirbef = dirbef * nudirbef * fact_em * to_sed_20
  204 + udirbef = udirbef * nudirbef * to_sed_20 ; error
  205 + dwdirbef = dwdirbe[6:9]/2.
  206 +
  207 +; WMAP
  208 + READCOL,data_path+'/EXAMPLE_OBSDATA/diffuse_ISM_SED.dat', wwmapf, wmapf, uwmapf, skipline=167, numline=5,/sil
  209 + wwmapf = wwmapf[3:4]
  210 + wmapf = wmapf[3:4]
  211 + uwmapf = uwmapf[3:4]
  212 + nuwmapf = clight/(wwmapf*1.d-4)
  213 + wmapf = wmapf * nuwmapf * fact_em * to_sed_20
  214 + uwmapf = uwmapf * nuwmapf * to_sed_20 ; error
  215 +
  216 +; DIRBE Arendt et al (1998) for |b|>25
  217 +; numbers from Li & Draine, apj, 2001, 554, 778-802
  218 + Wave_ARENDT = WDIRBE[2:*]
  219 + Dwave_ARENDT = DWDIRBE[2:*] / 2.
  220 + ARENDT = [0.97, 1.11, 7.16, 3.57, 5.30, 18.6, 22.5, 10.1] ; 10^-26 erg/s/H/sr
  221 + ARENDT = ARENDT * 1.d-26 * 1.d20 ; To erg s-1 cm-2 sr-1 for NH=10^20 H/cm2
  222 + err_ARENDT = 0.2 * ARENDT ; from Dwek et al. 1997 DIRBE 1Sigma unc = 20%
  223 + nu_arendt = nudirbe[2:*] * 1.e9
  224 +
  225 +; Normalization of the Arendt spectrum on the Boulanger 100 microns
  226 + wave_arendt_midIR = wave_arendt[0:3]
  227 + dwave_ARENDT_midir = Dwave_ARENDT[0:3]
  228 + nu_arendt_midIR = nu_arendt[0:3]
  229 + correl_coeff_midIR = [0.00183, 0.00291, 0.0462, 0.0480] ; for Inu
  230 + ucorrel_coeff_midIR = [0.00001, 0.00003, 0.0001, 0.0002] ; For Inu
  231 + arendt_midIR = correl_coeff_midIR * (dirbef[1]*100.*1e-4/clight*1e20) ; in (Inu) MJy sr-1
  232 + err_arendt_midIR = FLTARR(N_ELEMENTS(arendt_midIR))
  233 + for i=0,3 do begin
  234 + tmp= SQRT( ((udirbef[1]*100.*1e-4/clight*1e20)/(dirbef[1]*100.*1e-4/clight*1e20))^2. + (ucorrel_coeff_midIR[i]/correl_coeff_midIR[i])^2. )
  235 + err_arendt_midIR[i] = arendt_midIR[i] * tmp
  236 + endfor
  237 + arendt_midIR = arendt_midIR / wave_arendt_midIR/1e-4*clight/1e20 ; to erg s-1 cm-2 sr-1
  238 + err_arendt_midIR = err_arendt_midIR / wave_arendt_midIR/1e-4*clight/1e20 ; to erg s-1 cm-2 sr-1
  239 + wdirbe_ful = [ wave_arendt_midir, wdirbef ]
  240 + dwdirbe_ful = [ dwave_arendt_midir, dwdirbef ]
  241 + dirbe_ful = [ arendt_midir, dirbef ]
  242 + udirbe_ful = [ err_arendt_midir, udirbef ]
  243 +
  244 +; isocam galactic spectrum
  245 + RESTORE, data_path+'/EXAMPLE_OBSDATA/spectre_gal.xdr' ; wgal in microns, spec_gal in MJy/sr
  246 + nuisocam = clight / wgal/1.d-4
  247 + norm = 0.65*0.045/filters(9) ; normalization for Nh=1e20 cm-2 and I12/I100 =0.045
  248 + iso = 1d-17 * spec_gal*nuisocam * norm ; galactic mid-IR SED in erg/s/cm2/sr
  249 + stars = 1d3 * wgal * DUSTEM_BLACKBODY(wgal, 3d3, unit='w') ; assumed spectrum for stars in cgs
  250 + stars = 1.3d-6 * stars/stars(0) ; normalization of stellar spectrum
  251 + err_cvf = 0.2
  252 + isocam = iso-stars
  253 + smp = DUSTEM_GET_BAND_FLUX( data_path + 'FILTERS/', 'DIRBE', xs=wgal, ys=isocam )
  254 + isocam = isocam / smp.i_dirbe.ym(4) * arendt_midIR[2] ; factor is now 1.013027 (1.0235712 before)
  255 +
  256 +; Arome 3.3 microns: Giard et al 1988
  257 + xg = [3.3d]
  258 + yg = 1.1e-6 / 4./!pi * xg/0.05 ; SED erg/s/cm2/sr assumes a feature width of 0.05 mic
  259 + eg = 0.5e-6 / 4./!pi * xg/0.05 ; error
  260 +
  261 +; Modified BB overlaid to dust: default is 17.75 K and beta=1.8 (Miville-Deschênes et al 2013, Planck data)
  262 + np = 1000
  263 + wbr = ALOG10( [20.,1.d5] )
  264 + dwbr = (wbr(1)-wbr(0)) / (np-1)
  265 + lambdaf = 10.^(wbr(0) + findgen(np)*dwbr)
  266 + temp1 = bbpar(0)
  267 + beta = bbpar(1)
  268 + lamb_ref = 250.
  269 + qf = (lambdaf/ lamb_ref)^(-beta)
  270 + bbm = 1d3 * lambdaf * DUSTEM_BLACKBODY(lambdaf, temp1, unit='w')
  271 + SP1 = bbm*qf
  272 + firas_nuinu = firasf
  273 +; normalize to FIRAS @ wave WREF < wfiras_max and get dust cross-section per H
  274 + wfiras_max = 8d2
  275 + if WREF LE wfiras_max then lamb_ref = wref
  276 + tt = MIN( ABS(lambdaf-lamb_ref), ibb )
  277 + tt = MIN( ABS(wfirasf-lamb_ref), ifiras )
  278 + nw = 1
  279 + eps_firas = median(firasf(ifiras-nw:ifiras+nw)) / INTERPOL(sp1/qf, lambdaf, lamb_ref) / nh
  280 + SP1 = SP1 * median(firasf(ifiras-nw:ifiras+nw)) / INTERPOL(sp1, lambdaf, lamb_ref)
  281 +
  282 +; add HFI (Planck2011t, Dust in the diffuse interstellar medium and the Galactic halo)
  283 + nu_pep_dism = [5d3,3d3,857.,545.,353.] * 1d9 ; includes IRAS60 and 100
  284 + w_pep_dism = 1d4*clight / nu_pep_dism
  285 + dw_pep_dism = dblarr(n_elements(nu_pep_dism))
  286 + dw_pep_dism(0:1) = [31.,35.6] / 2.
  287 + dw_pep_dism(2:*) = w_pep_dism(2:*)/3. / 2.
  288 + y_pep_dism = [ 1.288, 6.522,5.624, 1.905, 0.465 ] * 1d-1 ; MJy/sr/1e20cm-2
  289 + u_pep_dism = [ 0.436, 1.473, 1.015, 0.347, 0.100 ] * 1d-1
  290 + y_pep_dism = fact_em * y_pep_dism * nu_pep_dism * 1d-17 ; MJy/sr/1e20cm-2 to erg/s/cm2/sr
  291 + u_pep_dism = fact_em * u_pep_dism * nu_pep_dism * 1d-17
  292 + y_hfi_dism = y_pep_dism(0:2) & u_hfi_dism = u_pep_dism(0:2)
  293 +
  294 +; add cosmosomas
  295 + IF keyword_set( COSMO ) then begin
  296 +; Watson et al 2005
  297 +; nu=1.e9*[ 0.408, 1.42, 10.9, 12.7, 14.7, 16.3, 22.8, 33.0, 40.9, 61.3, 93.8, 1250, 2143., 3.e3 ]
  298 +; i_jy=[6.3,7.3,17.,18.7,26.2,32.6,42.3,40.3,33.9,34.7,77.5,9.68e4,1.31e5,6.44e4 ]
  299 +; e_jy=[7.8,2.,0.1,0.4,0.6,1.5,0.2,0.4,0.7,1.8,4.3,7d2,1.25d3,100.]
  300 +; beam = 4.9e-4 ; steradians
  301 +; lref = 140d ; wave for normalization
  302 +
  303 +; nu in GHz and i_jy in Janskys
  304 +; Planck 2011p, "New light on anomalous microwave emission from spinning dust grains"
  305 + nu=[0.408,0.82,1.42,10.9,12.7,14.7,16.3,22.8,28.5,33.0,40.9,44.1,61.3,70.3,93.8,100.,143.,217.,353.,545.,857.,1250,2143.,3.e3]
  306 + iplck = where( (nu eq 33.) or (nu eq 40.9) or (nu eq 70.3) or (nu eq 100.) or (nu eq 143.) or (nu eq 217.) )
  307 + nu=1d9*[0.408,0.82,1.42,10.9,12.7,14.7,16.3,22.8,28.5,33.0,40.9,44.1,61.3,70.3,93.8,100.,143.,217.,353.,545.,857.,1250,2143.,3.e3]
  308 + i_jy=[9.7,9.4,8.0,16.1,20.,28.4,35.8,39.8,38.1,36.7,30.8,28.5,27.4,32.2,63.,78.4,202.,1050.,3060.,1.53d4,4.87d4,9.3d4,1.17d5,5.36d4]
  309 + e_jy=[3.3,4.7,1.7,1.8,2.2,3.1,4.,4.2,4.,3.9,3.3,3.2,3.4,3.9,7.8,15.4,22.,128.,467.,2.09d3,6.11d3,1.29d4,1.45d4,6.67d3]
  310 + fwhm = 1.81d
  311 + beam = !pi*(!pi/1.8d2 * fwhm/2d0)^2 ; steradians
  312 + lref = 140d ; wave for normalization
  313 +
  314 + x_pep_ame = 1d4*clight/nu
  315 + nc = n_elements(x_pep_ame)
  316 + y_pep_ame = 1.e-23 * nu * i_jy / beam
  317 + e_pep_ame = 1.e-23 * nu * e_jy / beam
  318 + lref = 240d
  319 + iref = WHERE( wdirbe_ful EQ lref, cr)
  320 + if cr EQ 1 then begin
  321 + yic = INTERPOL(y_pep_ame,x_pep_ame,wdirbe_ful[iref])
  322 + y_norm = dirbe_ful[iref]/yic
  323 + y_norm = y_norm[0]
  324 + endif else y_norm = 1d
  325 + is = WHERE( x_pep_ame/lref GE 0.9, cs)
  326 + x_pep_ame=x_pep_ame(is) & y_pep_ame=y_pep_ame(is)*y_norm & e_pep_ame=e_pep_ame(is)*y_norm
  327 + ENDIF
  328 +
  329 +;
  330 +; plot SED data
  331 +;
  332 + IF SHOW(0) NE '0' THEN BEGIN
  333 + if HARD(0) NE '0' then begin
  334 + !y.thick = 5
  335 + !x.thick = 5
  336 + !p.thick = 5
  337 + !p.charsize = 1.3
  338 + !p.charthick = 5
  339 + !x.ticklen = 0.04
  340 + set_plot,'ps'
  341 +; device,file=hard(0),xs=26, ys=20,/portrait,/color
  342 + device,file=hard(0),/portrait,/color
  343 + ihard = ihard + 1
  344 + endif else begin
  345 + window, wn(0), xs=900,ys=600,tit='SHOW_DUSTEM: SED '+strtrim(wn(0),2)
  346 + endelse
  347 +
  348 + xtit = 'Wavelength (!4l!3m)'
  349 + ytit = '!4m!3 I!d!4m!3!n (erg s!u-1!n cm!u-2!n sr!u-1!n)'
  350 + fine = 1
  351 +; plot_oo, INDGEN(1),/NODAT,/xs,/ys,XR=xr,YR=yr,XTIT=xtit,YTIT= ytit,tit=tit
  352 + plot_oo, INDGEN(1),/NODAT,xs=9,/ys,XR=xr,YR=yr,XTIT=xtit,YTIT= ytit
  353 + axis, /data, xr=1d-5*clight/xr, xax=1,/xlo,xs=1,xtit='Frequency (GHz)'
  354 + if DATA NE 0 then begin
  355 + if HARD(0) NE '0' then begin
  356 + oploterror,xg,yg,0.,eg,psym=5
  357 + oploterror, wfirasf, firasf, wfirasf*0d, ufirasf, errthick=0.7, /nohat
  358 + oploterror, wdirbe_ful(0:3), dirbe_ful(0:3), dwdirbe_ful(0:3), udirbe_ful(0:3), psym=6
  359 + oploterror, wdirbe_ful(6:*), dirbe_ful(6:*), dwdirbe_ful(6:*), udirbe_ful(6:*), psym=6
  360 +; oploterror, wdirbe_ful, dirbe_ful, dwdirbe_ful, udirbe_ful, psym=6
  361 + oploterror, wgal,isocam, wgal*0d, isocam*err_cvf, errthick=0.7, /nohat
  362 + oploterror, wwmapf, wmapf, wwmapf*0d, uwmapf, psym=4
  363 + oploterror, w_pep_dism, y_pep_dism, dw_pep_dism, u_pep_dism, psym=5
  364 + endif else begin
  365 + oploterror,xg,yg,0.,eg,psym=5
  366 + oploterror, wfirasf, firasf, wfirasf*0d, ufirasf, errthick=0.4, /nohat
  367 + oploterror, wdirbe_ful(0:3), dirbe_ful(0:3), dwdirbe_ful(0:3), udirbe_ful(0:3), psym=6
  368 + oploterror, wdirbe_ful(6:*), dirbe_ful(6:*), dwdirbe_ful(6:*), udirbe_ful(6:*), psym=6
  369 +; oploterror, wdirbe_ful, dirbe_ful, dwdirbe_ful, udirbe_ful, psym=6
  370 + oploterror, wgal,isocam, wgal*0d, isocam*err_cvf, errthick=0.4, /nohat
  371 + oploterror, wwmapf, wmapf, wwmapf*0d, uwmapf, psym=4
  372 + oploterror, w_pep_dism, y_pep_dism, dw_pep_dism, u_pep_dism, psym=5
  373 + endelse
  374 + endif
  375 + if DATA EQ 1 then begin
  376 + OPLOT, LAMBDAf, SP1, lines=1 ; FIR blackbody
  377 + sp1_firas = INTERPOL( sp1, lambdaf, wfirasf )
  378 + firas_chi2 = DUSTEM_CHI2( firasf, sp1_firas, 3, err=ufirasf )
  379 + print,'Grey body: Td = ',strtrim(bbpar(0),2),' and beta = ',strtrim(bbpar(1),2)
  380 + print,'Chi-squared of grey body to FIRAS: ', strtrim(firas_chi2,2)
  381 + endif
  382 + if keyword_set( CMB ) then begin
  383 + lambda_cmb = 1.d2^( 1.d0 + dindgen(500)*0.01 )
  384 + sp_cmb = 1d3 * lambda_cmb * DUSTEM_BLACKBODY(LAMBDA_CMB, 2.728, unit='w') ; SED in erg/s/cm2/s/sr
  385 + OPLOT, LAMBDA_CMB, SP_CMB, lines=0 ; CMB
  386 + endif
  387 + if keyword_set( COSMO ) AND DATA NE 0 then begin
  388 + oploterror, x_pep_ame, y_pep_ame, y_pep_ame*0d, e_pep_ame, ps=4
  389 +; oploterror, x_pep_ame(iplck), y_pep_ame(iplck), y_pep_ame(iplck)*0d, e_pep_ame(iplck), ps=5, syms=1.5, col=3
  390 + endif
  391 + ENDIF
  392 +
  393 +;
  394 +; get the model SED
  395 +;
  396 + fname = fortran_path + 'data/GRAIN.DAT'
  397 + nlines = FILE_LINES( fname )
  398 + OPENR, uu, fname, /get_lun
  399 + tmp = '#'
  400 + print,'(W) DUSTEM_SHOW_FORTRAN: GRAIN.DAT'
  401 + cnt = 0
  402 + WHILE STRPOS(tmp,'#') EQ 0 do begin
  403 + READF, uu, tmp
  404 + cnt = cnt + 1
  405 + ENDWHILE
  406 + r_opt = STRLOWCASE(STRTRIM(STRING(tmp),2))
  407 + print,r_opt
  408 + READF, uu, g0
  409 + ntype = nlines - (cnt+1)
  410 + nsize=intarr(ntype)
  411 + t_opt=strarr(ntype)
  412 + gtype = strarr(ntype)
  413 + propm = dblarr(ntype)
  414 + rho = dblarr(ntype)
  415 + for i=0,ntype-1 do begin
  416 + READF,uu,tmp
  417 + PRINT, tmp
  418 + tt = strsplit(tmp, /extract)
  419 + gtype(i) = strtrim(tt(0))
  420 + nsize(i)=fix(tt(1))
  421 + t_opt(i)=strlowcase(strtrim(tt(2)))
  422 + propm(i) = double(tt(3))
  423 + rho(i) = double(tt(4))
  424 + endfor
  425 + close,uu
  426 + free_lun,uu
  427 + nsz_max = MAX(nsize)
  428 +
  429 + IF n_elements(FSED) EQ 0 THEN fsed = fortran_path+'out/SED.RES'
  430 + OPENR, uu, fsed, /get_lun
  431 + tmp = '#'
  432 + WHILE (STRPOS(tmp,'#') EQ 0) do begin
  433 + READF, uu, tmp
  434 + ENDWHILE
  435 + tt = double( strsplit(tmp, ' ', /extract) )
  436 + ntype_sed = fix(tt(0))
  437 + if ntype_sed NE ntype then begin
  438 + print,'(F) DUSTEM_SHOW_FORTRAN: SED.RES & GRAIN.DAT have different NTYPE'
  439 + print,' data is not from present GRAIN.DAT'
  440 + return
  441 + endif
  442 + nlamb = fix(tt(1)) ; nr of wavelengths
  443 + x = dblarr(nlamb)
  444 + sedh = dblarr(nlamb,ntype+1)
  445 + for i=0,nlamb-1 do begin
  446 + READF, uu, tmp
  447 + tt = double( strsplit(tmp, ' ', /extract) )
  448 + x(i) = tt(0)
  449 + sedh(i,*) = tt(1:*)
  450 + endfor
  451 + close,uu
  452 + free_lun,uu
  453 + xlamb= x
  454 + sed = sedh * nh / 4. / !pi ; in erg/s/cm2/sr
  455 + if keyword_set( SW ) then sed = SMOOTH( sed, sw)
  456 +
  457 + if (DATA NE 1) AND (SHOW(0) NE '0') then begin
  458 + dy = 10.^((ALOG10(yr(1))-ALOG10(yr(0))) / 25.)
  459 + dx = 10.^((ALOG10(xr(1))-ALOG10(xr(0))) / 50.)
  460 + yps= 10.^((ALOG10(yr(1))+ALOG10(yr(0))) / 2. + (ALOG10(yr(1))-ALOG10(yr(0))) / 2.3)
  461 + if keyword_set(COSMO) then begin
  462 + xpr=10.^((ALOG10(xr(1))+ALOG10(xr(0)))/3.)
  463 + yps= 10.^((ALOG10(yr(1))+ALOG10(yr(0))) / 2. - (ALOG10(yr(1))-ALOG10(yr(0))) / 4.)
  464 + endif else xpr=xr(0)
  465 + xpr = xpr*[dx,dx^4]
  466 +; overlay model SED in erg/s/cm2/sr
  467 + for i=0,ntype-1 do begin
  468 + oplot, x, sed(*,i), lin=ls(i+1)
  469 + oplot,xpr,yps*[1.,1.], lin=ls(i+1)
  470 + xyouts,/data,xpr(1)*1.1,yps,gtype(i),chars=1
  471 + yps = yps/dy
  472 + endfor
  473 + oplot, x, sed(*,ntype),lin=ls(0),col=2
  474 + s1 = STRMID(STRTRIM(ROUND(1e1*g0)/1e1,2), 0, 4)
  475 + s2 = STRMID(STRTRIM(ROUND(1e2*alog10(nh))/1e2,2), 0, 5)
  476 + xyouts,/norm,0.6,0.85,'G!d0!n='+s1+' N!dH!n=10!u'+s2+'!ncm!u-2!n'
  477 +; overlay model polarized SED in erg/s/cm2/sr
  478 + ;IF (C_POLSED EQ 1) THEN oplot, x, sed_p(*,ntype),lin=ls(0),col=3
  479 + endif
  480 +
  481 +;
  482 +; fill in SMDAT
  483 +;
  484 +; first get model fluxes in instrument bands
  485 + unit = 'x(microns) SED(erg/s/cm2/sr)'
  486 + if n_elements(SMDAT) GT 0 then begin
  487 + smdat = DUSTEM_GET_BAND_FLUX( data_path + 'FILTERS/', inst, xs=x, ys=sed, unit=unit, smi=smdat )
  488 + endif else smdat = DUSTEM_GET_BAND_FLUX( data_path + 'FILTERS/', inst, xs=x, ys=sed, unit=unit )
  489 + smdat.com = com
  490 + stag = TAG_NAMES(smdat)
  491 + ;if c_polsed EQ 1 then smdat.m_emis.yp = sed_p
  492 +
  493 +; then get diffuse data available here
  494 + ii = WHERE( inst EQ 'DIRBE', cic)
  495 + if cic GT 0 then begin
  496 + smdat.i_dirbe.unit = smdat.i_dirbe.unit + ' YD(erg/s/cm2/sr)'
  497 + smdat.i_dirbe.yd = [ 0d, 0d, dirbe_ful ]
  498 + smdat.i_dirbe.err = [ 0d, 0d, udirbe_ful]
  499 + nband = n_elements( smdat.i_dirbe.x)
  500 + smdat.i_dirbe.isel = [ 0,0,intarr(nband-2)+1 ]
  501 + smdat.i_dirbe.npar = ntype
  502 + endif
  503 +
  504 + ii = WHERE( inst EQ 'HFI', cic)
  505 + if cic GT 0 then begin
  506 + smdat.i_hfi.unit = smdat.i_hfi.unit + ' YD(erg/s/cm2/sr)'
  507 + ibx = indgen(3) ; only 3 first bands in PEP DISM
  508 + smdat.i_hfi.yd(ibx) = y_hfi_dism
  509 + smdat.i_hfi.err(ibx) = u_hfi_dism
  510 + smdat.i_hfi.isel = [1,1,1,0,0,0]
  511 + smdat.i_hfi.npar = 1
  512 + endif
  513 +
  514 + ii = WHERE( inst EQ 'WMAP', cic)
  515 + if cic GT 0 then begin
  516 + smdat.i_wmap.unit = smdat.i_wmap.unit + ' YD(erg/s/cm2/sr)'
  517 + smdat.i_wmap.yd = [ 0d, 0d, 0d, wmapf ] ; only 61 and 94 GHz bands
  518 + smdat.i_wmap.err = [ 0d, 0d, 0d, uwmapf]
  519 + nband = n_elements( smdat.i_wmap.x)
  520 + smdat.i_wmap.isel = [ 0,0,0,intarr(nband-3)+1 ]
  521 + smdat.i_wmap.npar = 1
  522 + endif
  523 +
  524 +; put FIRAS pts in SMDAT
  525 + ii = WHERE( inst EQ 'FIRAS', cic)
  526 + if cic GT 0 then begin
  527 + nband = n_elements(wfirasf)
  528 + smdat = DUSTEM_ADD_INST( smdat, 'FIRAS', [n_elements(firasf),ntype+1] )
  529 + smdat.i_firas.unit = 'x(microns) YM(erg/s/cm2/sr) FLX(MJy/sr) YD(erg/s/cm2/sr)'
  530 + smdat.i_firas.yd = firasf
  531 + smdat.i_firas.err = ufirasf
  532 + sd_firas = dblarr(n_elements(wfirasf),ntype+1)
  533 + for itp=0,ntype do sd_firas(*,itp) = INTERPOL( sed(*,itp), x, wfirasf )
  534 + smdat.i_firas.ym = sd_firas
  535 + smdat.i_firas.isel = intarr(nband)+1
  536 + smdat.i_firas.npar = 2
  537 + endif
  538 +
  539 +; overlay model band fluxes
  540 + if (DATA NE 1) AND (SHOW(0) NE '0') then begin
  541 + itg = WHERE( STRPOS(stag,'I_') GE 0 AND stag NE 'I_FIRAS', ctg )
  542 +; then other instruments
  543 + if ctg GT 0 then begin
  544 + for k=0,ctg-1 do begin
  545 + oplot, smdat.(itg(k)).x, smdat.(itg(k)).ym(*,ntype), ps=6, syms=1.5, col=3
  546 + endfor
  547 + endif
  548 + endif
  549 +
  550 +;
  551 +; get extinction
  552 +;
  553 + OPENR, uu, fortran_path+'out/EXT.RES', /get_lun
  554 + tmp = '#'
  555 + WHILE STRPOS(tmp,'#') EQ 0 do begin
  556 + READF, uu, tmp
  557 + ENDWHILE
  558 + tt = double( strsplit(tmp, ' ', /extract) )
  559 + ntype_ext = fix(tt(0))
  560 + if ntype_ext NE ntype then begin
  561 + print,'(F) DUSTEM_SHOW_FORTRAN: EXT.RES & GRAIN.DAT have different NTYPE'
  562 + print,' data is not from present GRAIN.DAT'
  563 + return
  564 + endif
  565 + nlamb = fix(tt(1)) ; nr of wavelengths
  566 + x = dblarr(nlamb)
  567 + stmp = dblarr(nlamb,2*ntype+1)
  568 + ssca = dblarr(nlamb,ntype+1)
  569 + sabs = dblarr(nlamb,ntype+1)
  570 + sext = dblarr(nlamb,ntype+1)
  571 + alb = dblarr(nlamb,ntype+1)
  572 + for i=0,nlamb-1 do begin
  573 + READF, uu, tmp
  574 + tt = double( strsplit(tmp, ' ', /extract) )
  575 + x(i) = tt(0)
  576 + stmp(i,*) = tt(1:*)
  577 + endfor
  578 + CLOSE,uu
  579 + FREE_LUN,uu
  580 + wlm = x
  581 + x = 1. / wlm ; 1/micron
  582 +
  583 + mH = 1.67262158d-24 ; proton mass /gdust -> /gH
  584 + pm = [propm,propm]
  585 + for i=0,ntype-1 do begin
  586 + sabs(*,i) = stmp(*,i)
  587 + ssca(*,i) = stmp(*,ntype+i)
  588 + sext(*,i) = sabs(*,i) + ssca(*,i)
  589 + alb(*,i) = ssca(*,i) / sext(*,i)
  590 + endfor
  591 + for i=0,nlamb-1 do begin
  592 + sabs(i,ntype) = TOTAL(sabs(i,0:ntype-1))
  593 + ssca(i,ntype) = TOTAL(ssca(i,0:ntype-1))
  594 + sext(i,ntype) = TOTAL(sext(i,0:ntype-1))
  595 + alb(i,ntype) = ssca(i,ntype)/sext(i,ntype)
  596 + endfor
  597 +
  598 +; get RV
  599 + av = INTERPOL( sext(*,ntype), wlm, 0.55 )
  600 + ab = INTERPOL( sext(*,ntype), wlm, 0.44 )
  601 + rv = av / (ab-av)
  602 +
  603 +; get 250 microns emissivity
  604 + eps_a = dblarr(ntype+1) & eps_e = eps_a & eps_s = eps_a
  605 + for i = 0,ntype-1 do begin
  606 + eps_a(i)=INTERPOL(sabs(*,i), wlm, wref)
  607 + eps_s(i)=INTERPOL(ssca(*,i), wlm, wref)
  608 + eps_e(i)=INTERPOL(sext(*,i), wlm, wref)
  609 + endfor
  610 + eps_a(ntype) = INTERPOL(sabs(*,ntype), wlm, wref)
  611 + eps_s(ntype) = INTERPOL(ssca(*,ntype), wlm, wref)
  612 + eps_e(ntype) = INTERPOL(sext(*,ntype), wlm, wref)
  613 + print,'(W) DUSTEM_SHOW_FORTRAN: model dust cross-section @ ',STRTRIM(wref,2),' per type and total (cm2/H)', $
  614 + format='(A44,1E10.3,A27)'
  615 + print, ' Abs : ',eps_a, format='(A8,100(1E12.4))'
  616 + print, ' Sca : ',eps_s, format='(A8,100(1E12.4))'
  617 + print, ' Ext : ',eps_e, format='(A8,100(1E12.4))'
  618 + if WREF GT wfiras_max then begin
  619 + print,'(W) DUSTEM_SHOW_FORTRAN: WREF above longer FIRAS wave, using 250 microns'
  620 + wp = lamb_ref
  621 + endif else wp = wref
  622 + print,'(W) DUSTEM_SHOW_FORTRAN: dust cross-section @ ', STRTRIM(wp,2), ' microns from FIRAS',format='(A38,1E10.3,A20)'
  623 + print,' using T = ',bbpar(0), ' and beta = ',bbpar(1),' sigma(cm2/H) = ', eps_firas, $
  624 + format='(A27,1E8.2,A13,1E8.2,A17,1E12.4)'
  625 +
  626 +; fill in model
  627 + it = WHERE( stag EQ 'M_EXT', ct)
  628 + if ct EQ 0 then begin
  629 + smdat = DUSTEM_ADD_MOD( smdat, 'EXT', [n_elements(wlm),ntype+1])
  630 + smdat.m_ext.x = wlm
  631 + smdat.m_ext.y = sext
  632 + smdat.m_ext.abs = sabs
  633 + smdat.m_ext.sca = ssca
  634 + smdat.m_ext.alb = alb
  635 + smdat.m_ext.xr = wref
  636 + smdat.m_ext.yr_abs = eps_a
  637 + smdat.m_ext.yr_sca = eps_s
  638 + smdat.m_ext.rv = rv
  639 + endif
  640 +
  641 +; get standard Savage & Mathis 79 + Mathis 1990 extinction and fill in data
  642 + READCOL, data_path+'/EXAMPLE_OBSDATA/mean_ism_ext.dat', skip=3, x_sm, e_sm, /SIL
  643 + it = WHERE( stag EQ 'I_SM79', ct)
  644 + if ct EQ 0 then begin
  645 + smdat = DUSTEM_ADD_INST( smdat, 'SM79', [n_elements(x_sm),ntype+1] )
  646 + smdat.i_sm79.x = x_sm
  647 + smdat.i_sm79.ym = INTERPOL( sext(*,ntype), wlm, x_sm)
  648 + smdat.i_sm79.yd = e_sm
  649 + smdat.i_sm79.err = smdat.i_sm79.yd*0.2
  650 + smdat.i_sm79.unit = 'x(microns) sigma(cm2/H)'
  651 + smdat.i_sm79.npar = ntype
  652 + smdat.i_sm79.isel = intarr(n_elements(x_sm)) + 1
  653 + endif
  654 +
  655 +;
  656 +; plot the vis-UV extinction
  657 +;
  658 + yscl = 1d0
  659 + ip = WHERE( STRPOS(show,'extuv') GE 0, cp )
  660 + IF (SHOW(0) NE '0') AND (CP EQ 1) THEN BEGIN
  661 + if HARD(0) NE '0' then begin
  662 + device, file=hard(ihard), /portrait,/color
  663 + ihard = ihard + 1
  664 + endif else begin
  665 + window, wn(1), xs=600,ys=400, tit='DUSTEM_SHOW_FORTRAN: Extinction UV '+strtrim(wn(1),2)
  666 + endelse
  667 + xtit = 'x (!4l!3m!u-1!n)'
  668 + xr = [0,11]
  669 + if n_elements(WEXT) then begin
  670 + xe = [x,1./wext]
  671 + xe = xe(SORT(XE))
  672 + ei = INTERPOL(sext(*,ntype),x,xe)
  673 + tmp = MIN( ABS(xe - 1./wext),iw )
  674 + yr = minmax( sext(*,ntype)/ei(iw) ) * [1.,1.]
  675 + yscl = 1.d0 / ei(iw)
  676 + ytit='Normalized !4r!3!dext!n '
  677 + print,'(W) DUSTEM_SHOW_FORTRAN: extinction normalized to 1 at ',wext, ' microns yscl=',yscl
  678 + endif else begin
  679 + yr=[ 0, 2.5 ]
  680 + yscl = 1d0
  681 + ytit='!4r!3!dext!n (10!u-21!n cm!u2!n per H)'
  682 + endelse
  683 + plot, [1d], [1d], lin=ls(0), xr=xr,/xs,xtit=xtit, yr=yr,/ys,ytit=ytit, tit=tit
  684 + oplot, x, sext(*,ntype)*yscl, lin=ls(0), col=2
  685 + oplot, 1d/x_sm, e_sm*1d21*yscl, ps=4
  686 +; oploterror, 1d/x_sm, e_sm*1d21, smdat.i_sm79.err*1d21, psym = 4, /nohat
  687 + for i=0,ntype-1 do oplot, x, (sext(*,i))*yscl, lin=ls(i+1)
  688 + xyouts,/norm,0.2,0.8,'R!dV!n='+STRMID(STRTRIM(ROUND(1e1*rv)/1e1,2), 0, 4)
  689 + ENDIF
  690 +
  691 +; plot IR extinction
  692 + ip = WHERE( STRPOS(show,'extir') GE 0, cp )
  693 + IF (SHOW(0) NE '0') AND (CP EQ 1) THEN BEGIN
  694 + if HARD(0) NE '0' then begin
  695 + device, file=hard(ihard), /portrait,/color
  696 + ihard = ihard + 1
  697 + endif else begin
  698 + window, wn(2), xs=600,ys=400, tit='DUSTEM_SHOW_FORTRAN: Extinction IR '+strtrim(wn(2),2)
  699 + endelse
  700 + xtit = textoidl('\lambda (\mum)')
  701 + xr = [1,400]
  702 + yr = [1e-6,1.]
  703 + if yscl NE 1d0 THEN ytit='Normalized !4r!3!dext!n' ELSE $
  704 + ytit='!4r!3!dext!n (10!u-21!n cm!u2!n per H)'
  705 + plot_oo, [1d], [1d], xr=xr,/xs,xtit=xtit, yr=yr,/ys,ytit=ytit, tit=tit
  706 + oplot, wlm, sext(*,ntype)*yscl, lin=ls(0), col=2
  707 + oplot, x_sm, e_sm*1d21*yscl, ps=4
  708 +; oploterror, x_sm, e_sm*1d21, smdat.i_sm79.err*1d21, psym = 4, /nohat
  709 + for i=0,ntype-1 do oplot, wlm, sext(*,i)*yscl, lin=ls(i+1)
  710 + xyouts,/norm,0.8,0.85,'R!dV!n='+STRMID(STRTRIM(ROUND(1e1*rv)/1e1,2), 0, 4)
  711 + ENDIF
  712 +
  713 +;
  714 +; and the albedo
  715 +;
  716 + ip = WHERE( STRPOS(show,'alb') GE 0, cp )
  717 + IF (SHOW(0) NE '0') AND (CP EQ 1) THEN BEGIN
  718 + if HARD(0) NE '0' then begin
  719 + device, file=hard(ihard), /portrait,/color
  720 + ihard = ihard + 1
  721 + endif else begin
  722 + window, wn(3), xs=500,ys=350, tit='DUSTEM_SHOW_FORTRAN: Albedo '+strtrim(wn(3),2)
  723 + endelse
  724 + xtit = 'x (!4l!3m!u-1!n)'
  725 + xr = [0,11]
  726 + ytit='Albedo'
  727 + yr=[ 0, 1]
  728 + plot, x, alb(*,ntype), xr=xr,/xs,xtit=xtit, yr=yr,/ys,ytit=ytit, tit=tit
  729 + oplot, x, alb(*,ntype), col=2
  730 + for i=0,ntype-1 do oplot, x, alb(*,i), lin=ls(i+1)
  731 + ENDIF
  732 +
  733 +
  734 +;
  735 +; get the size distribution and plot
  736 +;
  737 + ip = WHERE( STRPOS(show,'sdist') GE 0, cp )
  738 + ir = WHERE( STRPOS(r_opt,'sdist') GE 0, cr )
  739 + IF CR EQ 0 THEN BEGIN
  740 + cp = 0
  741 + print,'(W) DUSTEM_SHOW_FORTRAN: SDIST keyword not set in current run'
  742 + ENDIF ELSE IF ((SHOW(0) NE '0') AND (CP EQ 1)) THEN BEGIN
  743 + fn = fortran_path+'out/SDIST.RES'
  744 + OPENR, uu, fn, /get_lun
  745 + tt = '#'
  746 + WHILE STRPOS(tt,'#') EQ 0 do begin
  747 + READF, uu, tt
  748 + ENDWHILE
  749 + ax = dblarr(nsz_max,ntype)
  750 + ava = dblarr(nsz_max,ntype)
  751 + nsz_tot = TOTAL(nsize)
  752 + ava_tot = dblarr(nsz_tot,ntype+1)
  753 + ax_tot = 0d
  754 + FOR i=0,ntype-1 do begin
  755 + READF,uu,tt
  756 + for is=0,nsize(i)-1 do begin
  757 + READF, uu, tx, ty
  758 + ax(is,i) = tx
  759 + ava(is,i) = ty
  760 + endfor
  761 + ax_tot = [ax_tot, ax(0:nsize(i)-1,i)]
  762 + ENDFOR
  763 + close,uu
  764 + free_lun,uu
  765 + ax_tot = ax_tot(1:*)
  766 + ax_tot = ax_tot(SORT(ax_tot))
  767 + FOR i=0,ntype-1 do begin
  768 + tt = INTERPOL( ava(0:nsize(i)-1,i), ax(0:nsize(i)-1,i), ax_tot )
  769 + ix = WHERE( ax_tot LT MIN(ax(*,i)) OR ax_tot GT MAX(ax(*,i)), cx )
  770 + if cx GT 0 then tt(ix) = 0d ; no extrapolation
  771 + ava_tot(*,i) = tt
  772 + endfor
  773 + for i=0, nsz_tot-1 do ava_tot(i,ntype) = TOTAL( ava_tot(i,0:ntype-1))
  774 +
  775 +; fill in model
  776 + it = WHERE( stag EQ 'M_SDIST', ct)
  777 + if ct EQ 0 then begin
  778 + smdat = DUSTEM_ADD_MOD( smdat, 'SDIST', [nsz_tot,ntype+1,nsz_max])
  779 + smdat.m_sdist.xtot = ax_tot
  780 + smdat.m_sdist.ytot = ava_tot
  781 + smdat.m_sdist.xi = ax
  782 + smdat.m_sdist.yi = ava
  783 + endif
  784 +
  785 + if HARD(0) NE '0' then begin
  786 + device, file=hard(nplots-1), /portrait,/color
  787 + endif else begin
  788 + window, wn(5), xs=500,ys=350, xpos=0,ypos=0,tit='DUSTEM_SHOW_FORTRAN: Size Distribution '+strtrim(wn(5),2)
  789 + endelse
  790 + yscl = 1.D29
  791 + xr=[0.1,1e4]
  792 + yr=[-3,3]
  793 + xtit='a (nm)'
  794 + ytit='log( 10!u29!n n!dH!u-1!n a!u4!n dn/da (cm!u3!n/H)) '
  795 + tit='DustEM'
  796 + plot_oi, ax(0:nsize(0)-1,0)*1.e7, alog10(ava(0:nsize(0)-1,0)*yscl), line=ls(1),xr=xr,/xs,xtit=xtit,/ys,yr=yr,ytit=ytit,tit='DUSTEM'
  797 + FOR i=1,ntype-1 DO begin
  798 + oplot, ax(0:nsize(i)-1,i)*1.e7, alog10(ava(0:nsize(i)-1,i)*yscl), line=ls(i+1)
  799 + ENDFOR
  800 +
  801 + ENDIF
  802 +
  803 +
  804 +; Display polarized SED
  805 +;
  806 + ip = WHERE( STRPOS(show,'polsed') GE 0, c_polsed )
  807 + IF (SHOW(0) NE '0') AND (C_POLsed EQ 1) THEN BEGIN
  808 + if HARD(0) NE '0' then begin
  809 + device, file=hard(ihard), /portrait,/color
  810 + ihard = ihard + 1
  811 + endif else begin
  812 + window, wn(6), xs=600,ys=400, tit='DUSTEM_SHOW_FORTRAN: Polarized SED '+strtrim(wn(6),2)
  813 + endelse
  814 +
  815 + ; get polarized SED
  816 + OPENR, uu, fortran_path+'out/SED_POL.RES', /get_lun
  817 + tmp = '#'
  818 + WHILE (STRPOS(tmp,'#') EQ 0) do begin
  819 + READF, uu, tmp
  820 + ENDWHILE
  821 + tt = double( strsplit(tmp, ' ', /extract) )
  822 + sedh_p = dblarr(nlamb,ntype+1)
  823 + for i=0,nlamb-1 do begin
  824 + readf, uu, tmp
  825 + tt = double( strsplit(tmp, ' ', /extract) )
  826 + sedh_p(i,*) = tt(1:*)
  827 + x(i) = tt(0)
  828 + endfor
  829 + close,uu
  830 + free_lun,uu
  831 + sed_p = sedh_p * nh / 4. / !pi ; in erg/s/cm2/sr
  832 +
  833 + yr = [1e-10,1e-5]
  834 + xr = [10,1e4]
  835 + dy = 10.^((ALOG10(yr(1))-ALOG10(yr(0))) / 25.)
  836 + dx = 10.^((ALOG10(xr(1))-ALOG10(xr(0))) / 50.)
  837 + yps= 10.^((ALOG10(yr(1))+ALOG10(yr(0))) / 2. + (ALOG10(yr(1))-ALOG10(yr(0))) / 2.3)
  838 + xpr=xr(0)
  839 + xpr = xpr*[dx,dx^4]
  840 +
  841 + xtit = 'Wavelength (!4l!3m)'
  842 + ytit = '!4m!3 P!d!4m!3!n (erg s!u-1!n cm!u-2!n sr!u-1!n)'
  843 + fine = 1
  844 + plot_oo, INDGEN(1),/NODAT,xs=9,/ys,XR=xr,YR=yr,XTIT=xtit,YTIT= ytit
  845 + axis, /data, xr=1d-5*clight/xr, xax=1,/xlo,xs=1,xtit='Frequency (GHz)'
  846 + for i=0,ntype-1 do begin
  847 + oplot, x, sed_p(*,i), lin=ls(i+1)
  848 + oplot,xpr,yps*[1.,1.], lin=ls(i+1)
  849 + xyouts,/data,xpr(1)*1.1,yps,gtype(i),chars=1
  850 + yps = yps/dy
  851 + endfor
  852 + oplot,x,sed_p(*,ntype),lin=ls(0),col=3
  853 + ENDIF
  854 +
  855 +
  856 +;
  857 +; get the polarisation extinction
  858 +;
  859 + ip = WHERE( STRPOS(show,'polext') GE 0, c_polext )
  860 + IF (SHOW(0) NE '0') AND (C_POLEXT EQ 1) THEN BEGIN
  861 +
  862 + itp = WHERE( STRPOS(t_opt,'pol') GE 0, ctp)
  863 + IF ctp EQ 0 THEN BEGIN
  864 + c_pol = 0
  865 + print,'(W) DUSTEM_SHOW_FORTRAN: no POL data in current run'
  866 + ENDIF ELSE BEGIN
  867 + OPENR, uu, fortran_path+'out/EXT_POL.RES', /get_lun
  868 + tmp = '#'
  869 + WHILE STRPOS(tmp,'#') EQ 0 do begin
  870 + READF, uu, tmp
  871 + ENDWHILE
  872 + tt = double( strsplit(tmp, ' ', /extract) )
  873 + ntype_pol = fix(tt(0))
  874 + if ntype_pol NE ntype then begin
  875 + print,'(F) DUSTEM_SHOW_FORTRAN: POL.RES & GRAIN.DAT have different NTYPE'
  876 + print,' data is not from present GRAIN.DAT'
  877 + return
  878 + endif
  879 + nlamb = fix(tt(1)) ; nr of wavelengths
  880 + x = dblarr(nlamb)
  881 + spabs = dblarr(nlamb,ntype+1)
  882 + spsca = dblarr(nlamb,ntype+1)
  883 + for i=0,nlamb-1 do begin
  884 + READF, uu, tmp
  885 + tt = double( strsplit(tmp, ' ', /extract) )
  886 + x(i) = tt(0)
  887 + spabs(i,0:ntype-1) = tt(1:ntype)
  888 + spsca(i,0:ntype-1) = tt(ntype+1:2*ntype)
  889 + spabs(i,ntype) = TOTAL(spabs(i,0:ntype-1))
  890 + spsca(i,ntype) = TOTAL(spsca(i,0:ntype-1))
  891 + endfor
  892 + close,uu
  893 + free_lun,uu
  894 +
  895 +; fill in model
  896 + smdat.m_ext.abs_p = spabs
  897 + smdat.m_ext.sca_p = spsca
  898 +
  899 + if HARD(0) NE '0' then begin
  900 + device, file=hard(ihard), /portrait,/color
  901 + ihard = ihard + 1
  902 + endif else begin
  903 + window, wn(7), xs=600,ys=400, xpos=0,ypos=0,tit='DUSTEM_SHOW_FORTRAN: Serkowski '+strtrim(wn(7),2)
  904 + endelse
  905 +
  906 +; plot Serkowski
  907 + yscl = 1.D23
  908 + yscl2 = 1.D2
  909 + xr=[0.2,10.]
  910 + yr=[0.1,5]
  911 + xtit = textoidl('1/\lambda (\mum^{-1})')
  912 + ytit = textoidl('\sigma_{pol} (10^{-23}cm^2/H)')
  913 + tit='DUSTEM'
  914 + plot_oo, 1./x, yscl2*(spabs(*,0)+spsca(*,0)), line=ls(1),xr=xr,/xs,xtit=xtit,/ys,yr=yr,ytit=ytit,tit=tit
  915 + FOR i=1,ntype-1 DO oplot, 1./x, yscl2*(spabs(*,i)+spsca(*,i)), line=ls(i+1)
  916 + oplot, 1./x, yscl2*(spabs(*,ntype)+spsca(*,ntype)), col=3
  917 + ix = WHERE(x_sm LE 7d, csm) ; keep wave below 7 microns
  918 + if csm GT 0 then begin
  919 + xx = 1./x_sm(ix)
  920 + xe = e_sm(ix)
  921 + endif
  922 + ix = SORT(xx)
  923 + xx = xx(ix) & xe = xe(ix)
  924 + fpol = DUSTEM_SERKOWSKI(xx)
  925 + oplot,xx,yscl*fpol/5.8e21*3.1,ps=4
  926 +; oplot,xx,25*fpol*3.1/5.8e21/xe, ps=5
  927 + ENDELSE
  928 +
  929 + ENDIF
  930 +
  931 +;
  932 +; Polarization fraction in emission
  933 +;
  934 + IF (SHOW(0) NE '0') AND (C_POLSED EQ 1) THEN BEGIN
  935 +; plot fractional polarisation
  936 + if HARD(0) NE '0' then begin
  937 + device, file=hard(ihard), /portrait,/color
  938 + ihard = ihard + 1
  939 + endif else begin
  940 + window, wn(8), xs=600,ys=400, xpos=0,ypos=0,tit='DUSTEM_SHOW_FORTRAN: P/I '+strtrim(wn(8),2)
  941 + endelse
  942 + xr=[10,1.e4]
  943 + yr=[0.,0.4]
  944 + xtit = textoidl('\lambda (\mum)')
  945 + ytit = textoidl('P/I')
  946 + tit=''
  947 + plot_oi, x, sed_p(*,0)/sed(*,0), line=ls(1),xr=xr,/xs,xtit=xtit,/ys,yr=yr,ytit=ytit,tit=tit
  948 + axis, /data, xr=1d-5*clight/xr, xax=1,/xlo,xs=1,xtit='Frequency (GHz)'
  949 + FOR i=1,ntype-1 DO begin
  950 + oplot, x, sed_p(*,i)/sed(*,i), line=ls(i+1)
  951 + ENDFOR
  952 + oplot, x, sed_p(*,ntype)/sed(*,ntype),col=3
  953 + ENDIF
  954 +
  955 +;
  956 +; Polarization fraction in extinction
  957 +;
  958 + IF (SHOW(0) NE '0') AND (C_POLEXT EQ 1) THEN BEGIN
  959 +; plot fractional polarisation
  960 + if HARD(0) NE '0' then begin
  961 + device, file=hard(ihard), /portrait,/color
  962 + ihard = ihard + 1
  963 + endif else begin
  964 + window, wn(9), xs=600,ys=400, xpos=0,ypos=0,tit='DUSTEM_SHOW_FORTRAN: p/tau '+strtrim(wn(9),2)
  965 + endelse
  966 + yscl = 1.
  967 + xr=[1.e-1,1.e4]
  968 + yr=[0.,0.5]
  969 + xtit = textoidl('\lambda (\mum)')
  970 + ytit = textoidl('p/\tau')
  971 + tit=''
  972 + plot_oi, x, yscl*(spabs(*,0)+spsca(*,0))/sext(*,0), line=ls(1),xr=xr,/xs,xtit=xtit,/ys,yr=yr,ytit=ytit,tit=tit
  973 + FOR i=1,ntype-1 DO begin
  974 + oplot, x, yscl*(spabs(*,i)+spsca(*,i))/sext(*,i), line=ls(i+1)
  975 + ENDFOR
  976 + oplot, x, yscl*(spabs(*,ntype)+spsca(*,ntype))/sext(*,ntype), col=3
  977 + ENDIF
  978 +
  979 +;
  980 +; Alignment function
  981 +;
  982 + ip = WHERE( STRPOS(show,'align') GE 0, c_align )
  983 + IF (SHOW(0) NE '0') AND (C_ALIGN EQ 1) THEN BEGIN
  984 + fname = fortran_path + 'data/ALIGN.DAT'
  985 + nlines = FILE_LINES( fname )
  986 + OPENR, uu, fname, /get_lun
  987 + tmp = '#'
  988 + print,'(W) DUSTEM_SHOW_FORTRAN: GRAIN.DAT'
  989 + cnt = 0
  990 + WHILE STRPOS(tmp,'#') EQ 0 do begin
  991 + READF, uu, tmp
  992 + cnt = cnt + 1
  993 + ENDWHILE
  994 + flags = tmp
  995 + readf, uu, anisG0
  996 +
  997 + if HARD(0) NE '0' then begin
  998 + device, file=hard(ihard), /portrait,/color
  999 + ihard = ihard + 1
  1000 + endif else begin
  1001 + window, wn(10), xs=600,ys=400, xpos=0,ypos=0,tit='DUSTEM_SHOW_FORTRAN: f_align '+strtrim(wn(10),2)
  1002 + endelse
  1003 +
  1004 + ; Parametric
  1005 + readf, uu, tmp
  1006 + tt = strsplit(tmp, /extract)
  1007 + align_type = tt(0)
  1008 + if (align_type eq 'par') then begin
  1009 + athresh = tt(1)
  1010 + pstiff = tt(2)
  1011 + plev = tt(3)
  1012 + n = 100
  1013 + ; Grain radius in microns
  1014 + radmin = 1d-3
  1015 + radmax = 10
  1016 + radius = radmin * exp(indgen(n)*alog(radmax/radmin)/n)
  1017 + fpol = 0.5 * plev * (1 + TANH(ALOG(radius/athresh) / pstiff ) )
  1018 + xr=[radmin,radmax]
  1019 + yr = [0,1.05]
  1020 + xtit=textoidl('Grain radius (\mum)')
  1021 + ytit='Alignment efficiency'
  1022 + plot_oi,radius,fpol,xr=xr,yr=yr,/ys,xtit=xtit,ytit=ytit
  1023 + endif
  1024 +
  1025 + ENDIF
  1026 +
  1027 +
  1028 +; get all the chi2
  1029 + if n_elements(smdat) EQ 0 then npar = ntype
  1030 + smdat = DUSTEM_FIL_CHI2( smdat,ntype=ntype+1 )
  1031 + stag = TAG_NAMES(smdat)
  1032 + itx = WHERE( STRPOS(stag,'I_') GE 0, ctx )
  1033 + print,'Chi-square of model to :'
  1034 + for ii=0,ctx-1 do print,stag(itx(ii))+': ', strtrim(smdat.(itx(ii)).chi2,2)
  1035 + print,'Chi-square of model to all data : ', strtrim(smdat.chi2,2)
  1036 +
  1037 +;
  1038 +; reset defaults
  1039 +;
  1040 + !x.tickname = ''
  1041 + !y.tickname = ''
  1042 +
  1043 + if HARD(0) NE '0' then begin
  1044 + device, /close
  1045 + set_plot,'x'
  1046 + print,'(W): hardcopies in ',hard
  1047 + !y.thick = 0
  1048 + !x.thick = 0
  1049 + !p.thick = 0
  1050 + !p.charsize = 1
  1051 + !p.charthick = 0
  1052 + !x.ticklen = 0.02
  1053 + endif
  1054 +
  1055 + RETURN
  1056 + the_end:
  1057 + END
  1058 +
  1059 +
  1060 +
  1061 +
src/idl/dustem_str_inst.pro 0 → 100644
  Diff comments   View file @52a3cc3
@@ -0,0 +1,36 @@ @@ -0,0 +1,36 @@
  1 +FUNCTION DUSTEM_STR_INST, n1, n2=n2, n3=n3
  2 +; returns structure containing flux and CC in band
  3 +; N1 (I): number of data points
  4 +; N2 (I): nr of grain types or different models
  5 +; N3 (I): nr of points in transmission (band flux data)
  6 +
  7 + if n_elements(n2) EQ 0 then n2 = 1
  8 +
  9 + if n_elements(n3) NE 0 then begin
  10 + strct = { NAME : strarr(n1), $
  11 + X : dblarr(n1), $
  12 + YD : dblarr(n1), $
  13 + ERR : dblarr(n1), $
  14 + YM : dblarr(n1,n2), $
  15 + FLX : dblarr(n1,n2), $
  16 + CC : dblarr(n1,n2), $
  17 + RR : dblarr(n1), $
  18 + ISEL : intarr(n1)+1, $
  19 + UNIT : '', $
  20 + NPAR : 0, $
  21 + CHI2 : 0d }
  22 + s1 = CREATE_STRUCT('TRANS', {X : dblarr(n1,n3), Y : dblarr(n1,n3) })
  23 + strct = CREATE_STRUCT( strct, s1 )
  24 + endif else if n_elements(BAND) EQ 0 then begin
  25 + strct = { X : dblarr(n1), $
  26 + YD : dblarr(n1), $
  27 + ERR : dblarr(n1) , $
  28 + YM : dblarr(n1,n2), $
  29 + ISEL : intarr(n1)+1, $
  30 + UNIT : '', $
  31 + NPAR : 0, $
  32 + CHI2 : 0d }
  33 + endif
  34 +
  35 + RETURN, strct
  36 +END