mod_thermal_emission.t

Go to the documentation of this file.

! module mod_thermal_emission -- synthesize emission flux of some
! thermal lines
! EUV lines database: 
! 'He_II_304' 'Fe_IX_171' 'Fe_XXIV_193' 'Fe_XIV_211' 'Fe_XVI_335'
! 'Fe_XVIII_94' 'Fe_XXI_131'
! subroutines: 
! get_EUV: get local EUV emission intensity (for 1d, 2d and 3d)
! get_SXR: get local Soft X-ray emission intensity (for 1d, 2d and 3d)
 
module mod_thermal_emission
  use mod_global_parameters
  use mod_geometry
  use mod_physics
  use mod_comm_lib, only: mpistop
 
  implicit none
 
  integer :: n_aia
  double precision :: t_aia(1:101)
  double precision :: f_94(1:101),f_131(1:101),f_171(1:101)
  double precision :: f_193(1:101),f_211(1:101),f_304(1:101)
  double precision :: f_335(1:101)
  integer :: n_iris
  double precision :: t_iris(1:41)
  double precision :: f_1354(1:41)
  integer :: n_eis
  double precision :: t_eis1(1:60),t_eis2(1:60)
  double precision :: f_263(1:60),f_264(1:60),f_192(1:60),f_255(1:60)
 
 
  double precision :: vec_xi1(1:3),vec_xi2(1:3),vec_los(1:3)
 
  data n_aia / 101 /
 
  data t_aia / 4. ,  4.05, 4.1,  4.15, 4.2,  4.25, 4.3,  4.35, &
               4.4,  4.45, 4.5,  4.55, 4.6,  4.65, 4.7,  4.75, &
               4.8,  4.85, 4.9,  4.95, 5. ,  5.05, 5.1,  5.15, &
               5.2,  5.25, 5.3,  5.35, 5.4,  5.45, 5.5,  5.55, &
               5.6,  5.65, 5.7,  5.75, 5.8,  5.85, 5.9,  5.95, &
               6. ,  6.05, 6.1,  6.15, 6.2,  6.25, 6.3,  6.35, &
               6.4,  6.45, 6.5,  6.55, 6.6,  6.65, 6.7,  6.75, &
               6.8,  6.85, 6.9,  6.95, 7. ,  7.05, 7.1,  7.15, &
               7.2,  7.25, 7.3,  7.35, 7.4,  7.45, 7.5,  7.55, &
               7.6,  7.65, 7.7,  7.75, 7.8,  7.85, 7.9,  7.95, &
               8. ,  8.05, 8.1,  8.15, 8.2,  8.25, 8.3,  8.35, &
               8.4,  8.45, 8.5,  8.55, 8.6,  8.65, 8.7,  8.75, &
               8.8,  8.85, 8.9,  8.95, 9. /
 
  data f_94 / 4.25022959d-37, 4.35880298d-36, 3.57054296d-35, 2.18175426d-34, & 
              8.97592571d-34, 2.68512961d-33, 7.49559346d-33, 2.11603751d-32, &
              5.39752853d-32, 1.02935904d-31, 1.33822307d-31, 1.40884290d-31, &
              1.54933156d-31, 2.07543102d-31, 3.42026227d-31, 6.31171444d-31, &
              1.16559416d-30, 1.95360497d-30, 2.77818735d-30, 3.43552578d-30, &
              4.04061803d-30, 4.75470982d-30, 5.65553769d-30, 6.70595782d-30, &
              7.80680354d-30, 8.93247715d-30, 1.02618156d-29, 1.25979030d-29, &
              1.88526483d-29, 3.62448572d-29, 7.50553279d-29, 1.42337571d-28, &
              2.37912813d-28, 3.55232305d-28, 4.84985757d-28, 6.20662827d-28, &
              7.66193687d-28, 9.30403645d-28, 1.10519802d-27, 1.25786927d-27, &
              1.34362634d-27, 1.33185242d-27, 1.22302081d-27, 1.05677973d-27, &
              9.23064720d-28, 8.78570994d-28, 8.02397416d-28, 5.87681142d-28, &
              3.82272695d-28, 3.11492649d-28, 3.85736090d-28, 5.98893519d-28, &
              9.57553548d-28, 1.46650267d-27, 2.10365847d-27, 2.79406671d-27, &
              3.39420087d-27, 3.71077520d-27, 3.57296767d-27, 2.95114380d-27, &
              2.02913103d-27, 1.13361825d-27, 5.13405629d-28, 2.01305089d-28, &
              8.15781482d-29, 4.28366817d-29, 3.08701543d-29, 2.68693906d-29, &
              2.51764203d-29, 2.41773103d-29, 2.33996083d-29, 2.26997246d-29, &
              2.20316143d-29, 2.13810001d-29, 2.07424438d-29, 2.01149189d-29, &
              1.94980213d-29, 1.88917920d-29, 1.82963583d-29, 1.77116920d-29, &
              1.71374392d-29, 1.65740593d-29, 1.60214447d-29, 1.54803205d-29, &
              1.49510777d-29, 1.44346818d-29, 1.39322305d-29, 1.34441897d-29, &
              1.29713709d-29, 1.25132618d-29, 1.20686068d-29, 1.14226584d-29, &
              1.09866413d-29, 1.05635524d-29, 1.01532444d-29, 9.75577134d-30, &
              9.37102736d-30, 8.99873335d-30, 8.63860172d-30, 8.29051944d-30, &
              7.95414793d-30 /
 
  data f_131 / 3.18403601d-37,   3.22254703d-36,   2.61657920d-35, &
               1.59575286d-34,   6.65779556d-34,   2.07015132d-33, &
               6.05768615d-33,   1.76074833d-32,   4.52633001d-32, &
               8.57121883d-32,   1.09184271d-31,   1.10207963d-31, &
               1.11371658d-31,   1.29105226d-31,   1.80385897d-31, &
               3.27295431d-31,   8.92002136d-31,   3.15214579d-30, &
               9.73440787d-30,   2.22709702d-29,   4.01788984d-29, &
               6.27471832d-29,   8.91764995d-29,   1.18725647d-28, &
               1.52888040d-28,   2.05082946d-28,   3.47651873d-28, &
               8.80482184d-28,   2.66533063d-27,   7.05805149d-27, &
               1.46072515d-26,   2.45282476d-26,   3.55303726d-26, &
               4.59075911d-26,   5.36503515d-26,   5.68444094d-26, &
               5.47222296d-26,   4.81119761d-26,   3.85959059d-26, &
               2.80383406d-26,   1.83977650d-26,   1.11182849d-26, &
               6.50748885d-27,   3.96843481d-27,   2.61876319d-27, &
               1.85525324d-27,   1.39717024d-27,   1.11504283d-27, &
               9.38169611d-28,   8.24801234d-28,   7.43331919d-28, &
               6.74537063d-28,   6.14495760d-28,   5.70805277d-28, &
               5.61219786d-28,   6.31981777d-28,   9.19747307d-28, &
               1.76795732d-27,   3.77985446d-27,   7.43166191d-27, &
               1.19785603d-26,   1.48234676d-26,   1.36673114d-26, &
               9.61047146d-27,   5.61209353d-27,   3.04779780d-27, &
               1.69378976d-27,   1.02113491d-27,   6.82223774d-28, &
               5.02099099d-28,   3.99377760d-28,   3.36279037d-28, &
               2.94767378d-28,   2.65740865d-28,   2.44396277d-28, &
               2.28003967d-28,   2.14941419d-28,   2.04178995d-28, &
               1.95031045d-28,   1.87011994d-28,   1.79777869d-28, &
               1.73093957d-28,   1.66795789d-28,   1.60785455d-28, &
               1.55002399d-28,   1.49418229d-28,   1.44022426d-28, &
               1.38807103d-28,   1.33772767d-28,   1.28908404d-28, &
               1.24196208d-28,   1.17437501d-28,   1.12854330d-28, &
               1.08410498d-28,   1.04112003d-28,   9.99529904d-29, &
               9.59358806d-29,   9.20512291d-29,   8.83009123d-29, &
               8.46817043d-29,   8.11921928d-29 /
 
  data f_171 / 2.98015581d-42, 1.24696230d-40, 3.37614652d-39, 5.64103034d-38, &
               5.20550266d-37, 2.77785939d-36, 1.16283616d-35, 6.50007689d-35, &
               9.96177399d-34, 1.89586076d-32, 2.10982799d-31, 1.36946479d-30, &
               6.27396553d-30, 2.29955134d-29, 7.13430211d-29, 1.91024282d-28, &
               4.35358848d-28, 7.94807808d-28, 1.07431875d-27, 1.08399488d-27, &
               9.16212938d-28, 7.34715770d-28, 6.59246382d-28, 9.13541375d-28, &
               2.05939035d-27, 5.08206555d-27, 1.10148083d-26, 2.01884662d-26, &
               3.13578384d-26, 4.14367719d-26, 5.36067711d-26, 8.74170213d-26, &
               1.64161233d-25, 2.94587860d-25, 4.76298332d-25, 6.91765639d-25, &
               9.08825111d-25, 1.08496183d-24, 1.17440114d-24, 1.13943939d-24, &
               9.71696981d-25, 7.09593688d-25, 4.31376399d-25, 2.12708486d-25, &
               8.47429567d-26, 3.17608104d-26, 1.95898842d-26, 1.98064242d-26, &
               1.67706555d-26, 8.99126003d-27, 3.29773878d-27, 1.28896127d-27, &
               8.51169698d-28, 7.53520167d-28, 6.18268143d-28, 4.30034650d-28, &
               2.78152409d-28, 1.95437088d-28, 1.65896278d-28, 1.68740181d-28, &
               1.76054383d-28, 1.63978419d-28, 1.32880591d-28, 1.00833205d-28, &
               7.82252806d-29, 6.36181741d-29, 5.34633869d-29, 4.58013864d-29, &
               3.97833422d-29, 3.49414760d-29, 3.09790940d-29, 2.76786227d-29, &
               2.48806269d-29, 2.24823367d-29, 2.04016653d-29, 1.85977413d-29, &
               1.70367499d-29, 1.56966125d-29, 1.45570643d-29, 1.35964565d-29, &
               1.27879263d-29, 1.21016980d-29, 1.15132499d-29, 1.09959628d-29, &
               1.05307482d-29, 1.01040261d-29, 9.70657096d-30, 9.33214234d-30, &
               8.97689427d-30, 8.63761192d-30, 8.31149879d-30, 7.85162401d-30, &
               7.53828281d-30, 7.23559452d-30, 6.94341530d-30, 6.66137038d-30, &
               6.38929156d-30, 6.12669083d-30, 5.87346434d-30, 5.62943622d-30, & 
               5.39435202d-30 /
 
  data f_193 / 6.40066486d-32, 4.92737300d-31, 2.95342934d-30, 1.28061594d-29, & 
               3.47747667d-29, 5.88554792d-29, 7.72171179d-29, 9.75609282d-29, &
               1.34318963d-28, 1.96252638d-28, 2.70163878d-28, 3.63192965d-28, &
               5.28087341d-28, 8.37821446d-28, 1.39089159d-27, 2.31749718d-27, &
               3.77510689d-27, 5.85198594d-27, 8.26021568d-27, 1.04870405d-26, &
               1.25209374d-26, 1.47406787d-26, 1.77174067d-26, 2.24098537d-26, &
               3.05926105d-26, 4.50018853d-26, 6.84720216d-26, 1.00595861d-25, &
               1.30759222d-25, 1.36481773d-25, 1.15943558d-25, 1.01467304d-25, &
               1.04092532d-25, 1.15071251d-25, 1.27416033d-25, 1.38463476d-25, &
               1.47882726d-25, 1.57041238d-25, 1.69786224d-25, 1.94970397d-25, &
               2.50332918d-25, 3.58321431d-25, 5.18061550d-25, 6.60405549d-25, &
               6.64085365d-25, 4.83825816d-25, 2.40545020d-25, 8.59534098d-26, &
               2.90920638d-26, 1.33204845d-26, 9.03933926d-27, 7.78910836d-27, &
               7.29342321d-27, 7.40267022d-27, 8.05279981d-27, 8.13829291d-27, &
               6.92634262d-27, 5.12521880d-27, 3.59527615d-27, 2.69617560d-27, &
               2.84432713d-27, 5.06697306d-27, 1.01281903d-26, 1.63526978d-26, &
               2.06759342d-26, 2.19482312d-26, 2.10050611d-26, 1.89837248d-26, &
               1.66347131d-26, 1.43071097d-26, 1.21518419d-26, 1.02078343d-26, &
               8.46936184d-27, 6.93015742d-27, 5.56973237d-27, 4.38951754d-27, &
               3.38456457d-27, 2.55309556d-27, 1.88904224d-27, 1.38057546d-27, &
               1.00718330d-27, 7.43581116d-28, 5.63562931d-28, 4.43359435d-28, &
               3.63923535d-28, 3.11248143d-28, 2.75586846d-28, 2.50672237d-28, &
               2.32419348d-28, 2.18325682d-28, 2.06834486d-28, 1.93497044d-28, &
               1.84540751d-28, 1.76356504d-28, 1.68741425d-28, 1.61566157d-28, &
               1.54754523d-28, 1.48249410d-28, 1.42020176d-28, 1.36045230d-28, &
               1.30307965d-28 /
 
  data f_211 / 4.74439912d-42, 1.95251522d-40, 5.19700194d-39, 8.53120166d-38, &
               7.72745727d-37, 4.04158559d-36, 1.64853511d-35, 8.56295439d-35, &
               1.17529722d-33, 2.16867729d-32, 2.40472264d-31, 1.56418133d-30, &
               7.20032889d-30, 2.65838271d-29, 8.33196904d-29, 2.26128236d-28, &
               5.24295811d-28, 9.77791121d-28, 1.35913489d-27, 1.43957785d-27, &
               1.37591544d-27, 1.49029886d-27, 2.06183401d-27, 3.31440622d-27, &
               5.42497318d-27, 8.41100374d-27, 1.17941366d-26, 1.49269794d-26, &
               1.71506074d-26, 1.71266353d-26, 1.51434781d-26, 1.36766622d-26, &
               1.33483562d-26, 1.36834518d-26, 1.45829002d-26, 1.62575306d-26, &
               1.88773347d-26, 2.22026986d-26, 2.54930499d-26, 2.80758138d-26, &
               3.06176409d-26, 3.62799792d-26, 5.13226109d-26, 8.46260744d-26, &
               1.38486586d-25, 1.86192535d-25, 1.78007934d-25, 1.16548409d-25, &
               5.89293257d-26, 2.69952884d-26, 1.24891081d-26, 6.41273176d-27, &
               4.08282914d-27, 3.26463328d-27, 2.76230280d-27, 2.08986882d-27, &
               1.37658470d-27, 8.48489381d-28, 5.19304217d-28, 3.19312514d-28, &
               2.02968197d-28, 1.50171666d-28, 1.39164218d-28, 1.42448821d-28, &
               1.41714519d-28, 1.33341059d-28, 1.20759270d-28, 1.07259692d-28, &
               9.44895400d-29, 8.29030041d-29, 7.25440631d-29, 6.33479483d-29, &
               5.51563757d-29, 4.79002469d-29, 4.14990482d-29, 3.59384972d-29, &
               3.12010860d-29, 2.72624742d-29, 2.40734791d-29, 2.15543565d-29, &
               1.95921688d-29, 1.80682882d-29, 1.68695662d-29, 1.59020936d-29, &
               1.50940886d-29, 1.43956179d-29, 1.37731622d-29, 1.32049043d-29, &
               1.26771875d-29, 1.21803879d-29, 1.17074716d-29, 1.10507836d-29, &
               1.06022834d-29, 1.01703080d-29, 9.75436986d-30, 9.35349257d-30, &
               8.96744546d-30, 8.59527489d-30, 8.23678940d-30, 7.89144480d-30, & 
               7.55891138d-30 /
 
  data f_304 / 3.62695850d-32, 2.79969087d-31, 1.68340584d-30, 7.32681440d-30, &
               1.99967770d-29, 3.41296785d-29, 4.55409104d-29, 5.94994635d-29, &
               8.59864963d-29, 1.39787633d-28, 3.17701965d-28, 1.14474920d-27, &
               4.44845958d-27, 1.54785841d-26, 4.70265345d-26, 1.24524365d-25, &
               2.81535352d-25, 5.10093666d-25, 6.83545307d-25, 6.82110329d-25, &
               5.66886188d-25, 4.36205513d-25, 3.29265688d-25, 2.49802368d-25, &
               1.92527113d-25, 1.51058572d-25, 1.20596047d-25, 9.76884267d-26, &
               7.89979266d-26, 6.18224289d-26, 4.67298332d-26, 3.57934505d-26, &
               2.84535785d-26, 2.32853022d-26, 1.95228514d-26, 1.67880071d-26, &
               1.47608785d-26, 1.32199691d-26, 1.20070960d-26, 1.09378177d-26, &
               1.00031730d-26, 9.62434001d-27, 1.05063954d-26, 1.27267143d-26, &
               1.45923057d-26, 1.36746707d-26, 1.03466970d-26, 6.97647829d-27, &
               4.63141039d-27, 3.19031994d-27, 2.33373613d-27, 1.81589079d-27, &
               1.48446917d-27, 1.26611478d-27, 1.12617468d-27, 1.03625148d-27, &
               9.61400595d-28, 8.79016231d-28, 7.82612130d-28, 6.73762960d-28, &
               5.59717956d-28, 4.53010243d-28, 3.65712196d-28, 3.00958686d-28, &
               2.54011502d-28, 2.18102277d-28, 1.88736437d-28, 1.63817539d-28, &
               1.42283147d-28, 1.23631916d-28, 1.07526003d-28, 9.36797928d-29, &
               8.18565660d-29, 7.18152734d-29, 6.32523238d-29, 5.59513985d-29, &
               4.96614048d-29, 4.42518826d-29, 3.95487628d-29, 3.54690294d-29, &
               3.18953930d-29, 2.87720933d-29, 2.60186750d-29, 2.36011522d-29, &
               2.14717806d-29, 1.95905217d-29, 1.79287981d-29, 1.64562262d-29, &
               1.51489425d-29, 1.39876064d-29, 1.29496850d-29, 1.18665438d-29, &
               1.10240474d-29, 1.02643099d-29, 9.57780996d-30, 8.95465151d-30, &
               8.38950190d-30, 7.87283711d-30, 7.40136507d-30, 6.96804279d-30, & 
               6.56945323d-30 /
 
  data f_335 / 2.46882661d-32, 1.89476632d-31, 1.13216502d-30, 4.89532008d-30, & 
               1.32745970d-29, 2.25390335d-29, 3.00511672d-29, 3.96035934d-29, &
               5.77977656d-29, 8.58600736d-29, 1.14083000d-28, 1.48644411d-28, &
               2.15788823d-28, 3.51628877d-28, 6.12200698d-28, 1.08184987d-27, &
               1.85590697d-27, 2.91679107d-27, 3.94405396d-27, 4.63610680d-27, &
               5.13824456d-27, 5.66602209d-27, 6.30009232d-27, 7.03422868d-27, &
               7.77973918d-27, 8.32371831d-27, 8.56724316d-27, 8.62601374d-27, &
               8.13308844d-27, 6.53188216d-27, 4.55197029d-27, 3.57590087d-27, &
               3.59571707d-27, 4.03502770d-27, 4.54366411d-27, 4.96914990d-27, &
               5.24601170d-27, 5.39979250d-27, 5.43023669d-27, 5.26235042d-27, &
               4.91585495d-27, 4.52628362d-27, 4.13385020d-27, 3.67538967d-27, &
               3.39939742d-27, 3.81284533d-27, 5.02332701d-27, 6.19438602d-27, &
               6.49613071d-27, 6.04010475d-27, 5.24664275d-27, 4.37225997d-27, &
               3.52957182d-27, 2.76212276d-27, 2.08473158d-27, 1.50850518d-27, &
               1.04602472d-27, 7.13091243d-28, 5.34289645d-28, 5.21079581d-28, &
               6.22246365d-28, 6.99555864d-28, 6.29665489d-28, 4.45077026d-28, &
               2.67046793d-28, 1.52774686d-28, 9.18061770d-29, 6.09116074d-29, &
               4.48562572d-29, 3.59463696d-29, 3.05820218d-29, 2.70766652d-29, &
               2.46144034d-29, 2.27758450d-29, 2.13331183d-29, 2.01537836d-29, &
               1.91566180d-29, 1.82893912d-29, 1.75167748d-29, 1.68136168d-29, &
               1.61615595d-29, 1.55481846d-29, 1.49643236d-29, 1.44046656d-29, &
               1.38657085d-29, 1.33459068d-29, 1.28447380d-29, 1.23615682d-29, &
               1.18963296d-29, 1.14478976d-29, 1.10146637d-29, 1.04039479d-29, &
               9.98611410d-30, 9.58205147d-30, 9.19202009d-30, 8.81551313d-30, &
               8.45252127d-30, 8.10224764d-30, 7.76469090d-30, 7.43954323d-30, &
               7.12653873d-30 /
 
 
  data n_iris / 41 /
 
  data t_iris / 4.        , 4.1       , 4.2       , 4.3       , 4.40000001, &
                4.50000001, 4.60000001, 4.70000001, 4.80000001, 4.90000001, &
                5.00000001, 5.10000002, 5.20000002, 5.30000002, 5.40000002, &
                5.50000002, 5.60000002, 5.70000003, 5.80000003, 5.90000003, &
                6.00000003, 6.10000003, 6.20000003, 6.30000003, 6.40000004, &
                6.50000004, 6.60000004, 6.70000004, 6.80000004, 6.90000004, &
                7.00000004, 7.10000005, 7.20000005, 7.30000005, 7.40000005, &
                7.50000005, 7.60000005, 7.70000006, 7.80000006, 7.90000006, &
                8.00000006 /
 
  data f_1354 / 0.00000000d+00, 0.00000000d+00, 0.00000000d+00, 0.00000000d+00, &
                0.00000000d+00, 0.00000000d+00, 0.00000000d+00, 0.00000000d+00, &
                0.00000000d+00, 0.00000000d+00, 0.00000000d+00, 0.00000000d+00, &
                0.00000000d+00, 0.00000000d+00, 0.00000000d+00, 0.00000000d+00, &
                0.00000000d+00, 0.00000000d+00, 0.00000000d+00, 0.00000000d+00, &
                0.00000000d+00, 0.00000000d+00, 0.00000000d+00, 1.09503647d-39, &
                5.47214550d-36, 2.42433983d-33, 2.75295034d-31, 1.21929718d-29, &
                2.48392125d-28, 2.33268145d-27, 8.68623633d-27, 1.00166284d-26, &
                3.63126633d-27, 7.45174807d-28, 1.38224064d-28, 2.69270994d-29, &
                5.53314977d-30, 1.15313092d-30, 2.34195788d-31, 4.48242942d-32, &
                7.94976380d-33 /
 
 
  data n_eis  / 60 /
 
  data t_eis1 / 1.99526231d+05, 2.23872114d+05, 2.51188643d+05, 2.81838293d+05, & 
                3.16227766d+05, 3.54813389d+05, 3.98107171d+05, 4.46683592d+05, &
                5.01187234d+05, 5.62341325d+05, 6.30957344d+05, 7.07945784d+05, &
                7.94328235d+05, 8.91250938d+05, 1.00000000d+06, 1.12201845d+06, &
                1.25892541d+06, 1.41253754d+06, 1.58489319d+06, 1.77827941d+06, &
                1.99526231d+06, 2.23872114d+06, 2.51188643d+06, 2.81838293d+06, &
                3.16227766d+06, 3.54813389d+06, 3.98107171d+06, 4.46683592d+06, &
                5.01187234d+06, 5.62341325d+06, 6.30957344d+06, 7.07945784d+06, &
                7.94328235d+06, 8.91250938d+06, 1.00000000d+07, 1.12201845d+07, &
                1.25892541d+07, 1.41253754d+07, 1.58489319d+07, 1.77827941d+07, &
                1.99526231d+07, 2.23872114d+07, 2.51188643d+07, 2.81838293d+07, &
                3.16227766d+07, 3.54813389d+07, 3.98107171d+07, 4.46683592d+07, &
                5.01187234d+07, 5.62341325d+07, 6.30957344d+07, 7.07945784d+07, &
                7.94328235d+07, 8.91250938d+07, 1.00000000d+08, 1.12201845d+08, &
                1.25892541d+08, 1.41253754d+08, 1.58489319d+08, 1.77827941d+08 /
 
  data t_eis2 / 1.99526231d+06, 2.23872114d+06, 2.51188643d+06, 2.81838293d+06, & 
                3.16227766d+06, 3.54813389d+06, 3.98107171d+06, 4.46683592d+06, &
                5.01187234d+06, 5.62341325d+06, 6.30957344d+06, 7.07945784d+06, &
                7.94328235d+06, 8.91250938d+06, 1.00000000d+07, 1.12201845d+07, &
                1.25892541d+07, 1.41253754d+07, 1.58489319d+07, 1.77827941d+07, &
                1.99526231d+07, 2.23872114d+07, 2.51188643d+07, 2.81838293d+07, &
                3.16227766d+07, 3.54813389d+07, 3.98107171d+07, 4.46683592d+07, &
                5.01187234d+07, 5.62341325d+07, 6.30957344d+07, 7.07945784d+07, &
                7.94328235d+07, 8.91250938d+07, 1.00000000d+08, 1.12201845d+08, &
                1.25892541d+08, 1.41253754d+08, 1.58489319d+08, 1.77827941d+08, &
                1.99526231d+08, 2.23872114d+08, 2.51188643d+08, 2.81838293d+08, &
                3.16227766d+08, 3.54813389d+08, 3.98107171d+08, 4.46683592d+08, &
                5.01187234d+08, 5.62341325d+08, 6.30957344d+08, 7.07945784d+08, &
                7.94328235d+08, 8.91250938d+08, 1.00000000d+09, 1.12201845d+09, &
                1.25892541d+09, 1.41253754d+09, 1.58489319d+09, 1.77827941d+09 /
 
  data f_263 /  0.00000000d+00, 0.00000000d+00, 0.00000000d+00, 0.00000000d+00, & 
                0.00000000d+00, 0.00000000d+00, 0.00000000d+00, 0.00000000d+00, &
                0.00000000d+00, 4.46454917d-45, 3.26774829d-42, 1.25292566d-39, &
                2.66922338d-37, 3.28497742d-35, 2.38677554d-33, 1.03937729d-31, &
                2.75075687d-30, 4.47961733d-29, 4.46729177d-28, 2.64862689d-27, &
                8.90863800d-27, 1.72437548d-26, 2.22217752d-26, 2.27999477d-26, &
                2.08264363d-26, 1.78226687d-26, 1.45821699d-26, 1.14675379d-26, &
                8.63082492d-27, 6.15925429d-27, 4.11252514d-27, 2.51530564d-27, &
                1.37090986d-27, 6.42443134d-28, 2.48392636d-28, 7.59187874d-29, &
                1.77852938d-29, 3.23945221d-30, 4.90533903d-31, 6.75458158d-32, &
                9.06878868d-33, 1.23927474d-33, 1.75769395d-34, 2.60710914d-35, &
                4.04318030d-36, 6.53500581d-37, 1.09365022d-37, 1.88383322d-38, &
                3.31425233d-39, 5.90964084d-40, 1.06147549d-40, 1.90706170d-41, &
                3.41331584d-42, 6.07310718d-43, 1.07364738d-43, 1.89085498d-44, &
                3.32598922d-45, 5.87125640d-46, 0.00000000d+00, 0.00000000d+00 /
 
  data f_264 /  0.00000000d+00, 2.81670057d-46, 1.28007268d-43, 2.54586603d-41, & 
                2.67887256d-39, 1.68413285d-37, 6.85702304d-36, 1.91797284d-34, &
                3.84675839d-33, 5.69939170d-32, 6.36224608d-31, 5.39176489d-30, &
                3.45478458d-29, 1.64848693d-28, 5.71476364d-28, 1.39909997d-27, &
                2.37743056d-27, 2.86712530d-27, 2.65206348d-27, 2.07175767d-27, &
                1.47866767d-27, 1.01087374d-27, 6.79605811d-28, 4.54746770d-28, &
                3.04351751d-28, 2.03639149d-28, 1.35940991d-28, 9.01451939d-29, &
                5.91289972d-29, 3.81821178d-29, 2.41434696d-29, 1.48871220d-29, &
                8.93362094d-30, 5.21097445d-30, 2.95964719d-30, 1.64278748d-30, &
                8.95571660d-31, 4.82096011d-31, 2.57390991d-31, 1.36821781d-31, &
                7.27136350d-32, 3.87019426d-32, 2.06883430d-32, 1.11228884d-32, &
                6.01883313d-33, 3.27790676d-33, 1.79805012d-33, 9.93085346d-34, &
                5.52139556d-34, 3.08881387d-34, 1.73890315d-34, 9.84434964d-35, &
                5.60603378d-35, 3.20626492d-35, 1.84111068d-35, 0.00000000d+00, &
                0.00000000d+00, 0.00000000d+00, 0.00000000d+00, 0.00000000d+00 /
 
  data f_192 /  0.00000000d+00, 0.00000000d+00, 0.00000000d+00, 4.35772105d-44, & 
                1.26162319d-41, 1.97471205d-39, 1.83409019d-37, 1.08206288d-35, &
                4.27914363d-34, 1.17943846d-32, 2.32565755d-31, 3.33087991d-30, &
                3.47013260d-29, 2.60375866d-28, 1.37737127d-27, 5.01053913d-27, &
                1.23479810d-26, 2.11310542d-26, 2.71831513d-26, 2.89851163d-26, &
                2.77312376d-26, 2.50025229d-26, 2.18323661d-26, 1.86980322d-26, &
                1.58035034d-26, 1.31985651d-26, 1.08733133d-26, 8.81804906d-27, &
                7.00417973d-27, 5.43356567d-27, 4.09857884d-27, 2.99651764d-27, &
                2.11902962d-27, 1.45014127d-27, 9.62291023d-28, 6.21548647d-28, &
                3.92807578d-28, 2.44230375d-28, 1.50167782d-28, 9.17611405d-29, &
                5.58707641d-29, 3.40570915d-29, 2.08030862d-29, 1.27588676d-29, &
                7.86535588d-30, 4.87646151d-30, 3.03888897d-30, 1.90578649d-30, &
                1.20195947d-30, 7.61955060d-31, 4.85602199d-31, 3.11049969d-31, &
                2.00087065d-31, 1.29223740d-31, 8.37422008d-32, 0.00000000d+00, &
                0.00000000d+00, 0.00000000d+00, 0.00000000d+00, 0.00000000d+00 /
 
  data f_255 /  0.00000000d+00, 0.00000000d+00, 0.00000000d+00, 1.76014287d-44, & 
                5.07057938d-42, 7.90473970d-40, 7.31852999d-38, 4.30709255d-36, &
                1.70009061d-34, 4.67925160d-33, 9.21703546d-32, 1.31918676d-30, &
                1.37393161d-29, 1.03102379d-28, 5.45694018d-28, 1.98699648d-27, &
                4.90346776d-27, 8.40524725d-27, 1.08321456d-26, 1.15714525d-26, &
                1.10905152d-26, 1.00155023d-26, 8.75799161d-27, 7.50935839d-27, &
                6.35253533d-27, 5.30919268d-27, 4.37669455d-27, 3.55185164d-27, &
                2.82347055d-27, 2.19257595d-27, 1.65589541d-27, 1.21224987d-27, &
                8.58395132d-28, 5.88163935d-28, 3.90721447d-28, 2.52593407d-28, &
                1.59739995d-28, 9.93802874d-29, 6.11343388d-29, 3.73711135d-29, &
                2.27618743d-29, 1.38793199d-29, 8.48060787d-30, 5.20305940d-30, &
                3.20867365d-30, 1.99011277d-30, 1.24064551d-30, 7.78310544d-31, &
                4.91013681d-31, 3.11338381d-31, 1.98451675d-31, 1.27135460d-31, &
                8.17917486d-32, 5.28280497d-32, 3.42357159d-32, 0.00000000d+00, &
                0.00000000d+00, 0.00000000d+00, 0.00000000d+00, 0.00000000d+00 /
 
  abstract interface
    subroutine get_subr1(w,x,ixI^L,ixO^L,res)
      use mod_global_parameters
      integer, intent(in)          :: ixI^L, ixO^L
      double precision, intent(in) :: w(ixI^S,nw)
      double precision, intent(in) :: x(ixI^S,1:ndim)
      double precision, intent(out):: res(ixI^S)
    end subroutine get_subr1
 
  end interface
 
  abstract interface
    subroutine get_2var_subr_te(ixI^L, ixO^L, w, val1, val2)
      use mod_global_parameters
      integer, intent(in)          :: ixI^L, ixO^L
      double precision, intent(in) :: w(ixI^S, nw)
      double precision, intent(out):: val1(ixI^S), val2(ixI^S)
    end subroutine get_2var_subr_te
  end interface
 
  type te_fluid
 
    procedure(get_subr1), pointer, nopass :: get_rho => null()
    procedure(get_subr1), pointer, nopass :: get_pthermal => null()
    procedure(get_subr1), pointer, nopass :: get_var_rfactor => null()
    procedure(get_2var_subr_te), pointer, nopass :: get_ne_nh => null()
 
  end type te_fluid
 
  type radsyn_euv_cache
    integer :: igrid=0
    integer :: level=0
    integer :: rft=1
    integer :: los_min=0
    integer :: los_max=0
    double precision, allocatable :: source(:^d&)
    double precision, allocatable :: opacity(:^d&)
    double precision, allocatable :: sourcev(:^d&)
    double precision, allocatable :: xface1(:),xface2(:),xface3(:)
    double precision, allocatable :: rface(:),thetaface(:),phiface(:)
    double precision, allocatable :: rface2(:),theta_cos(:),phi_sin(:),phi_cos(:)
    double precision :: box_min(1:3)=0.d0
    double precision :: box_max(1:3)=0.d0
    integer :: ixpmin1=1
    integer :: ixpmax1=0
    integer :: ixpmin2=1
    integer :: ixpmax2=0
    logical :: has_pixels=.false.
  end type radsyn_euv_cache
 
  character(len=std_len) :: ray_method_active='legacy'
  logical :: sph_use_dda=.false.
 
 
  contains
 
    subroutine check_synthetic_emission_options(datatype)
      use mod_global_parameters
 
      character(len=*), intent(in) :: datatype
 
      if (trim(radiation_transfer) /= 'thin' .and. trim(radiation_transfer) /= 'thick') then
        call mpistop("bad radiation_transfer")
      endif
 
      sph_use_dda=.false.
      select case(trim(ray_method))
      case('auto','')
        if (datatype=='image_euv' .and. coordinate==spherical) then
          ray_method_active='spherical'
          sph_use_dda=.true.
        else if (datatype=='image_euv' .and. coordinate==cartesian .and. dat_resolution .and. slab) then
          ray_method_active='cart'
        else
          ray_method_active='legacy'
        endif
      case('legacy')
        ray_method_active='legacy'
      case('cart','cart_dda')
        ray_method_active='cart'
      case('spherical','sph_intersection')
        ray_method_active='spherical'
      case('sph_dda','spherical_dda')
        ray_method_active='spherical'
        sph_use_dda=.true.
      case default
        call mpistop("bad ray_method")
      end select
 
      if (trim(emission_model) /= 'auto' .and. trim(emission_model) /= 'euv_aia' .and. &
          trim(emission_model) /= 'white_light' .and. trim(emission_model) /= 'radio_ff' .and. &
          trim(emission_model) /= 'pseudo_current') then
        call mpistop("bad emission_model")
      endif
 
      if ((output_tau .or. output_absorption_fraction) .and. trim(radiation_transfer) /= 'thick') then
        call mpistop("tau and absorption-fraction output need thick transfer")
      endif
 
      if (radsyn_pixel_batch<1) then
        call mpistop("radsyn_pixel_batch must be positive")
      endif
      if (radsyn_segment_batch_factor<0) then
        call mpistop("radsyn_segment_batch_factor must be non-negative")
      endif
      if (radsyn_segment_memory_mb<=zero) then
        call mpistop("radsyn_segment_memory_mb must be positive")
      endif
      if (radsyn_segment_comm_factor<1) then
        call mpistop("radsyn_segment_comm_factor must be positive")
      endif
 
      if (instrument_postprocess) then
        if (datatype /= 'image_euv' .or. .not. dat_resolution) then
          call mpistop("instrument_postprocess currently needs dat-resolution EUV images")
        endif
        if (trim(ray_method_active) == 'spherical') then
          call mpistop("instrument_postprocess is not yet supported for spherical rays")
        endif
        if (trim(emission_model) == 'pseudo_current') then
          call mpistop("instrument_postprocess currently supports only EUV AIA or radio_ff images")
        endif
        if (trim(emission_model) == 'radio_ff' .and. radio_beam_fwhm<=zero) then
          call mpistop("radio_ff instrument_postprocess needs radio_beam_fwhm > 0 arcsec")
        endif
      endif
 
      select case(trim(emission_model))
      case('auto')
        continue
      case('euv_aia')
        if (datatype /= 'image_euv' .and. datatype /= 'spectrum_euv') then
          call mpistop("emission_model=euv_aia is only valid for EUV synthesis")
        endif
      case('white_light')
        if (datatype /= 'image_whitelight') then
          call mpistop("emission_model=white_light is only valid for white-light synthesis")
        endif
      case('radio_ff')
        if (datatype /= 'image_euv') then
          call mpistop("emission_model=radio_ff currently reuses EUV-image convert types")
        endif
        if (radio_frequency<=zero) then
          call mpistop("emission_model=radio_ff needs radio_frequency > 0")
        endif
      case('pseudo_current')
        if (datatype /= 'image_euv') then
          call mpistop("emission_model=pseudo_current is only valid for EUV-image convert types")
        endif
        if (trim(radiation_transfer) /= 'thin') then
          call mpistop("emission_model=pseudo_current currently supports only thin transfer")
        endif
      end select
 
      if (trim(ray_method_active) == 'cart') then
        if (datatype /= 'image_euv' .or. coordinate /= cartesian .or. .not. slab) then
          call mpistop("ray_method=cart needs Cartesian EUV slab images")
        endif
      endif
      if (trim(ray_method_active) == 'spherical') then
        {^ifoned
        call mpistop("ray_method=spherical currently needs 3D spherical grids")
        }
        {^iftwod
        call mpistop("ray_method=spherical currently needs 3D spherical grids")
        }
        {^ifthreed
        if (datatype /= 'image_euv' .or. coordinate /= spherical .or. &
            (trim(radiation_transfer) /= 'thin' .and. trim(radiation_transfer) /= 'thick')) then
          call mpistop("bad ray_method=spherical mode")
        endif
        if (trim(emission_model) /= 'auto' .and. trim(emission_model) /= 'euv_aia') then
          call mpistop("ray_method=spherical currently supports only EUV AIA emission")
        endif
        if (xprobmin2<=1.d-10 .or. xprobmax2>=dpi-1.d-10) then
          call mpistop("ray_method=spherical does not support polar-axis crossing domains")
        endif
        if (xprobmax3<=xprobmin3 .or. xprobmax3-xprobmin3>=2.d0*dpi-1.d-10) then
          call mpistop("ray_method=spherical does not support phi-wrapping domains")
        endif
        }
      endif
      if (trim(radiation_transfer) == 'thick') then
        if (datatype /= 'image_euv') then
          call mpistop("thick transfer is only defined for EUV images")
        endif
        if (trim(ray_method_active) == 'spherical') then
          continue
        else if (trim(ray_method_active) == 'cart') then
          if (.not. slab) call mpistop("cartesian thick EUV currently needs slab output")
        else if (.not. slab .or. .not. dat_resolution) then
          call mpistop("thick EUV currently needs Cartesian dat_resolution output")
        endif
        if (trim(ray_method_active) /= 'cart' .and. &
            trim(ray_method_active) /= 'spherical' .and. &
            .not. ((los_phi==0 .and. los_theta==90) .or. &
                   (los_phi==90 .and. los_theta==90) .or. los_theta==0)) then
          call mpistop("thick EUV currently needs x/y/z-aligned LOS")
        endif
      endif
    end subroutine check_synthetic_emission_options
 
    subroutine integrate_transfer_step_first_order(emissivity,opacity,path_length,intensity,tau)
      ! First-order formal-solution step used by the planned ordered LOS transfer.
      double precision, intent(in) :: emissivity,opacity,path_length
      double precision, intent(inout) :: intensity,tau
 
      double precision :: dtau
 
      if (path_length<=zero) return
      intensity=intensity+transfer_attenuation(tau)*max(zero,emissivity)*path_length
      dtau=max(zero,opacity)*path_length
      tau=tau+dtau
    end subroutine integrate_transfer_step_first_order
 
    logical function radsyn_euv_has_doppler_output()
      radsyn_euv_has_doppler_output=trim(emission_model)/='pseudo_current' .and. &
           trim(emission_model)/='radio_ff' .and. &
           .not. (coordinate==spherical .and. trim(ray_method_active)=='spherical')
    end function radsyn_euv_has_doppler_output
 
    integer function radsyn_euv_num_outputs(has_doppler,has_thick) result(num_outputs)
      logical, intent(in) :: has_doppler,has_thick
 
      num_outputs=1
      if (has_doppler) num_outputs=num_outputs+1
      if (has_thick .and. output_tau) num_outputs=num_outputs+1
      if (has_thick .and. output_absorption_fraction) num_outputs=num_outputs+1
    end function radsyn_euv_num_outputs
 
    subroutine normalize_euv_doppler(nI1,nI2,EUV,Dpl,unitv)
      integer, intent(in) :: nI1,nI2
      double precision, intent(in) :: EUV(nI1,nI2),unitv
      double precision, intent(inout) :: Dpl(nI1,nI2)
 
      integer :: ix1,ix2
 
      do ix1=1,ni1
        do ix2=1,ni2
          if (euv(ix1,ix2)/=zero) then
            dpl(ix1,ix2)=(dpl(ix1,ix2)/euv(ix1,ix2))*unitv
          else
            dpl(ix1,ix2)=zero
          endif
          if (abs(dpl(ix1,ix2))<smalldouble) dpl(ix1,ix2)=zero
        enddo
      enddo
    end subroutine normalize_euv_doppler
 
    subroutine fill_euv_absorption_fraction(nI1,nI2,EUV,EUVthin,smallflux,Absorption,cap_to_one)
      integer, intent(in) :: nI1,nI2
      double precision, intent(in) :: EUV(nI1,nI2),EUVthin(nI1,nI2),smallflux
      double precision, intent(out) :: Absorption(nI1,nI2)
      logical, intent(in), optional :: cap_to_one
 
      integer :: ix1,ix2
      logical :: cap_absorption
 
      absorption=zero
      cap_absorption=.false.
      if (present(cap_to_one)) cap_absorption=cap_to_one
      do ix1=1,ni1
        do ix2=1,ni2
          if (euvthin(ix1,ix2)>smallflux) then
            absorption(ix1,ix2)=max(zero,(euvthin(ix1,ix2)-euv(ix1,ix2))/euvthin(ix1,ix2))
            if (cap_absorption) absorption(ix1,ix2)=min(one,absorption(ix1,ix2))
          endif
        enddo
      enddo
    end subroutine fill_euv_absorption_fraction
 
    subroutine pack_euv_image_outputs(nI1,nI2,EUV,wI,smallflux,has_doppler,has_thick,Dpl,Tau,EUVthin,&
                                      cap_absorption)
      integer, intent(in) :: nI1,nI2
      double precision, intent(in) :: EUV(nI1,nI2),smallflux
      double precision, intent(inout) :: wI(:,:,:)
      logical, intent(in) :: has_doppler,has_thick
      double precision, intent(in), optional :: Dpl(nI1,nI2),Tau(nI1,nI2),EUVthin(nI1,nI2)
      logical, intent(in), optional :: cap_absorption
 
      integer :: iw
      double precision, allocatable :: Absorption(:,:)
 
      wi=zero
      wi(:,:,1)=euv(:,:)
      iw=1
      if (has_doppler) then
        if (.not. present(dpl)) call mpistop("Doppler output requested without Doppler image")
        iw=iw+1
        wi(:,:,iw)=dpl(:,:)
      endif
      if (has_thick .and. output_tau) then
        if (.not. present(tau)) call mpistop("tau output requested without tau image")
        iw=iw+1
        wi(:,:,iw)=tau(:,:)
      endif
      if (has_thick .and. output_absorption_fraction) then
        if (.not. present(euvthin)) call mpistop("absorption output requested without thin image")
        allocate(absorption(ni1,ni2))
        call fill_euv_absorption_fraction(ni1,ni2,euv,euvthin,smallflux,absorption,cap_absorption)
        iw=iw+1
        wi(:,:,iw)=absorption(:,:)
        deallocate(absorption)
      endif
    end subroutine pack_euv_image_outputs
 
    subroutine radsyn_get_segment_batch_limits(pixel_batch_target,segment_batch_target,segment_comm_target)
      integer, intent(out) :: pixel_batch_target,segment_batch_target,segment_comm_target
 
      pixel_batch_target=max(1,radsyn_pixel_batch)
      if (radsyn_segment_batch_factor>0) then
        segment_batch_target=max(128,radsyn_segment_batch_factor*pixel_batch_target)
      else
        segment_batch_target=max(128,int(min(dble(huge(segment_batch_target)),&
             max(128.d0,radsyn_segment_memory_mb*1048576.d0/256.d0))))
      endif
      segment_comm_target=max(128,radsyn_segment_comm_factor*pixel_batch_target)
    end subroutine radsyn_get_segment_batch_limits
 
    double precision function transfer_attenuation(tau)
      double precision, intent(in) :: tau
 
      if (tau<=zero) then
        transfer_attenuation=one
      else
        transfer_attenuation=exp_clamped(-tau)
      endif
    end function transfer_attenuation
 
    double precision function exp_clamped(argument)
      double precision, intent(in) :: argument
 
      if (argument<-700.d0) then
        exp_clamped=zero
      else if (argument>700.d0) then
        exp_clamped=huge(one)
      else
        exp_clamped=exp(argument)
      endif
    end function exp_clamped
 
    double precision function pow10_clamped(exponent)
      double precision, intent(in) :: exponent
 
      if (exponent>300.d0) then
        pow10_clamped=1.d300
      else if (exponent<-300.d0) then
        pow10_clamped=zero
      else
        pow10_clamped=10.d0**exponent
      endif
    end function pow10_clamped
 
    double precision function interpolate_response_value(temperature,t_table,f_table,n_table,log_temperature,log_response)
      double precision, intent(in) :: temperature
      integer, intent(in) :: n_table
      double precision, intent(in) :: t_table(n_table),f_table(n_table)
      logical, intent(in) :: log_temperature,log_response
 
      integer :: ilo,ihi,imid
      double precision :: temp_lookup,response_lookup,flo,fhi
 
      interpolate_response_value=zero
      if (temperature<=zero) return
      if (log_temperature) then
        temp_lookup=log10(temperature)
      else
        temp_lookup=temperature
      endif
      if (temp_lookup<t_table(1) .or. temp_lookup>t_table(n_table)) return
      if (temp_lookup==t_table(n_table)) then
        if (log_response) then
          response_lookup=log10(max(f_table(n_table),1.d-99))
        else
          response_lookup=f_table(n_table)
        endif
      else
        ilo=1
        ihi=n_table
        do while (ihi-ilo>1)
          imid=(ilo+ihi)/2
          if (temp_lookup>=t_table(imid)) then
            ilo=imid
          else
            ihi=imid
          endif
        enddo
        if (log_response) then
          flo=log10(max(f_table(ilo),1.d-99))
          fhi=log10(max(f_table(ilo+1),1.d-99))
        else
          flo=f_table(ilo)
          fhi=f_table(ilo+1)
        endif
        response_lookup=flo*(temp_lookup-t_table(ilo+1))/(t_table(ilo)-t_table(ilo+1))+&
                        fhi*(temp_lookup-t_table(ilo))/(t_table(ilo+1)-t_table(ilo))
      endif
 
      if (log_response) then
        if (response_lookup>-99.d0) interpolate_response_value=10.d0**response_lookup
      else
        interpolate_response_value=response_lookup
      endif
      if (interpolate_response_value<zero) interpolate_response_value=zero
    end function interpolate_response_value
 
    subroutine apply_temperature_response(ixI^L,ixO^L,Te,flux,t_table,f_table,n_table,log_temperature,log_response)
      integer, intent(in) :: ixI^L, ixO^L, n_table
      double precision, intent(in) :: Te(ixI^S),t_table(n_table),f_table(n_table)
      double precision, intent(inout) :: flux(ixI^S)
      logical, intent(in) :: log_temperature,log_response
 
      integer :: ix^D
      double precision :: GT
 
      {do ix^db=ixomin^db,ixomax^db\}
        gt=interpolate_response_value(te(ix^d),t_table,f_table,n_table,log_temperature,log_response)
        flux(ix^d)=flux(ix^d)*gt
        if (flux(ix^d)<zero) flux(ix^d)=zero
      {enddo\}
    end subroutine apply_temperature_response
 
    subroutine get_euv_hhe_opacity(wl,ixI^L,ixO^L,w,x,fl,kappa)
      ! H I + He I + He II photoionization opacity in cm^-1.
      use mod_constants, only: kb_cgs
      use mod_eos, only: eos
 
      integer, intent(in) :: wl
      integer, intent(in) :: ixI^L, ixO^L
      double precision, intent(in) :: x(ixI^S,1:ndim)
      double precision, intent(in) :: w(ixI^S,1:nw)
      type(te_fluid), intent(in) :: fl
      double precision, intent(out) :: kappa(ixI^S)
 
      integer :: ix^D
      double precision :: pth(ixI^S),Te(ixI^S),Ne(ixI^S)
      double precision :: wave_ratio,s_H1,s_He1,s_He2,Pe
      double precision :: log_H21,log_He21,log_He32,log_He321,logScaleHe,w_H21
      double precision :: term0,term1,term2,denHe,i0,j1,j2,be
      double precision :: N_H,N_H1,N_He1,N_He2
      double precision, parameter :: Xe_H21=13.6d0, xe_he21=24.587d0, xe_he32=54.416d0
      double precision, parameter :: rHe=0.1d0
      double precision, parameter :: sigma_H1=5.16d-20, sigma_he1=9.25d-19, sigma_he2=7.17d-19
 
      call fl%get_pthermal(w,x,ixi^l,ixo^l,pth)
      call fl%get_rho(w,x,ixi^l,ixo^l,ne)
      call fl%get_var_Rfactor(w,x,ixi^l,ixo^l,te)
      te(ixo^s)=pth(ixo^s)/(ne(ixo^s)*te(ixo^s))*unit_temperature
      block
        double precision :: nH_dummy(ixI^S)
        call eos%get_ne_nH(ixi^l, ixo^l, w, ne, nh_dummy)
      end block
      if (si_unit) then
        ne(ixo^s)=ne(ixo^s)*unit_numberdensity/1.d6
      else
        ne(ixo^s)=ne(ixo^s)*unit_numberdensity
      endif
 
      wave_ratio=dble(wl)/171.d0
      s_h1=zero
      s_he1=zero
      s_he2=zero
      if (wl<=912) s_h1=wave_ratio**3*sigma_h1
      if (wl<=504) s_he1=wave_ratio**2*sigma_he1
      if (wl<=228) s_he2=wave_ratio**2.75d0*sigma_he2
      kappa(ixo^s)=zero
 
      {do ix^db=ixomin^db,ixomax^db\}
        if (te(ix^d)>zero .and. ne(ix^d)>zero) then
          pe=ne(ix^d)*kb_cgs*te(ix^d)
          if (pe>zero) then
            log_h21=2.5d0*log10(te(ix^d))-5040.d0*xe_h21/te(ix^d)-log10(pe)-0.48d0
            log_he21=log10(4.d0)+2.5d0*log10(te(ix^d))-5040.d0*xe_he21/te(ix^d)-log10(pe)-0.48d0
            log_he32=2.5d0*log10(te(ix^d))-5040.d0*xe_he32/te(ix^d)-log10(pe)-0.48d0
            w_h21=pow10_clamped(log_h21)
            i0=w_h21/(1.d0+w_h21)
            log_he321=log_he21+log_he32
            logscalehe=max(zero,log_he21,log_he321)
            term0=pow10_clamped(-logscalehe)
            term1=pow10_clamped(log_he21-logscalehe)
            term2=pow10_clamped(log_he321-logscalehe)
            denhe=term0+term1+term2
            if (denhe>zero) then
              j1=term1/denhe
              j2=term2/denhe
            else
              j1=zero
              j2=zero
            endif
            be=i0+rhe*(j1+2.d0*j2)
            if (be>smalldouble) then
              n_h=ne(ix^d)/be
              n_h1=n_h*(1.d0-i0)
              n_he1=(1.d0-j1-j2)*rhe*n_h
              n_he2=j1*rhe*n_h
              kappa(ix^d)=max(zero,n_h1*s_h1+n_he1*s_he1+n_he2*s_he2)
            endif
          endif
        endif
      {enddo\}
    end subroutine get_euv_hhe_opacity
 
    subroutine get_pseudo_current(igrid,ixI^L,ixO^L,w,source)
      integer, intent(in) :: igrid
      integer, intent(in) :: ixI^L, ixO^L
      double precision, intent(in) :: w(ixI^S,1:nw)
      double precision, intent(out) :: source(ixI^S)
 
      integer :: ix^D,idir,idirmin,idirmin0
      double precision :: current(ixI^S,7-2*ndir:3)
 
      if (.not. allocated(iw_mag)) then
        call mpistop("emission_model=pseudo_current needs magnetic-field variables")
      endif
 
      idirmin0=7-2*ndir
      current=zero
      call curlvector(w(ixi^s,iw_mag(1:ndir)),ixi^l,ixo^l,current,idirmin,idirmin0,ndir)
      if (b0field) then
        current(ixo^s,idirmin0:3)=current(ixo^s,idirmin0:3)+ps(igrid)%J0(ixo^s,idirmin0:3)
      endif
 
      source(ixi^s)=zero
      {do ix^db=ixomin^db,ixomax^db\}
        do idir=idirmin0,3
          source(ix^d)=source(ix^d)+current(ix^d,idir)**2
        enddo
      {enddo\}
    end subroutine get_pseudo_current
 
    subroutine get_radio_ff_source_opacity(ixI^L,ixO^L,w,x,fl,source,kappa)
      use mod_eos, only: eos
 
      integer, intent(in) :: ixI^L, ixO^L
      double precision, intent(in) :: x(ixI^S,1:ndim)
      double precision, intent(in) :: w(ixI^S,1:nw)
      type(te_fluid), intent(in) :: fl
      double precision, intent(out) :: source(ixI^S),kappa(ixI^S)
 
      integer :: ix^D
      double precision :: pth(ixI^S),Te(ixI^S),Ne(ixI^S)
      double precision :: nH_dummy(ixI^S),gff
 
      call fl%get_pthermal(w,x,ixi^l,ixo^l,pth)
      call fl%get_rho(w,x,ixi^l,ixo^l,ne)
      call fl%get_var_Rfactor(w,x,ixi^l,ixo^l,te)
      te(ixo^s)=pth(ixo^s)/(ne(ixo^s)*te(ixo^s))*unit_temperature
      call eos%get_ne_nH(ixi^l,ixo^l,w,ne,nh_dummy)
      if (si_unit) then
        ne(ixo^s)=ne(ixo^s)*unit_numberdensity/1.d6
      else
        ne(ixo^s)=ne(ixo^s)*unit_numberdensity
      endif
 
      source(ixi^s)=zero
      kappa(ixi^s)=zero
      {do ix^db=ixomin^db,ixomax^db\}
        if (te(ix^d)>zero .and. ne(ix^d)>zero) then
          if (te(ix^d)<2.d5) then
            gff=18.2d0+1.5d0*log(te(ix^d))-log(radio_frequency)
          else
            gff=24.5d0+log(te(ix^d))-log(radio_frequency)
          endif
          gff=max(one,gff)
          kappa(ix^d)=9.78d-3*ne(ix^d)**2*gff/(radio_frequency**2*te(ix^d)**1.5d0)
          source(ix^d)=te(ix^d)*kappa(ix^d)
        endif
      {enddo\}
    end subroutine get_radio_ff_source_opacity
 
    subroutine get_line_info(wl,ion,mass,logTe,line_center,spatial_px,spectral_px,sigma_PSF,width_slit)
      ! get information of the spectral line
      ! wl: wavelength
      ! mass: ion mass, unit -- proton mass
      ! logTe: peak temperature of emission line in logarithm
      ! line_center: center wavelength of emission line, unit -- Angstrom (0.1 nm) 
      ! spatial_px: pixel size in space of instrument (for image), unit -- arcsec
      ! spectral_px: pixel size in wagelength of instrument (for spectrum), unit -- Angstrom
      ! sigma_PSF: width of point spread function core (for instrument), unit -- pixel
      ! width_slit: width of slit for spectrograph, unit -- arcsec
      use mod_global_parameters
 
      integer, intent(in) :: wl
      integer, intent(out) :: mass
      character(len=30), intent(out) :: ion
      double precision, intent(out) :: logTe,line_center,spatial_px,spectral_px
      double precision, intent(out) :: sigma_PSF,width_slit
 
      select case(wl)
      case(304)
        ion='He II'
        mass=4
        logte=4.7d0
        line_center=303.8d0
        spatial_px=0.6d0
        spectral_px=0.02d0
        sigma_psf=0.895d0
        width_slit=0.6d0
      case(171)
        ion='Fe IX'
        mass=56
        logte=5.8d0
        line_center=171.1d0
        spatial_px=0.6d0
        spectral_px=0.02d0 
        sigma_psf=1.019d0
        width_slit=0.6d0
      case(193)
        ion='Fe XXIV'
        mass=56
        logte=7.3d0
        line_center=193.5d0
        spatial_px=0.6d0
        spectral_px=0.02d0
        sigma_psf=0.813d0
        width_slit=0.6d0
      case(211)
        ion='Fe XIV'
        mass=56
        logte=6.3d0
        line_center=211.3d0
        spatial_px=0.6d0
        spectral_px=0.02d0
        sigma_psf=0.913d0
        width_slit=0.6d0
      case(335)
        ion='Fe XVI'
        mass=56
        logte=6.4d0
        line_center=335.4d0
        spatial_px=0.6d0
        spectral_px=0.02d0
        sigma_psf=1.019d0
        width_slit=0.6d0
      case(94)
        ion='Fe XVIII'
        mass=56
        logte=6.8d0
        line_center=93.9d0
        spatial_px=0.6d0
        spectral_px=0.02d0
        sigma_psf=1.025d0
        width_slit=0.6d0
      case(131)
        ion='Fe XXI'
        mass=56
        logte=7.0d0
        line_center=131.0d0
        spatial_px=0.6d0
        spectral_px=0.02d0
        sigma_psf=0.984d0
        width_slit=0.6d0
      case(1354)
        ion='Fe XXI'
        mass=56
        logte=7.0d0
        line_center=1354.1d0
        spatial_px=0.1663d0
        spectral_px=12.98d-3
        sigma_psf=1.d0
        width_slit=0.33d0
      case(263)
        ion='Fe XVI'
        mass=56
        logte=6.4d0
        line_center=262.976d0
        spatial_px=1.d0
        spectral_px=22.d-3
        sigma_psf=1.d0
        width_slit=2.d0
      case(264)
        ion='Fe XXIII'
        mass=56
        logte=7.1d0
        line_center=263.765d0
        spatial_px=1.d0
        spectral_px=22.d-3
        sigma_psf=1.d0
        width_slit=2.d0
      case(192)
        ion='Fe XXIV'
        mass=56
        logte=7.2d0
        line_center=192.028d0
        spatial_px=1.d0
        spectral_px=22.d-3
        sigma_psf=1.d0
        width_slit=2.d0
      case(255)
        ion='Fe XXIV'
        mass=56
        logte=7.2d0
        line_center=255.113d0
        spatial_px=1.d0
        spectral_px=22.d-3
        sigma_psf=1.d0
        width_slit=2.d0
      case default
        call mpistop("No information about this line")
      end select
 
      spatial_px=spatial_px/instrument_resolution_factor
    end subroutine get_line_info
    
    subroutine get_euv(wl,ixI^L,ixO^L,w,x,fl,flux)
      ! calculate the local emission intensity of given EUV line (optically thin)
      ! wavelength is the wave length of the emission line
      ! unit [DN cm^-1 s^-1 pixel^-1]
      ! ingrate flux along line of sight: DN s^-1 pixel^-1
      use mod_global_parameters
      use mod_eos, only: eos
 
      integer, intent(in) :: wl
      integer, intent(in) :: ixI^L, ixO^L
      double precision, intent(in) :: x(ixI^S,1:ndim)
      double precision, intent(in) :: w(ixI^S,1:nw)
      type(te_fluid), intent(in) :: fl
      double precision, intent(out) :: flux(ixI^S)
 
      integer :: ix^D
      double precision :: pth(ixI^S),Te(ixI^S),Ne(ixI^S)
 
      call fl%get_pthermal(w,x,ixi^l,ixo^l,pth)
      call fl%get_rho(w,x,ixi^l,ixo^l,ne)
      call fl%get_var_Rfactor(w,x,ixi^l,ixo^l,te)
      te(ixo^s)=pth(ixo^s)/(ne(ixo^s)*te(ixo^s))*unit_temperature
      ! get actual electron density from EoS (replaces rho with ne)
      block
        double precision :: nH_dummy(ixI^S)
        call eos%get_ne_nH(ixi^l, ixo^l, w, ne, nh_dummy)
      end block
      if (si_unit) then
        ne(ixo^s)=ne(ixo^s)*unit_numberdensity/1.d6 ! m^-3 -> cm-3
        flux(ixo^s)=ne(ixo^s)**2
      else
        ne(ixo^s)=ne(ixo^s)*unit_numberdensity
        flux(ixo^s)=ne(ixo^s)**2
      endif
 
      select case(wl)
      case(94)
        call apply_temperature_response(ixi^l,ixo^l,te,flux,t_aia,f_94,n_aia,.true.,.true.)
      case(131)
        call apply_temperature_response(ixi^l,ixo^l,te,flux,t_aia,f_131,n_aia,.true.,.true.)
      case(171)
        call apply_temperature_response(ixi^l,ixo^l,te,flux,t_aia,f_171,n_aia,.true.,.true.)
      case(193)
        call apply_temperature_response(ixi^l,ixo^l,te,flux,t_aia,f_193,n_aia,.true.,.true.)
      case(211)
        call apply_temperature_response(ixi^l,ixo^l,te,flux,t_aia,f_211,n_aia,.true.,.true.)
      case(304)
        call apply_temperature_response(ixi^l,ixo^l,te,flux,t_aia,f_304,n_aia,.true.,.true.)
      case(335)
        call apply_temperature_response(ixi^l,ixo^l,te,flux,t_aia,f_335,n_aia,.true.,.true.)
      case(1354)
        call apply_temperature_response(ixi^l,ixo^l,te,flux,t_iris,f_1354,n_iris,.true.,.true.)
      case(263)
        call apply_temperature_response(ixi^l,ixo^l,te,flux,t_eis1,f_263,n_eis,.false.,.false.)
      case(264)
        call apply_temperature_response(ixi^l,ixo^l,te,flux,t_eis2,f_264,n_eis,.false.,.false.)
      case(192)
        call apply_temperature_response(ixi^l,ixo^l,te,flux,t_eis2,f_192,n_eis,.false.,.false.)
      case(255)
        call apply_temperature_response(ixi^l,ixo^l,te,flux,t_eis2,f_255,n_eis,.false.,.false.)
      case default
        call mpistop("Unknown wavelength")
      end select
    end subroutine get_euv
 
    subroutine get_sxr(ixI^L,ixO^L,w,x,fl,flux,El,Eu)
      !synthesize thermal SXR from El keV to Eu keV released by cm^-3/m^-3
      ! volume of plasma in 1 s
      !flux (cgs): photons cm^-3 s^-1
      !flux (SI): photons m^-3 s^-1
      use mod_global_parameters
      use mod_eos, only: eos
 
      integer, intent(in)           :: ixI^L,ixO^L
      integer, intent(in)           :: El,Eu
      double precision, intent(in)  :: x(ixI^S,1:ndim)
      double precision, intent(in)  :: w(ixI^S,nw)
      type(te_fluid), intent(in) :: fl
      double precision, intent(out) :: flux(ixI^S)
 
      integer :: ix^D,ixO^D
      integer :: iE,numE
      double precision :: I0,kb,keV,dE,Ei
      double precision :: pth(ixI^S),Te(ixI^S),kbT(ixI^S)
      double precision :: Ne(ixI^S),gff(ixI^S),fi(ixI^S)
      double precision :: EM(ixI^S)
 
      i0=3.01d-15   ! I0*4*pi*AU**2, I0 from Pinto (2015)
      kb=const_kb
      kev=1.0d3*const_ev
      de=0.1
      nume=floor((eu-el)/de)
      call fl%get_pthermal(w,x,ixi^l,ixo^l,pth)
      call fl%get_rho(w,x,ixi^l,ixo^l,ne)
      call fl%get_var_Rfactor(w,x,ixi^l,ixo^l,te)
      te(ixo^s)=pth(ixo^s)/(ne(ixo^s)*te(ixo^s))*unit_temperature
      ! get actual electron density from EoS (replaces rho with ne)
      block
        double precision :: nH_dummy(ixI^S)
        call eos%get_ne_nH(ixi^l, ixo^l, w, ne, nh_dummy)
      end block
      if (si_unit) then
        ne(ixo^s)=ne(ixo^s)*unit_numberdensity/1.d6 ! m^-3 -> cm-3
        em(ixo^s)=(ne(ixo^s))**2*1.d6 ! cm^-3 m^-3
      else
        ne(ixo^s)=ne(ixo^s)*unit_numberdensity
        em(ixo^s)=(ne(ixo^s))**2
      endif
      kbt(ixo^s)=kb*te(ixo^s)/kev
      flux(ixo^s)=0.0d0
      do ie=0,nume-1
        ei=de*ie+el*1.d0
        gff(ixo^s)=1.d0
        {do ix^db=ixomin^db,ixomax^db\}
          if (kbt(ix^d)>0.01*ei) then
            if(kbt(ix^d)<ei) gff(ix^d)=(kbt(ix^d)/ei)**0.4
            fi(ix^d)=(em(ix^d)*gff(ix^d))*exp_clamped(-ei/(kbt(ix^d)))/(ei*dsqrt(kbt(ix^d)))
          else
            fi(ix^d)=zero
          endif
        {enddo\}
        flux(ixo^s)=flux(ixo^s)+fi(ixo^s)*de
      enddo
      flux(ixo^s)=flux(ixo^s)*i0
    end subroutine get_sxr
 
    subroutine get_goes_sxr_flux(xbox^L,fl,eflux)
      !get GOES SXR 1-8A flux observing at 1AU from given box [w/m^2]
      use mod_global_parameters
 
      double precision, intent(in) :: xbox^L
      type(te_fluid), intent(in) :: fl
      double precision, intent(out) :: eflux
 
      double precision :: dxb^D,xb^L
      integer :: iigrid,igrid,j
      integer :: ixO^L,ixI^L,ix^D
      double precision :: eflux_grid,eflux_pe
 
      ^d&iximin^d=ixglo^d;
      ^d&iximax^d=ixghi^d;
      ^d&ixomin^d=ixmlo^d;
      ^d&ixomax^d=ixmhi^d;
      eflux_pe=zero
      do iigrid=1,igridstail; igrid=igrids(iigrid);
        ^d&dxlevel(^d)=rnode(rpdx^d_,igrid);
        ^d&xbmin^d=rnode(rpxmin^d_,igrid);
        ^d&xbmax^d=rnode(rpxmax^d_,igrid);
        call get_goes_flux_grid(ixi^l,ixo^l,ps(igrid)%w,ps(igrid)%x,ps(igrid)%dvolume(ixi^s),xbox^l,xb^l,fl,eflux_grid)
        eflux_pe=eflux_pe+eflux_grid
      enddo
      call mpi_allreduce(eflux_pe,eflux,1,mpi_double_precision,mpi_sum,icomm,ierrmpi)
    end subroutine get_goes_sxr_flux
 
    subroutine get_goes_flux_grid(ixI^L,ixO^L,w,x,dV,xbox^L,xb^L,fl,eflux_grid)
      use mod_global_parameters
      use mod_eos, only: eos
 
      integer, intent(in)           :: ixI^L,ixO^L
      double precision, intent(in)  :: x(ixI^S,1:ndim),dV(ixI^S)
      double precision, intent(in)  :: w(ixI^S,nw)
      double precision, intent(in)  :: xbox^L,xb^L
      type(te_fluid), intent(in) :: fl
      double precision, intent(out) :: eflux_grid
 
      integer :: ix^D,ixO^D,ixb^L
      integer :: iE,numE,j,inbox
      double precision :: I0,kb,keV,dE,Ei,El,Eu,A_cgs
      double precision :: pth(ixI^S),Te(ixI^S),kbT(ixI^S)
      double precision :: Ne(ixI^S),EM(ixI^S)
      double precision :: gff,fi,erg_SI
 
      ! check whether the grid is inside given box
      inbox=0
      {if (xbmin^d<xboxmax^d .and. xbmax^d>xboxmin^d) inbox=inbox+1\}
 
      if (inbox==ndim) then
        ! indexes for cells inside given box
        ^d&ixbmin^d=ixomin^d;
        ^d&ixbmax^d=ixomax^d;
        {if (xbmax^d>xboxmax^d) ixbmax^d=ixomax^d-ceiling((xbmax^d-xboxmax^d)/dxlevel(^d))\}
        {if (xbmin^d<xboxmin^d) ixbmin^d=ceiling((xboxmin^d-xbmin^d)/dxlevel(^d))+ixomin^d\}
 
        i0=1.07d-38 ! photon flux index for observed at 1AU [photon cm^3 m^-2 s^-1 keV^-1]
        kb=const_kb
        kev=1.0d3*const_ev
        erg_si=1.d-7
        a_cgs=1.d-8 ! Angstrom
        el=const_h*const_c/(8.d0*a_cgs)/kev ! 8 A
        eu=const_h*const_c/(1.d0*a_cgs)/kev ! 1 A
        de=0.1  ! keV
        nume=floor((eu-el)/de)
        call fl%get_pthermal(w,x,ixi^l,ixb^l,pth)
        call fl%get_rho(w,x,ixi^l,ixb^l,ne)
        call fl%get_var_Rfactor(w,x,ixi^l,ixb^l,te)
        te(ixb^s)=pth(ixb^s)/(ne(ixb^s)*te(ixb^s))*unit_temperature
        ! get actual electron density from EoS (replaces rho with ne)
        block
          double precision :: nH_dummy(ixI^S)
          call eos%get_ne_nH(ixi^l, ixb^l, w, ne, nh_dummy)
        end block
        if (si_unit) then
          ne(ixo^s)=ne(ixo^s)*unit_numberdensity/1.d6 ! m^-3 -> cm-3
          em(ixb^s)=(i0*(ne(ixb^s))**2)*dv(ixb^s)*(unit_length*1.d2)**3 ! cm^-3
        else
          ne(ixo^s)=ne(ixo^s)*unit_numberdensity
          em(ixb^s)=(i0*(ne(ixb^s))**2)*dv(ixb^s)*unit_length**3
        endif
        kbt(ixb^s)=kb*te(ixb^s)/kev
        eflux_grid=0.0d0
 
        do ie=0,nume-1
          ei=de*ie+el
          {do ix^db=ixbmin^db,ixbmax^db\}
            if (kbt(ix^d)>1.d-2*ei) then
              if(kbt(ix^d)<ei) then
                gff=(kbt(ix^d)/ei)**0.4
              else
                gff=1.d0
              endif
              fi=(em(ix^d)*gff)*exp_clamped(-ei/(kbt(ix^d)))/(ei*dsqrt(kbt(ix^d)))
              eflux_grid=eflux_grid+fi*de*ei
            endif
          {enddo\}
        enddo
        eflux_grid=eflux_grid*kev*erg_si
      endif
 
    end subroutine get_goes_flux_grid
 
  {^ifthreed
    subroutine get_euv_spectrum(qunit,fl)
      use mod_global_parameters
 
      integer, intent(in) :: qunit
      type(te_fluid), intent(in) :: fl
      character(20) :: datatype
 
      integer :: mass
      character (30) :: ion
      double precision :: logTe,lineCent,sigma_PSF,spaceRsl,wlRsl,wslit
      double precision :: xslit,arcsec
 
      datatype='spectrum_euv'
      call check_synthetic_emission_options(datatype)
      arcsec=7.25d7/unit_length
      call get_line_info(spectrum_wl,ion,mass,logte,linecent,spacersl,wlrsl,sigma_psf,wslit)
 
      if (mype==0) print *, '###################################################'
      select case(spectrum_wl)
      case (1354)
        if (mype==0) print *, 'Systhesizing EUV spectrum (observed by IRIS).'
      case (263,264,192,255)
        if (mype==0) print *, 'Systhesizing EUV spectrum (observed by Hinode/EIS).'
      case default
        call mpistop('Wrong wavelength!')
      end select
 
      if (spectrum_window_max<=spectrum_window_min) then
        call mpistop('Wrong spectrum window!')
      endif
 
      if (mype==0) write(*,'(a,f8.3,a)') ' Wavelength: ',linecent,' Angstrom'
      if (mype==0) print *, 'Unit of EUV flux: DN s^-1 pixel^-1'
 
      if (dat_resolution) then
        if (mype==0) then
          write(*,'(a,f5.3,a,f5.1,a)') ' Supposed pixel: ',wlrsl,' Angstrom x ',spacersl*725.0, ' km'
          print *, 'Unit of wavelength: Angstrom (0.1 nm) '
          if (si_unit) then
            write(*,'(a,f8.1,a)') ' Unit of length: ',unit_length/1.d6,' Mm'
          else
            write(*,'(a,f8.1,a)') ' Unit of length: ',unit_length/1.d8,' Mm'
          endif
          write(*,'(a,f8.1,a)') ' Supposed width of slit: ',wslit*725.0,' km'
        endif
        call get_spectrum_datresol(qunit,datatype,fl)
      else
        if (mype==0) then
          print *, 'Unit of wavelength: Angstrom (0.1 nm) '
          if (activate_unit_arcsec) then
            write(*,'(a,f5.3,a,f5.1,a)') ' Pixel: ',wlrsl,' Angstrom x ',spacersl*725.0, ' km'
            print *, 'Unit of length: arcsec (~725 km)'
            write(*,'(a,f8.1,a)') ' Location of slit: xI1 = ',location_slit,' arcsec'
            write(*,'(a,f8.1,a)') ' Width of slit: ',wslit,' arcsec'
          else
            if (si_unit) then
              if (mype==0) write(*,'(a,f8.1,a)') ' Unit of length: ',unit_length/1.d6,' Mm'
            else
              if (mype==0) write(*,'(a,f8.1,a)') ' Unit of length: ',unit_length/1.d8,' Mm'
            endif
            write(*,'(a,f8.1,a)') ' Location of slit: xI1 = ',location_slit,' Unit_length'
            write(*,'(a,f8.1,a)') ' Width of slit: ',wslit*725.d0,' km'
          endif
        endif
        if (mype==0) print *, 'Direction of the slit: parallel to xI2 vector'
        if (coordinate==cartesian .or. coordinate==spherical) then
          call get_spectrum(qunit,datatype,fl)
        else
          call mpistop("EUV spectrum synthesis: support for sperical coordinates is to be added!")
        endif
      endif
 
      if (mype==0) print *, '###################################################'
 
    end subroutine get_euv_spectrum
 
    subroutine get_spectrum_datresol(qunit,datatype,fl)
 
      integer, intent(in) :: qunit
      character(20), intent(in) :: datatype
      type(te_fluid), intent(in) :: fl
 
      integer :: numWL,numXS,iwL,ixS,numWI,numS
      double precision :: dwLg,xSmin,xSmax,wLmin,wLmax
      double precision, allocatable :: wL(:),xS(:),dwL(:),dxS(:)
      double precision, allocatable :: wI(:,:,:),spectra(:,:),spectra_rc(:,:)
      integer :: strtype,nstrb,nbb,nuni,nstr,bnx
      double precision :: qs,dxfirst,dxmid,lenstr
 
      integer :: iigrid,igrid,j,dir_loc
      double precision :: xbmin(1:ndim),xbmax(1:ndim)
 
      dwlg=1.d-3
      numwl=4*int((spectrum_window_max-spectrum_window_min)/(4.d0*dwlg))
      wlmin=(spectrum_window_max+spectrum_window_min)/2.d0-dwlg*numwl/2
      wlmax=(spectrum_window_max+spectrum_window_min)/2.d0+dwlg*numwl/2
      allocate(wl(numwl),dwl(numwl))
      dwl(:)=dwlg
      do iwl=1,numwl
        wl(iwl)=wlmin+iwl*dwlg-half*dwlg
      enddo
 
      select case(direction_slit)
      case (1)
        numxs=domain_nx1*2**(refine_max_level-1)
        xsmin=xprobmin1
        xsmax=xprobmax1
        bnx=block_nx1
        nbb=domain_nx1
        strtype=stretch_type(1)
        nstrb=nstretchedblocks_baselevel(1)
        qs=qstretch_baselevel(1)
        if (mype==0) print *, 'Direction of the slit: x'
      case (2)
        numxs=domain_nx2*2**(refine_max_level-1)
        xsmin=xprobmin2
        xsmax=xprobmax2
        bnx=block_nx2
        nbb=domain_nx2
        strtype=stretch_type(2)
        nstrb=nstretchedblocks_baselevel(2)
        qs=qstretch_baselevel(2)
        if (mype==0) print *, 'Direction of the slit: y'
      case (3)
        numxs=domain_nx3*2**(refine_max_level-1)
        xsmin=xprobmin3
        xsmax=xprobmax3
        bnx=block_nx3
        nbb=domain_nx3
        strtype=stretch_type(3)
        nstrb=nstretchedblocks_baselevel(3)
        qs=qstretch_baselevel(3)
        if (mype==0) print *, 'Direction of the slit: z'
      case default
        call mpistop('Wrong direction_slit')
      end select
 
      allocate(xs(numxs),dxs(numxs),spectra(numwl,numxs),spectra_rc(numwl,numxs))
      numwi=1
      allocate(wi(numwl,numxs,numwi))
 
      select case(strtype)
      case(0) ! uniform
        dxs(:)=(xsmax-xsmin)/numxs
        do ixs=1,numxs
          xs(ixs)=xsmin+dxs(ixs)*(ixs-half)
        enddo
      case(1) ! uni stretch
        qs=qs**(one/2**(refine_max_level-1))
        dxfirst=(xsmax-xsmin)*(one-qs)/(one-qs**numxs)
        dxs(1)=dxfirst
        do ixs=2,numxs
          dxs(ixs)=dxfirst*qs**(ixs-1)
          xs(ixs)=dxs(1)/(one-qs)*(one-qs**(ixs-1))+half*dxs(ixs)
        enddo
      case(2) ! symm stretch
        ! base level, nbb = nstr + nuni + nstr
        nstr=nstrb*bnx/2
        nuni=nbb-nstrb*bnx
        lenstr=(xsmax-xsmin)/(2.d0+nuni*(one-qs)/(one-qs**nstr))
        dxfirst=(xsmax-xsmin)/(dble(nuni)+2.d0/(one-qs)*(one-qs**nstr))
        dxmid=dxfirst
        ! refine_max level, numXI = nstr + nuni + nstr
        nstr=nstr*2**(refine_max_level-1)
        nuni=nuni*2**(refine_max_level-1)
        qs=qs**(one/2**(refine_max_level-1))
        dxfirst=lenstr*(one-qs)/(one-qs**nstr)
        dxmid=dxmid/2**(refine_max_level-1)
        ! uniform center
        if(nuni .gt. 0) then
          do ixs=nstr+1,nstr+nuni
            dxs(ixs)=dxmid
            xs(ixs)=lenstr+(dble(ixs)-0.5d0-nstr)*dxs(ixs)+xsmin
          enddo
        endif
        ! left half
        do ixs=nstr,1,-1
          dxs(ixs)=dxfirst*qs**(nstr-ixs)
          xs(ixs)=xsmin+lenstr-dxs(ixs)*half-dxfirst*(one-qs**(nstr-ixs))/(one-qs)
        enddo
        ! right half
        do ixs=nstr+nuni+1,numxs
          dxs(ixs)=dxfirst*qs**(ixs-nstr-nuni-1)
          xs(ixs)=xsmax-lenstr+dxs(ixs)*half+dxfirst*(one-qs**(ixs-nstr-nuni-1))/(one-qs)
        enddo
      case default
        call mpistop("unknown stretch type")
      end select
 
      if (los_phi==0 .and. los_theta==90 .and. direction_slit==2) then
      ! LOS->x slit->y
        dir_loc=3
      else if (los_phi==0 .and. los_theta==90 .and. direction_slit==3) then
      ! LOS->x slit->z
        dir_loc=2
      else if (los_phi==90 .and. los_theta==90 .and. direction_slit==1) then
      ! LOS->y slit->x
        dir_loc=3
      else if (los_phi==90 .and. los_theta==90 .and. direction_slit==3) then
      ! LOS->y slit->z
        dir_loc=1
      else if (los_theta==0 .and. direction_slit==1) then
      ! LOS->z slit->x
        dir_loc=2
      else if (los_theta==0 .and. direction_slit==2) then
      ! LOS->z slit->y
        dir_loc=1
      else
        call mpistop('Wrong combination of LOS and slit direction!')
      endif
 
      if (dir_loc==1) then
        if (location_slit>xprobmax1 .or. location_slit<xprobmin1) then
          call mpistop('Wrong value for location_slit!')
        endif
        if(mype==0) write(*,'(a,f8.1,a)') ' Location of slit: x = ',location_slit,' Unit_length'
      else if (dir_loc==2) then
        if (location_slit>xprobmax2 .or. location_slit<xprobmin2) then
          call mpistop('Wrong value for location_slit!')
        endif
        if(mype==0) write(*,'(a,f8.1,a)') ' Location of slit: y = ',location_slit,' Unit_length'
      else
        if (location_slit>xprobmax3 .or. location_slit<xprobmin3) then
          call mpistop('Wrong value for location_slit!')
        endif
        if(mype==0) write(*,'(a,f8.1,a)') ' Location of slit: z = ',location_slit,' Unit_length'
      endif
 
      ! find slit and do integration
      spectra=zero
      do iigrid=1,igridstail; igrid=igrids(iigrid);
        ^d&xbmin(^d)=rnode(rpxmin^d_,igrid);
        ^d&xbmax(^d)=rnode(rpxmax^d_,igrid);
        if (location_slit>=xbmin(dir_loc) .and. location_slit<xbmax(dir_loc)) then
          call integrate_spectra_datresol(igrid,wl,dwl,spectra,numwl,numxs,dir_loc,fl)
        endif
      enddo
 
      nums=numwl*numxs
      call mpi_allreduce(spectra,spectra_rc,nums,mpi_double_precision, &
                         mpi_sum,icomm,ierrmpi)
      do iwl=1,numwl
        do ixs=1,numxs
          if (spectra_rc(iwl,ixs)>smalldouble) then
            wi(iwl,ixs,1)=spectra_rc(iwl,ixs)
          else
            wi(iwl,ixs,1)=zero
          endif
        enddo
      enddo
 
      call output_data(qunit,wl,xs,dwl,dxs,wi,numwl,numxs,numwi,datatype)
 
      deallocate(wl,xs,dwl,dxs,spectra,spectra_rc,wi)
 
    end subroutine get_spectrum_datresol
 
    subroutine integrate_spectra_datresol(igrid,wL,dwL,spectra,numWL,numXS,dir_loc,fl)
      use mod_constants
 
      integer, intent(in) :: igrid,numWL,numXS,dir_loc
      type(te_fluid), intent(in) :: fl
      double precision, intent(in) :: wL(numWL),dwL(numWL)
      double precision, intent(inout) :: spectra(numWL,numXS)
 
      integer :: direction_LOS
      integer :: ixO^L,ixI^L,ix^D,ixOnew
      double precision, allocatable :: flux(:^D&),v(:^D&),pth(:^D&),Te(:^D&),rho(:^D&)
      double precision :: wlc,wlwd
 
      integer :: mass
      double precision :: logTe,lineCent
      character (30) :: ion
      double precision :: spaceRsl,wlRsl,sigma_PSF,wslit
 
      integer :: levelg,rft,ixSmin,ixSmax,iwL
      double precision :: flux_pix,dL
 
      call get_line_info(spectrum_wl,ion,mass,logte,linecent,spacersl,wlrsl,sigma_psf,wslit)
 
      if (los_phi==0 .and. los_theta==90) then
        direction_los=1
      else if (los_phi==90 .and. los_theta==90) then
        direction_los=2
      else
        direction_los=3
      endif
 
      ^d&ixomin^d=ixmlo^d\
      ^d&ixomax^d=ixmhi^d\
      ^d&iximin^d=ixglo^d\
      ^d&iximax^d=ixghi^d\
      allocate(flux(ixi^s),v(ixi^s),pth(ixi^s),te(ixi^s),rho(ixi^s))
 
      ^d&ix^d=ixomin^d;
      if (dir_loc==1) then
        do ix1=ixomin1,ixomax1
          if (location_slit>=(ps(igrid)%x(ix^d,1)-half*ps(igrid)%dx(ix^d,1)) .and. &
              location_slit<(ps(igrid)%x(ix^d,1)+half*ps(igrid)%dx(ix^d,1))) then
            ixonew=ix1
          endif
        enddo
        ixomin1=ixonew
        ixomax1=ixonew
      else if (dir_loc==2) then
        do ix2=ixomin2,ixomax2
          if (location_slit>=(ps(igrid)%x(ix^d,2)-half*ps(igrid)%dx(ix^d,2)) .and. &
              location_slit<(ps(igrid)%x(ix^d,2)+half*ps(igrid)%dx(ix^d,2))) then
            ixonew=ix2
          endif
        enddo
        ixomin2=ixonew
        ixomax2=ixonew
      else
        do ix3=ixomin3,ixomax3
          if (location_slit>=(ps(igrid)%x(ix^d,3)-half*ps(igrid)%dx(ix^d,3)) .and. &
              location_slit<(ps(igrid)%x(ix^d,3)+half*ps(igrid)%dx(ix^d,3))) then
            ixonew=ix3
          endif
        enddo
        ixomin3=ixonew
        ixomax3=ixonew
      endif
 
      call get_euv(spectrum_wl,ixi^l,ixo^l,ps(igrid)%w,ps(igrid)%x,fl,flux)
      flux(ixo^s)=flux(ixo^s)/instrument_resolution_factor**2   ! adjust flux due to artifical change of resolution
      call fl%get_rho(ps(igrid)%w,ps(igrid)%x,ixi^l,ixo^l,rho)
      v(ixo^s)=-ps(igrid)%w(ixo^s,iw_mom(direction_los))/rho(ixo^s)
      call fl%get_pthermal(ps(igrid)%w,ps(igrid)%x,ixi^l,ixo^l,pth)
      call fl%get_var_Rfactor(ps(igrid)%w,ps(igrid)%x,ixi^l,ixo^l,te)
      te(ixo^s)=pth(ixo^s)/(te(ixo^s)*rho(ixo^s))
 
      ! grid parameters
      levelg=ps(igrid)%level
      rft=2**(refine_max_level-levelg)
 
      {do ix^d=ixomin^d,ixomax^d\}
        if (flux(ix^d)>smalldouble) then
          if (si_unit) then
            wlc=linecent*(1.d0+v(ix^d)*unit_velocity*1.d2/const_c)
          else
            wlc=linecent*(1.d0+v(ix^d)*unit_velocity/const_c)
          endif
          wlwd=sqrt(kb_cgs*te(ix^d)*unit_temperature/(mass*mp_cgs))
          wlwd=wlwd*linecent/const_c
          ! involved pixel
          select case(direction_slit)
          case(1)
            ixsmin=(block_nx1*(node(pig1_,igrid)-1)+(ix1-ixomin1))*rft+1
            ixsmax=(block_nx1*(node(pig1_,igrid)-1)+(ix1-ixomin1+1))*rft
          case(2)
            ixsmin=(block_nx2*(node(pig2_,igrid)-1)+(ix2-ixomin2))*rft+1
            ixsmax=(block_nx2*(node(pig2_,igrid)-1)+(ix2-ixomin2+1))*rft
          case(3)
            ixsmin=(block_nx3*(node(pig3_,igrid)-1)+(ix3-ixomin3))*rft+1
            ixsmax=(block_nx3*(node(pig3_,igrid)-1)+(ix3-ixomin3+1))*rft
          end select
          ! LOS depth
          select case(direction_los)
          case(1)
            dl=ps(igrid)%dx(ix^d,1)*unit_length
          case(2)
            dl=ps(igrid)%dx(ix^d,2)*unit_length
          case default
            dl=ps(igrid)%dx(ix^d,3)*unit_length
          end select
          if (si_unit) dl=dl*1.d2
          ! integral pixel flux
          do iwl=1,numwl
            flux_pix=flux(ix^d)*wlrsl*dl*exp_clamped(-(wl(iwl)-wlc)**2/(2*wlwd**2))/(sqrt(2*dpi)*wlwd)
            if (flux_pix>smalldouble) then
              flux_pix=flux_pix*wslit/spacersl
              spectra(iwl,ixsmin:ixsmax)=spectra(iwl,ixsmin:ixsmax)+flux_pix
            endif
          enddo
        endif
      {enddo\}
 
      deallocate(flux,v,pth,te,rho)
 
    end subroutine integrate_spectra_datresol
 
    subroutine get_spectrum(qunit,datatype,fl)
 
      integer, intent(in) :: qunit
      character(20), intent(in) :: datatype
      type(te_fluid), intent(in) :: fl
 
      integer :: numWL,numXS,iwL,ixS,numWI,ix^D
      double precision :: dwLg,dxSg,xSmin,xSmax,xScent,wLmin,wLmax
      double precision, allocatable :: wL(:),xS(:),dwL(:),dxS(:)
      double precision, allocatable :: wI(:,:,:),spectra(:,:),spectra_rc(:,:)
      double precision :: vec_cor(1:3),xI_cor(1:2)
      double precision :: res,r_loc,r_max
 
      integer :: mass
      character (30) :: ion
      double precision :: logTe,lineCent,sigma_PSF,spaceRsl,wlRsl,wslit
      double precision :: unitv,arcsec,RHESSI_rsl,pixel
      integer :: iigrid,igrid,i,j,numS
      double precision :: xLmin,xLmax,xslit
 
      if (coordinate==spherical) then
        call init_vectors_spherical()
      else
        ! cartesian
        call init_vectors_cartesian()
      endif
 
      ! calculate domain in space
      if (coordinate==spherical) then
        xsmin=-abs(xprobmax1)
        xsmax=abs(xprobmax1)
      else
        do ix1=1,2
          if (ix1==1) vec_cor(1)=xprobmin1
          if (ix1==2) vec_cor(1)=xprobmax1
          do ix2=1,2
            if (ix2==1) vec_cor(2)=xprobmin2
            if (ix2==2) vec_cor(2)=xprobmax2
            do ix3=1,2
              if (ix3==1) vec_cor(3)=xprobmin3
              if (ix3==2) vec_cor(3)=xprobmax3
              if (big_image) then
                r_loc=(vec_cor(1)-x_origin(1))**2
                r_loc=r_loc+(vec_cor(2)-x_origin(2))**2
                r_loc=r_loc+(vec_cor(3)-x_origin(3))**2
                r_loc=sqrt(r_loc)
                if (ix1==1 .and. ix2==1 .and. ix3==1) then
                  r_max=r_loc
                else
                  r_max=max(r_max,r_loc)
                endif
              else
                call get_cor_image(vec_cor,xi_cor)
                if (ix1==1 .and. ix2==1 .and. ix3==1) then
                  xsmin=xi_cor(2)
                  xsmax=xi_cor(2)
                else
                  xsmin=min(xsmin,xi_cor(2))
                  xsmax=max(xsmax,xi_cor(2))
                endif
              endif
            enddo
          enddo
        enddo
        if (big_image) then
          xsmin=-r_max
          xsmax=r_max
        endif
      endif
      xscent=(xsmin+xsmax)/2.d0
 
      ! tables for storing spectra data
      if (si_unit) then
        arcsec=7.25d5/unit_length
      else
        arcsec=7.25d7/unit_length
      endif
      call get_line_info(spectrum_wl,ion,mass,logte,linecent,spacersl,wlrsl,sigma_psf,wslit)
      dxsg=spacersl*arcsec
      numxs=ceiling((xsmax-xscent)/dxsg)
      xsmin=xscent-numxs*dxsg
      xsmax=xscent+numxs*dxsg
      numxs=numxs*2
      dwlg=wlrsl
      numwl=2*int((spectrum_window_max-spectrum_window_min)/(2.d0*dwlg))
      wlmin=(spectrum_window_max+spectrum_window_min)/2.d0-dwlg*numwl/2
      wlmax=(spectrum_window_max+spectrum_window_min)/2.d0+dwlg*numwl/2
      allocate(wl(numwl),dwl(numwl),xs(numxs),dxs(numxs))
      numwi=1
      allocate(wi(numwl,numxs,numwi),spectra(numwl,numxs),spectra_rc(numwl,numxs))
      do iwl=1,numwl
        wl(iwl)=wlmin+iwl*dwlg-half*dwlg
        dwl=dwlg
      enddo
      do ixs=1,numxs
        xs(ixs)=xsmin+dxsg*(ixs-half)
        dxs(ixs)=dxsg
      enddo
 
      ! find slit and do integration
      spectra=zero
      do iigrid=1,igridstail; igrid=igrids(iigrid);
        do ix1=1,2
          if (ix1==1) vec_cor(1)=rnode(rpxmin1_,igrid)
          if (ix1==2) vec_cor(1)=rnode(rpxmax1_,igrid)
          do ix2=1,2
            if (ix2==1) vec_cor(2)=rnode(rpxmin2_,igrid)
            if (ix2==2) vec_cor(2)=rnode(rpxmax2_,igrid)
            do ix3=1,2
              if (ix3==1) vec_cor(3)=rnode(rpxmin3_,igrid)
              if (ix3==2) vec_cor(3)=rnode(rpxmax3_,igrid)
              call get_cor_image(vec_cor,xi_cor)
              if (ix1==1 .and. ix2==1 .and. ix3==1) then
                xlmin=xi_cor(1)
                xlmax=xi_cor(1)
              else
                xlmin=min(xlmin,xi_cor(1))
                xlmax=max(xlmax,xi_cor(1))
              endif
            enddo
          enddo
        enddo
 
        if (activate_unit_arcsec) then 
          xslit=location_slit*arcsec
        else
          xslit=location_slit
        endif
        if (xslit>=xlmin-wslit*arcsec .and. xslit<=xlmax+wslit*arcsec) then
          call integrate_spectra_cartesian(igrid,wl,dwlg,xs,dxsg,spectra,numwl,numxs,fl)
        endif
      enddo
 
      nums=numwl*numxs
      call mpi_allreduce(spectra,spectra_rc,nums,mpi_double_precision, &
                         mpi_sum,icomm,ierrmpi)
      do iwl=1,numwl
        do ixs=1,numxs
          if (spectra_rc(iwl,ixs)>smalldouble) then
            wi(iwl,ixs,1)=spectra_rc(iwl,ixs)
          else
            wi(iwl,ixs,1)=zero
          endif
        enddo
      enddo
 
      if (activate_unit_arcsec) then 
        xs=xs/arcsec
        dxs=dxs/arcsec
      endif
 
      call output_data(qunit,wl,xs,dwl,dxs,wi,numwl,numxs,numwi,datatype)
 
      deallocate(wl,xs,dwl,dxs,spectra,spectra_rc,wi)
 
    end subroutine get_spectrum
 
    subroutine integrate_spectra_cartesian(igrid,wL,dwLg,xS,dxSg,spectra,numWL,numXS,fl)
 
      integer, intent(in) :: igrid,numWL,numXS
      double precision, intent(in) :: wL(numWL),xS(numXS)
      double precision, intent(in) :: dwLg,dxSg
      double precision, intent(inout) :: spectra(numWL,numXS)
      type(te_fluid), intent(in) :: fl
 
      integer :: ixO^L,ixI^L,ix^D,ixOnew,j
      double precision, allocatable :: flux(:^D&),v(:^D&),pth(:^D&),Te(:^D&),rho(:^D&)
      double precision :: wlc,wlwd,res,dst_slit,xslit,arcsec
      double precision :: vloc(1:3),xloc(1:3),dxloc(1:3),xIloc(1:2),dxIloc(1:2)
      integer :: nSubC^D,iSubC^D,iwL,ixS,ixSmin,ixSmax,iwLmin,iwLmax,nwL
      double precision :: slit_width,dxSubC^D,xerf^L,fluxSubC
      double precision :: xSubC(1:3),xCent(1:2)
 
      integer :: mass
      double precision :: logTe,lineCent
      character (30) :: ion
      double precision :: spaceRsl,wlRsl,sigma_PSF,wslit
      double precision :: sigma_wl,sigma_xs,factor
 
      if (si_unit) then
        arcsec=7.25d5/unit_length
      else
        arcsec=7.25d7/unit_length
      endif
      if (activate_unit_arcsec) then 
        xslit=location_slit*arcsec
      else
        xslit=location_slit
      endif
 
      call get_line_info(spectrum_wl,ion,mass,logte,linecent,spacersl,wlrsl,sigma_psf,wslit)
 
      ^d&ixomin^d=ixmlo^d\
      ^d&ixomax^d=ixmhi^d\
      ^d&iximin^d=ixglo^d\
      ^d&iximax^d=ixghi^d\
      allocate(flux(ixi^s),v(ixi^s),pth(ixi^s),te(ixi^s),rho(ixi^s))
      ! get local EUV flux and velocity
      call get_euv(spectrum_wl,ixi^l,ixo^l,ps(igrid)%w,ps(igrid)%x,fl,flux)
      flux(ixo^s)=flux(ixo^s)/instrument_resolution_factor**2   ! adjust flux due to artifical change of resolution
      call fl%get_pthermal(ps(igrid)%w,ps(igrid)%x,ixi^l,ixo^l,pth)
      call fl%get_rho(ps(igrid)%w,ps(igrid)%x,ixi^l,ixo^l,rho)
      call fl%get_var_Rfactor(ps(igrid)%w,ps(igrid)%x,ixi^l,ixo^l,te)
      te(ixo^s)=pth(ixo^s)/(te(ixo^s)*rho(ixo^s))
      {do ix^d=ixomin^d,ixomax^d\}
        do j=1,3
          vloc(j)=ps(igrid)%w(ix^d,iw_mom(j))/rho(ix^d)
        enddo
        call dot_product_loc(vloc,vec_los,res)
        v(ix^d)=res
      {enddo\}
 
      deallocate(rho)
 
      slit_width=wslit*arcsec
      sigma_wl=sigma_psf*dwlg
      sigma_xs=sigma_psf*dxsg
      {do ix^d=ixomin^d,ixomax^d\}
        if (flux(ix^d)>smalldouble) then
          xloc(1:3)=ps(igrid)%x(ix^d,1:3)
          dxloc(1:3)=ps(igrid)%dx(ix^d,1:3)
          call get_cor_image(xloc,xiloc)
          call dot_product_loc(dxloc,vec_xi1,res)
          dxiloc(1)=abs(res)
          if (xiloc(1)>=xslit-half*(slit_width+dxiloc(1)) .and. & 
              xiloc(1)<=xslit+half*(slit_width+dxiloc(1))) then
            ^d&nsubc^d=1;
            ^d&nsubc^d=max(nsubc^d,ceiling(ps(igrid)%dx(ix^dd,^d)*abs(vec_xi1(^d))/(slit_width/16.d0)));
            ^d&nsubc^d=max(nsubc^d,ceiling(ps(igrid)%dx(ix^dd,^d)*abs(vec_xi2(^d))/(dxsg/4.d0)));
            ^d&dxsubc^d=ps(igrid)%dx(ix^dd,^d)/nsubc^d;
            ! local line center and line width
            if (si_unit) then
              fluxsubc=flux(ix^d)*dxsubc1*dxsubc2*dxsubc3*unit_length*1.d2/dxsg/dxsg  ! DN s^-1
              wlc=linecent*(1.d0+v(ix^d)*unit_velocity*1.d2/const_c)
            else
              fluxsubc=flux(ix^d)*dxsubc1*dxsubc2*dxsubc3*unit_length/dxsg/dxsg  ! DN s^-1
              wlc=linecent*(1.d0+v(ix^d)*unit_velocity/const_c)
            endif
            wlwd=sqrt(kb_cgs*te(ix^d)*unit_temperature/(mass*mp_cgs))
            wlwd=wlwd*linecent/const_c
            ! dividing a cell to several parts to get more accurate integrating values
            {do isubc^d=1,nsubc^d\}
              ^d&xsubc(^d)=xloc(^d)-half*dxloc(^d)+(isubc^d-half)*dxsubc^d;
              call get_cor_image(xsubc,xcent)
              dst_slit=abs(xcent(1)-xslit)  ! space distance to slit center
              if (dst_slit<=half*slit_width) then
                ixs=floor((xcent(2)-(xs(1)-half*dxsg))/dxsg)+1
                ixsmin=max(1,ixs-3)
                ixsmax=min(ixs+3,numxs)
                iwl=floor((wlc-(wl(1)-half*dwlg))/dwlg)+1
                nwl=3*ceiling(wlwd/dwlg+1)
                iwlmin=max(1,iwl-nwl)
                iwlmax=min(iwl+nwl,numwl)
                ! calculate the contribution to nearby pixels
                do iwl=iwlmin,iwlmax
                  do ixs=ixsmin,ixsmax
                    xerfmin1=(wl(iwl)-half*dwlg-wlc)/sqrt(2.d0*(sigma_wl**2+wlwd**2))
                    xerfmax1=(wl(iwl)+half*dwlg-wlc)/sqrt(2.d0*(sigma_wl**2+wlwd**2))
                    xerfmin2=(xs(ixs)-half*dxsg-xcent(2))/(sqrt(2.d0)*sigma_xs)
                    xerfmax2=(xs(ixs)+half*dxsg-xcent(2))/(sqrt(2.d0)*sigma_xs)
                    factor=(erfc(xerfmin1)-erfc(xerfmax1))*(erfc(xerfmin2)-erfc(xerfmax2))/4.d0
                    spectra(iwl,ixs)=spectra(iwl,ixs)+fluxsubc*factor
                  enddo
                enddo
                ! nearby pixels
              endif
            {enddo\}
          endif
        endif
      {enddo\}
 
      deallocate(flux,v,pth,te)
    end subroutine integrate_spectra_cartesian
  }
 
  {^ifthreed
    subroutine get_euv_image(qunit,fl)
      use mod_global_parameters
 
      integer, intent(in) :: qunit
      type(te_fluid), intent(in) :: fl
      character(20) :: datatype
 
      integer :: mass
      character (30) :: ion
      double precision :: logTe,lineCent,sigma_PSF,spaceRsl,wlRsl,wslit
      double precision :: t0,t1
 
      t0=mpi_wtime()
      datatype='image_euv'
      call check_synthetic_emission_options(datatype)
      call get_line_info(wavelength,ion,mass,logte,linecent,spacersl,wlrsl,sigma_psf,wslit)
 
      if (mype==0) then
        print *, '###################################################'
        print *, 'Systhesizing EUV image'
        write(*,'(a,f8.3,a)') ' Wavelength: ',linecent,' Angstrom'
        print *, 'Unit of EUV flux: DN s^-1 pixel^-1'
      endif
 
      if (dat_resolution) then
        if (.not. slab .and. .not. (coordinate==spherical .and. trim(ray_method_active)=='spherical')) &
          call mpistop('EUV dat-resolution needs Cartesian or spherical native rays')
        if (mype==0) then
          write(*,'(a,f7.1,a,f7.1,a,f5.1,a,f5.1,a)') ' Supposed Pixel: ',spacersl*725.0,' km x ',spacersl*725.0, & 
                                                     ' km  (', spacersl, ' arcsec x ', spacersl, ' arcsec)'
          if (si_unit) then
            write(*,'(a,f8.1,a)') ' Unit of length: ',unit_length/1.d6,' Mm'
          else
            write(*,'(a,f8.1,a)') ' Unit of length: ',unit_length/1.d8,' Mm'
          endif
        endif
        if (coordinate==spherical .and. trim(ray_method_active)=='spherical') then
          call get_image_datresol(qunit,datatype,fl)
        else if (trim(ray_method_active)=='cart') then
          call get_image_datresol(qunit,datatype,fl)
        else if (los_phi==0 .and. los_theta==90) then
          call get_image_datresol(qunit,datatype,fl)
        else if (los_phi==90 .and. los_theta==90) then
          call get_image_datresol(qunit,datatype,fl)
        else if (los_theta==0) then
          call get_image_datresol(qunit,datatype,fl)
        else
          call mpistop('ERROR: Wrong LOS for synthesizing emission!')
        endif
      else
        if (mype==0) then
          write(*,'(a,f7.1,a,f7.1,a,f5.1,a,f5.1,a)') ' Pixel: ',spacersl*725.0,' km x ',spacersl*725.0, ' km  (', &
                                                                  spacersl, ' arcsec x ', spacersl, ' arcsec)'
          if (activate_unit_arcsec) then
            print *, 'Unit of length: arcsec (~725 km)'
          else
            if (si_unit) then
              write(*,'(a,f8.1,a)') ' Unit of length: ',unit_length/1.d6,' Mm'
            else
              write(*,'(a,f8.1,a)') ' Unit of length: ',unit_length/1.d8,' Mm'
            endif
          endif
        endif
        if (coordinate==cartesian) then
          if (mype==0) write(*,'(a,f8.3,f8.3,f8.3,a)') ' Mapping: [',x_origin(1),x_origin(2),x_origin(3), &
                                                     '] of the simulation box is located at [X=0,Y=0] of the image'
            call get_image(qunit,datatype,fl)
        else if (coordinate==spherical) then
          if (mype==0) write(*,'(a,f6.3,f8.3,f8.3,a)') ' Mapping: R=0 of the simulation box is located at [X=0,Y=0] of the image'
          call get_image(qunit,datatype,fl)
        else
          call mpistop("EUV synthesis: this coordinate is not supported!")
        endif
      endif
 
      t1=mpi_wtime()
      if (mype==0) print *, 'time comsuming: ',t1-t0,' s'
      if (mype==0) print *, '###################################################'
      
    end subroutine get_euv_image
 
    subroutine get_sxr_image(qunit,fl)
      use mod_global_parameters
 
      integer, intent(in) :: qunit
      type(te_fluid), intent(in) :: fl
      character(20) :: datatype
      double precision :: RHESSI_rsl
      double precision :: t0,t1
 
      t0=mpi_wtime()
      datatype='image_sxr'
      call check_synthetic_emission_options(datatype)
      rhessi_rsl=2.3/instrument_resolution_factor
 
      if (mype==0) then
        print *, '###################################################'
        print *, 'Systhesizing SXR image (observed at 1 AU).'
        write(*,'(a,i2,a,i2,a)') ' Passband: ',emin_sxr,' - ',emax_sxr,' keV'
      endif
 
      if (dat_resolution) then
        if (coordinate/=cartesian) call mpistop('SXR synthesis: only cartesian is supported for .dat resolution!')
        if (mype==0) then
          print *, 'Unit of SXR flux: photons cm^-2 s^-1 pixel^-1'
          write(*,'(a,f5.1,a,f5.1,a,f5.1,a,f5.1,a)') ' Supposed Pixel: ',rhessi_rsl*0.725, ' Mm x ',rhessi_rsl*0.725, &
                                                     ' Mm  (', rhessi_rsl, ' arcsec x ', rhessi_rsl, ' arcsec)'
          if (si_unit) then
            write(*,'(a,f8.1,a)') ' Unit of length: ',unit_length/1.d6,' Mm'
          else
            write(*,'(a,f8.1,a)') ' Unit of length: ',unit_length/1.d8,' Mm'
          endif
        endif
        if (los_phi==0 .and. los_theta==90) then
          call get_image_datresol(qunit,datatype,fl)
        else if (los_phi==90 .and. los_theta==90) then
          call get_image_datresol(qunit,datatype,fl)
        else if (los_theta==0) then
          call get_image_datresol(qunit,datatype,fl)
        else
          call mpistop('ERROR: Wrong LOS for synthesizing emission!')
        endif
      else
        if (mype==0) then
          print *, 'Unit of SXR flux: photons cm^-2 s^-1 pixel^-1'
          write(*,'(a,f5.1,a,f5.1,a,f5.1,a,f5.1,a)') ' Pixel: ',rhessi_rsl*0.725, ' Mm x ',rhessi_rsl*0.725, &
                                                      ' Mm  (', rhessi_rsl, ' arcsec x ', rhessi_rsl, ' arcsec)'
          if (activate_unit_arcsec) then
            print *, 'Unit of length: arcsec (~725 km)'
          else
            if (si_unit) then
              write(*,'(a,f8.1,a)') ' Unit of length: ',unit_length/1.d6,' Mm'
            else
              write(*,'(a,f8.1,a)') ' Unit of length: ',unit_length/1.d8,' Mm'
            endif
          endif
        endif
        if (coordinate==cartesian) then
          if (mype==0) write(*,'(a,f8.3,f8.3,f8.3,a)') ' Mapping: [',x_origin(1),x_origin(2),x_origin(3), &
                                                     '] of the simulation box is located at [X=0,Y=0] of the image'
            call get_image(qunit,datatype,fl)
        else if (coordinate==spherical) then
          if (mype==0) write(*,'(a,f6.3,f8.3,f8.3,a)') ' Mapping: R=0 of the simulation box is located at [X=0,Y=0] of the image'
          call get_image(qunit,datatype,fl)
        else
          call mpistop("SXR synthesis: this coordinate is not supported!")
        endif
      endif
 
      t1=mpi_wtime()
      if (mype==0) print *, 'time comsuming:',t1-t0
      if (mype==0) print *, '###################################################'
 
    end subroutine get_sxr_image
 
    subroutine get_whitelight_image(qunit,fl)
      use mod_global_parameters
 
      integer, intent(in) :: qunit
      type(te_fluid), intent(in) :: fl
      character(20) :: datatype
      double precision :: LASCO_rsl
 
      if (mype==0) print *, '###################################################'
 
      if (whitelight_instrument=='LASCO/C1') then
        lasco_rsl=5.6d0/instrument_resolution_factor
        if (mype==0) print *, 'Systhesizing white light image (observed by LASCO/C1).'
      else if (whitelight_instrument=='LASCO/C2') then
        lasco_rsl=11.4d0/instrument_resolution_factor
        if (mype==0) print *, 'Systhesizing white light image (observed by LASCO/C2).'
      else if (whitelight_instrument=='LASCO/C3') then
        lasco_rsl=56.d0/instrument_resolution_factor
        if (mype==0) print *, 'Systhesizing white light image (observed by LASCO/C3).'
      else
        call mpistop('Whitelight synthesis: instrument is not supported!')
      endif
 
      if (mype==0) write(*,'(a,f5.1,a,f5.1,a,f5.1,a,f5.1,a)') ' Pixel: ',lasco_rsl*0.725,' Mm x ',lasco_rsl*0.725, ' Mm  (', &
                                                                lasco_rsl, ' arcsec x ', lasco_rsl, ' arcsec) '
      if (mype==0) print *, 'Unit of white light flux: average Sun brightness'
 
      datatype='image_whitelight'
      call check_synthetic_emission_options(datatype)
 
      if (mype==0) then
        if (activate_unit_arcsec) then
          print *, 'Unit of length: arcsec (~725 km)'
        else
          if (si_unit) then
            if (mype==0) write(*,'(a,f8.1,a)') ' Unit of length: ',unit_length/1.d6,' Mm'
          else
            if (mype==0) write(*,'(a,f8.1,a)') ' Unit of length: ',unit_length/1.d8,' Mm'
          endif
        endif
      endif
 
      if (coordinate==spherical) then
        if (mype==0) write(*,'(a,f6.3,f8.3,f8.3,a)') ' Mapping: R=0 of the simulation box is located at [X=0,Y=0] of the image'
        call get_image(qunit,datatype,fl)
      else
        call mpistop("Whitelight synthesis: this coordinate is not supported!")
      endif
 
      if (mype==0) print *, '###################################################'
 
    end subroutine get_whitelight_image
 
    subroutine postprocess_euv_instrument_image(nSrc1,nSrc2,xSrc1,xSrc2,dxSrc1,dxSrc2,&
                                                EUV,Dpl,nOut1,nOut2,xOut1,xOut2,&
                                                dxOut1,dxOut2,wOut,numWOut,Tau,EUVthin)
      use mod_global_parameters
      use mod_constants
 
      integer, intent(in) :: nSrc1,nSrc2
      double precision, intent(in) :: xSrc1(nSrc1),xSrc2(nSrc2)
      double precision, intent(in) :: dxSrc1(nSrc1),dxSrc2(nSrc2)
      double precision, intent(in) :: EUV(nSrc1,nSrc2),Dpl(nSrc1,nSrc2)
      integer, intent(out) :: nOut1,nOut2,numWOut
      double precision, allocatable, intent(out) :: xOut1(:),xOut2(:),dxOut1(:),dxOut2(:)
      double precision, allocatable, intent(out) :: wOut(:,:,:)
      double precision, intent(in), optional :: Tau(nSrc1,nSrc2),EUVthin(nSrc1,nSrc2)
 
      integer :: mass,ixS1,ixS2,ixP1,ixP2,ixC1,ixC2,iw
      integer :: ixPmin1,ixPmax1,ixPmin2,ixPmax2
      character(30) :: ion
      double precision :: logTe,lineCent,spaceRsl,wlRsl,sigma_PSF,wslit
      double precision :: arcsec,dxInst,xMin1,xMax1,xMin2,xMax2,xCent1,xCent2
      double precision :: sigma0,xerfmin1,xerfmax1,xerfmin2,xerfmax2
      double precision :: factor,weightSum,weightNorm,thinVal,tauVal
      double precision, allocatable :: dplNum(:,:),thinOut(:,:),tauOut(:,:),tauWeight(:,:)
 
      call get_line_info(wavelength,ion,mass,logte,linecent,spacersl,wlrsl,sigma_psf,wslit)
      if (si_unit) then
        arcsec=7.25d5/unit_length
      else
        arcsec=7.25d7/unit_length
      endif
      dxinst=spacersl*arcsec
      if (dxinst<=zero) call mpistop("instrument_postprocess has non-positive pixel size")
 
      xmin1=minval(xsrc1-half*dxsrc1)
      xmax1=maxval(xsrc1+half*dxsrc1)
      xmin2=minval(xsrc2-half*dxsrc2)
      xmax2=maxval(xsrc2+half*dxsrc2)
      xcent1=half*(xmin1+xmax1)
      xcent2=half*(xmin2+xmax2)
      nout1=16*max(1,ceiling((xmax1-xmin1)/(16.d0*dxinst)))
      nout2=16*max(1,ceiling((xmax2-xmin2)/(16.d0*dxinst)))
      xmin1=xcent1-half*dble(nout1)*dxinst
      xmin2=xcent2-half*dble(nout2)*dxinst
 
      allocate(xout1(nout1),xout2(nout2),dxout1(nout1),dxout2(nout2))
      do ixp1=1,nout1
        xout1(ixp1)=xmin1+dxinst*(dble(ixp1)-half)
        dxout1(ixp1)=dxinst
      enddo
      do ixp2=1,nout2
        xout2(ixp2)=xmin2+dxinst*(dble(ixp2)-half)
        dxout2(ixp2)=dxinst
      enddo
 
      numwout=2
      if (present(tau) .and. output_tau) numwout=numwout+1
      if (present(euvthin) .and. output_absorption_fraction) numwout=numwout+1
      allocate(wout(nout1,nout2,numwout),dplnum(nout1,nout2))
      wout=zero
      dplnum=zero
      if (present(euvthin)) then
        allocate(thinout(nout1,nout2))
        thinout=zero
      endif
      if (present(tau) .and. output_tau) then
        allocate(tauout(nout1,nout2),tauweight(nout1,nout2))
        tauout=zero
        tauweight=zero
      endif
 
      sigma0=sigma_psf*dxinst
      do ixs1=1,nsrc1
        do ixs2=1,nsrc2
          thinval=zero
          tauval=zero
          if (present(euvthin)) thinval=euvthin(ixs1,ixs2)
          if (present(tau)) tauval=tau(ixs1,ixs2)
          if (abs(euv(ixs1,ixs2))<=smalldouble .and. abs(thinval)<=smalldouble .and. &
              abs(tauval)<=smalldouble) cycle
 
          ixc1=floor((xsrc1(ixs1)-(xout1(1)-half*dxinst))/dxinst)+1
          ixc2=floor((xsrc2(ixs2)-(xout2(1)-half*dxinst))/dxinst)+1
          ixpmin1=max(1,ixc1-3)
          ixpmax1=min(nout1,ixc1+3)
          ixpmin2=max(1,ixc2-3)
          ixpmax2=min(nout2,ixc2+3)
 
          weightsum=zero
          do ixp1=ixpmin1,ixpmax1
            do ixp2=ixpmin2,ixpmax2
              xerfmin1=((xout1(ixp1)-half*dxinst)-xsrc1(ixs1))/(sqrt(2.d0)*sigma0)
              xerfmax1=((xout1(ixp1)+half*dxinst)-xsrc1(ixs1))/(sqrt(2.d0)*sigma0)
              xerfmin2=((xout2(ixp2)-half*dxinst)-xsrc2(ixs2))/(sqrt(2.d0)*sigma0)
              xerfmax2=((xout2(ixp2)+half*dxinst)-xsrc2(ixs2))/(sqrt(2.d0)*sigma0)
              factor=(erfc(xerfmin1)-erfc(xerfmax1))*(erfc(xerfmin2)-erfc(xerfmax2))/4.d0
              weightsum=weightsum+factor
            enddo
          enddo
          if (weightsum<=zero) cycle
 
          do ixp1=ixpmin1,ixpmax1
            do ixp2=ixpmin2,ixpmax2
              xerfmin1=((xout1(ixp1)-half*dxinst)-xsrc1(ixs1))/(sqrt(2.d0)*sigma0)
              xerfmax1=((xout1(ixp1)+half*dxinst)-xsrc1(ixs1))/(sqrt(2.d0)*sigma0)
              xerfmin2=((xout2(ixp2)-half*dxinst)-xsrc2(ixs2))/(sqrt(2.d0)*sigma0)
              xerfmax2=((xout2(ixp2)+half*dxinst)-xsrc2(ixs2))/(sqrt(2.d0)*sigma0)
              factor=(erfc(xerfmin1)-erfc(xerfmax1))*(erfc(xerfmin2)-erfc(xerfmax2))/4.d0
              weightnorm=factor/weightsum
              wout(ixp1,ixp2,1)=wout(ixp1,ixp2,1)+euv(ixs1,ixs2)*weightnorm
              dplnum(ixp1,ixp2)=dplnum(ixp1,ixp2)+euv(ixs1,ixs2)*dpl(ixs1,ixs2)*weightnorm
              if (present(euvthin)) thinout(ixp1,ixp2)=thinout(ixp1,ixp2)+thinval*weightnorm
              if (present(tau) .and. output_tau) then
                tauout(ixp1,ixp2)=tauout(ixp1,ixp2)+tauval*weightnorm
                tauweight(ixp1,ixp2)=tauweight(ixp1,ixp2)+weightnorm
              endif
            enddo
          enddo
        enddo
      enddo
 
      do ixp1=1,nout1
        do ixp2=1,nout2
          if (wout(ixp1,ixp2,1)>smalldouble) then
            wout(ixp1,ixp2,2)=dplnum(ixp1,ixp2)/wout(ixp1,ixp2,1)
          else
            wout(ixp1,ixp2,2)=zero
          endif
        enddo
      enddo
      iw=2
      if (present(tau) .and. output_tau) then
        iw=iw+1
        do ixp1=1,nout1
          do ixp2=1,nout2
            if (tauweight(ixp1,ixp2)>zero) then
              wout(ixp1,ixp2,iw)=tauout(ixp1,ixp2)/tauweight(ixp1,ixp2)
            else
              wout(ixp1,ixp2,iw)=zero
            endif
          enddo
        enddo
      endif
      if (present(euvthin) .and. output_absorption_fraction) then
        iw=iw+1
        do ixp1=1,nout1
          do ixp2=1,nout2
            if (thinout(ixp1,ixp2)>smalldouble) then
              wout(ixp1,ixp2,iw)=min(one,max(zero,(thinout(ixp1,ixp2)-wout(ixp1,ixp2,1))/thinout(ixp1,ixp2)))
            else
              wout(ixp1,ixp2,iw)=zero
            endif
          enddo
        enddo
      endif
 
      if (mype==0) then
        write(*,'(a,2(i8,1x),a,2(i8,1x),a,1pe12.5)') &
          ' instrument_postprocess EUV grid src/out: ',nsrc1,nsrc2,' -> ',nout1,nout2,' dx=',dxinst
      endif
 
      deallocate(dplnum)
      if (allocated(thinout)) deallocate(thinout)
      if (allocated(tauout)) deallocate(tauout,tauweight)
    end subroutine postprocess_euv_instrument_image
 
    subroutine postprocess_radio_beam_image(nSrc1,nSrc2,xSrc1,xSrc2,dxSrc1,dxSrc2,&
                                            Bright,nOut1,nOut2,xOut1,xOut2,&
                                            dxOut1,dxOut2,wOut,numWOut,Tau,BrightThin)
      use mod_global_parameters
 
      integer, intent(in) :: nSrc1,nSrc2
      double precision, intent(in) :: xSrc1(nSrc1),xSrc2(nSrc2)
      double precision, intent(in) :: dxSrc1(nSrc1),dxSrc2(nSrc2)
      double precision, intent(in) :: Bright(nSrc1,nSrc2)
      integer, intent(out) :: nOut1,nOut2,numWOut
      double precision, allocatable, intent(out) :: xOut1(:),xOut2(:),dxOut1(:),dxOut2(:)
      double precision, allocatable, intent(out) :: wOut(:,:,:)
      double precision, intent(in), optional :: Tau(nSrc1,nSrc2),BrightThin(nSrc1,nSrc2)
 
      integer :: ixS1,ixS2,ixP1,ixP2,ixC1,ixC2,iw,nStencil
      integer :: ixPmin1,ixPmax1,ixPmin2,ixPmax2
      double precision :: arcsec,beamPixel,beamSigma,xMin1,xMax1,xMin2,xMax2,xCent1,xCent2
      double precision :: distance1,distance2,weight,cellArea,thinVal,tauVal
      double precision, allocatable :: norm(:,:),thinOut(:,:),tauOut(:,:),tauNorm(:,:)
 
      if (si_unit) then
        arcsec=7.25d5/unit_length
      else
        arcsec=7.25d7/unit_length
      endif
      beamsigma=radio_beam_fwhm*arcsec/sqrt(8.d0*log(2.d0))
      if (radio_beam_pixel_size>zero) then
        beampixel=radio_beam_pixel_size*arcsec
      else
        beampixel=radio_beam_fwhm*arcsec/3.d0
      endif
      if (beamsigma<=zero .or. beampixel<=zero) then
        call mpistop("radio beam postprocess has non-positive beam or pixel size")
      endif
 
      xmin1=minval(xsrc1-half*dxsrc1)
      xmax1=maxval(xsrc1+half*dxsrc1)
      xmin2=minval(xsrc2-half*dxsrc2)
      xmax2=maxval(xsrc2+half*dxsrc2)
      xcent1=half*(xmin1+xmax1)
      xcent2=half*(xmin2+xmax2)
      nout1=16*max(1,ceiling((xmax1-xmin1)/(16.d0*beampixel)))
      nout2=16*max(1,ceiling((xmax2-xmin2)/(16.d0*beampixel)))
      xmin1=xcent1-half*dble(nout1)*beampixel
      xmin2=xcent2-half*dble(nout2)*beampixel
 
      allocate(xout1(nout1),xout2(nout2),dxout1(nout1),dxout2(nout2))
      do ixp1=1,nout1
        xout1(ixp1)=xmin1+beampixel*(dble(ixp1)-half)
        dxout1(ixp1)=beampixel
      enddo
      do ixp2=1,nout2
        xout2(ixp2)=xmin2+beampixel*(dble(ixp2)-half)
        dxout2(ixp2)=beampixel
      enddo
 
      numwout=1
      if (present(tau) .and. output_tau) numwout=numwout+1
      if (present(brightthin) .and. output_absorption_fraction) numwout=numwout+1
      allocate(wout(nout1,nout2,numwout),norm(nout1,nout2))
      wout=zero
      norm=zero
      if (present(brightthin)) then
        allocate(thinout(nout1,nout2))
        thinout=zero
      endif
      if (present(tau) .and. output_tau) then
        allocate(tauout(nout1,nout2),taunorm(nout1,nout2))
        tauout=zero
        taunorm=zero
      endif
 
      nstencil=max(3,ceiling(4.d0*beamsigma/beampixel)+1)
      do ixs1=1,nsrc1
        do ixs2=1,nsrc2
          thinval=zero
          tauval=zero
          if (present(brightthin)) thinval=brightthin(ixs1,ixs2)
          if (present(tau)) tauval=tau(ixs1,ixs2)
          if (abs(bright(ixs1,ixs2))<=smalldouble .and. abs(thinval)<=smalldouble .and. &
              abs(tauval)<=smalldouble) cycle
 
          ixc1=floor((xsrc1(ixs1)-(xout1(1)-half*beampixel))/beampixel)+1
          ixc2=floor((xsrc2(ixs2)-(xout2(1)-half*beampixel))/beampixel)+1
          ixpmin1=max(1,ixc1-nstencil)
          ixpmax1=min(nout1,ixc1+nstencil)
          ixpmin2=max(1,ixc2-nstencil)
          ixpmax2=min(nout2,ixc2+nstencil)
          cellarea=max(smalldouble,dxsrc1(ixs1)*dxsrc2(ixs2))
 
          do ixp1=ixpmin1,ixpmax1
            distance1=xout1(ixp1)-xsrc1(ixs1)
            do ixp2=ixpmin2,ixpmax2
              distance2=xout2(ixp2)-xsrc2(ixs2)
              weight=exp_clamped(-half*(distance1**2+distance2**2)/beamsigma**2)*cellarea
              wout(ixp1,ixp2,1)=wout(ixp1,ixp2,1)+bright(ixs1,ixs2)*weight
              norm(ixp1,ixp2)=norm(ixp1,ixp2)+weight
              if (present(brightthin)) thinout(ixp1,ixp2)=thinout(ixp1,ixp2)+thinval*weight
              if (present(tau) .and. output_tau) then
                tauout(ixp1,ixp2)=tauout(ixp1,ixp2)+tauval*weight
                taunorm(ixp1,ixp2)=taunorm(ixp1,ixp2)+weight
              endif
            enddo
          enddo
        enddo
      enddo
 
      do ixp1=1,nout1
        do ixp2=1,nout2
          if (norm(ixp1,ixp2)>zero) then
            wout(ixp1,ixp2,1)=wout(ixp1,ixp2,1)/norm(ixp1,ixp2)
            if (present(brightthin)) thinout(ixp1,ixp2)=thinout(ixp1,ixp2)/norm(ixp1,ixp2)
          else
            wout(ixp1,ixp2,1)=zero
            if (present(brightthin)) thinout(ixp1,ixp2)=zero
          endif
        enddo
      enddo
 
      iw=1
      if (present(tau) .and. output_tau) then
        iw=iw+1
        do ixp1=1,nout1
          do ixp2=1,nout2
            if (taunorm(ixp1,ixp2)>zero) then
              wout(ixp1,ixp2,iw)=tauout(ixp1,ixp2)/taunorm(ixp1,ixp2)
            else
              wout(ixp1,ixp2,iw)=zero
            endif
          enddo
        enddo
      endif
      if (present(brightthin) .and. output_absorption_fraction) then
        iw=iw+1
        do ixp1=1,nout1
          do ixp2=1,nout2
            if (thinout(ixp1,ixp2)>smalldouble) then
              wout(ixp1,ixp2,iw)=min(one,max(zero,(thinout(ixp1,ixp2)-wout(ixp1,ixp2,1))/thinout(ixp1,ixp2)))
            else
              wout(ixp1,ixp2,iw)=zero
            endif
          enddo
        enddo
      endif
 
      if (mype==0) then
        write(*,'(a,2(i8,1x),a,2(i8,1x),a,2(1pe12.5,1x))') &
          ' radio_beam_postprocess grid src/out: ',nsrc1,nsrc2,' -> ',nout1,nout2,&
          ' fwhm/pixel=',radio_beam_fwhm,beampixel/arcsec
      endif
 
      deallocate(norm)
      if (allocated(thinout)) deallocate(thinout)
      if (allocated(tauout)) deallocate(tauout,taunorm)
    end subroutine postprocess_radio_beam_image
 
    subroutine get_image_datresol(qunit,datatype,fl)
      ! integrate emission flux along line of sight (LOS)
      ! in a 3D simulation box and get a 2D EUV image
      use mod_global_parameters
      use mod_constants
 
      integer, intent(in) :: qunit
      character(20), intent(in) :: datatype
      type(te_fluid), intent(in) :: fl
 
      double precision :: dx^D
      integer :: numX^D,ix^D
      double precision, allocatable :: EUV(:,:),EUVs(:,:),Dpl(:,:),Dpls(:,:)
      double precision, allocatable :: EUVthin(:,:),Tau(:,:)
      double precision, allocatable :: SXR(:,:),SXRs(:,:),wI(:,:,:)
      double precision, allocatable :: xI1(:),xI2(:),dxI1(:),dxI2(:),dxIi
      integer :: numXI1,numXI2,numSI,numWI,iw
      double precision :: xI^L
      integer :: iigrid,igrid,i,j
      double precision, allocatable :: xIF1(:),xIF2(:),dxIF1(:),dxIF2(:)
      double precision, allocatable :: xIP1(:),xIP2(:),dxIP1(:),dxIP2(:),wIP(:,:,:)
      integer :: nXIF1,nXIF2
      integer :: nXIP1,nXIP2,numWIP
      double precision :: xIF^L
      double precision :: vec_cor(1:3),xI_cor(1:2),dxDDA,xIcent1,xIcent2
 
      double precision :: unitv,arcsec,RHESSI_rsl
      integer :: strtype^D,nstrb^D,nbb^D,nuni^D,nstr^D,bnx^D
      double precision :: qs^D,dxfirst^D,dxmid^D,lenstr^D
      logical :: has_doppler_output,has_thick_output
 
      numx1=domain_nx1*2**(refine_max_level-1)
      numx2=domain_nx2*2**(refine_max_level-1)
      numx3=domain_nx3*2**(refine_max_level-1)
 
      if (trim(ray_method_active)=='cart') call init_vectors_cartesian()
      if (coordinate==spherical .and. trim(ray_method_active)=='spherical') call init_vectors_spherical()
 
      ! parameters for creating table
      if (coordinate==spherical .and. trim(ray_method_active)=='spherical') then
        call get_sph_intersection_image_bounds(xifmin1,xifmax1,xifmin2,xifmax2)
        call get_sph_intersection_datresol_spacing(dxdda)
        xicent1=half*(xifmin1+xifmax1)
        xicent2=half*(xifmin2+xifmax2)
        nxif1=max(1,ceiling((xifmax1-xifmin1)/dxdda))
        nxif2=max(1,ceiling((xifmax2-xifmin2)/dxdda))
        xifmin1=xicent1-half*dble(nxif1)*dxdda
        xifmax1=xicent1+half*dble(nxif1)*dxdda
        xifmin2=xicent2-half*dble(nxif2)*dxdda
        xifmax2=xicent2+half*dble(nxif2)*dxdda
        bnx1=1
        bnx2=1
        nbb1=nxif1
        nbb2=nxif2
        strtype1=0
        strtype2=0
        nstrb1=0
        nstrb2=0
        qs1=one
        qs2=one
        if (mype==0) write(*,'(a,1pe12.5,a,2(i8,1x))') &
          ' spherical native dat-resolution image-plane dx: ',dxdda,' n=',nxif1,nxif2
      else if (trim(ray_method_active)=='cart' .and. .not. &
          ((los_phi==0 .and. los_theta==90) .or. &
           (los_phi==90 .and. los_theta==90) .or. los_theta==0)) then
        do ix1=1,2
          if (ix1==1) vec_cor(1)=xprobmin1
          if (ix1==2) vec_cor(1)=xprobmax1
          do ix2=1,2
            if (ix2==1) vec_cor(2)=xprobmin2
            if (ix2==2) vec_cor(2)=xprobmax2
            do ix3=1,2
              if (ix3==1) vec_cor(3)=xprobmin3
              if (ix3==2) vec_cor(3)=xprobmax3
              call get_cor_image(vec_cor,xi_cor)
              if (ix1==1 .and. ix2==1 .and. ix3==1) then
                xifmin1=xi_cor(1)
                xifmax1=xi_cor(1)
                xifmin2=xi_cor(2)
                xifmax2=xi_cor(2)
              else
                xifmin1=min(xifmin1,xi_cor(1))
                xifmax1=max(xifmax1,xi_cor(1))
                xifmin2=min(xifmin2,xi_cor(2))
                xifmax2=max(xifmax2,xi_cor(2))
              endif
            enddo
          enddo
        enddo
        dxdda=min((xprobmax1-xprobmin1)/dble(numx1),&
                  (xprobmax2-xprobmin2)/dble(numx2),&
                  (xprobmax3-xprobmin3)/dble(numx3))
        xicent1=half*(xifmin1+xifmax1)
        xicent2=half*(xifmin2+xifmax2)
        nxif1=max(1,ceiling((xifmax1-xifmin1)/dxdda))
        nxif2=max(1,ceiling((xifmax2-xifmin2)/dxdda))
        xifmin1=xicent1-half*dble(nxif1)*dxdda
        xifmax1=xicent1+half*dble(nxif1)*dxdda
        xifmin2=xicent2-half*dble(nxif2)*dxdda
        xifmax2=xicent2+half*dble(nxif2)*dxdda
        bnx1=1
        bnx2=1
        nbb1=nxif1
        nbb2=nxif2
        strtype1=0
        strtype2=0
        nstrb1=0
        nstrb2=0
        qs1=one
        qs2=one
      else if (los_phi==0 .and. los_theta==90) then
        nxif1=domain_nx2*2**(refine_max_level-1)
        nxif2=domain_nx3*2**(refine_max_level-1)
        xifmin1=xprobmin2
        xifmax1=xprobmax2
        xifmin2=xprobmin3
        xifmax2=xprobmax3
        bnx1=block_nx2
        bnx2=block_nx3
        nbb1=domain_nx2
        nbb2=domain_nx3
        strtype1=stretch_type(2)
        strtype2=stretch_type(3)
        nstrb1=nstretchedblocks_baselevel(2)
        nstrb2=nstretchedblocks_baselevel(3)
        qs1=qstretch_baselevel(2)
        qs2=qstretch_baselevel(3)
        if (mype==0) write(*,'(a)') ' LOS vector: [-1.00  0.00  0.00]'
        if (mype==0) write(*,'(a)') ' xI1 vector: [ 0.00  1.00  0.00]'
        if (mype==0) write(*,'(a)') ' xI2 vector: [ 0.00  0.00  1.00]'
      else if (los_phi==90 .and. los_theta==90) then
        nxif1=domain_nx3*2**(refine_max_level-1)
        nxif2=domain_nx1*2**(refine_max_level-1)
        xifmin1=xprobmin3
        xifmax1=xprobmax3
        xifmin2=xprobmin1
        xifmax2=xprobmax1
        bnx1=block_nx3
        bnx2=block_nx1
        nbb1=domain_nx3
        nbb2=domain_nx1
        strtype1=stretch_type(3)
        strtype2=stretch_type(1)
        nstrb1=nstretchedblocks_baselevel(3)
        nstrb2=nstretchedblocks_baselevel(1)
        qs1=qstretch_baselevel(3)
        qs2=qstretch_baselevel(1)
        if (mype==0) write(*,'(a)') ' LOS vector: [ 0.00 -1.00  0.00]'
        if (mype==0) write(*,'(a)') ' xI1 vector: [-1.00  0.00  0.00]'
        if (mype==0) write(*,'(a)') ' xI2 vector: [ 0.00  0.00  1.00]'
      else
        nxif1=domain_nx1*2**(refine_max_level-1)
        nxif2=domain_nx2*2**(refine_max_level-1)
        xifmin1=xprobmin1
        xifmax1=xprobmax1
        xifmin2=xprobmin2
        xifmax2=xprobmax2
        bnx1=block_nx1
        bnx2=block_nx2
        nbb1=domain_nx1
        nbb2=domain_nx2
        strtype1=stretch_type(1)
        strtype2=stretch_type(2)
        nstrb1=nstretchedblocks_baselevel(1)
        nstrb2=nstretchedblocks_baselevel(2)
        qs1=qstretch_baselevel(1)
        qs2=qstretch_baselevel(2)
        if (mype==0) write(*,'(a)') ' LOS vector: [ 0.00  0.00 -1.00]'
        if (mype==0) write(*,'(a)') ' xI1 vector: [ 1.00  0.00  0.00]'
        if (mype==0) write(*,'(a)') ' xI2 vector: [ 0.00  1.00  0.00]'
      endif
      allocate(xif1(nxif1),xif2(nxif2),dxif1(nxif1),dxif2(nxif2))
 
      ! initialize image coordinate
      select case(strtype1)
      case(0) ! uniform
        dxif1(:)=(xifmax1-xifmin1)/nxif1
        do ix1=1,nxif1
          xif1(ix1)=xifmin1+dxif1(ix1)*(ix1-half)
        enddo
      case(1) ! uni stretch
        qs1=qs1**(one/2**(refine_max_level-1))
        dxfirst1=(xifmax1-xifmin1)*(one-qs1)/(one-qs1**nxif1)
        dxif1(1)=dxfirst1
        do ix1=2,nxif1
          dxif1(ix1)=dxfirst1*qs1**(ix1-1)
          xif1(ix1)=dxif1(1)/(one-qs1)*(one-qs1**(ix1-1))+half*dxif1(ix1)
        enddo
      case(2) ! symm stretch
        ! base level, nbb = nstr + nuni + nstr
        nstr1=nstrb1*bnx1/2
        nuni1=nbb1-nstrb1*bnx1
        lenstr1=(xifmax1-xifmin1)/(2.d0+nuni1*(one-qs1)/(one-qs1**nstr1))
        dxfirst1=(xifmax1-xifmin1)/(dble(nuni1)+2.d0/(one-qs1)*(one-qs1**nstr1))
        dxmid1=dxfirst1
        ! refine_max level, numXI = nstr + nuni + nstr
        nstr1=nstr1*2**(refine_max_level-1)
        nuni1=nuni1*2**(refine_max_level-1)
        qs1=qs1**(one/2**(refine_max_level-1))
        dxfirst1=lenstr1*(one-qs1)/(one-qs1**nstr1)
        dxmid1=dxmid1/2**(refine_max_level-1)
        ! uniform center
        if(nuni1 .gt. 0) then
          do ix1=nstr1+1,nstr1+nuni1
            dxif1(ix1)=dxmid1
            xif1(ix1)=lenstr1+(dble(ix1)-0.5d0-nstr1)*dxif1(ix1)+xifmin1
          enddo
        endif
        ! left half
        do ix1=nstr1,1,-1
          dxif1(ix1)=dxfirst1*qs1**(nstr1-ix1)
          xif1(ix1)=xifmin1+lenstr1-dxif1(ix1)*half-dxfirst1*(one-qs1**(nstr1-ix1))/(one-qs1)
        enddo
        ! right half
        do ix1=nstr1+nuni1+1,nxif1
          dxif1(ix1)=dxfirst1*qs1**(ix1-nstr1-nuni1-1)
          xif1(ix1)=xifmax1-lenstr1+dxif1(ix1)*half+dxfirst1*(one-qs1**(ix1-nstr1-nuni1-1))/(one-qs1)
        enddo
      case default
        call mpistop("unknown stretch type")
      end select
 
      select case(strtype2)
      case(0) ! uniform
        dxif2(:)=(xifmax2-xifmin2)/nxif2
        do ix2=1,nxif2
          xif2(ix2)=xifmin2+dxif2(ix2)*(ix2-half)
        enddo
      case(1) ! uni stretch
        qs2=qs2**(one/2**(refine_max_level-1))
        dxfirst2=(xifmax2-xifmin2)*(one-qs2)/(one-qs2**nxif2)
        dxif2(1)=dxfirst2
        do ix2=2,nxif1
          dxif2(ix2)=dxfirst2*qs2**(ix2-1)
          xif2(ix2)=dxif2(1)/(one-qs2)*(one-qs2**(ix2-1))+half*dxif2(ix2)
        enddo
      case(2) ! symm stretch
        ! base level, nbb = nstr + nuni + nstr
        nstr2=nstrb2*bnx2/2
        nuni2=nbb2-nstrb2*bnx2
        lenstr2=(xifmax2-xifmin2)/(2.d0+nuni2*(one-qs2)/(one-qs2**nstr2))
        dxfirst2=(xifmax2-xifmin2)/(dble(nuni2)+2.d0/(one-qs2)*(one-qs2**nstr2))
        dxmid2=dxfirst2
        ! refine_max level, numXI = nstr + nuni + nstr
        nstr2=nstr2*2**(refine_max_level-1)
        nuni2=nuni2*2**(refine_max_level-1)
        qs2=qs2**(one/2**(refine_max_level-1))
        dxfirst2=lenstr2*(one-qs2)/(one-qs2**nstr2)
        dxmid2=dxmid2/2**(refine_max_level-1)
        ! uniform center
        if(nuni2 .gt. 0) then
          do ix2=nstr2+1,nstr2+nuni2
            dxif2(ix2)=dxmid2
            xif2(ix2)=lenstr2+(dble(ix2)-0.5d0-nstr2)*dxif2(ix2)+xifmin2
          enddo
        endif
        ! left half
        do ix2=nstr2,1,-1
          dxif2(ix2)=dxfirst2*qs2**(nstr2-ix2)
          xif2(ix2)=xifmin2+lenstr2-dxif2(ix2)*half-dxfirst2*(one-qs2**(nstr2-ix2))/(one-qs2)
        enddo
        ! right half
        do ix2=nstr2+nuni2+1,nxif2
          dxif2(ix2)=dxfirst2*qs2**(ix2-nstr2-nuni2-1)
          xif2(ix2)=xifmax2-lenstr2+dxif2(ix2)*half+dxfirst2*(one-qs2**(ix2-nstr2-nuni2-1))/(one-qs2)
        enddo
      case default
        call mpistop("unknown stretch type")
      end select
 
      ! integrate EUV flux and get cell average flux for image
      if (datatype=='image_euv') then
        if (si_unit) then
          unitv=unit_velocity/1.0e3 ! km/s
        else
          unitv=unit_velocity/1.0e5 ! km/s
        endif
        has_thick_output=trim(radiation_transfer)=='thick'
        has_doppler_output=radsyn_euv_has_doppler_output()
        numwi=radsyn_euv_num_outputs(has_doppler_output,has_thick_output)
        allocate(wi(nxif1,nxif2,numwi))
        allocate(euv(nxif1,nxif2),dpl(nxif1,nxif2))
        if (trim(radiation_transfer)=='thick') then
          allocate(euvthin(nxif1,nxif2),tau(nxif1,nxif2))
          if (coordinate==spherical .and. trim(ray_method_active)=='spherical') then
            call integrate_euv_sph_intersection_thick(nxif1,nxif2,xif1,xif2,dxif1(1),fl,euv,tau,euvthin)
            dpl=zero
          else if (trim(ray_method_active)=='cart') then
            call integrate_euv_cart_dda_thick_datresol(nxif1,nxif2,xif1,xif2,fl,euv,dpl,tau,euvthin)
          else
            call integrate_euv_thick_datresol(nxif1,nxif2,fl,euv,dpl,tau,euvthin)
          endif
          if (has_doppler_output) then
            where(euv<smalldouble) euv=zero
            call normalize_euv_doppler(nxif1,nxif2,euv,dpl,unitv)
          endif
        else
          allocate(euvs(nxif1,nxif2),dpls(nxif1,nxif2))
          euvs=0.0d0
          euv=0.0d0
          dpl=0.d0
          dpls=0.d0
          if (coordinate==spherical .and. trim(ray_method_active)=='spherical') then
            call integrate_euv_sph_intersection_thin(nxif1,nxif2,xif1,xif2,dxif1(1),fl,euv)
            euvs=euv
            numsi=nxif1*nxif2
            call mpi_allreduce(euvs,euv,numsi,mpi_double_precision, &
                               mpi_sum,icomm,ierrmpi)
          else if (trim(ray_method_active)=='cart') then
            call integrate_euv_cart_dda_datresol(nxif1,nxif2,xif1,xif2,fl,euv,dpl)
          else
            do iigrid=1,igridstail; igrid=igrids(iigrid);
              call integrate_euv_datresol(igrid,nxif1,nxif2,xif1,xif2,dxif1,dxif2,fl,euvs,dpls)
            enddo
            numsi=nxif1*nxif2
            call mpi_allreduce(euvs,euv,numsi,mpi_double_precision, &
                               mpi_sum,icomm,ierrmpi)
            call mpi_allreduce(dpls,dpl,numsi,mpi_double_precision, &
                               mpi_sum,icomm,ierrmpi)
          endif
          if (has_doppler_output) then
            where(euv<smalldouble) euv=zero
            call normalize_euv_doppler(nxif1,nxif2,euv,dpl,unitv)
          endif
          deallocate(euvs,dpls)
        endif
        if (has_thick_output) then
          if (has_doppler_output) then
            call pack_euv_image_outputs(nxif1,nxif2,euv,wi,smalldouble,has_doppler_output,&
                                        has_thick_output,dpl=dpl,tau=tau,euvthin=euvthin)
          else
            call pack_euv_image_outputs(nxif1,nxif2,euv,wi,smalldouble,has_doppler_output,&
                                        has_thick_output,tau=tau,euvthin=euvthin)
          endif
        else if (has_doppler_output) then
          call pack_euv_image_outputs(nxif1,nxif2,euv,wi,smalldouble,has_doppler_output,&
                                      has_thick_output,dpl=dpl)
        else
          call pack_euv_image_outputs(nxif1,nxif2,euv,wi,smalldouble,has_doppler_output,&
                                      has_thick_output)
        endif
 
        if (instrument_postprocess) then
          if (trim(emission_model)=='radio_ff') then
            if (trim(radiation_transfer)=='thick') then
              call postprocess_radio_beam_image(nxif1,nxif2,xif1,xif2,dxif1,dxif2,&
                                                euv,nxip1,nxip2,xip1,xip2,&
                                                dxip1,dxip2,wip,numwip,tau=tau,brightthin=euvthin)
            else
              call postprocess_radio_beam_image(nxif1,nxif2,xif1,xif2,dxif1,dxif2,&
                                                euv,nxip1,nxip2,xip1,xip2,&
                                                dxip1,dxip2,wip,numwip)
            endif
          else if (trim(radiation_transfer)=='thick') then
            call postprocess_euv_instrument_image(nxif1,nxif2,xif1,xif2,dxif1,dxif2,&
                                                  euv,dpl,nxip1,nxip2,xip1,xip2,&
                                                  dxip1,dxip2,wip,numwip,tau=tau,euvthin=euvthin)
          else
            call postprocess_euv_instrument_image(nxif1,nxif2,xif1,xif2,dxif1,dxif2,&
                                                  euv,dpl,nxip1,nxip2,xip1,xip2,&
                                                  dxip1,dxip2,wip,numwip)
          endif
          call output_data(qunit,xip1,xip2,dxip1,dxip2,wip,nxip1,nxip2,numwip,datatype)
          deallocate(xip1,xip2,dxip1,dxip2,wip)
        else
          call output_data(qunit,xif1,xif2,dxif1,dxif2,wi,nxif1,nxif2,numwi,datatype)
        endif
        if (trim(radiation_transfer)=='thick') then
          deallocate(wi,euv,dpl,euvthin,tau)
        else
          deallocate(wi,euv,dpl)
        endif
      endif
 
      ! integrate SXR flux and get cell average flux for image
      if (datatype=='image_sxr') then
        if (si_unit) then
          arcsec=7.25d5
        else
          arcsec=7.25d7
        endif
        rhessi_rsl=2.3d0/instrument_resolution_factor
        numwi=1
        allocate(wi(nxif1,nxif2,numwi))
        allocate(sxrs(nxif1,nxif2),sxr(nxif1,nxif2))
        sxrs=0.0d0
        sxr=0.0d0
        do iigrid=1,igridstail; igrid=igrids(iigrid);
          call integrate_sxr_datresol(igrid,nxif1,nxif2,xif1,xif2,dxif1,dxif2,fl,sxrs)
        enddo
        numsi=nxif1*nxif2
        call mpi_allreduce(sxrs,sxr,numsi,mpi_double_precision, &
                           mpi_sum,icomm,ierrmpi)
 
        sxr=sxr*(rhessi_rsl*arcsec)**2 ! photons cm^-2 s^-1 pixel^-1
        do ix1=1,nxif1
          do ix2=1,nxif2
            if (sxr(ix1,ix2)<smalldouble) sxr(ix1,ix2)=zero
          enddo
        enddo
        wi(:,:,1)=sxr(:,:)
 
        call output_data(qunit,xif1,xif2,dxif1,dxif2,wi,nxif1,nxif2,numwi,datatype)
        deallocate(wi,sxr,sxrs)
      endif
 
      deallocate(xif1,xif2,dxif1,dxif2)
 
    end subroutine get_image_datresol
 
    subroutine integrate_sxr_datresol(igrid,nXIF1,nXIF2,xIF1,xIF2,dxIF1,dxIF2,fl,SXR)
      use mod_global_parameters
 
      integer, intent(in) :: igrid,nXIF1,nXIF2
      double precision, intent(in) :: xIF1(nXIF1),xIF2(nXIF2)
      double precision, intent(in) :: dxIF1(nXIF1),dxIF2(nXIF2)
      type(te_fluid), intent(in) :: fl
      double precision, intent(out) :: SXR(nXIF1,nXIF2)
 
      integer :: ixO^L,ixO^D,ixI^L,ix^D,i,j
      double precision :: xb^L,xd^D
      double precision, allocatable :: flux(:^D&),opacity(:^D&)
      double precision, allocatable :: dxb1(:^D&),dxb2(:^D&),dxb3(:^D&)
      double precision, allocatable :: SXRg(:,:),xg1(:),xg2(:),dxg1(:),dxg2(:)
      integer :: levelg,nXg1,nXg2,iXgmin1,iXgmax1,iXgmin2,iXgmax2,rft,iXg^D
      double precision :: SXRt,xc^L,xg^L,r2,area_1AU
      integer :: ixP^L,ixP^D
      integer :: direction_LOS
 
      if (los_phi==0 .and. los_theta==90) then
        direction_los=1
      else if (los_phi==90 .and. los_theta==90) then
        direction_los=2
      else
        direction_los=3
      endif
 
      ^d&ixomin^d=ixmlo^d\
      ^d&ixomax^d=ixmhi^d\
      ^d&iximin^d=ixglo^d\
      ^d&iximax^d=ixghi^d\
      ^d&xbmin^d=rnode(rpxmin^d_,igrid)\
      ^d&xbmax^d=rnode(rpxmax^d_,igrid)\
 
      allocate(flux(ixi^s))
      allocate(dxb1(ixi^s),dxb2(ixi^s),dxb3(ixi^s))
      dxb1(ixo^s)=ps(igrid)%dx(ixo^s,1)
      dxb2(ixo^s)=ps(igrid)%dx(ixo^s,2)
      dxb3(ixo^s)=ps(igrid)%dx(ixo^s,3)
      ! get local SXR flux
      call get_sxr(ixi^l,ixo^l,ps(igrid)%w,ps(igrid)%x,fl,flux,emin_sxr,emax_sxr)
 
      ! grid parameters
      levelg=ps(igrid)%level
      rft=2**(refine_max_level-levelg)
 
      ! fine table for storing EUV flux of current grid
      select case(direction_los)
      case(1)
        nxg1=iximax2*rft
        nxg2=iximax3*rft
      case(2)
        nxg1=iximax3*rft
        nxg2=iximax1*rft
      case(3)
        nxg1=iximax1*rft
        nxg2=iximax2*rft
      end select
      allocate(sxrg(nxg1,nxg2),xg1(nxg1),xg2(nxg2),dxg1(nxg1),dxg2(nxg2))
      sxrg=zero
      xg1=zero
      xg2=zero
 
      ! integrate for different direction
      select case(direction_los)
      case(1)
        do ix2=ixomin2,ixomax2
          ixgmin1=(ix2-1)*rft+1
          ixgmax1=ix2*rft
          do ix3=ixomin3,ixomax3
            ixgmin2=(ix3-1)*rft+1
            ixgmax2=ix3*rft
            sxrt=0.d0
            do ix1=ixomin1,ixomax1
              sxrt=sxrt+flux(ix^d)*dxb1(ix^d)*unit_length
            enddo
            sxrg(ixgmin1:ixgmax1,ixgmin2:ixgmax2)=sxrt
          enddo
        enddo
      case(2)
        do ix3=ixomin3,ixomax3
          ixgmin1=(ix3-1)*rft+1
          ixgmax1=ix3*rft
          do ix1=ixomin1,ixomax1
            ixgmin2=(ix1-1)*rft+1
            ixgmax2=ix1*rft
            sxrt=0.d0
            do ix2=ixomin2,ixomax2
              sxrt=sxrt+flux(ix^d)*dxb2(ix^d)*unit_length
            enddo
            sxrg(ixgmin1:ixgmax1,ixgmin2:ixgmax2)=sxrt
          enddo
        enddo
      case(3)
        do ix1=ixomin1,ixomax1
          ixgmin1=(ix1-1)*rft+1
          ixgmax1=ix1*rft
          do ix2=ixomin2,ixomax2
            ixgmin2=(ix2-1)*rft+1
            ixgmax2=ix2*rft
            sxrt=0.d0
            do ix3=ixomin3,ixomax3
              sxrt=sxrt+flux(ix^d)*dxb3(ix^d)*unit_length
            enddo
            sxrg(ixgmin1:ixgmax1,ixgmin2:ixgmax2)=sxrt
          enddo
        enddo
      end select
 
      area_1au=2.81d27
      sxrg=sxrg/area_1au
 
      ! mapping grid data to global table
      ! index ranges in local table
      select case(direction_los)
      case(1)
        ixgmin1=(ixomin2-1)*rft+1
        ixgmax1=ixomax2*rft
        ixgmin2=(ixomin3-1)*rft+1
        ixgmax2=ixomax3*rft
      case(2)
        ixgmin1=(ixomin3-1)*rft+1
        ixgmax1=ixomax3*rft
        ixgmin2=(ixomin1-1)*rft+1
        ixgmax2=ixomax1*rft
      case(3)
        ixgmin1=(ixomin1-1)*rft+1
        ixgmax1=ixomax1*rft
        ixgmin2=(ixomin2-1)*rft+1
        ixgmax2=ixomax2*rft
      end select
      ! index ranges in global table & mapping
      select case(direction_los)
      case(1)
        ixpmin1=(node(pig2_,igrid)-1)*rft*block_nx2+1
        ixpmax1=node(pig2_,igrid)*rft*block_nx2
        ixpmin2=(node(pig3_,igrid)-1)*rft*block_nx3+1
        ixpmax2=node(pig3_,igrid)*rft*block_nx3
      case(2)
        ixpmin1=(node(pig3_,igrid)-1)*rft*block_nx3+1
        ixpmax1=node(pig3_,igrid)*rft*block_nx3
        ixpmin2=(node(pig1_,igrid)-1)*rft*block_nx1+1
        ixpmax2=node(pig1_,igrid)*rft*block_nx1
      case(3)
        ixpmin1=(node(pig1_,igrid)-1)*rft*block_nx1+1
        ixpmax1=node(pig1_,igrid)*rft*block_nx1
        ixpmin2=(node(pig2_,igrid)-1)*rft*block_nx2+1
        ixpmax2=node(pig2_,igrid)*rft*block_nx2
      end select
      xg1(ixgmin1:ixgmax1)=xif1(ixpmin1:ixpmax1)
      xg2(ixgmin2:ixgmax2)=xif2(ixpmin2:ixpmax2)
      dxg1(ixgmin1:ixgmax1)=dxif1(ixpmin1:ixpmax1)
      dxg2(ixgmin2:ixgmax2)=dxif2(ixpmin2:ixpmax2)
      sxr(ixpmin1:ixpmax1,ixpmin2:ixpmax2)=sxr(ixpmin1:ixpmax1,ixpmin2:ixpmax2)+&
                                           sxrg(ixgmin1:ixgmax1,ixgmin2:ixgmax2)
 
      deallocate(flux,dxb1,dxb2,dxb3,sxrg,xg1,xg2,dxg1,dxg2)
 
    end subroutine integrate_sxr_datresol
 
    subroutine integrate_euv_datresol(igrid,nXIF1,nXIF2,xIF1,xIF2,dxIF1,dxIF2,fl,EUV,Dpl)
      use mod_global_parameters
 
      integer, intent(in) :: igrid,nXIF1,nXIF2
      double precision, intent(in) :: xIF1(nXIF1),xIF2(nXIF2)
      double precision, intent(in) :: dxIF1(nXIF1),dxIF2(nXIF2)
      type(te_fluid), intent(in) :: fl
      double precision, intent(out) :: EUV(nXIF1,nXIF2),Dpl(nXIF1,nXIF2)
 
      integer :: ixO^L,ixO^D,ixI^L,ix^D,i,j
      double precision :: xb^L,xd^D
      double precision, allocatable :: flux(:^D&),v(:^D&),rho(:^D&),opacity(:^D&)
      double precision, allocatable :: dxb1(:^D&),dxb2(:^D&),dxb3(:^D&)
      double precision, allocatable :: EUVg(:,:),Fvg(:,:),xg1(:),xg2(:),dxg1(:),dxg2(:)
      integer :: levelg,nXg1,nXg2,iXgmin1,iXgmax1,iXgmin2,iXgmax2,rft,iXg^D
      double precision :: EUVt,Fvt,xc^L,xg^L,r2
      integer :: ixP^L,ixP^D
      integer :: direction_LOS
 
      if (los_phi==0 .and. los_theta==90) then
        direction_los=1
      else if (los_phi==90 .and. los_theta==90) then
        direction_los=2
      else
        direction_los=3
      endif
 
      ^d&ixomin^d=ixmlo^d\
      ^d&ixomax^d=ixmhi^d\
      ^d&iximin^d=ixglo^d\
      ^d&iximax^d=ixghi^d\
      ^d&xbmin^d=rnode(rpxmin^d_,igrid)\
      ^d&xbmax^d=rnode(rpxmax^d_,igrid)\
 
      allocate(flux(ixi^s),v(ixi^s),rho(ixi^s),opacity(ixi^s))
      allocate(dxb1(ixi^s),dxb2(ixi^s),dxb3(ixi^s))
      dxb1(ixo^s)=ps(igrid)%dx(ixo^s,1)
      dxb2(ixo^s)=ps(igrid)%dx(ixo^s,2)
      dxb3(ixo^s)=ps(igrid)%dx(ixo^s,3)
      if (trim(emission_model)=='pseudo_current') then
        call get_pseudo_current(igrid,ixi^l,ixo^l,ps(igrid)%w,flux)
        v(ixo^s)=zero
        deallocate(rho)
      else if (trim(emission_model)=='radio_ff') then
        call get_radio_ff_source_opacity(ixi^l,ixo^l,ps(igrid)%w,ps(igrid)%x,fl,flux,opacity)
        v(ixo^s)=zero
        deallocate(rho)
      else
        ! get local EUV flux and velocity
        call get_euv(wavelength,ixi^l,ixo^l,ps(igrid)%w,ps(igrid)%x,fl,flux)
        flux(ixo^s)=flux(ixo^s)/instrument_resolution_factor**2   ! adjust flux due to artifical change of resolution
        call fl%get_rho(ps(igrid)%w,ps(igrid)%x,ixi^l,ixo^l,rho)
        v(ixo^s)=-ps(igrid)%w(ixo^s,iw_mom(direction_los))/rho(ixo^s)
        deallocate(rho)
      endif
 
      ! grid parameters
      levelg=ps(igrid)%level
      rft=2**(refine_max_level-levelg)
 
      ! fine table for storing EUV flux of current grid
      select case(direction_los)
      case(1)
        nxg1=iximax2*rft
        nxg2=iximax3*rft
      case(2)
        nxg1=iximax3*rft
        nxg2=iximax1*rft
      case(3)
        nxg1=iximax1*rft
        nxg2=iximax2*rft
      end select
      allocate(euvg(nxg1,nxg2),fvg(nxg1,nxg2),xg1(nxg1),xg2(nxg2),dxg1(nxg1),dxg2(nxg2))
      euvg=zero
      fvg=zero
      xg1=zero
      xg2=zero
 
      ! integrate for different direction
      select case(direction_los)
      case(1)
        do ix2=ixomin2,ixomax2
          ixgmin1=(ix2-1)*rft+1
          ixgmax1=ix2*rft
          do ix3=ixomin3,ixomax3
            ixgmin2=(ix3-1)*rft+1
            ixgmax2=ix3*rft
            euvt=0.d0
            fvt=0.d0
            do ix1=ixomin1,ixomax1
              euvt=euvt+flux(ix^d)*dxb1(ix^d)*unit_length
              fvt=fvt+flux(ix^d)*dxb1(ix^d)*unit_length*v(ix^d)
            enddo
            euvg(ixgmin1:ixgmax1,ixgmin2:ixgmax2)=euvt
            fvg(ixgmin1:ixgmax1,ixgmin2:ixgmax2)=fvt
          enddo
        enddo
      case(2)
        do ix3=ixomin3,ixomax3
          ixgmin1=(ix3-1)*rft+1
          ixgmax1=ix3*rft
          do ix1=ixomin1,ixomax1
            ixgmin2=(ix1-1)*rft+1
            ixgmax2=ix1*rft
            euvt=0.d0
            fvt=0.d0
            do ix2=ixomin2,ixomax2
              euvt=euvt+flux(ix^d)*dxb2(ix^d)*unit_length
              fvt=fvt+flux(ix^d)*dxb2(ix^d)*unit_length*v(ix^d)
            enddo
            euvg(ixgmin1:ixgmax1,ixgmin2:ixgmax2)=euvt
            fvg(ixgmin1:ixgmax1,ixgmin2:ixgmax2)=fvt
          enddo
        enddo
      case(3)
        do ix1=ixomin1,ixomax1
          ixgmin1=(ix1-1)*rft+1
          ixgmax1=ix1*rft
          do ix2=ixomin2,ixomax2
            ixgmin2=(ix2-1)*rft+1
            ixgmax2=ix2*rft
            euvt=0.d0
            fvt=0.d0
            do ix3=ixomin3,ixomax3
              euvt=euvt+flux(ix^d)*dxb3(ix^d)*unit_length
              fvt=fvt+flux(ix^d)*dxb3(ix^d)*unit_length*v(ix^d)
            enddo
            euvg(ixgmin1:ixgmax1,ixgmin2:ixgmax2)=euvt
            fvg(ixgmin1:ixgmax1,ixgmin2:ixgmax2)=fvt
          enddo
        enddo
      end select
      if (si_unit) then
        euvg=euvg*1.d2
        fvg=fvg*1.d2
      endif
 
      ! mapping grid data to global table
      ! index ranges in local table
      select case(direction_los)
      case(1)
        ixgmin1=(ixomin2-1)*rft+1
        ixgmax1=ixomax2*rft
        ixgmin2=(ixomin3-1)*rft+1
        ixgmax2=ixomax3*rft
      case(2)
        ixgmin1=(ixomin3-1)*rft+1
        ixgmax1=ixomax3*rft
        ixgmin2=(ixomin1-1)*rft+1
        ixgmax2=ixomax1*rft
      case(3)
        ixgmin1=(ixomin1-1)*rft+1
        ixgmax1=ixomax1*rft
        ixgmin2=(ixomin2-1)*rft+1
        ixgmax2=ixomax2*rft
      end select
      ! index ranges in global table & mapping
      select case(direction_los)
      case(1)
        ixpmin1=(node(pig2_,igrid)-1)*rft*block_nx2+1
        ixpmax1=node(pig2_,igrid)*rft*block_nx2
        ixpmin2=(node(pig3_,igrid)-1)*rft*block_nx3+1
        ixpmax2=node(pig3_,igrid)*rft*block_nx3
      case(2)
        ixpmin1=(node(pig3_,igrid)-1)*rft*block_nx3+1
        ixpmax1=node(pig3_,igrid)*rft*block_nx3
        ixpmin2=(node(pig1_,igrid)-1)*rft*block_nx1+1
        ixpmax2=node(pig1_,igrid)*rft*block_nx1
      case(3)
        ixpmin1=(node(pig1_,igrid)-1)*rft*block_nx1+1
        ixpmax1=node(pig1_,igrid)*rft*block_nx1
        ixpmin2=(node(pig2_,igrid)-1)*rft*block_nx2+1
        ixpmax2=node(pig2_,igrid)*rft*block_nx2
      end select
      xg1(ixgmin1:ixgmax1)=xif1(ixpmin1:ixpmax1)
      xg2(ixgmin2:ixgmax2)=xif2(ixpmin2:ixpmax2)
      dxg1(ixgmin1:ixgmax1)=dxif1(ixpmin1:ixpmax1)
      dxg2(ixgmin2:ixgmax2)=dxif2(ixpmin2:ixpmax2)
      euv(ixpmin1:ixpmax1,ixpmin2:ixpmax2)=euv(ixpmin1:ixpmax1,ixpmin2:ixpmax2)+&
                                           euvg(ixgmin1:ixgmax1,ixgmin2:ixgmax2)
      dpl(ixpmin1:ixpmax1,ixpmin2:ixpmax2)=dpl(ixpmin1:ixpmax1,ixpmin2:ixpmax2)+&
                                           fvg(ixgmin1:ixgmax1,ixgmin2:ixgmax2)
 
      deallocate(flux,v,opacity,dxb1,dxb2,dxb3,euvg,fvg,xg1,xg2,dxg1,dxg2)
 
    end subroutine integrate_euv_datresol
 
  }
 
  {^ifthreed
 
    subroutine ray_box_intersection_cart(ray_origin,ray_dir,box_min,box_max,hit,t_enter,t_exit)
      double precision, intent(in) :: ray_origin(1:3),ray_dir(1:3),box_min(1:3),box_max(1:3)
      logical, intent(out) :: hit
      double precision, intent(out) :: t_enter,t_exit
 
      integer :: idir
      double precision :: t1,t2,td
 
      hit=.true.
      t_enter=-huge(one)
      t_exit=huge(one)
      do idir=1,3
        if (abs(ray_dir(idir))<=smalldouble) then
          if (ray_origin(idir)<box_min(idir) .or. ray_origin(idir)>box_max(idir)) then
            hit=.false.
            return
          endif
        else
          t1=(box_min(idir)-ray_origin(idir))/ray_dir(idir)
          t2=(box_max(idir)-ray_origin(idir))/ray_dir(idir)
          if (t1>t2) then
            td=t1
            t1=t2
            t2=td
          endif
          t_enter=max(t_enter,t1)
          t_exit=min(t_exit,t2)
          if (t_enter>=t_exit) then
            hit=.false.
            return
          endif
        endif
      enddo
    end subroutine ray_box_intersection_cart
 
    subroutine build_cart_dda_faces(ixI^L,ixO^L,x,dx,xface1,xface2,xface3)
      integer, intent(in) :: ixI^L, ixO^L
      double precision, intent(in) :: x(ixI^S,1:ndim),dx(ixI^S,1:ndim)
      double precision, allocatable, intent(out) :: xface1(:),xface2(:),xface3(:)
 
      integer :: ix^D
 
      allocate(xface1(ixomin1:ixomax1+1),xface2(ixomin2:ixomax2+1),xface3(ixomin3:ixomax3+1))
 
      ix2=ixomin2
      ix3=ixomin3
      do ix1=ixomin1,ixomax1
        xface1(ix1)=x(ix^d,1)-half*dx(ix^d,1)
      enddo
      xface1(ixomax1+1)=x(ixomax1,ixomin2,ixomin3,1)+half*dx(ixomax1,ixomin2,ixomin3,1)
 
      ix1=ixomin1
      ix3=ixomin3
      do ix2=ixomin2,ixomax2
        xface2(ix2)=x(ix^d,2)-half*dx(ix^d,2)
      enddo
      xface2(ixomax2+1)=x(ixomin1,ixomax2,ixomin3,2)+half*dx(ixomin1,ixomax2,ixomin3,2)
 
      ix1=ixomin1
      ix2=ixomin2
      do ix3=ixomin3,ixomax3
        xface3(ix3)=x(ix^d,3)-half*dx(ix^d,3)
      enddo
      xface3(ixomax3+1)=x(ixomin1,ixomin2,ixomax3,3)+half*dx(ixomin1,ixomin2,ixomax3,3)
    end subroutine build_cart_dda_faces
 
    integer function cart_dda_locate_index(pos,faces,imin,imax) result(idx)
      integer, intent(in) :: imin,imax
      double precision, intent(in) :: pos,faces(imin:imax+1)
 
      integer :: ilo,ihi,imid
 
      if (pos<=faces(imin)) then
        idx=imin
        return
      endif
      if (pos>=faces(imax+1)) then
        idx=imax
        return
      endif
 
      ilo=imin
      ihi=imax+1
      do while (ihi-ilo>1)
        imid=(ilo+ihi)/2
        if (pos>=faces(imid)) then
          ilo=imid
        else
          ihi=imid
        endif
      enddo
      idx=min(imax,max(imin,ilo))
    end function cart_dda_locate_index
 
    subroutine cart_dda_init_axis(ray_origin_axis,ray_dir_axis,faces,imin,imax,idx,step,tMax)
      integer, intent(in) :: imin,imax,idx
      double precision, intent(in) :: ray_origin_axis,ray_dir_axis,faces(imin:imax+1)
      integer, intent(out) :: step
      double precision, intent(out) :: tMax
 
      if (ray_dir_axis>zero) then
        step=1
        tmax=(faces(idx+1)-ray_origin_axis)/ray_dir_axis
      else if (ray_dir_axis<zero) then
        step=-1
        tmax=(faces(idx)-ray_origin_axis)/ray_dir_axis
      else
        step=0
        tmax=huge(one)
      endif
    end subroutine cart_dda_init_axis
 
    subroutine cart_dda_advance_axis(ray_origin_axis,ray_dir_axis,faces,imin,imax,idx,step,tMax,done)
      integer, intent(in) :: imin,imax,step
      double precision, intent(in) :: ray_origin_axis,ray_dir_axis,faces(imin:imax+1)
      integer, intent(inout) :: idx
      double precision, intent(inout) :: tMax
      logical, intent(out) :: done
 
      done=.false.
      idx=idx+step
      if (idx<imin .or. idx>imax) then
        done=.true.
        return
      endif
      if (step>0) then
        tmax=(faces(idx+1)-ray_origin_axis)/ray_dir_axis
      else if (step<0) then
        tmax=(faces(idx)-ray_origin_axis)/ray_dir_axis
      else
        tmax=huge(one)
      endif
    end subroutine cart_dda_advance_axis
 
    subroutine acc_euv_cart_dda(ixI^L,ixO^L,source,sourcev,&
                                ray_origin,xface1,xface2,xface3,t_enter,t_exit,EUVp,Dplp)
      integer, intent(in) :: ixI^L, ixO^L
      double precision, intent(in) :: source(ixI^S),sourcev(ixI^S)
      double precision, intent(in) :: ray_origin(1:3)
      double precision, intent(in) :: xface1(ixOmin1:ixOmax1+1),xface2(ixOmin2:ixOmax2+1),&
                                      xface3(ixOmin3:ixOmax3+1)
      double precision, intent(in) :: t_enter,t_exit
      double precision, intent(inout) :: EUVp,Dplp
 
      integer :: ix^D,step(1:3)
      double precision :: pos(1:3),tMax(1:3),tNow,tNext,ds_cm,epsRay
      logical :: done
 
      if (t_exit<=t_enter) return
      epsray=max(1.d-12,1.d-10*abs(t_exit-t_enter))
      pos=ray_origin+(t_enter+epsray)*vec_los
      ix1=cart_dda_locate_index(pos(1),xface1,ixomin1,ixomax1)
      ix2=cart_dda_locate_index(pos(2),xface2,ixomin2,ixomax2)
      ix3=cart_dda_locate_index(pos(3),xface3,ixomin3,ixomax3)
 
      call cart_dda_init_axis(ray_origin(1),vec_los(1),xface1,ixomin1,ixomax1,ix1,step(1),tmax(1))
      call cart_dda_init_axis(ray_origin(2),vec_los(2),xface2,ixomin2,ixomax2,ix2,step(2),tmax(2))
      call cart_dda_init_axis(ray_origin(3),vec_los(3),xface3,ixomin3,ixomax3,ix3,step(3),tmax(3))
 
      tnow=t_enter
      do
        tnext=min(t_exit,tmax(1),tmax(2),tmax(3))
        if (tnext>tnow) then
          ds_cm=(tnext-tnow)*unit_length
          if (si_unit) ds_cm=ds_cm*1.d2
          euvp=euvp+source(ix^d)*ds_cm
          dplp=dplp+sourcev(ix^d)*ds_cm
        endif
        tnow=tnext
        if (tnow>=t_exit-epsray) exit
 
        if (tmax(1)<=tnow+epsray) then
          call cart_dda_advance_axis(ray_origin(1),vec_los(1),xface1,ixomin1,ixomax1,ix1,step(1),tmax(1),done)
          if (done) exit
        endif
        if (tmax(2)<=tnow+epsray) then
          call cart_dda_advance_axis(ray_origin(2),vec_los(2),xface2,ixomin2,ixomax2,ix2,step(2),tmax(2),done)
          if (done) exit
        endif
        if (tmax(3)<=tnow+epsray) then
          call cart_dda_advance_axis(ray_origin(3),vec_los(3),xface3,ixomin3,ixomax3,ix3,step(3),tmax(3),done)
          if (done) exit
        endif
      enddo
    end subroutine acc_euv_cart_dda
 
    subroutine append_cart_dda_segment(segments,nseg,capacity,pixel_id,tseg,jds,kds,jvds)
      double precision, allocatable, intent(inout) :: segments(:,:)
      integer, intent(inout) :: nseg,capacity
      integer, intent(in) :: pixel_id
      double precision, intent(in) :: tseg,jds,kds,jvds
 
      double precision, allocatable :: tmp(:,:)
      integer :: new_capacity
 
      if (capacity<=0) then
        capacity=1024
        allocate(segments(5,capacity))
      else if (nseg>=capacity) then
        new_capacity=2*capacity
        allocate(tmp(5,new_capacity))
        tmp(:,1:capacity)=segments(:,1:capacity)
        call move_alloc(tmp,segments)
        capacity=new_capacity
      endif
 
      nseg=nseg+1
      segments(1,nseg)=dble(pixel_id)
      segments(2,nseg)=tseg
      segments(3,nseg)=jds
      segments(4,nseg)=kds
      segments(5,nseg)=jvds
    end subroutine append_cart_dda_segment
 
    subroutine collect_euv_cart_dda_segments(ixI^L,ixO^L,source,opacity,sourcev,&
                                             pixel_id,ray_origin,xface1,xface2,xface3,t_enter,t_exit,&
                                             segments,nseg,capacity)
      integer, intent(in) :: ixI^L, ixO^L
      double precision, intent(in) :: source(ixI^S),opacity(ixI^S),sourcev(ixI^S)
      integer, intent(in) :: pixel_id
      double precision, intent(in) :: ray_origin(1:3)
      double precision, intent(in) :: xface1(ixOmin1:ixOmax1+1),xface2(ixOmin2:ixOmax2+1),&
                                      xface3(ixOmin3:ixOmax3+1)
      double precision, intent(in) :: t_enter,t_exit
      double precision, allocatable, intent(inout) :: segments(:,:)
      integer, intent(inout) :: nseg,capacity
 
      integer :: ix^D,step(1:3)
      double precision :: pos(1:3),tMax(1:3),tNow,tNext,ds_cm,epsRay,tseg
      double precision :: jds,kds,jvds
      logical :: done
 
      if (t_exit<=t_enter) return
      epsray=max(1.d-12,1.d-10*abs(t_exit-t_enter))
      pos=ray_origin+(t_enter+epsray)*vec_los
      ix1=cart_dda_locate_index(pos(1),xface1,ixomin1,ixomax1)
      ix2=cart_dda_locate_index(pos(2),xface2,ixomin2,ixomax2)
      ix3=cart_dda_locate_index(pos(3),xface3,ixomin3,ixomax3)
 
      call cart_dda_init_axis(ray_origin(1),vec_los(1),xface1,ixomin1,ixomax1,ix1,step(1),tmax(1))
      call cart_dda_init_axis(ray_origin(2),vec_los(2),xface2,ixomin2,ixomax2,ix2,step(2),tmax(2))
      call cart_dda_init_axis(ray_origin(3),vec_los(3),xface3,ixomin3,ixomax3,ix3,step(3),tmax(3))
 
      tnow=t_enter
      do
        tnext=min(t_exit,tmax(1),tmax(2),tmax(3))
        if (tnext>tnow) then
          ds_cm=(tnext-tnow)*unit_length
          if (si_unit) ds_cm=ds_cm*1.d2
          jds=source(ix^d)*ds_cm
          kds=opacity(ix^d)*ds_cm
          jvds=sourcev(ix^d)*ds_cm
          if (jds/=zero .or. kds/=zero .or. jvds/=zero) then
            tseg=half*(tnow+tnext)
            call append_cart_dda_segment(segments,nseg,capacity,pixel_id,tseg,jds,kds,jvds)
          endif
        endif
        tnow=tnext
        if (tnow>=t_exit-epsray) exit
 
        if (tmax(1)<=tnow+epsray) then
          call cart_dda_advance_axis(ray_origin(1),vec_los(1),xface1,ixomin1,ixomax1,ix1,step(1),tmax(1),done)
          if (done) exit
        endif
        if (tmax(2)<=tnow+epsray) then
          call cart_dda_advance_axis(ray_origin(2),vec_los(2),xface2,ixomin2,ixomax2,ix2,step(2),tmax(2),done)
          if (done) exit
        endif
        if (tmax(3)<=tnow+epsray) then
          call cart_dda_advance_axis(ray_origin(3),vec_los(3),xface3,ixomin3,ixomax3,ix3,step(3),tmax(3),done)
          if (done) exit
        endif
      enddo
    end subroutine collect_euv_cart_dda_segments
 
    subroutine sort_segment_indices_near_to_far(segments,idx,nidx)
      double precision, intent(in) :: segments(:,:)
      integer, intent(inout) :: idx(:)
      integer, intent(in) :: nidx
 
      if (nidx<=1) return
      if (nidx<=32) then
        call insertion_sort_segment_indices(segments,idx,1,nidx)
      else
        call quicksort_segment_indices(segments,idx,1,nidx)
      endif
    end subroutine sort_segment_indices_near_to_far
 
    subroutine insertion_sort_segment_indices(segments,idx,ilo,ihi)
      double precision, intent(in) :: segments(:,:)
      integer, intent(inout) :: idx(:)
      integer, intent(in) :: ilo,ihi
 
      integer :: i,j,key
 
      do i=ilo+1,ihi
        key=idx(i)
        j=i-1
        do while (j>=ilo .and. segments(2,idx(j))>segments(2,key))
          idx(j+1)=idx(j)
          j=j-1
        enddo
        idx(j+1)=key
      enddo
    end subroutine insertion_sort_segment_indices
 
    recursive subroutine quicksort_segment_indices(segments,idx,ilo,ihi)
      double precision, intent(in) :: segments(:,:)
      integer, intent(inout) :: idx(:)
      integer, intent(in) :: ilo,ihi
 
      integer :: i,j,tmp
      double precision :: pivot
 
      if (ihi-ilo<=32) then
        call insertion_sort_segment_indices(segments,idx,ilo,ihi)
        return
      endif
 
      i=ilo
      j=ihi
      pivot=segments(2,idx((ilo+ihi)/2))
      do
        do while (segments(2,idx(i))<pivot)
          i=i+1
        enddo
        do while (segments(2,idx(j))>pivot)
          j=j-1
        enddo
        if (i<=j) then
          tmp=idx(i)
          idx(i)=idx(j)
          idx(j)=tmp
          i=i+1
          j=j-1
        endif
        if (i>j) exit
      enddo
 
      if (ilo<j) call quicksort_segment_indices(segments,idx,ilo,j)
      if (i<ihi) call quicksort_segment_indices(segments,idx,i,ihi)
    end subroutine quicksort_segment_indices
 
    integer function segment_pixel_owner(pixel_id) result(owner)
      integer, intent(in) :: pixel_id
 
      owner=mod(pixel_id-1,npe)
    end function segment_pixel_owner
 
    logical function segment_is_valid(segments,is,nvars) result(valid)
      double precision, intent(in) :: segments(:,:)
      integer, intent(in) :: is,nvars
 
      integer :: iv
 
      valid=.true.
      do iv=1,nvars
        if (segments(iv,is)/=segments(iv,is) .or. abs(segments(iv,is))>=1.d90) then
          valid=.false.
          return
        endif
      enddo
    end function segment_is_valid
 
    subroutine cart_dda_block_pixel_range(box_min,box_max,nXIF1,nXIF2,xIF1,xIF2,ixPmin1,ixPmax1,ixPmin2,ixPmax2,has_pixels)
      double precision, intent(in) :: box_min(1:3),box_max(1:3)
      integer, intent(in) :: nXIF1,nXIF2
      double precision, intent(in) :: xIF1(nXIF1),xIF2(nXIF2)
      integer, intent(out) :: ixPmin1,ixPmax1,ixPmin2,ixPmax2
      logical, intent(out) :: has_pixels
 
      integer :: i1,i2,i3
      double precision :: vec_cor(1:3),xI_cor(1:2)
      double precision :: xmin1,xmax1,xmin2,xmax2,dx1,dx2
 
      do i1=1,2
        if (i1==1) vec_cor(1)=box_min(1)
        if (i1==2) vec_cor(1)=box_max(1)
        do i2=1,2
          if (i2==1) vec_cor(2)=box_min(2)
          if (i2==2) vec_cor(2)=box_max(2)
          do i3=1,2
            if (i3==1) vec_cor(3)=box_min(3)
            if (i3==2) vec_cor(3)=box_max(3)
            call get_cor_image(vec_cor,xi_cor)
            if (i1==1 .and. i2==1 .and. i3==1) then
              xmin1=xi_cor(1)
              xmax1=xi_cor(1)
              xmin2=xi_cor(2)
              xmax2=xi_cor(2)
            else
              xmin1=min(xmin1,xi_cor(1))
              xmax1=max(xmax1,xi_cor(1))
              xmin2=min(xmin2,xi_cor(2))
              xmax2=max(xmax2,xi_cor(2))
            endif
          enddo
        enddo
      enddo
 
      if (nxif1>1) then
        dx1=abs(xif1(2)-xif1(1))
      else
        dx1=max(one,abs(xmax1-xmin1))
      endif
      if (nxif2>1) then
        dx2=abs(xif2(2)-xif2(1))
      else
        dx2=max(one,abs(xmax2-xmin2))
      endif
 
      ixpmin1=max(1,floor((xmin1-xif1(1))/dx1)+1-1)
      ixpmax1=min(nxif1,ceiling((xmax1-xif1(1))/dx1)+1+1)
      ixpmin2=max(1,floor((xmin2-xif2(1))/dx2)+1-1)
      ixpmax2=min(nxif2,ceiling((xmax2-xif2(1))/dx2)+1+1)
      has_pixels=ixpmin1<=ixpmax1 .and. ixpmin2<=ixpmax2
    end subroutine cart_dda_block_pixel_range
 
    subroutine integrate_euv_cart_dda_datresol(nXIF1,nXIF2,xIF1,xIF2,fl,EUV,Dpl)
      use mod_global_parameters
 
      integer, intent(in) :: nXIF1,nXIF2
      double precision, intent(in) :: xIF1(nXIF1),xIF2(nXIF2)
      type(te_fluid), intent(in) :: fl
      double precision, intent(out) :: EUV(nXIF1,nXIF2),Dpl(nXIF1,nXIF2)
 
      integer :: ixO^L,ixO^D,ixI^L,ix^D
      integer :: iigrid,igrid,ixP1,ixP2,numSI,ixPmin1,ixPmax1,ixPmin2,ixPmax2
      double precision :: box_min(1:3),box_max(1:3),ray_origin(1:3)
      double precision :: t_enter,t_exit,vlos
      double precision :: profile_local(2),profile_global(2)
      logical :: hit,has_pixels
      double precision, allocatable :: source(:^D&),sourcev(:^D&),rho(:^D&),opacity(:^D&)
      double precision, allocatable :: xface1(:),xface2(:),xface3(:)
      double precision, allocatable :: EUVs(:,:),Dpls(:,:)
 
      allocate(euvs(nxif1,nxif2),dpls(nxif1,nxif2))
      euvs=zero
      dpls=zero
      profile_local=zero
 
      do iigrid=1,igridstail; igrid=igrids(iigrid);
        ^d&ixomin^d=ixmlo^d\
        ^d&ixomax^d=ixmhi^d\
        ^d&iximin^d=ixglo^d\
        ^d&iximax^d=ixghi^d\
 
        box_min(1)=rnode(rpxmin1_,igrid)
        box_min(2)=rnode(rpxmin2_,igrid)
        box_min(3)=rnode(rpxmin3_,igrid)
        box_max(1)=rnode(rpxmax1_,igrid)
        box_max(2)=rnode(rpxmax2_,igrid)
        box_max(3)=rnode(rpxmax3_,igrid)
        call build_cart_dda_faces(ixi^l,ixo^l,ps(igrid)%x,ps(igrid)%dx,xface1,xface2,xface3)
        call cart_dda_block_pixel_range(box_min,box_max,nxif1,nxif2,xif1,xif2,&
                                        ixpmin1,ixpmax1,ixpmin2,ixpmax2,has_pixels)
        if (.not. has_pixels) then
          deallocate(xface1,xface2,xface3)
          cycle
        endif
 
        allocate(source(ixi^s),sourcev(ixi^s),rho(ixi^s),opacity(ixi^s))
        source=zero
        sourcev=zero
        if (trim(emission_model)=='pseudo_current') then
          call get_pseudo_current(igrid,ixi^l,ixo^l,ps(igrid)%w,source)
        else if (trim(emission_model)=='radio_ff') then
          call get_radio_ff_source_opacity(ixi^l,ixo^l,ps(igrid)%w,ps(igrid)%x,fl,source,opacity)
        else
          call get_euv(wavelength,ixi^l,ixo^l,ps(igrid)%w,ps(igrid)%x,fl,source)
          source(ixo^s)=source(ixo^s)/instrument_resolution_factor**2
          call fl%get_rho(ps(igrid)%w,ps(igrid)%x,ixi^l,ixo^l,rho)
          do ix1=ixomin1,ixomax1
            do ix2=ixomin2,ixomax2
              do ix3=ixomin3,ixomax3
                if (rho(ix^d)>smalldouble) then
                  vlos=(ps(igrid)%w(ix^d,iw_mom(1))*vec_los(1)+&
                        ps(igrid)%w(ix^d,iw_mom(2))*vec_los(2)+&
                        ps(igrid)%w(ix^d,iw_mom(3))*vec_los(3))/rho(ix^d)
                  sourcev(ix^d)=source(ix^d)*vlos
                endif
              enddo
            enddo
          enddo
        endif
        deallocate(rho,opacity)
 
        do ixp1=ixpmin1,ixpmax1
          do ixp2=ixpmin2,ixpmax2
            ray_origin=x_origin+xif1(ixp1)*vec_xi1+xif2(ixp2)*vec_xi2
            profile_local(1)=profile_local(1)+one
            call ray_box_intersection_cart(ray_origin,vec_los,box_min,box_max,hit,t_enter,t_exit)
            if (hit) then
              profile_local(2)=profile_local(2)+one
              call acc_euv_cart_dda(ixi^l,ixo^l,source,sourcev,&
                                    ray_origin,xface1,xface2,xface3,t_enter,t_exit,euvs(ixp1,ixp2),dpls(ixp1,ixp2))
            endif
          enddo
        enddo
 
        deallocate(source,sourcev,xface1,xface2,xface3)
      enddo
 
      numsi=nxif1*nxif2
      call mpi_allreduce(euvs,euv,numsi,mpi_double_precision,mpi_sum,icomm,ierrmpi)
      call mpi_allreduce(dpls,dpl,numsi,mpi_double_precision,mpi_sum,icomm,ierrmpi)
      call mpi_allreduce(profile_local,profile_global,2,mpi_double_precision,mpi_sum,icomm,ierrmpi)
      if (radsyn_verbose .and. mype==0) then
        write(*,'(a,2(es12.5,1x))') ' cart_dda thin profile ray_tests ray_hits: ',profile_global
      endif
      deallocate(euvs,dpls)
    end subroutine integrate_euv_cart_dda_datresol
 
    subroutine integrate_euv_cart_dda_thick_datresol(nXIF1,nXIF2,xIF1,xIF2,fl,EUV,Dpl,Tau,EUVthin)
      use mod_global_parameters
 
      integer, intent(in) :: nXIF1,nXIF2
      double precision, intent(in) :: xIF1(nXIF1),xIF2(nXIF2)
      type(te_fluid), intent(in) :: fl
      double precision, intent(out) :: EUV(nXIF1,nXIF2),Dpl(nXIF1,nXIF2)
      double precision, intent(out) :: Tau(nXIF1,nXIF2),EUVthin(nXIF1,nXIF2)
 
      integer, parameter :: nSegVars=5
      integer :: ixO^L,ixO^D,ixI^L,ix^D
      integer :: iigrid,igrid,ixP1,ixP2,ipix,ipixStart,ipixEnd,nPixBatch,pixel_id
      integer :: nseg,capacity,totalCount,totalSeg,ipe,is,iseg,nidx,owner,isegDest,nsegBefore
      integer :: ixGlobal,iyGlobal,ixPmin1,ixPmax1,ixPmin2,ixPmax2,iFirst,iLast,iLocal
      integer :: nPixBatchTarget
      integer :: maxSegBatchTarget,maxSegCommTarget,maxNsegBatch,nPixTotal
      integer :: maxOwnerSegCount,maxOwnerSegCountLocal,segOffset,recvFill,totalRoundCount,totalRoundSeg
      integer, allocatable :: sendCounts(:),recvCounts(:),sendDispls(:),recvDispls(:)
      integer, allocatable :: roundSendCounts(:),roundRecvCounts(:)
      integer, allocatable :: roundSendDispls(:),roundRecvDispls(:)
      integer, allocatable :: ownerSegCounts(:),ownerOffsets(:),idx(:)
      integer, allocatable :: bucketCounts(:),bucketOffsets(:),bucketFill(:)
      double precision :: ray_origin(1:3)
      double precision :: t_enter,t_exit,vlos,atten
      double precision :: profile_local(5),profile_global(5),profile_batch(5)
      logical :: hit,has_pixels,batchAccepted,batchReduced
      double precision, allocatable :: rho(:^D&)
      double precision, allocatable :: segments(:,:),segments_send(:,:),segments_recv(:,:)
      double precision, allocatable :: segments_recv_round(:,:)
      double precision, allocatable :: image_reduce(:,:)
      type(radsyn_euv_cache), allocatable :: cache(:)
 
      euv=zero
      dpl=zero
      tau=zero
      euvthin=zero
      profile_local=zero
      allocate(sendcounts(0:npe-1),recvcounts(0:npe-1),senddispls(0:npe-1),recvdispls(0:npe-1))
      allocate(roundsendcounts(0:npe-1),roundrecvcounts(0:npe-1))
      allocate(roundsenddispls(0:npe-1),roundrecvdispls(0:npe-1))
      allocate(ownersegcounts(0:npe-1),owneroffsets(0:npe-1))
      allocate(cache(igridstail))
      call radsyn_get_segment_batch_limits(npixbatchtarget,maxsegbatchtarget,maxsegcommtarget)
      allocate(bucketcounts(npixbatchtarget),bucketoffsets(npixbatchtarget+1),&
               bucketfill(npixbatchtarget))
 
      do iigrid=1,igridstail; igrid=igrids(iigrid);
        ^d&ixomin^d=ixmlo^d\
        ^d&ixomax^d=ixmhi^d\
        ^d&iximin^d=ixglo^d\
        ^d&iximax^d=ixghi^d\
 
        cache(iigrid)%igrid=igrid
        allocate(cache(iigrid)%source(ixi^s),cache(iigrid)%opacity(ixi^s),&
                 cache(iigrid)%sourcev(ixi^s),rho(ixi^s))
        cache(iigrid)%source=zero
        cache(iigrid)%opacity=zero
        cache(iigrid)%sourcev=zero
        if (trim(emission_model)=='radio_ff') then
          call get_radio_ff_source_opacity(ixi^l,ixo^l,ps(igrid)%w,ps(igrid)%x,fl,&
                                           cache(iigrid)%source,cache(iigrid)%opacity)
        else
          call get_euv(wavelength,ixi^l,ixo^l,ps(igrid)%w,ps(igrid)%x,fl,cache(iigrid)%source)
          cache(iigrid)%source(ixo^s)=cache(iigrid)%source(ixo^s)/instrument_resolution_factor**2
          call get_euv_hhe_opacity(wavelength,ixi^l,ixo^l,ps(igrid)%w,ps(igrid)%x,fl,cache(iigrid)%opacity)
          call fl%get_rho(ps(igrid)%w,ps(igrid)%x,ixi^l,ixo^l,rho)
          do ix1=ixomin1,ixomax1
            do ix2=ixomin2,ixomax2
              do ix3=ixomin3,ixomax3
                if (rho(ix^d)>smalldouble) then
                  vlos=(ps(igrid)%w(ix^d,iw_mom(1))*vec_los(1)+&
                        ps(igrid)%w(ix^d,iw_mom(2))*vec_los(2)+&
                        ps(igrid)%w(ix^d,iw_mom(3))*vec_los(3))/rho(ix^d)
                  cache(iigrid)%sourcev(ix^d)=cache(iigrid)%source(ix^d)*vlos
                endif
              enddo
            enddo
          enddo
        endif
        deallocate(rho)
        cache(iigrid)%box_min(1)=rnode(rpxmin1_,igrid)
        cache(iigrid)%box_min(2)=rnode(rpxmin2_,igrid)
        cache(iigrid)%box_min(3)=rnode(rpxmin3_,igrid)
        cache(iigrid)%box_max(1)=rnode(rpxmax1_,igrid)
        cache(iigrid)%box_max(2)=rnode(rpxmax2_,igrid)
        cache(iigrid)%box_max(3)=rnode(rpxmax3_,igrid)
        call build_cart_dda_faces(ixi^l,ixo^l,ps(igrid)%x,ps(igrid)%dx,&
                                  cache(iigrid)%xface1,cache(iigrid)%xface2,&
                                  cache(iigrid)%xface3)
        call cart_dda_block_pixel_range(cache(iigrid)%box_min,cache(iigrid)%box_max,&
             nxif1,nxif2,xif1,xif2,cache(iigrid)%ixPmin1,cache(iigrid)%ixPmax1,&
             cache(iigrid)%ixPmin2,cache(iigrid)%ixPmax2,cache(iigrid)%has_pixels)
      enddo
 
      npixtotal=nxif1*nxif2
      ipixstart=1
      do while (ipixstart<=npixtotal)
        ipixend=min(nxif1*nxif2,ipixstart+npixbatchtarget-1)
        npixbatch=ipixend-ipixstart+1
        batchaccepted=.false.
        batchreduced=.false.
 
        do while (.not. batchaccepted)
          nseg=0
          capacity=0
          profile_batch=zero
 
          do iigrid=1,igridstail; igrid=igrids(iigrid);
            ^d&ixomin^d=ixmlo^d\
            ^d&ixomax^d=ixmhi^d\
            ^d&iximin^d=ixglo^d\
            ^d&iximax^d=ixghi^d\
 
            ixpmin1=cache(iigrid)%ixPmin1
            ixpmax1=cache(iigrid)%ixPmax1
            ixpmin2=cache(iigrid)%ixPmin2
            ixpmax2=cache(iigrid)%ixPmax2
            has_pixels=cache(iigrid)%has_pixels
            if (.not. has_pixels) cycle
 
            do ixp2=ixpmin2,ixpmax2
              ifirst=max(ipixstart,(ixp2-1)*nxif1+ixpmin1)
              ilast=min(ipixend,(ixp2-1)*nxif1+ixpmax1)
              if (ifirst>ilast) cycle
              do ipix=ifirst,ilast
                ixp1=1+mod(ipix-1,nxif1)
                ray_origin=x_origin+xif1(ixp1)*vec_xi1+xif2(ixp2)*vec_xi2
                profile_batch(1)=profile_batch(1)+one
                call ray_box_intersection_cart(ray_origin,vec_los,cache(iigrid)%box_min,&
                                               cache(iigrid)%box_max,hit,t_enter,t_exit)
                if (hit) then
                  profile_batch(2)=profile_batch(2)+one
                  nsegbefore=nseg
                  call collect_euv_cart_dda_segments(ixi^l,ixo^l,cache(iigrid)%source,&
                                                     cache(iigrid)%opacity,cache(iigrid)%sourcev,&
                                                     ipix,ray_origin,cache(iigrid)%xface1,&
                                                     cache(iigrid)%xface2,cache(iigrid)%xface3,&
                                                     t_enter,t_exit,&
                                                     segments,nseg,capacity)
                  profile_batch(3)=profile_batch(3)+dble(nseg-nsegbefore)
                endif
              enddo
            enddo
          enddo
 
          call mpi_allreduce(nseg,maxnsegbatch,1,mpi_integer,mpi_max,icomm,ierrmpi)
          if (maxnsegbatch>maxsegbatchtarget .and. npixbatch>1) then
            npixbatch=max(1,npixbatch/2)
            ipixend=ipixstart+npixbatch-1
            if (allocated(segments)) deallocate(segments)
            batchreduced=.true.
          else
            batchaccepted=.true.
          endif
        enddo
 
        profile_local=profile_local+profile_batch
        if (radsyn_verbose .and. mype==0 .and. batchreduced) then
          write(*,'(a,3(i0,1x))') ' cart_dda thick adaptive batch: ',&
               ipixstart,ipixend,maxnsegbatch
        endif
 
        if (.not. allocated(segments)) then
          capacity=1
          allocate(segments(nsegvars,capacity))
        endif
        ownersegcounts=0
        do is=1,nseg
          owner=segment_pixel_owner(nint(segments(1,is)))
          ownersegcounts(owner)=ownersegcounts(owner)+1
        enddo
        sendcounts=nsegvars*ownersegcounts
        senddispls(0)=0
        do ipe=1,npe-1
          senddispls(ipe)=senddispls(ipe-1)+sendcounts(ipe-1)
        enddo
 
        allocate(segments_send(nsegvars,max(1,nseg)))
        owneroffsets=0
        do is=1,nseg
          owner=segment_pixel_owner(nint(segments(1,is)))
          isegdest=senddispls(owner)/nsegvars+owneroffsets(owner)+1
          segments_send(:,isegdest)=segments(:,is)
          owneroffsets(owner)=owneroffsets(owner)+1
        enddo
 
        call mpi_alltoall(sendcounts,1,mpi_integer,recvcounts,1,mpi_integer,icomm,ierrmpi)
        recvdispls(0)=0
        do ipe=1,npe-1
          recvdispls(ipe)=recvdispls(ipe-1)+recvcounts(ipe-1)
        enddo
        totalcount=sum(recvcounts)
        totalseg=totalcount/nsegvars
        profile_local(4)=profile_local(4)+dble(totalcount)
        allocate(segments_recv(nsegvars,max(1,totalseg)))
 
        recvfill=0
        maxownersegcountlocal=maxval(ownersegcounts)
        call mpi_allreduce(maxownersegcountlocal,maxownersegcount,1,mpi_integer,mpi_max,icomm,ierrmpi)
        do segoffset=0,maxownersegcount-1,maxsegcommtarget
          roundsendcounts=0
          roundsenddispls=senddispls
          do ipe=0,npe-1
            if (ownersegcounts(ipe)>segoffset) then
              roundsendcounts(ipe)=nsegvars*min(maxsegcommtarget,ownersegcounts(ipe)-segoffset)
              roundsenddispls(ipe)=senddispls(ipe)+nsegvars*segoffset
            endif
          enddo
 
          call mpi_alltoall(roundsendcounts,1,mpi_integer,roundrecvcounts,1,mpi_integer,icomm,ierrmpi)
          roundrecvdispls(0)=0
          do ipe=1,npe-1
            roundrecvdispls(ipe)=roundrecvdispls(ipe-1)+roundrecvcounts(ipe-1)
          enddo
          totalroundcount=sum(roundrecvcounts)
          totalroundseg=totalroundcount/nsegvars
          allocate(segments_recv_round(nsegvars,max(1,totalroundseg)))
 
          call mpi_alltoallv(segments_send,roundsendcounts,roundsenddispls,mpi_double_precision,&
                             segments_recv_round,roundrecvcounts,roundrecvdispls,&
                             mpi_double_precision,icomm,ierrmpi)
 
          if (totalroundseg>0) then
            segments_recv(:,recvfill+1:recvfill+totalroundseg)=segments_recv_round(:,1:totalroundseg)
            recvfill=recvfill+totalroundseg
          endif
          deallocate(segments_recv_round)
        enddo
 
        if (recvfill/=totalseg) call mpistop("cart_dda thick segmented receive mismatch")
 
        if (totalseg>0) then
          allocate(idx(totalseg))
          bucketcounts(1:npixbatch)=0
          do is=1,totalseg
            if (segment_is_valid(segments_recv,is,nsegvars)) then
              ipix=nint(segments_recv(1,is))
              if (ipix>=ipixstart .and. ipix<=ipixend .and. segment_pixel_owner(ipix)==mype) then
                ilocal=ipix-ipixstart+1
                bucketcounts(ilocal)=bucketcounts(ilocal)+1
              endif
            endif
          enddo
 
          bucketoffsets(1)=1
          do ilocal=1,npixbatch
            bucketoffsets(ilocal+1)=bucketoffsets(ilocal)+bucketcounts(ilocal)
          enddo
          bucketfill(1:npixbatch)=bucketoffsets(1:npixbatch)
          do is=1,totalseg
            if (segment_is_valid(segments_recv,is,nsegvars)) then
              ipix=nint(segments_recv(1,is))
              if (ipix>=ipixstart .and. ipix<=ipixend .and. segment_pixel_owner(ipix)==mype) then
                ilocal=ipix-ipixstart+1
                idx(bucketfill(ilocal))=is
                bucketfill(ilocal)=bucketfill(ilocal)+1
              endif
            endif
          enddo
 
          do ipix=ipixstart,ipixend
            if (segment_pixel_owner(ipix)/=mype) cycle
            ilocal=ipix-ipixstart+1
            nidx=bucketcounts(ilocal)
            if (nidx>0) then
              profile_local(5)=profile_local(5)+dble(nidx)*dble(nidx)
              call sort_segment_indices_near_to_far(segments_recv,idx(bucketoffsets(ilocal):bucketoffsets(ilocal+1)-1),nidx)
              ixglobal=1+mod(ipix-1,nxif1)
              iyglobal=1+(ipix-1)/nxif1
              do iseg=bucketoffsets(ilocal),bucketoffsets(ilocal+1)-1
                is=idx(iseg)
                euvthin(ixglobal,iyglobal)=euvthin(ixglobal,iyglobal)+segments_recv(3,is)
                atten=transfer_attenuation(tau(ixglobal,iyglobal))
                euv(ixglobal,iyglobal)=euv(ixglobal,iyglobal)+atten*segments_recv(3,is)
                dpl(ixglobal,iyglobal)=dpl(ixglobal,iyglobal)+atten*segments_recv(5,is)
                tau(ixglobal,iyglobal)=tau(ixglobal,iyglobal)+max(zero,segments_recv(4,is))
              enddo
            endif
          enddo
          deallocate(idx)
        endif
 
        deallocate(segments_send,segments_recv)
        if (allocated(segments)) deallocate(segments)
        ipixstart=ipixend+1
      enddo
 
      do iigrid=1,igridstail
        if (allocated(cache(iigrid)%source)) deallocate(cache(iigrid)%source)
        if (allocated(cache(iigrid)%opacity)) deallocate(cache(iigrid)%opacity)
        if (allocated(cache(iigrid)%sourcev)) deallocate(cache(iigrid)%sourcev)
        if (allocated(cache(iigrid)%xface1)) deallocate(cache(iigrid)%xface1)
        if (allocated(cache(iigrid)%xface2)) deallocate(cache(iigrid)%xface2)
        if (allocated(cache(iigrid)%xface3)) deallocate(cache(iigrid)%xface3)
      enddo
      deallocate(cache)
      deallocate(sendcounts,recvcounts,senddispls,recvdispls,roundsendcounts,roundrecvcounts,&
                 roundsenddispls,roundrecvdispls,ownersegcounts,owneroffsets,bucketcounts,&
                 bucketoffsets,bucketfill)
      allocate(image_reduce(nxif1,nxif2))
      call mpi_allreduce(euv,image_reduce,nxif1*nxif2,mpi_double_precision,mpi_sum,icomm,ierrmpi)
      euv=image_reduce
      call mpi_allreduce(dpl,image_reduce,nxif1*nxif2,mpi_double_precision,mpi_sum,icomm,ierrmpi)
      dpl=image_reduce
      call mpi_allreduce(tau,image_reduce,nxif1*nxif2,mpi_double_precision,mpi_sum,icomm,ierrmpi)
      tau=image_reduce
      call mpi_allreduce(euvthin,image_reduce,nxif1*nxif2,mpi_double_precision,mpi_sum,icomm,ierrmpi)
      euvthin=image_reduce
      deallocate(image_reduce)
      call mpi_allreduce(profile_local,profile_global,5,mpi_double_precision,mpi_sum,icomm,ierrmpi)
      if (radsyn_verbose .and. mype==0) then
        write(*,'(a,5(es12.5,1x))') &
          ' cart_dda thick profile: ',profile_global
      endif
    end subroutine integrate_euv_cart_dda_thick_datresol
 
    subroutine integrate_euv_thick_datresol(nXIF1,nXIF2,fl,EUV,Dpl,Tau,EUVthin)
      use mod_global_parameters
 
      integer, intent(in) :: nXIF1,nXIF2
      type(te_fluid), intent(in) :: fl
      double precision, intent(out) :: EUV(nXIF1,nXIF2),Dpl(nXIF1,nXIF2)
      double precision, intent(out) :: Tau(nXIF1,nXIF2),EUVthin(nXIF1,nXIF2)
 
      integer :: ixO^L,ixO^D,ixI^L,ix^D
      integer :: iigrid,igrid,levelg,rft,direction_LOS,nLOS,numSeg,nLayerVars,nLayerSeg
      integer :: ixP1,ixP2,ixL,iSub1,iSub2,relL
      integer :: nLosBatch,nBatch,iBatch,ixLstart,ixLend,ixLgridStart,ixLgridEnd
      integer :: ixPmin1,ixPmin2
      double precision :: ds_cm,jds,kds,jvds,atten,layerBytes,targetBytes
      double precision, allocatable :: rho(:^D&)
      double precision, allocatable :: layer_ds(:,:,:,:),layer_all(:,:,:,:)
      type(radsyn_euv_cache), allocatable :: cache(:)
 
      if (los_phi==0 .and. los_theta==90) then
        direction_los=1
        nlos=domain_nx1*2**(refine_max_level-1)
      else if (los_phi==90 .and. los_theta==90) then
        direction_los=2
        nlos=domain_nx2*2**(refine_max_level-1)
      else
        direction_los=3
        nlos=domain_nx3*2**(refine_max_level-1)
      endif
 
      nlayervars=3
      if (nxif1>huge(numseg)/max(1,nxif2) .or. nxif1*nxif2>huge(numseg)/nlayervars) then
        call mpistop("thick EUV layer buffer is too large for one MPI reduction")
      endif
      nlayerseg=nxif1*nxif2*nlayervars
      targetbytes=256.d0*1024.d0*1024.d0
      layerbytes=dble(nlayerseg)*8.d0*2.d0
      nlosbatch=max(1,min(16,int(targetbytes/max(one,layerbytes))))
      if (nlayerseg>huge(numseg)/nlosbatch) then
        call mpistop("thick EUV batched layer buffer is too large for one MPI reduction")
      endif
 
      allocate(cache(igridstail))
      do iigrid=1,igridstail; igrid=igrids(iigrid);
        ^d&ixomin^d=ixmlo^d\
        ^d&ixomax^d=ixmhi^d\
        ^d&iximin^d=ixglo^d\
        ^d&iximax^d=ixghi^d\
 
        cache(iigrid)%igrid=igrid
        levelg=ps(igrid)%level
        rft=2**(refine_max_level-levelg)
        cache(iigrid)%level=levelg
        cache(iigrid)%rft=rft
 
        select case(direction_los)
        case(1)
          cache(iigrid)%los_min=(node(pig1_,igrid)-1)*rft*block_nx1+1
          cache(iigrid)%los_max=node(pig1_,igrid)*rft*block_nx1
        case(2)
          cache(iigrid)%los_min=(node(pig2_,igrid)-1)*rft*block_nx2+1
          cache(iigrid)%los_max=node(pig2_,igrid)*rft*block_nx2
        case(3)
          cache(iigrid)%los_min=(node(pig3_,igrid)-1)*rft*block_nx3+1
          cache(iigrid)%los_max=node(pig3_,igrid)*rft*block_nx3
        end select
 
        allocate(cache(iigrid)%source(ixi^s),cache(iigrid)%opacity(ixi^s),&
                 cache(iigrid)%sourcev(ixi^s),rho(ixi^s))
        cache(iigrid)%source=zero
        cache(iigrid)%opacity=zero
        cache(iigrid)%sourcev=zero
        if (trim(emission_model)=='radio_ff') then
          call get_radio_ff_source_opacity(ixi^l,ixo^l,ps(igrid)%w,ps(igrid)%x,fl,&
                                           cache(iigrid)%source,cache(iigrid)%opacity)
        else
          call get_euv(wavelength,ixi^l,ixo^l,ps(igrid)%w,ps(igrid)%x,fl,cache(iigrid)%source)
          cache(iigrid)%source(ixo^s)=cache(iigrid)%source(ixo^s)/instrument_resolution_factor**2
          call get_euv_hhe_opacity(wavelength,ixi^l,ixo^l,ps(igrid)%w,ps(igrid)%x,fl,cache(iigrid)%opacity)
          call fl%get_rho(ps(igrid)%w,ps(igrid)%x,ixi^l,ixo^l,rho)
          cache(iigrid)%sourcev(ixo^s)=cache(iigrid)%source(ixo^s)*&
                                       (-ps(igrid)%w(ixo^s,iw_mom(direction_los))/rho(ixo^s))
        endif
        deallocate(rho)
      enddo
 
      ! Stream a small batch of finest LOS layers; this avoids a full Npix*Nlos column buffer.
      allocate(layer_ds(nxif1,nxif2,nlayervars,nlosbatch),layer_all(nxif1,nxif2,nlayervars,nlosbatch))
      euv=zero
      dpl=zero
      tau=zero
      euvthin=zero
 
      do ixlstart=1,nlos,nlosbatch
        ixlend=min(nlos,ixlstart+nlosbatch-1)
        nbatch=ixlend-ixlstart+1
        layer_ds(:,:,:,1:nbatch)=zero
 
        do iigrid=1,igridstail
          ixlgridstart=max(ixlstart,cache(iigrid)%los_min)
          ixlgridend=min(ixlend,cache(iigrid)%los_max)
          if (ixlgridstart>ixlgridend) cycle
          igrid=cache(iigrid)%igrid
          rft=cache(iigrid)%rft
          ^d&ixomin^d=ixmlo^d\
          ^d&ixomax^d=ixmhi^d\
          ^d&iximin^d=ixglo^d\
          ^d&iximax^d=ixghi^d\
 
          do ixl=ixlgridstart,ixlgridend
            ibatch=ixl-ixlstart+1
            rell=ixl-cache(iigrid)%los_min
 
            select case(direction_los)
            case(1)
              ix1=ixomin1+rell/rft
              do ix2=ixomin2,ixomax2
                ixpmin1=(node(pig2_,igrid)-1)*rft*block_nx2+(ix2-ixomin2)*rft+1
                do ix3=ixomin3,ixomax3
                  ixpmin2=(node(pig3_,igrid)-1)*rft*block_nx3+(ix3-ixomin3)*rft+1
                  ds_cm=ps(igrid)%dx(ix^d,1)*unit_length/dble(rft)
                  if (si_unit) ds_cm=ds_cm*1.d2
                  jds=cache(iigrid)%source(ix^d)*ds_cm
                  kds=cache(iigrid)%opacity(ix^d)*ds_cm
                  jvds=cache(iigrid)%sourcev(ix^d)*ds_cm
                  do isub1=0,rft-1
                    ixp1=ixpmin1+isub1
                    do isub2=0,rft-1
                      ixp2=ixpmin2+isub2
                      layer_ds(ixp1,ixp2,1,ibatch)=layer_ds(ixp1,ixp2,1,ibatch)+jds
                      layer_ds(ixp1,ixp2,2,ibatch)=layer_ds(ixp1,ixp2,2,ibatch)+kds
                      layer_ds(ixp1,ixp2,3,ibatch)=layer_ds(ixp1,ixp2,3,ibatch)+jvds
                    enddo
                  enddo
                enddo
              enddo
            case(2)
              ix2=ixomin2+rell/rft
              do ix3=ixomin3,ixomax3
                ixpmin1=(node(pig3_,igrid)-1)*rft*block_nx3+(ix3-ixomin3)*rft+1
                do ix1=ixomin1,ixomax1
                  ixpmin2=(node(pig1_,igrid)-1)*rft*block_nx1+(ix1-ixomin1)*rft+1
                  ds_cm=ps(igrid)%dx(ix^d,2)*unit_length/dble(rft)
                  if (si_unit) ds_cm=ds_cm*1.d2
                  jds=cache(iigrid)%source(ix^d)*ds_cm
                  kds=cache(iigrid)%opacity(ix^d)*ds_cm
                  jvds=cache(iigrid)%sourcev(ix^d)*ds_cm
                  do isub1=0,rft-1
                    ixp1=ixpmin1+isub1
                    do isub2=0,rft-1
                      ixp2=ixpmin2+isub2
                      layer_ds(ixp1,ixp2,1,ibatch)=layer_ds(ixp1,ixp2,1,ibatch)+jds
                      layer_ds(ixp1,ixp2,2,ibatch)=layer_ds(ixp1,ixp2,2,ibatch)+kds
                      layer_ds(ixp1,ixp2,3,ibatch)=layer_ds(ixp1,ixp2,3,ibatch)+jvds
                    enddo
                  enddo
                enddo
              enddo
            case(3)
              ix3=ixomin3+rell/rft
              do ix1=ixomin1,ixomax1
                ixpmin1=(node(pig1_,igrid)-1)*rft*block_nx1+(ix1-ixomin1)*rft+1
                do ix2=ixomin2,ixomax2
                  ixpmin2=(node(pig2_,igrid)-1)*rft*block_nx2+(ix2-ixomin2)*rft+1
                  ds_cm=ps(igrid)%dx(ix^d,3)*unit_length/dble(rft)
                  if (si_unit) ds_cm=ds_cm*1.d2
                  jds=cache(iigrid)%source(ix^d)*ds_cm
                  kds=cache(iigrid)%opacity(ix^d)*ds_cm
                  jvds=cache(iigrid)%sourcev(ix^d)*ds_cm
                  do isub1=0,rft-1
                    ixp1=ixpmin1+isub1
                    do isub2=0,rft-1
                      ixp2=ixpmin2+isub2
                      layer_ds(ixp1,ixp2,1,ibatch)=layer_ds(ixp1,ixp2,1,ibatch)+jds
                      layer_ds(ixp1,ixp2,2,ibatch)=layer_ds(ixp1,ixp2,2,ibatch)+kds
                      layer_ds(ixp1,ixp2,3,ibatch)=layer_ds(ixp1,ixp2,3,ibatch)+jvds
                    enddo
                  enddo
                enddo
              enddo
            end select
          enddo
        enddo
 
        numseg=nlayerseg*nbatch
        call mpi_allreduce(layer_ds,layer_all,numseg,mpi_double_precision,mpi_sum,icomm,ierrmpi)
 
        do ibatch=1,nbatch
          !$OMP PARALLEL DO COLLAPSE(2) PRIVATE(atten) SCHEDULE(static)
          do ixp1=1,nxif1
            do ixp2=1,nxif2
              euvthin(ixp1,ixp2)=euvthin(ixp1,ixp2)+layer_all(ixp1,ixp2,1,ibatch)
              atten=transfer_attenuation(tau(ixp1,ixp2))
              euv(ixp1,ixp2)=euv(ixp1,ixp2)+atten*layer_all(ixp1,ixp2,1,ibatch)
              dpl(ixp1,ixp2)=dpl(ixp1,ixp2)+atten*layer_all(ixp1,ixp2,3,ibatch)
              tau(ixp1,ixp2)=tau(ixp1,ixp2)+layer_all(ixp1,ixp2,2,ibatch)
            enddo
          enddo
          !$OMP END PARALLEL DO
        enddo
      enddo
 
      do iigrid=1,igridstail
        if (allocated(cache(iigrid)%source)) deallocate(cache(iigrid)%source)
        if (allocated(cache(iigrid)%opacity)) deallocate(cache(iigrid)%opacity)
        if (allocated(cache(iigrid)%sourcev)) deallocate(cache(iigrid)%sourcev)
      enddo
      deallocate(cache,layer_ds,layer_all)
 
    end subroutine integrate_euv_thick_datresol
 
  }
 
  {^ifthreed
 
    subroutine build_sph_intersection_faces(ixI^L,ixO^L,x,dx,rface,thetaface,phiface)
      integer, intent(in) :: ixI^L, ixO^L
      double precision, intent(in) :: x(ixI^S,1:ndim),dx(ixI^S,1:ndim)
      double precision, allocatable, intent(out) :: rface(:),thetaface(:),phiface(:)
      integer :: ix1,ix2,ix3
 
      allocate(rface(ixomin1:ixomax1+1),thetaface(ixomin2:ixomax2+1),phiface(ixomin3:ixomax3+1))
      do ix1=ixomin1,ixomax1
        rface(ix1)=x(ix1,ixomin2,ixomin3,1)-half*dx(ix1,ixomin2,ixomin3,1)
      enddo
      rface(ixomax1+1)=x(ixomax1,ixomin2,ixomin3,1)+half*dx(ixomax1,ixomin2,ixomin3,1)
      do ix2=ixomin2,ixomax2
        thetaface(ix2)=x(ixomin1,ix2,ixomin3,2)-half*dx(ixomin1,ix2,ixomin3,2)
      enddo
      thetaface(ixomax2+1)=x(ixomin1,ixomax2,ixomin3,2)+half*dx(ixomin1,ixomax2,ixomin3,2)
      do ix3=ixomin3,ixomax3
        phiface(ix3)=x(ixomin1,ixomin2,ix3,3)-half*dx(ixomin1,ixomin2,ix3,3)
      enddo
      phiface(ixomax3+1)=x(ixomin1,ixomin2,ixomax3,3)+half*dx(ixomin1,ixomin2,ixomax3,3)
    end subroutine build_sph_intersection_faces
 
    subroutine sph_add_t(tvals,nt,capacity,t)
      double precision, allocatable, intent(inout) :: tvals(:)
      integer, intent(inout) :: nt,capacity
      double precision, intent(in) :: t
 
      double precision, allocatable :: tmp(:)
 
      if (t /= t .or. abs(t)>1.d90) return
      if (.not. allocated(tvals)) then
        capacity=64
        allocate(tvals(capacity))
      else if (nt>=capacity) then
        allocate(tmp(capacity))
        tmp=tvals
        deallocate(tvals)
        allocate(tvals(2*capacity))
        tvals(1:capacity)=tmp
        deallocate(tmp)
        capacity=2*capacity
      endif
      nt=nt+1
      tvals(nt)=t
    end subroutine sph_add_t
 
    subroutine sph_add_t_fixed(tvals,nt,t)
      double precision, intent(inout) :: tvals(:)
      integer, intent(inout) :: nt
      double precision, intent(in) :: t
 
      if (t /= t .or. abs(t)>1.d90) return
      if (nt>=size(tvals)) return
      nt=nt+1
      tvals(nt)=t
    end subroutine sph_add_t_fixed
 
    subroutine sph_sort_unique_t(tvals,nt)
      double precision, intent(inout) :: tvals(:)
      integer, intent(inout) :: nt
 
      integer :: i,j,nout
      double precision :: key,epsT
 
      if (nt<=1) return
      do i=2,nt
        key=tvals(i)
        j=i-1
        do while (j>=1 .and. tvals(j)>key)
          tvals(j+1)=tvals(j)
          j=j-1
        enddo
        tvals(j+1)=key
      enddo
      epst=max(1.d-12,1.d-10*max(one,abs(tvals(nt)-tvals(1))))
      nout=1
      do i=2,nt
        if (abs(tvals(i)-tvals(nout))>epst) then
          nout=nout+1
          tvals(nout)=tvals(i)
        endif
      enddo
      nt=nout
    end subroutine sph_sort_unique_t
 
    subroutine sph_add_sphere_intersections(ray_origin,ray_dir,rface,tvals,nt,capacity)
      double precision, intent(in) :: ray_origin(1:3),ray_dir(1:3),rface
      double precision, allocatable, intent(inout) :: tvals(:)
      integer, intent(inout) :: nt,capacity
 
      double precision :: aa,bb,cc,disc,root
 
      aa=sum(ray_dir**2)
      bb=2.d0*sum(ray_origin*ray_dir)
      cc=sum(ray_origin**2)-rface**2
      disc=bb**2-4.d0*aa*cc
      if (disc<zero) return
      root=sqrt(max(zero,disc))
      call sph_add_t(tvals,nt,capacity,(-bb-root)/(2.d0*aa))
      call sph_add_t(tvals,nt,capacity,(-bb+root)/(2.d0*aa))
    end subroutine sph_add_sphere_intersections
 
    subroutine sph_add_theta_intersections(ray_origin,ray_dir,thetaface,tvals,nt,capacity)
      double precision, intent(in) :: ray_origin(1:3),ray_dir(1:3),thetaface
      double precision, allocatable, intent(inout) :: tvals(:)
      integer, intent(inout) :: nt,capacity
 
      double precision :: cth,aa,bb,cc,disc,root
 
      cth=cos(thetaface)
      aa=ray_dir(3)**2-cth**2*sum(ray_dir**2)
      bb=2.d0*(ray_origin(3)*ray_dir(3)-cth**2*sum(ray_origin*ray_dir))
      cc=ray_origin(3)**2-cth**2*sum(ray_origin**2)
      if (abs(aa)<1.d-14) then
        if (abs(bb)>1.d-14) call sph_add_t(tvals,nt,capacity,-cc/bb)
        return
      endif
      disc=bb**2-4.d0*aa*cc
      if (disc<zero) return
      root=sqrt(max(zero,disc))
      call sph_add_t(tvals,nt,capacity,(-bb-root)/(2.d0*aa))
      call sph_add_t(tvals,nt,capacity,(-bb+root)/(2.d0*aa))
    end subroutine sph_add_theta_intersections
 
    subroutine sph_add_phi_intersection(ray_origin,ray_dir,phiface,tvals,nt,capacity)
      double precision, intent(in) :: ray_origin(1:3),ray_dir(1:3),phiface
      double precision, allocatable, intent(inout) :: tvals(:)
      integer, intent(inout) :: nt,capacity
 
      double precision :: normal(1:3),denom,numer
 
      normal(1)=-sin(phiface)
      normal(2)=cos(phiface)
      normal(3)=zero
      denom=sum(normal*ray_dir)
      if (abs(denom)<1.d-14) return
      numer=sum(normal*ray_origin)
      call sph_add_t(tvals,nt,capacity,-numer/denom)
    end subroutine sph_add_phi_intersection
 
    subroutine sph_cart_to_coord(pos,sph)
      double precision, intent(in) :: pos(1:3)
      double precision, intent(out) :: sph(1:3)
 
      sph(1)=sqrt(sum(pos**2))
      if (sph(1)>zero) then
        sph(2)=acos(max(-one,min(one,pos(3)/sph(1))))
      else
        sph(2)=zero
      endif
      sph(3)=atan2(pos(2),pos(1))
    end subroutine sph_cart_to_coord
 
    integer function sph_locate_index(value,faces,imin,imax) result(idx)
      integer, intent(in) :: imin,imax
      double precision, intent(in) :: value,faces(imin:imax+1)
 
      integer :: ilo,ihi,imid
 
      idx=0
      if (value<faces(imin)-1.d-12 .or. value>faces(imax+1)+1.d-12) return
      if (value<=faces(imin)) then
        idx=imin
        return
      endif
      if (value>=faces(imax+1)) then
        idx=imax
        return
      endif
 
      ilo=imin
      ihi=imax+1
      do while (ihi-ilo>1)
        imid=(ilo+ihi)/2
        if (value>=faces(imid)) then
          ilo=imid
        else
          ihi=imid
        endif
      enddo
      idx=min(imax,max(imin,ilo))
    end function sph_locate_index
 
    integer function sph_locate_index_desc(value,faces,imin,imax) result(idx)
      integer, intent(in) :: imin,imax
      double precision, intent(in) :: value,faces(imin:imax+1)
 
      integer :: ilo,ihi,imid
 
      idx=0
      if (value>faces(imin)+1.d-12 .or. value<faces(imax+1)-1.d-12) return
      if (value>=faces(imin)) then
        idx=imin
        return
      endif
      if (value<=faces(imax+1)) then
        idx=imax
        return
      endif
 
      ilo=imin
      ihi=imax+1
      do while (ihi-ilo>1)
        imid=(ilo+ihi)/2
        if (value<=faces(imid)) then
          ilo=imid
        else
          ihi=imid
        endif
      enddo
      idx=min(imax,max(imin,ilo))
    end function sph_locate_index_desc
 
    subroutine sph_locate_cell(pos,rface,thetaface,phiface,ixO^L,ix1,ix2,ix3,inside)
      double precision, intent(in) :: pos(1:3)
      double precision, intent(in) :: rface(ixOmin1:ixOmax1+1),thetaface(ixOmin2:ixOmax2+1),&
                                      phiface(ixOmin3:ixOmax3+1)
      integer, intent(in) :: ixO^L
      integer, intent(out) :: ix1,ix2,ix3
      logical, intent(out) :: inside
 
      double precision :: sph(1:3),phi
 
      call sph_cart_to_coord(pos,sph)
      phi=sph(3)
      if (phi<phiface(ixomin3)-1.d-12) phi=phi+2.d0*dpi
      if (phi>phiface(ixomax3+1)+1.d-12) phi=phi-2.d0*dpi
      ix1=sph_locate_index(sph(1),rface,ixomin1,ixomax1)
      ix2=sph_locate_index(sph(2),thetaface,ixomin2,ixomax2)
      ix3=sph_locate_index(phi,phiface,ixomin3,ixomax3)
      inside=ix1>0 .and. ix2>0 .and. ix3>0
    end subroutine sph_locate_cell
 
    logical function sph_segment_visible(pos,ximg1,ximg2) result(visible)
      use mod_constants
      double precision, intent(in) :: pos(1:3),ximg1,ximg2
 
      double precision :: dotp,rc,rthick,rloc
 
      rthick=r_opt_thick*const_rsun/unit_length
      rc=sqrt(ximg1**2+ximg2**2)
      rloc=sqrt(sum(pos**2))
      call dot_product_loc(vec_los,pos,dotp)
      visible=.true.
      if (dotp>=zero) then
        if (rc<=rthick) visible=.false.
      else
        if (rloc<=rthick) visible=.false.
      endif
    end function sph_segment_visible
 
    subroutine sph_block_pixel_range(rface,thetaface,phiface,ixO^L,nXI1,nXI2,xI1,xI2,dxI,&
                                     ixPmin1,ixPmax1,ixPmin2,ixPmax2,has_pixels)
      double precision, intent(in) :: rface(ixOmin1:ixOmax1+1),thetaface(ixOmin2:ixOmax2+1),&
                                      phiface(ixOmin3:ixOmax3+1)
      integer, intent(in) :: ixO^L,nXI1,nXI2
      double precision, intent(in) :: xI1(nXI1),xI2(nXI2),dxI
      integer, intent(out) :: ixPmin1,ixPmax1,ixPmin2,ixPmax2
      logical, intent(out) :: has_pixels
 
      integer, parameter :: nsample=5
      integer :: ir,it,ip
      double precision :: sph(1:3),xcent(1:2)
      double precision :: xmin1,xmax1,xmin2,xmax2
      double precision :: wr,wt,wp,pad
 
      has_pixels=.false.
      xmin1=huge(one)
      xmax1=-huge(one)
      xmin2=huge(one)
      xmax2=-huge(one)
      do ir=0,nsample-1
        wr=dble(ir)/dble(nsample-1)
        sph(1)=(one-wr)*rface(ixomin1)+wr*rface(ixomax1+1)
        do it=0,nsample-1
          wt=dble(it)/dble(nsample-1)
          sph(2)=(one-wt)*thetaface(ixomin2)+wt*thetaface(ixomax2+1)
          do ip=0,nsample-1
            wp=dble(ip)/dble(nsample-1)
            if (ir/=0 .and. ir/=nsample-1 .and. it/=0 .and. it/=nsample-1 .and. &
                ip/=0 .and. ip/=nsample-1) cycle
            sph(3)=(one-wp)*phiface(ixomin3)+wp*phiface(ixomax3+1)
            call get_cor_image_spherical(sph,xcent)
            xmin1=min(xmin1,xcent(1))
            xmax1=max(xmax1,xcent(1))
            xmin2=min(xmin2,xcent(2))
            xmax2=max(xmax2,xcent(2))
          enddo
        enddo
      enddo
      pad=2.d0*dxi
      xmin1=xmin1-pad
      xmax1=xmax1+pad
      xmin2=xmin2-pad
      xmax2=xmax2+pad
      ixpmin1=max(1,floor((xmin1-(xi1(1)-half*dxi))/dxi)+1)
      ixpmax1=min(nxi1,ceiling((xmax1-(xi1(1)-half*dxi))/dxi))
      ixpmin2=max(1,floor((xmin2-(xi2(1)-half*dxi))/dxi)+1)
      ixpmax2=min(nxi2,ceiling((xmax2-(xi2(1)-half*dxi))/dxi))
      has_pixels=ixpmin1<=ixpmax1 .and. ixpmin2<=ixpmax2
    end subroutine sph_block_pixel_range
 
    subroutine acc_euv_sph_intersection(ixI^L,ixO^L,source,ray_origin,ximg1,ximg2,&
                                        rface,thetaface,phiface,EUVp)
      integer, intent(in) :: ixI^L,ixO^L
      double precision, intent(in) :: source(ixI^S),ray_origin(1:3),ximg1,ximg2
      double precision, intent(in) :: rface(ixOmin1:ixOmax1+1),thetaface(ixOmin2:ixOmax2+1),&
                                      phiface(ixOmin3:ixOmax3+1)
      double precision, intent(inout) :: EUVp
 
      integer :: nt,capacity,i,ix^D
      double precision, allocatable :: tvals(:)
      double precision :: posMid(1:3),ds_cm,tMid,t0,t1
      logical :: inside
 
      nt=0
      capacity=0
      do ix1=ixomin1,ixomax1+1
        call sph_add_sphere_intersections(ray_origin,vec_los,rface(ix1),tvals,nt,capacity)
      enddo
      do ix2=ixomin2,ixomax2+1
        call sph_add_theta_intersections(ray_origin,vec_los,thetaface(ix2),tvals,nt,capacity)
      enddo
      do ix3=ixomin3,ixomax3+1
        call sph_add_phi_intersection(ray_origin,vec_los,phiface(ix3),tvals,nt,capacity)
      enddo
      if (nt<2) then
        if (allocated(tvals)) deallocate(tvals)
        return
      endif
      call sph_sort_unique_t(tvals,nt)
 
      do i=1,nt-1
        t0=tvals(i)
        t1=tvals(i+1)
        if (t1<=t0) cycle
        tmid=half*(t0+t1)
        posmid=ray_origin+tmid*vec_los
        if (.not. sph_segment_visible(posmid,ximg1,ximg2)) cycle
        call sph_locate_cell(posmid,rface,thetaface,phiface,ixo^l,ix1,ix2,ix3,inside)
        if (.not. inside) cycle
        ds_cm=(t1-t0)*unit_length
        if (si_unit) ds_cm=ds_cm*1.d2
        euvp=euvp+source(ix^d)*ds_cm
      enddo
      deallocate(tvals)
    end subroutine acc_euv_sph_intersection
 
    subroutine collect_euv_sph_intersection_segments(ixI^L,ixO^L,source,opacity,&
                                                     pixel_id,ray_origin,ximg1,ximg2,&
                                                     rface,thetaface,phiface,rface2,&
                                                     theta_cos,phi_sin,phi_cos,&
                                                     segments,nseg,capacity)
      use mod_constants, only: const_rsun
 
      integer, intent(in) :: ixI^L,ixO^L,pixel_id
      double precision, intent(in) :: source(ixI^S),opacity(ixI^S)
      double precision, intent(in) :: ray_origin(1:3),ximg1,ximg2
      double precision, intent(in) :: rface(ixOmin1:ixOmax1+1),thetaface(ixOmin2:ixOmax2+1),&
                                      phiface(ixOmin3:ixOmax3+1)
      double precision, intent(in) :: rface2(ixOmin1:ixOmax1+1),theta_cos(ixOmin2:ixOmax2+1),&
                                      phi_sin(ixOmin3:ixOmax3+1),phi_cos(ixOmin3:ixOmax3+1)
      double precision, allocatable, intent(inout) :: segments(:,:)
      integer, intent(inout) :: nseg,capacity
 
      integer :: nt,i,ix^D
      double precision :: tvals(2*(ixOmax1-ixOmin1+2)+2*(ixOmax2-ixOmin2+2)+&
                                (ixOmax3-ixOmin3+2))
      double precision :: posMid(1:3),ds_cm,tMid,t0,t1,jds,kds
      double precision :: dir2,origin2,odotd,aa,bb,cc,disc,root,cth2
      double precision :: denom,numer,r2,mu,phi,dotp,rthick2,rc2
      logical :: inside
 
      nt=0
      dir2=sum(vec_los**2)
      origin2=sum(ray_origin**2)
      odotd=sum(ray_origin*vec_los)
      rthick2=(r_opt_thick*const_rsun/unit_length)**2
      rc2=ximg1**2+ximg2**2
 
      do ix1=ixomin1,ixomax1+1
        aa=dir2
        bb=2.d0*odotd
        cc=origin2-rface2(ix1)
        disc=bb**2-4.d0*aa*cc
        if (disc>=zero) then
          root=sqrt(max(zero,disc))
          call sph_add_t_fixed(tvals,nt,(-bb-root)/(2.d0*aa))
          call sph_add_t_fixed(tvals,nt,(-bb+root)/(2.d0*aa))
        endif
      enddo
      do ix2=ixomin2,ixomax2+1
        cth2=theta_cos(ix2)**2
        aa=vec_los(3)**2-cth2*dir2
        bb=2.d0*(ray_origin(3)*vec_los(3)-cth2*odotd)
        cc=ray_origin(3)**2-cth2*origin2
        if (abs(aa)<1.d-14) then
          if (abs(bb)>1.d-14) call sph_add_t_fixed(tvals,nt,-cc/bb)
        else
          disc=bb**2-4.d0*aa*cc
          if (disc>=zero) then
            root=sqrt(max(zero,disc))
            call sph_add_t_fixed(tvals,nt,(-bb-root)/(2.d0*aa))
            call sph_add_t_fixed(tvals,nt,(-bb+root)/(2.d0*aa))
          endif
        endif
      enddo
      do ix3=ixomin3,ixomax3+1
        denom=-phi_sin(ix3)*vec_los(1)+phi_cos(ix3)*vec_los(2)
        if (abs(denom)>=1.d-14) then
          numer=-phi_sin(ix3)*ray_origin(1)+phi_cos(ix3)*ray_origin(2)
          call sph_add_t_fixed(tvals,nt,-numer/denom)
        endif
      enddo
      if (nt<2) return
      call sph_sort_unique_t(tvals,nt)
 
      do i=1,nt-1
        t0=tvals(i)
        t1=tvals(i+1)
        if (t1<=t0) cycle
        tmid=half*(t0+t1)
        posmid=ray_origin+tmid*vec_los
        r2=sum(posmid**2)
        dotp=sum(vec_los*posmid)
        if (dotp>=zero) then
          if (rc2<=rthick2) cycle
        else
          if (r2<=rthick2) cycle
        endif
 
        ix1=sph_locate_index(r2,rface2,ixomin1,ixomax1)
        if (r2>zero) then
          mu=posmid(3)/sqrt(r2)
        else
          mu=one
        endif
        ix2=sph_locate_index_desc(mu,theta_cos,ixomin2,ixomax2)
        phi=atan2(posmid(2),posmid(1))
        if (phi<phiface(ixomin3)-1.d-12) phi=phi+2.d0*dpi
        if (phi>phiface(ixomax3+1)+1.d-12) phi=phi-2.d0*dpi
        ix3=sph_locate_index(phi,phiface,ixomin3,ixomax3)
        inside=ix1>0 .and. ix2>0 .and. ix3>0
        if (.not. inside) cycle
        ds_cm=(t1-t0)*unit_length
        if (si_unit) ds_cm=ds_cm*1.d2
        jds=max(zero,source(ix^d))*ds_cm
        kds=max(zero,opacity(ix^d))*ds_cm
        call append_cart_dda_segment(segments,nseg,capacity,pixel_id,tmid,jds,kds,zero)
      enddo
    end subroutine collect_euv_sph_intersection_segments
 
    subroutine sph_locate_cell_fast(pos,rface2,theta_cos,phiface,ixO^L,ix1,ix2,ix3,inside)
      double precision, intent(in) :: pos(1:3)
      double precision, intent(in) :: rface2(ixOmin1:ixOmax1+1),theta_cos(ixOmin2:ixOmax2+1),&
                                      phiface(ixOmin3:ixOmax3+1)
      integer, intent(in) :: ixO^L
      integer, intent(out) :: ix1,ix2,ix3
      logical, intent(out) :: inside
 
      double precision :: r2,mu,phi
 
      r2=sum(pos**2)
      ix1=sph_locate_index(r2,rface2,ixomin1,ixomax1)
      if (r2>zero) then
        mu=pos(3)/sqrt(r2)
      else
        mu=one
      endif
      ix2=sph_locate_index_desc(mu,theta_cos,ixomin2,ixomax2)
      phi=atan2(pos(2),pos(1))
      if (phi<phiface(ixomin3)-1.d-12) phi=phi+2.d0*dpi
      if (phi>phiface(ixomax3+1)+1.d-12) phi=phi-2.d0*dpi
      ix3=sph_locate_index(phi,phiface,ixomin3,ixomax3)
      inside=ix1>0 .and. ix2>0 .and. ix3>0
    end subroutine sph_locate_cell_fast
 
    subroutine sph_try_exit_candidate(t,tNow,tExit,epsRay,tNext,found)
      double precision, intent(in) :: t,tNow,tExit,epsRay
      double precision, intent(inout) :: tNext
      logical, intent(inout) :: found
 
      if (t>tnow+epsray .and. t<=texit+epsray .and. t<tnext) then
        tnext=t
        found=.true.
      endif
    end subroutine sph_try_exit_candidate
 
    subroutine sph_try_theta_exit_candidate(t,theta_face_cos,ray_origin,tNow,tExit,epsRay,tNext,found)
      double precision, intent(in) :: t,theta_face_cos,ray_origin(1:3),tNow,tExit,epsRay
      double precision, intent(inout) :: tNext
      logical, intent(inout) :: found
 
      double precision :: pos(1:3),r2
 
      if (t<=tnow+epsray .or. t>texit+epsray .or. t>=tnext) return
      pos=ray_origin+t*vec_los
      r2=sum(pos**2)
      if (r2<=zero) return
      if (theta_face_cos>1.d-12 .and. pos(3)<-1.d-10) return
      if (theta_face_cos<-1.d-12 .and. pos(3)>1.d-10) return
      if (abs(pos(3)**2-theta_face_cos**2*r2)>1.d-6*max(one,r2)) return
      tnext=t
      found=.true.
    end subroutine sph_try_theta_exit_candidate
 
    subroutine sph_try_phi_exit_candidate(t,phi_face_sin,phi_face_cos,ray_origin,tNow,tExit,epsRay,tNext,found)
      double precision, intent(in) :: t,phi_face_sin,phi_face_cos,ray_origin(1:3),tNow,tExit,epsRay
      double precision, intent(inout) :: tNext
      logical, intent(inout) :: found
 
      double precision :: pos(1:3),radialDot
 
      if (t<=tnow+epsray .or. t>texit+epsray .or. t>=tnext) return
      pos=ray_origin+t*vec_los
      radialdot=phi_face_cos*pos(1)+phi_face_sin*pos(2)
      if (radialdot<-1.d-10) return
      tnext=t
      found=.true.
    end subroutine sph_try_phi_exit_candidate
 
    subroutine sph_next_cell_exit(ray_origin,rface2,theta_cos,phiface,phi_sin,phi_cos,ixO^L,&
                                  ix1,ix2,ix3,tNow,tExit,epsRay,tNext,found)
      double precision, intent(in) :: ray_origin(1:3)
      double precision, intent(in) :: rface2(ixOmin1:ixOmax1+1),theta_cos(ixOmin2:ixOmax2+1),&
                                      phiface(ixOmin3:ixOmax3+1)
      double precision, intent(in) :: phi_sin(ixOmin3:ixOmax3+1),phi_cos(ixOmin3:ixOmax3+1)
      integer, intent(in) :: ixO^L,ix1,ix2,ix3
      double precision, intent(in) :: tNow,tExit,epsRay
      double precision, intent(out) :: tNext
      logical, intent(out) :: found
 
      integer :: iface
      double precision :: dir2,origin2,odotd,aa,bb,cc,disc,root,cth2,denom,numer
 
      found=.false.
      tnext=huge(one)
      dir2=sum(vec_los**2)
      origin2=sum(ray_origin**2)
      odotd=sum(ray_origin*vec_los)
 
      do iface=ix1,ix1+1
        aa=dir2
        bb=2.d0*odotd
        cc=origin2-rface2(iface)
        disc=bb**2-4.d0*aa*cc
        if (disc>=zero) then
          root=sqrt(max(zero,disc))
          call sph_try_exit_candidate((-bb-root)/(2.d0*aa),tnow,texit,epsray,tnext,found)
          call sph_try_exit_candidate((-bb+root)/(2.d0*aa),tnow,texit,epsray,tnext,found)
        endif
      enddo
 
      do iface=ix2,ix2+1
        cth2=theta_cos(iface)**2
        aa=vec_los(3)**2-cth2*dir2
        bb=2.d0*(ray_origin(3)*vec_los(3)-cth2*odotd)
        cc=ray_origin(3)**2-cth2*origin2
        if (abs(aa)<1.d-14) then
          if (abs(bb)>1.d-14) call sph_try_theta_exit_candidate(-cc/bb,theta_cos(iface),&
               ray_origin,tnow,texit,epsray,tnext,found)
        else
          disc=bb**2-4.d0*aa*cc
          if (disc>=zero) then
            root=sqrt(max(zero,disc))
            call sph_try_theta_exit_candidate((-bb-root)/(2.d0*aa),theta_cos(iface),&
                 ray_origin,tnow,texit,epsray,tnext,found)
            call sph_try_theta_exit_candidate((-bb+root)/(2.d0*aa),theta_cos(iface),&
                 ray_origin,tnow,texit,epsray,tnext,found)
          endif
        endif
      enddo
 
      do iface=ix3,ix3+1
        denom=-phi_sin(iface)*vec_los(1)+phi_cos(iface)*vec_los(2)
        if (abs(denom)>=1.d-14) then
          numer=-phi_sin(iface)*ray_origin(1)+phi_cos(iface)*ray_origin(2)
          call sph_try_phi_exit_candidate(-numer/denom,phi_sin(iface),phi_cos(iface),ray_origin,&
               tnow,texit,epsray,tnext,found)
        endif
      enddo
    end subroutine sph_next_cell_exit
 
    subroutine collect_euv_sph_dda_interval(ixI^L,ixO^L,source,opacity,pixel_id,&
                                            ray_origin,ximg1,ximg2,rface2,theta_cos,phiface,&
                                            phi_sin,phi_cos,&
                                            t_enter,t_exit,segments,nseg,capacity,ok)
      use mod_constants, only: const_rsun
 
      integer, intent(in) :: ixI^L,ixO^L,pixel_id
      double precision, intent(in) :: source(ixI^S),opacity(ixI^S)
      double precision, intent(in) :: ray_origin(1:3),ximg1,ximg2
      double precision, intent(in) :: rface2(ixOmin1:ixOmax1+1),theta_cos(ixOmin2:ixOmax2+1),&
                                      phiface(ixOmin3:ixOmax3+1)
      double precision, intent(in) :: phi_sin(ixOmin3:ixOmax3+1),phi_cos(ixOmin3:ixOmax3+1)
      double precision, intent(in) :: t_enter,t_exit
      double precision, allocatable, intent(inout) :: segments(:,:)
      integer, intent(inout) :: nseg,capacity
      logical, intent(out) :: ok
 
      integer :: ix^D,nstep,maxSteps
      double precision :: tNow,tNext,tEnd,tMid,epsRay,ds_cm,jds,kds
      double precision :: pos(1:3),r2,dotp,rthick2,rc2
      logical :: inside,found
 
      ok=.true.
      if (t_exit<=t_enter) return
      epsray=max(1.d-12,1.d-10*max(one,abs(t_exit-t_enter)))
      pos=ray_origin+(t_enter+epsray)*vec_los
      call sph_locate_cell_fast(pos,rface2,theta_cos,phiface,ixo^l,ix1,ix2,ix3,inside)
      if (.not. inside) then
        ok=.false.
        return
      endif
 
      rthick2=(r_opt_thick*const_rsun/unit_length)**2
      rc2=ximg1**2+ximg2**2
      tnow=t_enter
      nstep=0
      maxsteps=8*((ixomax1-ixomin1+1)+(ixomax2-ixomin2+1)+(ixomax3-ixomin3+1)+3)
 
      do while (tnow<t_exit-epsray)
        call sph_next_cell_exit(ray_origin,rface2,theta_cos,phiface,phi_sin,phi_cos,ixo^l,&
                                ix1,ix2,ix3,tnow,t_exit,epsray,tnext,found)
        if (.not. found) then
          ok=.false.
          return
        endif
        tend=min(tnext,t_exit)
        if (tend>tnow) then
          tmid=half*(tnow+tend)
          pos=ray_origin+tmid*vec_los
          r2=sum(pos**2)
          dotp=sum(vec_los*pos)
          if (.not. ((dotp>=zero .and. rc2<=rthick2) .or. &
                     (dotp<zero .and. r2<=rthick2))) then
            ds_cm=(tend-tnow)*unit_length
            if (si_unit) ds_cm=ds_cm*1.d2
            jds=max(zero,source(ix^d))*ds_cm
            kds=max(zero,opacity(ix^d))*ds_cm
            call append_cart_dda_segment(segments,nseg,capacity,pixel_id,tmid,jds,kds,zero)
          endif
        endif
        tnow=tend
        if (tnow>=t_exit-epsray) exit
        pos=ray_origin+(tnow+epsray)*vec_los
        call sph_locate_cell_fast(pos,rface2,theta_cos,phiface,ixo^l,ix1,ix2,ix3,inside)
        if (.not. inside) then
          ok=.false.
          return
        endif
        nstep=nstep+1
        if (nstep>maxsteps) then
          ok=.false.
          return
        endif
      enddo
    end subroutine collect_euv_sph_dda_interval
 
    subroutine collect_euv_sph_dda_segments(ixI^L,ixO^L,source,opacity,&
                                            pixel_id,ray_origin,ximg1,ximg2,&
                                            rface,thetaface,phiface,rface2,&
                                            theta_cos,phi_sin,phi_cos,&
                                            segments,nseg,capacity,fallback)
      integer, intent(in) :: ixI^L,ixO^L,pixel_id
      double precision, intent(in) :: source(ixI^S),opacity(ixI^S)
      double precision, intent(in) :: ray_origin(1:3),ximg1,ximg2
      double precision, intent(in) :: rface(ixOmin1:ixOmax1+1),thetaface(ixOmin2:ixOmax2+1),&
                                      phiface(ixOmin3:ixOmax3+1)
      double precision, intent(in) :: rface2(ixOmin1:ixOmax1+1),theta_cos(ixOmin2:ixOmax2+1),&
                                      phi_sin(ixOmin3:ixOmax3+1),phi_cos(ixOmin3:ixOmax3+1)
      double precision, allocatable, intent(inout) :: segments(:,:)
      integer, intent(inout) :: nseg,capacity
      logical, intent(out) :: fallback
 
      integer :: nt,i,nsegStart,ix^D
      double precision :: tvals(12),posMid(1:3),t0,t1,tMid
      double precision :: dir2,origin2,odotd,aa,bb,cc,disc,root,cth2,denom,numer
      logical :: inside,ok
 
      fallback=.false.
      nsegstart=nseg
      nt=0
      dir2=sum(vec_los**2)
      origin2=sum(ray_origin**2)
      odotd=sum(ray_origin*vec_los)
 
      do ix1=ixomin1,ixomax1+1,ixomax1-ixomin1+1
        aa=dir2
        bb=2.d0*odotd
        cc=origin2-rface2(ix1)
        disc=bb**2-4.d0*aa*cc
        if (disc>=zero) then
          root=sqrt(max(zero,disc))
          call sph_add_t_fixed(tvals,nt,(-bb-root)/(2.d0*aa))
          call sph_add_t_fixed(tvals,nt,(-bb+root)/(2.d0*aa))
        endif
      enddo
      do ix2=ixomin2,ixomax2+1,ixomax2-ixomin2+1
        cth2=theta_cos(ix2)**2
        aa=vec_los(3)**2-cth2*dir2
        bb=2.d0*(ray_origin(3)*vec_los(3)-cth2*odotd)
        cc=ray_origin(3)**2-cth2*origin2
        if (abs(aa)<1.d-14) then
          if (abs(bb)>1.d-14) call sph_add_t_fixed(tvals,nt,-cc/bb)
        else
          disc=bb**2-4.d0*aa*cc
          if (disc>=zero) then
            root=sqrt(max(zero,disc))
            call sph_add_t_fixed(tvals,nt,(-bb-root)/(2.d0*aa))
            call sph_add_t_fixed(tvals,nt,(-bb+root)/(2.d0*aa))
          endif
        endif
      enddo
      do ix3=ixomin3,ixomax3+1,ixomax3-ixomin3+1
        denom=-phi_sin(ix3)*vec_los(1)+phi_cos(ix3)*vec_los(2)
        if (abs(denom)>=1.d-14) then
          numer=-phi_sin(ix3)*ray_origin(1)+phi_cos(ix3)*ray_origin(2)
          call sph_add_t_fixed(tvals,nt,-numer/denom)
        endif
      enddo
 
      if (nt<2) return
      call sph_sort_unique_t(tvals,nt)
 
      do i=1,nt-1
        t0=tvals(i)
        t1=tvals(i+1)
        if (t1<=t0) cycle
        tmid=half*(t0+t1)
        posmid=ray_origin+tmid*vec_los
        call sph_locate_cell_fast(posmid,rface2,theta_cos,phiface,ixo^l,ix1,ix2,ix3,inside)
        if (.not. inside) cycle
        call collect_euv_sph_dda_interval(ixi^l,ixo^l,source,opacity,pixel_id,&
             ray_origin,ximg1,ximg2,rface2,theta_cos,phiface,phi_sin,phi_cos,&
             t0,t1,segments,nseg,capacity,ok)
        if (.not. ok) then
          nseg=nsegstart
          fallback=.true.
          call collect_euv_sph_intersection_segments(ixi^l,ixo^l,source,opacity,&
               pixel_id,ray_origin,ximg1,ximg2,rface,thetaface,phiface,rface2,&
               theta_cos,phi_sin,phi_cos,segments,nseg,capacity)
          return
        endif
      enddo
 
    end subroutine collect_euv_sph_dda_segments
 
    subroutine integrate_euv_sph_intersection_thin(numXI1,numXI2,xI1,xI2,dxI,fl,EM)
      use mod_global_parameters
 
      integer, intent(in) :: numXI1,numXI2
      double precision, intent(in) :: xI1(numXI1),xI2(numXI2),dxI
      type(te_fluid), intent(in) :: fl
      double precision, intent(inout) :: EM(numXI1,numXI2)
 
      integer :: ixO^L,ixI^L,ix^D
      integer :: iigrid,igrid,ixP1,ixP2,ixPmin1,ixPmax1,ixPmin2,ixPmax2
      double precision :: ray_origin(1:3),profile_local(3),profile_global(3)
      double precision, allocatable :: source(:^D&)
      double precision, allocatable :: rface(:),thetaface(:),phiface(:)
      logical :: has_pixels
 
      profile_local=zero
      do iigrid=1,igridstail; igrid=igrids(iigrid);
        ^d&ixomin^d=ixmlo^d\
        ^d&ixomax^d=ixmhi^d\
        ^d&iximin^d=ixglo^d\
        ^d&iximax^d=ixghi^d\
 
        allocate(source(ixi^s))
        call get_euv(wavelength,ixi^l,ixo^l,ps(igrid)%w,ps(igrid)%x,fl,source)
        source(ixo^s)=source(ixo^s)/instrument_resolution_factor**2
        call build_sph_intersection_faces(ixi^l,ixo^l,ps(igrid)%x,ps(igrid)%dx,rface,thetaface,phiface)
        call sph_block_pixel_range(rface,thetaface,phiface,ixo^l,numxi1,numxi2,xi1,xi2,dxi,&
                                   ixpmin1,ixpmax1,ixpmin2,ixpmax2,has_pixels)
        if (has_pixels) then
          do ixp1=ixpmin1,ixpmax1
            do ixp2=ixpmin2,ixpmax2
              ray_origin=xi1(ixp1)*vec_xi1+xi2(ixp2)*vec_xi2
              profile_local(1)=profile_local(1)+one
              call acc_euv_sph_intersection(ixi^l,ixo^l,source,ray_origin,xi1(ixp1),xi2(ixp2),&
                                            rface,thetaface,phiface,em(ixp1,ixp2))
            enddo
          enddo
          profile_local(2)=profile_local(2)+dble((ixpmax1-ixpmin1+1)*(ixpmax2-ixpmin2+1))
        endif
        profile_local(3)=profile_local(3)+one
        deallocate(source,rface,thetaface,phiface)
      enddo
      call mpi_allreduce(profile_local,profile_global,3,mpi_double_precision,mpi_sum,icomm,ierrmpi)
      if (radsyn_verbose .and. mype==0) then
        write(*,'(a,3(es12.5,1x))') ' sph_intersection thin profile rays pixels blocks: ',profile_global
      endif
    end subroutine integrate_euv_sph_intersection_thin
 
    subroutine integrate_euv_sph_intersection_thick(numXI1,numXI2,xI1,xI2,dxI,fl,EUV,Tau,EUVthin)
      use mod_global_parameters
 
      integer, intent(in) :: numXI1,numXI2
      double precision, intent(in) :: xI1(numXI1),xI2(numXI2),dxI
      type(te_fluid), intent(in) :: fl
      double precision, intent(out) :: EUV(numXI1,numXI2),Tau(numXI1,numXI2),EUVthin(numXI1,numXI2)
 
      integer, parameter :: nSegVars=5
      integer :: ixO^L,ixI^L,ix^D
      integer :: iigrid,igrid,ixP1,ixP2,ipix,ipixStart,ipixEnd,nPixBatch,pixel_id
      integer :: nseg,capacity,totalCount,totalSeg,ipe,is,iseg,nidx,owner,isegDest,nsegBefore
      integer :: ixGlobal,iyGlobal,ixPmin1,ixPmax1,ixPmin2,ixPmax2,iFirst,iLast,iLocal
      integer :: nPixBatchTarget
      integer :: maxSegBatchTarget,maxSegCommTarget,maxNsegBatch,nPixTotal
      integer :: maxOwnerSegCount,maxOwnerSegCountLocal,segOffset,recvFill,totalRoundCount,totalRoundSeg
      integer :: sphDdaFallbackLocal,sphDdaFallbackGlobal
      integer, allocatable :: sendCounts(:),recvCounts(:),sendDispls(:),recvDispls(:)
      integer, allocatable :: roundSendCounts(:),roundRecvCounts(:)
      integer, allocatable :: roundSendDispls(:),roundRecvDispls(:)
      integer, allocatable :: ownerSegCounts(:),ownerOffsets(:),idx(:)
      integer, allocatable :: bucketCounts(:),bucketOffsets(:),bucketFill(:)
      double precision :: ray_origin(1:3),atten
      double precision :: profile_local(5),profile_global(5),profile_batch(5)
      double precision :: phys_max_local(2),phys_max_global(2)
      double precision :: phys_sum_local(2),phys_sum_global(2),phys_sum_batch(2)
      double precision, allocatable :: segments(:,:),segments_send(:,:),segments_recv(:,:)
      double precision, allocatable :: segments_recv_round(:,:)
      double precision, allocatable :: image_reduce(:,:)
      logical :: has_pixels,batchAccepted,batchReduced,ddaFallback
      type(radsyn_euv_cache), allocatable :: cache(:)
 
      euv=zero
      tau=zero
      euvthin=zero
      profile_local=zero
      phys_max_local=zero
      phys_sum_local=zero
      sphddafallbacklocal=0
      allocate(sendcounts(0:npe-1),recvcounts(0:npe-1),senddispls(0:npe-1),recvdispls(0:npe-1))
      allocate(roundsendcounts(0:npe-1),roundrecvcounts(0:npe-1))
      allocate(roundsenddispls(0:npe-1),roundrecvdispls(0:npe-1))
      allocate(ownersegcounts(0:npe-1),owneroffsets(0:npe-1))
      allocate(cache(igridstail))
      call radsyn_get_segment_batch_limits(npixbatchtarget,maxsegbatchtarget,maxsegcommtarget)
      allocate(bucketcounts(npixbatchtarget),bucketoffsets(npixbatchtarget+1),&
               bucketfill(npixbatchtarget))
 
      do iigrid=1,igridstail; igrid=igrids(iigrid);
        ^d&ixomin^d=ixmlo^d\
        ^d&ixomax^d=ixmhi^d\
        ^d&iximin^d=ixglo^d\
        ^d&iximax^d=ixghi^d\
 
        cache(iigrid)%igrid=igrid
        allocate(cache(iigrid)%source(ixi^s),cache(iigrid)%opacity(ixi^s))
        cache(iigrid)%source=zero
        cache(iigrid)%opacity=zero
        call get_euv(wavelength,ixi^l,ixo^l,ps(igrid)%w,ps(igrid)%x,fl,cache(iigrid)%source)
        cache(iigrid)%source(ixo^s)=cache(iigrid)%source(ixo^s)/instrument_resolution_factor**2
        call get_euv_hhe_opacity(wavelength,ixi^l,ixo^l,ps(igrid)%w,ps(igrid)%x,fl,cache(iigrid)%opacity)
        phys_max_local(1)=max(phys_max_local(1),maxval(cache(iigrid)%source(ixo^s)))
        phys_max_local(2)=max(phys_max_local(2),maxval(cache(iigrid)%opacity(ixo^s)))
        call build_sph_intersection_faces(ixi^l,ixo^l,ps(igrid)%x,ps(igrid)%dx,&
                                          cache(iigrid)%rface,cache(iigrid)%thetaface,&
                                          cache(iigrid)%phiface)
        allocate(cache(iigrid)%rface2(ixomin1:ixomax1+1),&
                 cache(iigrid)%theta_cos(ixomin2:ixomax2+1),&
                 cache(iigrid)%phi_sin(ixomin3:ixomax3+1),&
                 cache(iigrid)%phi_cos(ixomin3:ixomax3+1))
        cache(iigrid)%rface2=cache(iigrid)%rface**2
        cache(iigrid)%theta_cos=cos(cache(iigrid)%thetaface)
        cache(iigrid)%phi_sin=sin(cache(iigrid)%phiface)
        cache(iigrid)%phi_cos=cos(cache(iigrid)%phiface)
        call sph_block_pixel_range(cache(iigrid)%rface,cache(iigrid)%thetaface,&
             cache(iigrid)%phiface,ixo^l,numxi1,numxi2,xi1,xi2,dxi,&
             cache(iigrid)%ixPmin1,cache(iigrid)%ixPmax1,&
             cache(iigrid)%ixPmin2,cache(iigrid)%ixPmax2,cache(iigrid)%has_pixels)
      enddo
 
      npixtotal=numxi1*numxi2
      ipixstart=1
      do while (ipixstart<=npixtotal)
        ipixend=min(numxi1*numxi2,ipixstart+npixbatchtarget-1)
        npixbatch=ipixend-ipixstart+1
        batchaccepted=.false.
        batchreduced=.false.
 
        do while (.not. batchaccepted)
          nseg=0
          capacity=0
          profile_batch=zero
          phys_sum_batch=zero
 
          do iigrid=1,igridstail; igrid=igrids(iigrid);
            ^d&ixomin^d=ixmlo^d\
            ^d&ixomax^d=ixmhi^d\
            ^d&iximin^d=ixglo^d\
            ^d&iximax^d=ixghi^d\
 
            ixpmin1=cache(iigrid)%ixPmin1
            ixpmax1=cache(iigrid)%ixPmax1
            ixpmin2=cache(iigrid)%ixPmin2
            ixpmax2=cache(iigrid)%ixPmax2
            has_pixels=cache(iigrid)%has_pixels
            if (.not. has_pixels) cycle
 
            do ixp2=ixpmin2,ixpmax2
              ifirst=max(ipixstart,(ixp2-1)*numxi1+ixpmin1)
              ilast=min(ipixend,(ixp2-1)*numxi1+ixpmax1)
              if (ifirst>ilast) cycle
              do ipix=ifirst,ilast
                ixp1=1+mod(ipix-1,numxi1)
                pixel_id=ipix
                ray_origin=xi1(ixp1)*vec_xi1+xi2(ixp2)*vec_xi2
                profile_batch(1)=profile_batch(1)+one
                nsegbefore=nseg
                if (sph_use_dda) then
                  call collect_euv_sph_dda_segments(ixi^l,ixo^l,cache(iigrid)%source,&
                       cache(iigrid)%opacity,pixel_id,ray_origin,xi1(ixp1),xi2(ixp2),&
                       cache(iigrid)%rface,cache(iigrid)%thetaface,cache(iigrid)%phiface,&
                       cache(iigrid)%rface2,cache(iigrid)%theta_cos,&
                       cache(iigrid)%phi_sin,cache(iigrid)%phi_cos,&
                       segments,nseg,capacity,ddafallback)
                  if (ddafallback) sphddafallbacklocal=sphddafallbacklocal+1
                else
                  call collect_euv_sph_intersection_segments(ixi^l,ixo^l,cache(iigrid)%source,&
                       cache(iigrid)%opacity,pixel_id,ray_origin,xi1(ixp1),xi2(ixp2),&
                       cache(iigrid)%rface,cache(iigrid)%thetaface,cache(iigrid)%phiface,&
                       cache(iigrid)%rface2,cache(iigrid)%theta_cos,&
                       cache(iigrid)%phi_sin,cache(iigrid)%phi_cos,&
                       segments,nseg,capacity)
                endif
                if (nseg>nsegbefore) profile_batch(2)=profile_batch(2)+one
                profile_batch(3)=profile_batch(3)+dble(nseg-nsegbefore)
                do iseg=nsegbefore+1,nseg
                  phys_sum_batch(1)=phys_sum_batch(1)+segments(3,iseg)
                  phys_sum_batch(2)=phys_sum_batch(2)+segments(4,iseg)
                enddo
              enddo
            enddo
          enddo
 
          call mpi_allreduce(nseg,maxnsegbatch,1,mpi_integer,mpi_max,icomm,ierrmpi)
          if (maxnsegbatch>maxsegbatchtarget .and. npixbatch>1) then
            npixbatch=max(1,npixbatch/2)
            ipixend=ipixstart+npixbatch-1
            if (allocated(segments)) deallocate(segments)
            batchreduced=.true.
          else
            batchaccepted=.true.
          endif
        enddo
 
        profile_local=profile_local+profile_batch
        phys_sum_local=phys_sum_local+phys_sum_batch
        if (radsyn_verbose .and. mype==0 .and. batchreduced) then
          if (sph_use_dda) then
            write(*,'(a,3(i0,1x))') ' sph_dda thick adaptive batch: ',&
                 ipixstart,ipixend,maxnsegbatch
          else
            write(*,'(a,3(i0,1x))') ' sph_intersection thick adaptive batch: ',&
                 ipixstart,ipixend,maxnsegbatch
          endif
        endif
 
        if (.not. allocated(segments)) then
          capacity=1
          allocate(segments(nsegvars,capacity))
        endif
        ownersegcounts=0
        do is=1,nseg
          owner=segment_pixel_owner(nint(segments(1,is)))
          ownersegcounts(owner)=ownersegcounts(owner)+1
        enddo
        sendcounts=nsegvars*ownersegcounts
        senddispls(0)=0
        do ipe=1,npe-1
          senddispls(ipe)=senddispls(ipe-1)+sendcounts(ipe-1)
        enddo
 
        allocate(segments_send(nsegvars,max(1,nseg)))
        owneroffsets=0
        do is=1,nseg
          owner=segment_pixel_owner(nint(segments(1,is)))
          isegdest=senddispls(owner)/nsegvars+owneroffsets(owner)+1
          segments_send(:,isegdest)=segments(:,is)
          owneroffsets(owner)=owneroffsets(owner)+1
        enddo
 
        call mpi_alltoall(sendcounts,1,mpi_integer,recvcounts,1,mpi_integer,icomm,ierrmpi)
        recvdispls(0)=0
        do ipe=1,npe-1
          recvdispls(ipe)=recvdispls(ipe-1)+recvcounts(ipe-1)
        enddo
        totalcount=sum(recvcounts)
        totalseg=totalcount/nsegvars
        profile_local(4)=profile_local(4)+dble(totalcount)
        allocate(segments_recv(nsegvars,max(1,totalseg)))
 
        recvfill=0
        maxownersegcountlocal=maxval(ownersegcounts)
        call mpi_allreduce(maxownersegcountlocal,maxownersegcount,1,mpi_integer,mpi_max,icomm,ierrmpi)
        do segoffset=0,maxownersegcount-1,maxsegcommtarget
          roundsendcounts=0
          roundsenddispls=senddispls
          do ipe=0,npe-1
            if (ownersegcounts(ipe)>segoffset) then
              roundsendcounts(ipe)=nsegvars*min(maxsegcommtarget,ownersegcounts(ipe)-segoffset)
              roundsenddispls(ipe)=senddispls(ipe)+nsegvars*segoffset
            endif
          enddo
 
          call mpi_alltoall(roundsendcounts,1,mpi_integer,roundrecvcounts,1,mpi_integer,icomm,ierrmpi)
          roundrecvdispls(0)=0
          do ipe=1,npe-1
            roundrecvdispls(ipe)=roundrecvdispls(ipe-1)+roundrecvcounts(ipe-1)
          enddo
          totalroundcount=sum(roundrecvcounts)
          totalroundseg=totalroundcount/nsegvars
          allocate(segments_recv_round(nsegvars,max(1,totalroundseg)))
 
          call mpi_alltoallv(segments_send,roundsendcounts,roundsenddispls,mpi_double_precision,&
                             segments_recv_round,roundrecvcounts,roundrecvdispls,&
                             mpi_double_precision,icomm,ierrmpi)
 
          if (totalroundseg>0) then
            segments_recv(:,recvfill+1:recvfill+totalroundseg)=segments_recv_round(:,1:totalroundseg)
            recvfill=recvfill+totalroundseg
          endif
          deallocate(segments_recv_round)
        enddo
 
        if (recvfill/=totalseg) call mpistop("ray-segment receive mismatch")
 
        if (totalseg>0) then
          allocate(idx(totalseg))
          bucketcounts(1:npixbatch)=0
          do is=1,totalseg
            if (segment_is_valid(segments_recv,is,4)) then
              ipix=nint(segments_recv(1,is))
              if (ipix>=ipixstart .and. ipix<=ipixend .and. segment_pixel_owner(ipix)==mype) then
                ilocal=ipix-ipixstart+1
                bucketcounts(ilocal)=bucketcounts(ilocal)+1
              endif
            endif
          enddo
 
          bucketoffsets(1)=1
          do ilocal=1,npixbatch
            bucketoffsets(ilocal+1)=bucketoffsets(ilocal)+bucketcounts(ilocal)
          enddo
          bucketfill(1:npixbatch)=bucketoffsets(1:npixbatch)
          do is=1,totalseg
            if (segment_is_valid(segments_recv,is,4)) then
              ipix=nint(segments_recv(1,is))
              if (ipix>=ipixstart .and. ipix<=ipixend .and. segment_pixel_owner(ipix)==mype) then
                ilocal=ipix-ipixstart+1
                idx(bucketfill(ilocal))=is
                bucketfill(ilocal)=bucketfill(ilocal)+1
              endif
            endif
          enddo
 
          do ipix=ipixstart,ipixend
            if (segment_pixel_owner(ipix)/=mype) cycle
            ilocal=ipix-ipixstart+1
            nidx=bucketcounts(ilocal)
            if (nidx>0) then
              profile_local(5)=profile_local(5)+dble(nidx)*dble(nidx)
              call sort_segment_indices_near_to_far(segments_recv,&
                   idx(bucketoffsets(ilocal):bucketoffsets(ilocal+1)-1),nidx)
              ixglobal=1+mod(ipix-1,numxi1)
              iyglobal=1+(ipix-1)/numxi1
              do iseg=bucketoffsets(ilocal),bucketoffsets(ilocal+1)-1
                is=idx(iseg)
                euvthin(ixglobal,iyglobal)=euvthin(ixglobal,iyglobal)+segments_recv(3,is)
                atten=transfer_attenuation(tau(ixglobal,iyglobal))
                euv(ixglobal,iyglobal)=euv(ixglobal,iyglobal)+atten*segments_recv(3,is)
                tau(ixglobal,iyglobal)=tau(ixglobal,iyglobal)+max(zero,segments_recv(4,is))
              enddo
            endif
          enddo
          deallocate(idx)
        endif
 
        deallocate(segments_send,segments_recv)
        if (allocated(segments)) deallocate(segments)
        ipixstart=ipixend+1
      enddo
 
      do iigrid=1,igridstail
        if (allocated(cache(iigrid)%source)) deallocate(cache(iigrid)%source)
        if (allocated(cache(iigrid)%opacity)) deallocate(cache(iigrid)%opacity)
        if (allocated(cache(iigrid)%rface)) deallocate(cache(iigrid)%rface)
        if (allocated(cache(iigrid)%thetaface)) deallocate(cache(iigrid)%thetaface)
        if (allocated(cache(iigrid)%phiface)) deallocate(cache(iigrid)%phiface)
        if (allocated(cache(iigrid)%rface2)) deallocate(cache(iigrid)%rface2)
        if (allocated(cache(iigrid)%theta_cos)) deallocate(cache(iigrid)%theta_cos)
        if (allocated(cache(iigrid)%phi_sin)) deallocate(cache(iigrid)%phi_sin)
        if (allocated(cache(iigrid)%phi_cos)) deallocate(cache(iigrid)%phi_cos)
      enddo
      deallocate(cache)
      deallocate(sendcounts,recvcounts,senddispls,recvdispls,roundsendcounts,roundrecvcounts,&
                 roundsenddispls,roundrecvdispls,ownersegcounts,owneroffsets,bucketcounts,&
                 bucketoffsets,bucketfill)
      allocate(image_reduce(numxi1,numxi2))
      call mpi_allreduce(euv,image_reduce,numxi1*numxi2,mpi_double_precision,mpi_sum,icomm,ierrmpi)
      euv=image_reduce
      call mpi_allreduce(tau,image_reduce,numxi1*numxi2,mpi_double_precision,mpi_sum,icomm,ierrmpi)
      tau=image_reduce
      call mpi_allreduce(euvthin,image_reduce,numxi1*numxi2,mpi_double_precision,mpi_sum,icomm,ierrmpi)
      euvthin=image_reduce
      deallocate(image_reduce)
      call mpi_allreduce(profile_local,profile_global,5,mpi_double_precision,mpi_sum,icomm,ierrmpi)
      call mpi_allreduce(phys_max_local,phys_max_global,2,mpi_double_precision,mpi_max,icomm,ierrmpi)
      call mpi_allreduce(phys_sum_local,phys_sum_global,2,mpi_double_precision,mpi_sum,icomm,ierrmpi)
      call mpi_allreduce(sphddafallbacklocal,sphddafallbackglobal,1,mpi_integer,mpi_sum,icomm,ierrmpi)
      if (radsyn_verbose .and. mype==0) then
        if (sph_use_dda) then
          write(*,'(a,5(es12.5,1x))') ' sph_dda thick profile: ',profile_global
          write(*,'(a,i0)') ' sph_dda thick fallback rays: ',sphddafallbackglobal
          write(*,'(a,4(es12.5,1x))') ' sph_dda thick physics maxj maxk sumjds sumkds: ',&
               phys_max_global(1),phys_max_global(2),phys_sum_global(1),phys_sum_global(2)
        else
          write(*,'(a,5(es12.5,1x))') ' sph_intersection thick profile: ',profile_global
          write(*,'(a,4(es12.5,1x))') ' sph_intersection thick physics maxj maxk sumjds sumkds: ',&
               phys_max_global(1),phys_max_global(2),phys_sum_global(1),phys_sum_global(2)
        endif
      endif
    end subroutine integrate_euv_sph_intersection_thick
 
  }
 
  {^ifthreed
 
    subroutine get_sph_intersection_image_bounds(xImin1,xImax1,xImin2,xImax2)
      double precision, intent(out) :: xImin1,xImax1,xImin2,xImax2
 
      integer, parameter :: nsample=5
      integer :: iigrid,igrid,ir,it,ip
      integer :: ixI^L,ixO^L
      double precision, allocatable :: rface(:),thetaface(:),phiface(:)
      double precision :: local_min1,local_max1,local_min2,local_max2
      double precision :: sph(1:3),xcent(1:2),wr,wt,wp
 
      local_min1=huge(one)
      local_max1=-huge(one)
      local_min2=huge(one)
      local_max2=-huge(one)
 
      do iigrid=1,igridstail
        igrid=igrids(iigrid)
        ^d&ixomin^d=ixmlo^d\
        ^d&ixomax^d=ixmhi^d\
        ^d&iximin^d=ixglo^d\
        ^d&iximax^d=ixghi^d\
 
        call build_sph_intersection_faces(ixi^l,ixo^l,ps(igrid)%x,ps(igrid)%dx,&
                                          rface,thetaface,phiface)
        do ir=0,nsample-1
          wr=dble(ir)/dble(nsample-1)
          sph(1)=(one-wr)*rface(ixomin1)+wr*rface(ixomax1+1)
          do it=0,nsample-1
            wt=dble(it)/dble(nsample-1)
            sph(2)=(one-wt)*thetaface(ixomin2)+wt*thetaface(ixomax2+1)
            do ip=0,nsample-1
              wp=dble(ip)/dble(nsample-1)
              if (ir/=0 .and. ir/=nsample-1 .and. it/=0 .and. it/=nsample-1 .and. &
                  ip/=0 .and. ip/=nsample-1) cycle
              sph(3)=(one-wp)*phiface(ixomin3)+wp*phiface(ixomax3+1)
              call get_cor_image_spherical(sph,xcent)
              local_min1=min(local_min1,xcent(1))
              local_max1=max(local_max1,xcent(1))
              local_min2=min(local_min2,xcent(2))
              local_max2=max(local_max2,xcent(2))
            enddo
          enddo
        enddo
        deallocate(rface,thetaface,phiface)
      enddo
 
      call mpi_allreduce(local_min1,ximin1,1,mpi_double_precision,mpi_min,icomm,ierrmpi)
      call mpi_allreduce(local_max1,ximax1,1,mpi_double_precision,mpi_max,icomm,ierrmpi)
      call mpi_allreduce(local_min2,ximin2,1,mpi_double_precision,mpi_min,icomm,ierrmpi)
      call mpi_allreduce(local_max2,ximax2,1,mpi_double_precision,mpi_max,icomm,ierrmpi)
      if (ximin1>0.5d0*huge(one) .or. ximax1<-0.5d0*huge(one) .or. &
          ximin2>0.5d0*huge(one) .or. ximax2<-0.5d0*huge(one)) then
        call mpistop("sph_intersection could not determine image bounds")
      endif
    end subroutine get_sph_intersection_image_bounds
 
    subroutine get_sph_intersection_datresol_spacing(dxI)
      double precision, intent(out) :: dxI
 
      integer :: iigrid,igrid,ixI^L,ixO^L,ix^D
      double precision :: local_min,global_min,dr,ds_theta,ds_phi,rval,theta
 
      local_min=huge(one)
      do iigrid=1,igridstail
        igrid=igrids(iigrid)
        ^d&ixomin^d=ixmlo^d\
        ^d&ixomax^d=ixmhi^d\
        ^d&iximin^d=ixglo^d\
        ^d&iximax^d=ixghi^d\
 
        do ix1=ixomin1,ixomax1
          do ix2=ixomin2,ixomax2
            do ix3=ixomin3,ixomax3
              rval=max(smalldouble,ps(igrid)%x(ix^d,1))
              theta=ps(igrid)%x(ix^d,2)
              dr=ps(igrid)%dx(ix^d,1)
              ds_theta=rval*ps(igrid)%dx(ix^d,2)
              ds_phi=rval*max(smalldouble,sin(theta))*ps(igrid)%dx(ix^d,3)
              local_min=min(local_min,dr,ds_theta,ds_phi)
            enddo
          enddo
        enddo
      enddo
 
      call mpi_allreduce(local_min,global_min,1,mpi_double_precision,mpi_min,icomm,ierrmpi)
      if (global_min<=zero .or. global_min>half*huge(one)) then
        call mpistop("sph_intersection could not determine dat-resolution image spacing")
      endif
      dxi=global_min
    end subroutine get_sph_intersection_datresol_spacing
 
    subroutine get_image(qunit,datatype,fl)
      ! integrate emission flux along line of sight (LOS) 
      ! in a 3D simulation box and get a 2D EUV image
      use mod_global_parameters
      use mod_constants
 
      integer, intent(in) :: qunit
      type(te_fluid), intent(in) :: fl
      character(20), intent(in) :: datatype
 
      integer :: ix^D,numXI1,numXI2,numWI
      double precision :: xImin1,xImax1,xImin2,xImax2,xIcent1,xIcent2,dxI
      double precision, allocatable :: xI1(:),xI2(:),dxI1(:),dxI2(:)
      double precision, allocatable :: wI(:,:,:),wIs(:,:,:),EM(:,:),Dpl(:,:),Tau(:,:),EMthin(:,:),WLB(:,:,:)
      double precision :: vec_temp1(1:3),vec_temp2(1:3)
      double precision :: vec_z(1:3),vec_cor(1:3),xI_cor(1:2)
      double precision :: res,LOS_psi,r_max,r_loc
 
      integer :: mass
      character (30) :: ion
      double precision :: logTe,lineCent,sigma_PSF,spaceRsl,wlRsl,wslit
      double precision :: arcsec,RHESSI_rsl,LASCO_rsl,pixel,R_occult,smallflux
      integer :: iigrid,igrid,i,j,numSI,iw
      logical :: emit,ray_image_global,has_thick_output
 
      if (coordinate==spherical) then
        call init_vectors_spherical()
      else
        ! cartesian
        call init_vectors_cartesian()
      endif
 
      ! calculate domain of the image
      if (coordinate==spherical) then
        if (trim(ray_method_active)=='spherical' .and. datatype=='image_euv') then
          call get_sph_intersection_image_bounds(ximin1,ximax1,ximin2,ximax2)
        else
          ximin1=-abs(xprobmax1)
          ximin2=-abs(xprobmax1)
          ximax1=abs(xprobmax1)
          ximax2=abs(xprobmax1)
        endif
      else
        ! calculate domain of the image
        do ix1=1,2
          if (ix1==1) vec_cor(1)=xprobmin1
          if (ix1==2) vec_cor(1)=xprobmax1
          do ix2=1,2
            if (ix2==1) vec_cor(2)=xprobmin2
            if (ix2==2) vec_cor(2)=xprobmax2
            do ix3=1,2
              if (ix3==1) vec_cor(3)=xprobmin3
              if (ix3==2) vec_cor(3)=xprobmax3
              if (big_image) then
                r_loc=(vec_cor(1)-x_origin(1))**2
                r_loc=r_loc+(vec_cor(2)-x_origin(2))**2
                r_loc=r_loc+(vec_cor(3)-x_origin(3))**2
                r_loc=sqrt(r_loc)
                if (ix1==1 .and. ix2==1 .and. ix3==1) then
                  r_max=r_loc
                else
                  r_max=max(r_max,r_loc)
                endif
              else
                call get_cor_image(vec_cor,xi_cor)
                if (ix1==1 .and. ix2==1 .and. ix3==1) then
                  ximin1=xi_cor(1)
                  ximax1=xi_cor(1)
                  ximin2=xi_cor(2)
                  ximax2=xi_cor(2)
                else
                  ximin1=min(ximin1,xi_cor(1))
                  ximax1=max(ximax1,xi_cor(1))
                  ximin2=min(ximin2,xi_cor(2))
                  ximax2=max(ximax2,xi_cor(2))
                endif
              endif
            enddo
          enddo
        enddo
        if (big_image) then
          ximin1=-r_max
          ximin2=-r_max
          ximax1=r_max
          ximax2=r_max
        endif
      endif
      xicent1=(ximin1+ximax1)/2.d0
      xicent2=(ximin2+ximax2)/2.d0
 
      ! tables for image
      if (si_unit) then
        arcsec=7.25d5/unit_length
      else
        arcsec=7.25d7/unit_length
      endif
      if (datatype=='image_euv') then
        call get_line_info(wavelength,ion,mass,logte,linecent,spacersl,wlrsl,sigma_psf,wslit)
        dxi=spacersl*arcsec  ! intrument resolution of image
        smallflux=smalldouble
      else if (datatype=='image_sxr') then
        rhessi_rsl=2.3d0/instrument_resolution_factor
        dxi=rhessi_rsl*arcsec
        smallflux=1.d-40
      else if (datatype=='image_whitelight') then
        if (whitelight_instrument=='LASCO/C1') then
          lasco_rsl=5.6d0/instrument_resolution_factor
          r_occult=1.1d0
        else if (whitelight_instrument=='LASCO/C2') then
          lasco_rsl=11.4d0/instrument_resolution_factor
          r_occult=2.d0
        else if (whitelight_instrument=='LASCO/C3') then
          lasco_rsl=56.d0/instrument_resolution_factor
          r_occult=3.7d0
        else
          call mpistop('Whitelight synthesis: instrument is not supported!')
        endif
        dxi=lasco_rsl*arcsec
        if (r_occultor>1.d0) r_occult=r_occultor
        r_occult=r_occult*const_rsun/unit_length
        smallflux=1.d-20
      endif
      numxi1=8*ceiling((ximax1-xicent1)/dxi/8.d0)
      ximin1=xicent1-numxi1*dxi
      ximax1=xicent1+numxi1*dxi
      numxi1=numxi1*2
      numxi2=8*ceiling((ximax2-xicent2)/dxi/8.d0)
      ximin2=xicent2-numxi2*dxi
      ximax2=xicent2+numxi2*dxi
      numxi2=numxi2*2
      allocate(xi1(numxi1),xi2(numxi2),dxi1(numxi1),dxi2(numxi2))
      do ix1=1,numxi1
        xi1(ix1)=ximin1+dxi*(ix1-half)
        dxi1(ix1)=dxi
      enddo
      do ix2=1,numxi2
        xi2(ix2)=ximin2+dxi*(ix2-half)
        dxi2(ix2)=dxi
      enddo
 
      ! calculate emission
      if (datatype=='image_euv' .or. datatype=='image_sxr') then
        has_thick_output=datatype=='image_euv' .and. trim(radiation_transfer)=='thick' .and. &
            ((coordinate==spherical .and. trim(ray_method_active)=='spherical') .or. &
             (coordinate==cartesian .and. trim(ray_method_active)=='cart'))
        if (datatype=='image_euv') then
          numwi=radsyn_euv_num_outputs(.false.,has_thick_output)
        else
          numwi=1
        endif
        allocate(wi(numxi1,numxi2,numwi),wis(numxi1,numxi2,numwi),em(numxi1,numxi2))
        wi=zero
        wis=zero
        em=zero
        ray_image_global=.false.
        if (has_thick_output) then
          allocate(tau(numxi1,numxi2),emthin(numxi1,numxi2))
          tau=zero
          emthin=zero
        endif
        if (coordinate==cartesian .and. datatype=='image_euv' .and. &
            trim(ray_method_active)=='cart') then
          ray_image_global=.true.
          allocate(dpl(numxi1,numxi2))
          dpl=zero
          if (trim(radiation_transfer)=='thick') then
            call integrate_euv_cart_dda_thick_datresol(numxi1,numxi2,xi1,xi2,fl,em,dpl,tau,emthin)
          else
            call integrate_euv_cart_dda_datresol(numxi1,numxi2,xi1,xi2,fl,em,dpl)
          endif
          deallocate(dpl)
        else if (coordinate==cartesian) then
          do iigrid=1,igridstail; igrid=igrids(iigrid);
            call integrate_emission_cartesian(igrid,numxi1,numxi2,xi1,xi2,dxi,fl,datatype,em)
          enddo
        else if (trim(ray_method_active) == 'spherical' .and. datatype == 'image_euv') then
          if (trim(radiation_transfer) == 'thick') then
            ray_image_global=.true.
            call integrate_euv_sph_intersection_thick(numxi1,numxi2,xi1,xi2,dxi,fl,em,tau,emthin)
          else
            call integrate_euv_sph_intersection_thin(numxi1,numxi2,xi1,xi2,dxi,fl,em)
          endif
        else
          do iigrid=1,igridstail; igrid=igrids(iigrid);
            call integrate_emission_spherical(igrid,numxi1,numxi2,xi1,xi2,dxi,fl,datatype,em)
          enddo
        endif
        if (ray_image_global) then
          if (has_thick_output) then
            call pack_euv_image_outputs(numxi1,numxi2,em,wi,smallflux,.false.,&
                                        has_thick_output,tau=tau,euvthin=emthin,&
                                        cap_absorption=.true.)
          else
            call pack_euv_image_outputs(numxi1,numxi2,em,wi,smallflux,.false.,has_thick_output)
          endif
        else
          do ix1=1,numxi1
            do ix2=1,numxi2
              if (em(ix1,ix2)>smallflux) wis(ix1,ix2,1)=em(ix1,ix2)
            enddo
          enddo
        endif
        if (.not. ray_image_global) then
          numsi=numxi1*numxi2*numwi
          call mpi_allreduce(wis,wi,numsi,mpi_double_precision,mpi_sum,icomm,ierrmpi)
        endif
        if (activate_unit_arcsec) then
          xi1=xi1/arcsec
          dxi1=dxi1/arcsec
          xi2=xi2/arcsec
          dxi2=dxi2/arcsec
        endif
        call output_data(qunit,xi1,xi2,dxi1,dxi2,wi,numxi1,numxi2,numwi,datatype)
        if (allocated(tau)) deallocate(tau)
        if (allocated(emthin)) deallocate(emthin)
        deallocate(wi,wis,em)
      else if (datatype=='image_whitelight') then
        numwi=2
        allocate(wi(numxi1,numxi2,numwi),wis(numxi1,numxi2,numwi),wlb(numxi1,numxi2,numwi))
        wi=zero
        wis=zero
        wlb=zero
        if (coordinate==spherical) then
          do iigrid=1,igridstail; igrid=igrids(iigrid);
            call integrate_whitelight_spherical(igrid,numxi1,numxi2,numwi,xi1,xi2,dxi,fl,datatype,wlb)
          enddo
        endif
        do ix1=1,numxi1
          do ix2=1,numxi2
            if (wlb(ix1,ix2,1)>smallflux) then 
              wis(ix1,ix2,1)=wlb(ix1,ix2,1)
              wis(ix1,ix2,2)=wlb(ix1,ix2,2)
            endif
          enddo
        enddo
        numsi=numxi1*numxi2*numwi
        call mpi_allreduce(wis,wi,numsi,mpi_double_precision,mpi_sum,icomm,ierrmpi)
        if (activate_unit_arcsec) then
          xi1=xi1/arcsec
          dxi1=dxi1/arcsec
          xi2=xi2/arcsec
          dxi2=dxi2/arcsec
        endif
        call output_data(qunit,xi1,xi2,dxi1,dxi2,wi,numxi1,numxi2,numwi,datatype)
        deallocate(wi,wis,wlb)
      endif
 
      deallocate(xi1,xi2,dxi1,dxi2)
 
    end subroutine get_image
 
    subroutine integrate_emission_cartesian(igrid,numXI1,numXI2,xI1,xI2,dxI,fl,datatype,EM)
      integer, intent(in) :: igrid,numXI1,numXI2
      double precision, intent(in) :: xI1(numXI1),xI2(numXI2)
      double precision, intent(in) :: dxI
      type(te_fluid), intent(in) :: fl
      character(20), intent(in) :: datatype
      double precision, intent(inout) :: EM(numXI1,numXI2)
 
      integer :: ixO^L,ixO^D,ixI^L,ix^D,i,j
      double precision :: xb^L,xd^D
      double precision, allocatable :: flux(:^D&),opacity(:^D&)
      double precision :: res
      integer :: ixP^L,ixP^D,nSubC^D,iSubC^D
      double precision :: xSubP1,xSubP2,dxSubP,xerf^L,fluxsubC
      double precision :: xSubC(1:3),dxSubC^D,xCent(1:2)
 
      integer :: mass
      double precision :: logTe
      character (30) :: ion
      double precision :: lineCent
      double precision :: sigma_PSF,spaceRsl,wlRsl,sigma0,factor,wslit
      double precision :: arcsec,pixel,RHESSI_rsl,area_1AU
      double precision :: aa,bb
 
      ^d&ixomin^d=ixmlo^d\
      ^d&ixomax^d=ixmhi^d\
      ^d&iximin^d=ixglo^d\
      ^d&iximax^d=ixghi^d\
      ^d&xbmin^d=rnode(rpxmin^d_,igrid)\
      ^d&xbmax^d=rnode(rpxmax^d_,igrid)\
 
      if (si_unit) then
        arcsec=7.25d5/unit_length
      else
        arcsec=7.25d7/unit_length
      endif
 
      allocate(flux(ixi^s),opacity(ixi^s))
      if (datatype=='image_euv') then
        if (trim(emission_model)=='pseudo_current') then
          call get_pseudo_current(igrid,ixi^l,ixo^l,ps(igrid)%w,flux)
        else if (trim(emission_model)=='radio_ff') then
          call get_radio_ff_source_opacity(ixi^l,ixo^l,ps(igrid)%w,ps(igrid)%x,fl,flux,opacity)
        else
          ! get local EUV flux and velocity
          call get_euv(wavelength,ixi^l,ixo^l,ps(igrid)%w,ps(igrid)%x,fl,flux)
          flux(ixo^s)=flux(ixo^s)/instrument_resolution_factor**2   ! adjust flux due to artifical change of resolution
        endif
        call get_line_info(wavelength,ion,mass,logte,linecent,spacersl,wlrsl,sigma_psf,wslit)
        pixel=spacersl*arcsec
        sigma0=sigma_psf*pixel
      else if (datatype=='image_sxr') then
        ! get local SXR flux photons cm^-3 s^-1 (cgs) or photons m^-3 s^-1 (SI)
        call get_sxr(ixi^l,ixo^l,ps(igrid)%w,ps(igrid)%x,fl,flux,emin_sxr,emax_sxr) 
        rhessi_rsl=2.3d0/instrument_resolution_factor
        sigma_psf=1.d0
        pixel=rhessi_rsl*arcsec
        sigma0=sigma_psf*pixel
        area_1au=2.81d27
      endif
 
      ! integrate emission
      {do ix^d=ixomin^d,ixomax^d\}
        ^d&nsubc^d=1;
        ^d&nsubc^d=max(nsubc^d,ceiling(ps(igrid)%dx(ix^dd,^d)*abs(vec_xi1(^d))/(dxi/2.d0)));
        ^d&nsubc^d=max(nsubc^d,ceiling(ps(igrid)%dx(ix^dd,^d)*abs(vec_xi2(^d))/(dxi/2.d0)));
        ^d&dxsubc^d=ps(igrid)%dx(ix^dd,^d)/nsubc^d;
        if (datatype=='image_euv') then
          if (si_unit) then
            fluxsubc=flux(ix^d)*dxsubc1*dxsubc2*dxsubc3*unit_length*1.d2/dxi/dxi  ! DN s^-1
          else
            fluxsubc=flux(ix^d)*dxsubc1*dxsubc2*dxsubc3*unit_length/dxi/dxi  ! DN s^-1
          endif
        else if (datatype=='image_sxr') then
          ! sub-cell SXR flux at 1 AU [photons s^-1 cm^-2]
          fluxsubc=flux(ix^d)*dxsubc1*dxsubc2*dxsubc3*unit_length**3/area_1au
        endif
        if (fluxsubc>smalldouble) then
          ! dividing a cell to several parts to get more accurate integrating values
          {do isubc^d=1,nsubc^d\}
            ^d&xsubc(^d)=ps(igrid)%x(ix^dd,^d)-half*ps(igrid)%dx(ix^dd,^d)+(isubc^d-half)*dxsubc^d;
            ! mapping the 3D coordinate to location at the image
            call get_cor_image(xsubc,xcent)
            ! distribution at nearby pixels
            ixp1=floor((xcent(1)-(xi1(1)-half*dxi))/dxi)+1
            ixp2=floor((xcent(2)-(xi2(1)-half*dxi))/dxi)+1
            ixpmin1=max(1,ixp1-3)
            ixpmax1=min(ixp1+3,numxi1)
            ixpmin2=max(1,ixp2-3)
            ixpmax2=min(ixp2+3,numxi2)
            do ixp1=ixpmin1,ixpmax1
              do ixp2=ixpmin2,ixpmax2
                xerfmin1=((xi1(ixp1)-half*dxi)-xcent(1))/(sqrt(2.d0)*sigma0) 
                xerfmax1=((xi1(ixp1)+half*dxi)-xcent(1))/(sqrt(2.d0)*sigma0)
                xerfmin2=((xi2(ixp2)-half*dxi)-xcent(2))/(sqrt(2.d0)*sigma0)
                xerfmax2=((xi2(ixp2)+half*dxi)-xcent(2))/(sqrt(2.d0)*sigma0)
                factor=(erfc(xerfmin1)-erfc(xerfmax1))*(erfc(xerfmin2)-erfc(xerfmax2))/4.d0
                em(ixp1,ixp2)=em(ixp1,ixp2)+fluxsubc*factor
              enddo !ixP2
            enddo !ixP1
          {enddo\} !iSubC
        endif
      {enddo\} !ix
 
      deallocate(flux,opacity)
    end subroutine integrate_emission_cartesian
 
    subroutine integrate_emission_spherical(igrid,numXI1,numXI2,xI1,xI2,dxI,fl,datatype,EM)
      integer, intent(in) :: igrid,numXI1,numXI2
      double precision, intent(in) :: xI1(numXI1),xI2(numXI2)
      double precision, intent(in) :: dxI
      type(te_fluid), intent(in) :: fl
      character(20), intent(in) :: datatype
      double precision, intent(inout) :: EM(numXI1,numXI2)
 
      integer :: ixO^L,ixO^D,ixI^L,ix^D,i,j
      double precision, allocatable :: flux(:^D&),Ne(:^D&),opacity(:^D&)
      integer :: ixP^L,ixP^D,nSubC^D,iSubC^D
      double precision :: xSubP1,xSubP2,dxSubP,xerf^L,fluxsubC,RsubC
      double precision :: TBsubC,PBsubC
      double precision :: xSubC(1:3),dxSubC^D,xCent(1:2),xSubC_car(1:3)
      double precision :: R_thick,dotp,dvolume,R_occult,Rc
      double precision :: dxl(1:3),x_sph(1:3),dx_sph(1:3)
      double precision :: unitv_r(1:3),unitv_theta(1:3),unitv_phi(1:3)
      logical :: sun_back_side,emit
 
      integer :: mass
      double precision :: logTe
      character (30) :: ion
      double precision :: lineCent
      double precision :: sigma_PSF,spaceRsl,wlRsl,sigma0,factor,wslit
      double precision :: RHESSI_rsl,area_1AU,arcsec,pixel
 
      ^d&ixomin^d=ixmlo^d;
      ^d&ixomax^d=ixmhi^d;
      ^d&iximin^d=ixglo^d;
      ^d&iximax^d=ixghi^d;
 
      if (si_unit) then
        arcsec=7.25d5/unit_length
      else
        arcsec=7.25d7/unit_length
      endif
 
      allocate(flux(ixi^s),opacity(ixi^s))
      if (datatype=='image_euv') then
        if (trim(emission_model)=='pseudo_current') then
          call get_pseudo_current(igrid,ixi^l,ixo^l,ps(igrid)%w,flux)
        else if (trim(emission_model)=='radio_ff') then
          call get_radio_ff_source_opacity(ixi^l,ixo^l,ps(igrid)%w,ps(igrid)%x,fl,flux,opacity)
        else
          ! get local EUV flux and velocity
          call get_euv(wavelength,ixi^l,ixo^l,ps(igrid)%w,ps(igrid)%x,fl,flux)
          flux(ixo^s)=flux(ixo^s)/instrument_resolution_factor**2   ! adjust flux due to artifical change of resolution
        endif
        call get_line_info(wavelength,ion,mass,logte,linecent,spacersl,wlrsl,sigma_psf,wslit)
        pixel=spacersl*arcsec
        sigma0=sigma_psf*pixel
      else if (datatype=='image_sxr') then
        ! get local SXR flux photons cm^-3 s^-1 (cgs) or photons m^-3 s^-1 (SI)
        call get_sxr(ixi^l,ixo^l,ps(igrid)%w,ps(igrid)%x,fl,flux,emin_sxr,emax_sxr) 
        rhessi_rsl=2.3d0/instrument_resolution_factor
        sigma_psf=1.d0
        pixel=rhessi_rsl*arcsec
        sigma0=sigma_psf*pixel
        area_1au=2.81d27
      endif
 
      ! integrate emission
      r_thick=r_opt_thick*const_rsun/unit_length
      {do ix^d=ixomin^d,ixomax^d\}
        x_sph(1:3)=ps(igrid)%x(ix^d,1:3)
        dx_sph(1:3)=ps(igrid)%dx(ix^d,1:3)
        dxl(1)=dx_sph(1) ! cell size in length
        dxl(2)=x_sph(1)*dx_sph(2) ! cell size in length
        dxl(3)=x_sph(1)*dsin(x_sph(2))*dx_sph(3) ! cell size in length
        ! dividing a cell to several sub-cells to get more accurate integrating values
        ^d&nsubc^d=1;
        call get_unit_vector_spherical(x_sph,unitv_r,unitv_theta,unitv_phi)
        call dot_product_loc(unitv_r,vec_xi1,dotp)
        nsubc1=max(nsubc1,ceiling(dxl(1)*abs(dotp)/(dxi/2.d0)))
        call dot_product_loc(unitv_r,vec_xi2,dotp)
        nsubc1=max(nsubc1,ceiling(dxl(1)*abs(dotp)/(dxi/2.d0)))
        call dot_product_loc(unitv_theta,vec_xi1,dotp)
        nsubc2=max(nsubc2,ceiling(dxl(2)*abs(dotp)/(dxi/2.d0)))
        call dot_product_loc(unitv_theta,vec_xi2,dotp)
        nsubc2=max(nsubc2,ceiling(dxl(2)*abs(dotp)/(dxi/2.d0)))
        call dot_product_loc(unitv_phi,vec_xi1,dotp)
        nsubc3=max(nsubc3,ceiling(dxl(3)*abs(dotp)/(dxi/2.d0)))
        call dot_product_loc(unitv_phi,vec_xi2,dotp)
        nsubc3=max(nsubc3,ceiling(dxl(3)*abs(dotp)/(dxi/2.d0)))
 
        ! integrate sub-cells
        do isubc1=1,nsubc1
          ! sub-cell center coordinate in spherical
          xsubc(1)=x_sph(1)-half*dx_sph(1)+(isubc1-half)*dx_sph(1)/nsubc1
          rsubc=xsubc(1)
          dxsubc1=dx_sph(1)/nsubc1 ! sub-cell size in length
          do isubc2=1,nsubc2
            ! sub-cell center coordinate in spherical
            xsubc(2)=x_sph(2)-half*dx_sph(2)+(isubc2-half)*dx_sph(2)/nsubc2
            dxsubc2=xsubc(1)*dx_sph(2)/nsubc2 ! sub-cell size in length
            dxsubc3=xsubc(1)*dsin(xsubc(2))*dx_sph(3)/nsubc3  ! sub-cell size in length
            dvolume=dxsubc1*dxsubc2*dxsubc3
            if (datatype=='image_euv') then
              if (si_unit) then
                fluxsubc=flux(ix^d)*dvolume*unit_length*1.d2/dxi/dxi  ! DN s^-1
              else
                fluxsubc=flux(ix^d)*dvolume*unit_length/dxi/dxi  ! DN s^-1
              endif
            else if (datatype=='image_sxr') then
              ! sub-cell SXR flux at 1 AU [photons s^-1 cm^-2]
              fluxsubc=flux(ix^d)*dvolume*unit_length**3/area_1au
            endif
            ! enter integration if flux large enough
            if (fluxsubc>smalldouble) then
              do isubc3=1,nsubc3
                ! sub-cell center coordinate in spherical
                xsubc(3)=x_sph(3)-half*dx_sph(3)+(isubc3-half)*dx_sph(3)/nsubc3
                call get_cor_image_spherical(xsubc,xcent)
                rc=dsqrt(xcent(1)**2+xcent(2)**2) ! distance to sun center (on the image plane)
                !
                ! whether the local emitted photons can arrive the telescope
                call spherical_to_cartesian(xsubc,xsubc_car)
                call dot_product_loc(vec_los,xsubc_car,dotp)
                sun_back_side=.true.
                if (dotp<0.d0) sun_back_side=.false.
                ! whether the local emission can reach the telescope
                if (sun_back_side) then
                  emit=.false.
                  if (rc>r_thick) emit=.true.
                else
                  emit=.true.
                  if (xsubc(1)<=r_thick) emit=.false.
                endif
                !
                if (emit) then
                  ! mapping the 3D coordinate to location at the image
                  ! distribution at nearby pixels
                  ixp1=floor((xcent(1)-(xi1(1)-half*dxi))/dxi)+1
                  ixp2=floor((xcent(2)-(xi2(1)-half*dxi))/dxi)+1
                  ixpmin1=max(1,ixp1-3)
                  ixpmax1=min(ixp1+3,numxi1)
                  ixpmin2=max(1,ixp2-3)
                  ixpmax2=min(ixp2+3,numxi2)
                  do ixp1=ixpmin1,ixpmax1
                    do ixp2=ixpmin2,ixpmax2
                      xerfmin1=((xi1(ixp1)-half*dxi)-xcent(1))/(sqrt(2.d0)*sigma0)
                      xerfmax1=((xi1(ixp1)+half*dxi)-xcent(1))/(sqrt(2.d0)*sigma0)
                      xerfmin2=((xi2(ixp2)-half*dxi)-xcent(2))/(sqrt(2.d0)*sigma0)
                      xerfmax2=((xi2(ixp2)+half*dxi)-xcent(2))/(sqrt(2.d0)*sigma0)
                      factor=(erfc(xerfmin1)-erfc(xerfmax1))*(erfc(xerfmin2)-erfc(xerfmax2))/4.d0
                      em(ixp1,ixp2)=em(ixp1,ixp2)+fluxsubc*factor
                    enddo !ixP2
                  enddo !ixP1
                endif !emit
              enddo !iSubC3
            endif !smallflux
          enddo !iSubC2
        enddo !iSubC1
      {enddo\} !ix
 
      deallocate(flux,opacity)
 
    end subroutine integrate_emission_spherical
 
    subroutine integrate_whitelight_spherical(igrid,numXI1,numXI2,numWI,xI1,xI2,dxI,fl,datatype,WLB)
      use mod_eos, only: eos
 
      integer, intent(in) :: igrid,numXI1,numXI2,numWI
      double precision, intent(in) :: xI1(numXI1),xI2(numXI2)
      double precision, intent(in) :: dxI
      type(te_fluid), intent(in) :: fl
      character(20), intent(in) :: datatype
      double precision, intent(inout) :: WLB(numXI1,numXI2,numWI)
 
      integer :: ixO^L,ixO^D,ixI^L,ix^D,i,j
      double precision, allocatable :: flux(:^D&),Ne(:^D&)
      integer :: ixP^L,ixP^D,nSubC^D,iSubC^D
      double precision :: xSubP1,xSubP2,dxSubP,xerf^L,fluxsubC,RsubC
      double precision :: sigma_PSF,sigma0,arcsec,pixel,LASCO_rsl
      double precision :: A,B,C,D,Rc,Ne0,TBsubC,PBsubC,factor
      double precision :: R_thick,dotp,dvolume,R_occult
      double precision :: xSubC(1:3),dxSubC^D,xCent(1:2),xSubC_car(1:3)
      double precision :: dxl(1:3),x_sph(1:3),dx_sph(1:3)
      double precision :: unitv_r(1:3),unitv_theta(1:3),unitv_phi(1:3)
      logical :: emit
 
      ^d&ixomin^d=ixmlo^d;
      ^d&ixomax^d=ixmhi^d;
      ^d&iximin^d=ixglo^d;
      ^d&iximax^d=ixghi^d;
 
      if (si_unit) then
        arcsec=7.25d5/unit_length
      else
        arcsec=7.25d7/unit_length
      endif
 
      allocate(ne(ixi^s))
      if (whitelight_instrument=='LASCO/C1') then
        lasco_rsl=5.6d0/instrument_resolution_factor
        r_occult=1.1d0
      else if (whitelight_instrument=='LASCO/C2') then
        lasco_rsl=11.4d0/instrument_resolution_factor
        r_occult=2.d0
      else if (whitelight_instrument=='LASCO/C3') then
        lasco_rsl=56.d0/instrument_resolution_factor
        r_occult=3.7d0
      endif
      if (r_occultor>1.d0) r_occult=r_occultor
      r_occult=r_occult*const_rsun/unit_length
      call fl%get_rho(ps(igrid)%w,ps(igrid)%x,ixi^l,ixo^l,ne)
      ! get actual electron density from EoS (replaces rho with ne)
      block
        double precision :: nH_dummy(ixI^S)
        call eos%get_ne_nH(ixi^l, ixo^l, ps(igrid)%w, ne, nh_dummy)
      end block
      sigma_psf=1.d0
      pixel=lasco_rsl*arcsec
      sigma0=sigma_psf*pixel
 
      ! integrate emission
      r_thick=r_opt_thick*const_rsun/unit_length
      {do ix^d=ixomin^d,ixomax^d\}
        x_sph(1:3)=ps(igrid)%x(ix^d,1:3)
        dx_sph(1:3)=ps(igrid)%dx(ix^d,1:3)
        dxl(1)=dx_sph(1) ! cell size in length
        dxl(2)=x_sph(1)*dx_sph(2) ! cell size in length
        dxl(3)=x_sph(1)*dsin(x_sph(2))*dx_sph(3) ! cell size in length
        ne0=ne(ix^d)*unit_numberdensity
        ! dividing a cell to several sub-cells to get more accurate integrating values
        ^d&nsubc^d=1;
        call get_unit_vector_spherical(x_sph,unitv_r,unitv_theta,unitv_phi)
        call dot_product_loc(unitv_r,vec_xi1,dotp)
        nsubc1=max(nsubc1,ceiling(dxl(1)*abs(dotp)/(dxi/2.d0)))
        call dot_product_loc(unitv_r,vec_xi2,dotp)
        nsubc1=max(nsubc1,ceiling(dxl(1)*abs(dotp)/(dxi/2.d0)))
        call dot_product_loc(unitv_theta,vec_xi1,dotp)
        nsubc2=max(nsubc2,ceiling(dxl(2)*abs(dotp)/(dxi/2.d0)))
        call dot_product_loc(unitv_theta,vec_xi2,dotp)
        nsubc2=max(nsubc2,ceiling(dxl(2)*abs(dotp)/(dxi/2.d0)))
        call dot_product_loc(unitv_phi,vec_xi1,dotp)
        nsubc3=max(nsubc3,ceiling(dxl(3)*abs(dotp)/(dxi/2.d0)))
        call dot_product_loc(unitv_phi,vec_xi2,dotp)
        nsubc3=max(nsubc3,ceiling(dxl(3)*abs(dotp)/(dxi/2.d0)))
 
        ! integrate sub-cells
        do isubc1=1,nsubc1
          ! sub-cell center coordinate in spherical
          xsubc(1)=x_sph(1)-half*dx_sph(1)+(isubc1-half)*dx_sph(1)/nsubc1
          rsubc=xsubc(1)
          dxsubc1=dx_sph(1)/nsubc1 ! sub-cell size in length
          call get_thomson_parameters(rsubc,a,b,c,d)
          do isubc2=1,nsubc2
            ! sub-cell center coordinate in spherical
            xsubc(2)=x_sph(2)-half*dx_sph(2)+(isubc2-half)*dx_sph(2)/nsubc2
            dxsubc2=xsubc(1)*dx_sph(2)/nsubc2 ! sub-cell size in length
            dxsubc3=xsubc(1)*dsin(xsubc(2))*dx_sph(3)/nsubc3  ! sub-cell size in length
            dvolume=dxsubc1*dxsubc2*dxsubc3
            do isubc3=1,nsubc3
              ! sub-cell center coordinate in spherical
              xsubc(3)=x_sph(3)-half*dx_sph(3)+(isubc3-half)*dx_sph(3)/nsubc3
              call get_cor_image_spherical(xsubc,xcent)
              rc=dsqrt(xcent(1)**2+xcent(2)**2) ! distance to sun center (on the image plane)
              ! whether the local emitted photons can arrive the telescope
              emit=.false.
              if (rc>r_occult) then 
                emit=.true.
                ! scaterring flux from cm^-3 of plasma
                call get_whitelight_thomson(rsubc,rc,ne0,a,b,c,d,tbsubc,pbsubc)
                tbsubc=tbsubc*dvolume*unit_length/dxi/dxi
                pbsubc=pbsubc*dvolume*unit_length/dxi/dxi
                if (tbsubc<1.d-20) emit=.false.
              endif
              if (emit) then
                ! mapping the 3D coordinate to location at the image
                ! distribution at nearby pixels
                ixp1=floor((xcent(1)-(xi1(1)-half*dxi))/dxi)+1
                ixp2=floor((xcent(2)-(xi2(1)-half*dxi))/dxi)+1
                ixpmin1=max(1,ixp1-3)
                ixpmax1=min(ixp1+3,numxi1)
                ixpmin2=max(1,ixp2-3)
                ixpmax2=min(ixp2+3,numxi2)
                do ixp1=ixpmin1,ixpmax1
                  do ixp2=ixpmin2,ixpmax2
                    xerfmin1=((xi1(ixp1)-half*dxi)-xcent(1))/(sqrt(2.d0)*sigma0)
                    xerfmax1=((xi1(ixp1)+half*dxi)-xcent(1))/(sqrt(2.d0)*sigma0)
                    xerfmin2=((xi2(ixp2)-half*dxi)-xcent(2))/(sqrt(2.d0)*sigma0)
                    xerfmax2=((xi2(ixp2)+half*dxi)-xcent(2))/(sqrt(2.d0)*sigma0)
                    factor=(erfc(xerfmin1)-erfc(xerfmax1))*(erfc(xerfmin2)-erfc(xerfmax2))/4.d0
                    wlb(ixp1,ixp2,1)=wlb(ixp1,ixp2,1)+tbsubc*factor
                    wlb(ixp1,ixp2,2)=wlb(ixp1,ixp2,2)+pbsubc*factor
                  enddo !ixP2
                enddo !ixP1
              endif
            enddo !iSubC3
          enddo !iSubC2
        enddo !iSubC1
      {enddo\} !ix
 
      deallocate(ne)
 
    end subroutine integrate_whitelight_spherical
 
    subroutine get_thomson_parameters(Rl,A,B,C,D)
      ! parameters given in Billings 1968
      use mod_constants
      double precision, intent(in) :: Rl
      double precision, intent(inout) :: A,B,C,D
 
      double precision :: sinO,cosO,sinO2,cosO2,tmp
 
      sino=const_rsun/(rl*unit_length)
      sino2=sino**2
      coso2=1.d0-sino2
      coso=abs(dsqrt(coso2))
      tmp=log((1.d0+sino)/coso)
      a=coso*sino2
      b=-(1.d0-3.d0*sino2-(coso2/sino)*(1.d0+3.d0*sino2)*tmp)/8.d0
      c=4.d0/3.d0-coso-coso*coso2/3.d0
      d=(5.d0+sino2-(coso2/sino)*(5.d0-sino2)*tmp)/8.d0
 
    end subroutine get_thomson_parameters
 
    subroutine get_whitelight_thomson(Rl,Rin,Ne,A,B,C,D,fluxTB,fluxPB)
      ! use the method in SSW/eltheory
      double precision, intent(in) :: Rl,Rin,Ne,A,B,C,D
      double precision, intent(inout) :: fluxTB,fluxPB
 
      double precision :: const,u,Bt,Br,PB,TB,sinchi2
 
      u=0.63d0
      const=1.24878d-25/(1.d0-u/3.d0)
      sinchi2=(rin/rl)**2
      bt=const*(c+u*(d-c))
      pb=const*sinchi2*((a+u*(b-a)))
      br=bt-pb
      tb=bt+br
      fluxtb=tb*ne
      fluxpb=pb*ne
 
    end subroutine get_whitelight_thomson
 
    subroutine get_unit_vector_spherical(x_sph,unitv_r,unitv_theta,unitv_phi)
      double precision, intent(in) :: x_sph(1:3)
      double precision, intent(inout) :: unitv_r(1:3),unitv_theta(1:3),unitv_phi(1:3)
 
      unitv_r(1)=dsin(x_sph(2))*dcos(x_sph(3))
      unitv_r(2)=dsin(x_sph(2))*dsin(x_sph(3))
      unitv_r(3)=dcos(x_sph(2))
      unitv_theta(1)=dcos(x_sph(2))*dcos(x_sph(3))
      unitv_theta(2)=dcos(x_sph(2))*dsin(x_sph(3))
      unitv_theta(3)=-dsin(x_sph(2))
      unitv_phi(1)=-dsin(x_sph(3))
      unitv_phi(2)=dcos(x_sph(3))
      unitv_phi(3)=zero
 
    end subroutine get_unit_vector_spherical
 
    subroutine output_data(qunit,xO1,xO2,dxO1,dxO2,wO,nXO1,nXO2,nWO,datatype)
      ! change the format of data and write data
      use mod_global_parameters
 
      integer, intent(in) :: qunit,nXO1,nXO2,nWO
      double precision, intent(in) :: dxO1(nxO1),dxO2(nxO2)
      double precision, intent(in) :: xO1(nXO1),xO2(nxO2)
      double precision, intent(inout) :: wO(nXO1,nXO2,nWO)
      character(20), intent(in) :: datatype
 
      integer :: nPiece,nP1,nP2,nC1,nC2,nWC
      integer :: piece_nmax1,piece_nmax2,ix1,ix2,j,ipc,ixc1,ixc2
      double precision :: uniform_tol
      double precision, allocatable :: xC(:,:,:,:),wC(:,:,:,:),dxC(:,:,:,:)
 
      ! clean small values
      uniform_tol=1.d-10
      do ix1=1,nxo1
        do ix2=1,nxo2
          do j=1,nwo
            if (abs(wo(ix1,ix2,j))<smalldouble) wo(ix1,ix2,j)=zero
          enddo
        enddo
      enddo
 
      ! how many cells in each grid
      if (dat_resolution) then
        if (datatype=='image_euv' .or. datatype=='image_sxr') then
          if (los_phi==0 .and. los_theta==90) then
            piece_nmax1=block_nx2
            piece_nmax2=block_nx3
          else if (los_phi==90 .and. los_theta==90) then
            piece_nmax1=block_nx3
            piece_nmax2=block_nx1
          else
            piece_nmax1=block_nx1
            piece_nmax2=block_nx2
          endif
        else if (datatype=='spectrum_euv') then
          piece_nmax1=16
          if (direction_slit==1) then
            piece_nmax2=block_nx1
          else if (direction_slit==2) then
            piece_nmax2=block_nx2
          else
            piece_nmax2=block_nx3
          endif
        endif
      else
        piece_nmax1=20
        piece_nmax2=20
      endif
      loopn1: do j=piece_nmax1,1,-1
        if(mod(nxo1,j)==0) then
          nc1=j
          exit loopn1
        endif
      enddo loopn1
      loopn2: do j=piece_nmax2,1,-1
        if(mod(nxo2,j)==0) then
          nc2=j
          exit loopn2
        endif
      enddo loopn2
      ! how many grids
      np1=nxo1/nc1
      np2=nxo2/nc2
      npiece=np1*np2
      nwc=nwo
 
      ! output images
      select case(convert_type)
        case('EIvtuCCmpi','ESvtuCCmpi','SIvtuCCmpi','WIvtuCCmpi')
          ! put data into grids
          allocate(xc(npiece,nc1,nc2,2))
          allocate(dxc(npiece,nc1,nc2,2))
          allocate(wc(npiece,nc1,nc2,nwo))
          do ipc=1,npiece
            do ixc1=1,nc1
              do ixc2=1,nc2
                ix1=mod(ipc-1,np1)*nc1+ixc1
                ix2=floor(1.0*(ipc-1)/np1)*nc2+ixc2
                xc(ipc,ixc1,ixc2,1)=xo1(ix1)
                xc(ipc,ixc1,ixc2,2)=xo2(ix2)
                dxc(ipc,ixc1,ixc2,1)=dxo1(ix1)
                dxc(ipc,ixc1,ixc2,2)=dxo2(ix2)
                do j=1,nwc
                  wc(ipc,ixc1,ixc2,j)=wo(ix1,ix2,j)
                enddo
              enddo
            enddo
          enddo
          ! write data into vtu file
          call write_image_vtucc(qunit,xc,wc,dxc,npiece,nc1,nc2,nwc,datatype)
          deallocate(xc,dxc,wc)
        case('EIvtiCCmpi','ESvtiCCmpi','SIvtiCCmpi','WIvtiCCmpi')
          if (dat_resolution .and. &
              (maxval(abs(dxo1(:)-dxo1(1)))>uniform_tol*max(one,abs(dxo1(1))) .or. &
               maxval(abs(dxo2(:)-dxo2(1)))>uniform_tol*max(one,abs(dxo2(1))))) then
            call mpistop("vti needs uniform dat-resolution image grids")
          else
            call write_image_vticc(qunit,xo1,xo2,dxo1,dxo2,wo,nxo1,nxo2,nwo,nc1,nc2)
          endif
        case default
          call mpistop("Error in synthesize emission: Unknown convert_type")
      end select
 
    end subroutine output_data
  }
 
    subroutine write_image_vticc(qunit,xO1,xO2,dxO1,dxO2,wO,nXO1,nXO2,nWO,nC1,nC2)
      ! write image data to vti
      use mod_global_parameters
 
      integer, intent(in) :: qunit,nXO1,nXO2,nWO,nC1,nC2
      double precision, intent(in) :: xO1(nXO1),xO2(nxO2)
      double precision, intent(in) :: dxO1(nxO1),dxO2(nxO2)
      double precision, intent(in) :: wO(nXO1,nXO2,nWO)
 
      double precision :: origin(1:3), spacing(1:3)
      integer :: wholeExtent(1:6)
      integer :: iw
      integer :: ixC1,ixC2
 
      integer :: filenr
      logical :: fileopen
      character (70) :: subname,wname,vname,nameL,nameS
      character (len=std_len) :: filename
      logical :: sph_datres_no_doppler
 
 
      origin(1)=xo1(1)-0.5d0*dxo1(1)
      origin(2)=xo2(1)-0.5d0*dxo2(1)
      origin(3)=zero
      spacing(1)=dxo1(1)
      spacing(2)=dxo2(1)
      spacing(3)=one
      wholeextent=0
      wholeextent(2)=nxo1
      wholeextent(4)=nxo2
      sph_datres_no_doppler=dat_resolution .and. coordinate==spherical .and. trim(ray_method_active)=='spherical'
 
      if (mype==0) then
        inquire(qunit,opened=fileopen)
        if(.not.fileopen)then
          ! generate filename 
          filenr=snapshotini
          if (autoconvert) filenr=snapshotnext
          if (convert_type=='EIvtiCCmpi') then
            write(filename,'(a,i4.4,a)') trim(filename_euv),filenr,".vti"
          else if (convert_type=='SIvtiCCmpi') then
            write(filename,'(a,i4.4,a)') trim(filename_sxr),filenr,".vti"
          else if (convert_type=='WIvtiCCmpi') then
            write(filename,'(a,i4.4,a)') trim(filename_whitelight),filenr,".vti"
          else if (convert_type=='ESvtiCCmpi') then
            write(filename,'(a,i4.4,a)') trim(filename_spectrum),filenr,".vti"
          endif
          open(qunit,file=filename,status='unknown',form='formatted')
        endif
 
        ! generate xml header
        write(qunit,'(a)')'<?xml version="1.0"?>'
        write(qunit,'(a)',advance='no') '<VTKFile type="ImageData"'
        write(qunit,'(a)')' version="0.1" byte_order="LittleEndian">'
        write(qunit,'(a,3(1pe14.6),a,6(i10),a,3(1pe14.6),a)')'  <ImageData Origin="',&
              origin,'" WholeExtent="',wholeextent,'" Spacing="',spacing,'">'
        ! file info        
        write(qunit,'(a)')'<FieldData>'
        write(qunit,'(2a)')'<DataArray type="Float32" Name="TIME" ',&
                           'NumberOfTuples="1" format="ascii">'
        write(qunit,*) real(global_time*time_convert_factor)
        write(qunit,'(a)')'</DataArray>'
        write(qunit,'(a)')'</FieldData>'
        ! pixel/cell data
        write(qunit,'(a,6(i10),a)') '<Piece Extent="',wholeextent,'">'
        write(qunit,'(a)')'<CellData>'
        do iw=1,nwo
          ! variable name
          if (convert_type=='EIvtiCCmpi') then
            if (wavelength<100) then
              write(vname,'(a,i2)') "AIA",wavelength
            else if (wavelength<1000) then
              write(vname,'(a,i3)') "AIA",wavelength
            else
              write(vname,'(a,i4)') "IRIS",wavelength
            endif
            if (trim(emission_model)=='pseudo_current' .and. iw==1) vname='pseudo_current'
            if (trim(emission_model)=='radio_ff' .and. iw==1) vname='radio_brightness_temperature'
            if (trim(radiation_transfer)=='thick' .and. iw==1) vname=trim(vname)//'_thick'
            if (iw==2 .and. dat_resolution .and. (.not. sph_datres_no_doppler) .and. &
                trim(emission_model)/='radio_ff' .and. &
                trim(emission_model)/='pseudo_current') vname='Doppler_velocity'
            if (output_tau .and. trim(radiation_transfer)=='thick' .and. &
                ((trim(emission_model)=='radio_ff' .and. iw==2) .or. &
                 (trim(emission_model)/='radio_ff' .and. trim(emission_model)/='pseudo_current' .and. &
                  ((dat_resolution .and. ((sph_datres_no_doppler .and. iw==2) .or. &
                                          ((.not. sph_datres_no_doppler) .and. iw==3))) .or. &
                   ((.not. dat_resolution) .and. iw==2))))) then
              vname='tau'
            endif
            if (output_absorption_fraction .and. trim(radiation_transfer)=='thick' .and. &
                ((trim(emission_model)=='radio_ff' .and. ((output_tau .and. iw==3) .or. &
                                                         ((.not. output_tau) .and. iw==2))) .or. &
                 (trim(emission_model)/='radio_ff' .and. trim(emission_model)/='pseudo_current' .and. &
                  ((dat_resolution .and. sph_datres_no_doppler .and. output_tau .and. iw==3) .or. &
                   (dat_resolution .and. sph_datres_no_doppler .and. (.not. output_tau) .and. iw==2) .or. &
                   (dat_resolution .and. (.not. sph_datres_no_doppler) .and. output_tau .and. iw==4) .or. &
                   (dat_resolution .and. (.not. sph_datres_no_doppler) .and. (.not. output_tau) .and. iw==3) .or. &
                   ((.not. dat_resolution) .and. output_tau .and. iw==3) .or. &
                   ((.not. dat_resolution) .and. (.not. output_tau) .and. iw==2))))) then
              vname='absorption_fraction'
            endif
          else if (convert_type=='SIvtiCCmpi') then
            if (emin_sxr<10 .and. emax_sxr<10) then
              write(vname,'(a,i1,a,i1,a)') "SXR",emin_sxr,"-",emax_sxr,"keV"
            else if (emin_sxr<10 .and. emax_sxr>=10) then
              write(vname,'(a,i1,a,i2,a)') "SXR",emin_sxr,"-",emax_sxr,"keV"
            else
              write(vname,'(a,i2,a,i2,a)') "SXR",emin_sxr,"-",emax_sxr,"keV"
            endif
          else if (convert_type=='WIvtiCCmpi') then
            if (iw==1) write(vname,'(a)')'B'
            if (iw==2) write(vname,'(a)')'pB'
          else if (convert_type=='ESvtiCCmpi') then
            if (spectrum_wl==1354) then
              write(vname,'(a,i4)') "SG",spectrum_wl
            else
              write(vname,'(a,i3)') "EIS",spectrum_wl
            endif
          endif
          write(qunit,'(a,a,a)')&
            '<DataArray type="Float64" Name="',trim(vname),'" format="ascii">'
          write(qunit,'(200(1pe14.6))') ((wo(ixc1,ixc2,iw),ixc1=1,nxo1),ixc2=1,nxo2)
          write(qunit,'(a)')'</DataArray>'
        enddo
        write(qunit,'(a)')'</CellData>'
        write(qunit,'(a)')'</Piece>'
        ! end
        write(qunit,'(a)')'</ImageData>'
        write(qunit,'(a)')'</VTKFile>'
        close(qunit)
      endif
 
    end subroutine write_image_vticc
 
    subroutine write_image_vtucc(qunit,xC,wC,dxC,nPiece,nC1,nC2,nWC,datatype)
      ! write image data to vtu
      use mod_global_parameters
 
      integer, intent(in) :: qunit
      integer, intent(in) :: nPiece,nC1,nC2,nWC
      double precision, intent(in) :: xC(nPiece,nC1,nC2,2),dxC(nPiece,nc1,nc2,2)
      double precision, intent(in) :: wC(nPiece,nC1,nC2,nWC)
      character(20), intent(in) :: datatype
 
      integer :: nP1,nP2
      double precision :: xP(nPiece,nC1+1,nC2+1,2)
      integer :: filenr
      logical :: fileopen
      character (70) :: subname,wname,vname,nameL,nameS
      character (len=std_len) :: filename
      integer :: ixC1,ixC2,ixP,ix1,ix2,j
      integer :: nc,np,icel,VTK_type
      logical :: sph_datres_no_doppler
 
      np1=nc1+1
      np2=nc2+1
      np=np1*np2
      nc=nc1*nc2
      sph_datres_no_doppler=dat_resolution .and. coordinate==spherical .and. trim(ray_method_active)=='spherical'
      ! cell corner location     
      do ixp=1,npiece
        do ix1=1,np1
          do ix2=1,np2
            if (ix1<np1) xp(ixp,ix1,ix2,1)=xc(ixp,ix1,1,1)-0.5d0*dxc(ixp,ix1,1,1)
            if (ix1==np1) xp(ixp,ix1,ix2,1)=xc(ixp,ix1-1,1,1)+0.5d0*dxc(ixp,ix1-1,1,1)
            if (ix2<np2) xp(ixp,ix1,ix2,2)=xc(ixp,1,ix2,2)-0.5d0*dxc(ixp,1,ix2,2)
            if (ix2==np2) xp(ixp,ix1,ix2,2)=xc(ixp,1,ix2-1,2)+0.5d0*dxc(ixp,1,ix2-1,2)
          enddo
        enddo
      enddo
      if (mype==0) then
        inquire(qunit,opened=fileopen)
        if(.not.fileopen)then
          ! generate filename 
          filenr=snapshotini
          if (autoconvert) filenr=snapshotnext
          if (datatype=='image_euv') then
            write(filename,'(a,i4.4,a)') trim(filename_euv),filenr,".vtu"
          else if (datatype=='image_sxr') then
            write(filename,'(a,i4.4,a)') trim(filename_sxr),filenr,".vtu"
          else if (datatype=='image_whitelight') then
            write(filename,'(a,i4.4,a)') trim(filename_whitelight),filenr,".vtu"
          else if (datatype=='spectrum_euv') then
            write(filename,'(a,i4.4,a)') trim(filename_spectrum),filenr,".vtu"
          endif
          open(qunit,file=filename,status='unknown',form='formatted')
        endif
        ! generate xml header
        write(qunit,'(a)')'<?xml version="1.0"?>'
        write(qunit,'(a)',advance='no') '<VTKFile type="UnstructuredGrid"'
        write(qunit,'(a)')' version="0.1" byte_order="LittleEndian">'
        write(qunit,'(a)')'<UnstructuredGrid>'
        write(qunit,'(a)')'<FieldData>'
        write(qunit,'(2a)')'<DataArray type="Float32" Name="TIME" ',&
                           'NumberOfTuples="1" format="ascii">'
        write(qunit,*) real(global_time*time_convert_factor)
        write(qunit,'(a)')'</DataArray>'
        write(qunit,'(a)')'</FieldData>'
        do ixp=1,npiece
          write(qunit,'(a,i7,a,i7,a)') &
                '<Piece NumberOfPoints="',np,'" NumberOfCells="',nc,'">'
          write(qunit,'(a)')'<CellData>'
          do j=1,nwc
            if (datatype=='image_euv') then
              if (j==1) then
                if (wavelength<100) then
                  write(vname,'(a,i2)') "AIA",wavelength
                else if (wavelength<1000) then
                  write(vname,'(a,i3)') "AIA",wavelength
                else
                  write(vname,'(a,i4)') "IRIS",wavelength
                endif
                if (trim(emission_model)=='pseudo_current') vname='pseudo_current'
                if (trim(emission_model)=='radio_ff') vname='radio_brightness_temperature'
                if (trim(radiation_transfer)=='thick') vname=trim(vname)//'_thick'
              endif
              if (j==2 .and. dat_resolution .and. (.not. sph_datres_no_doppler) .and. &
                  trim(emission_model)/='radio_ff' .and. &
                  trim(emission_model)/='pseudo_current') vname='Doppler_velocity'
              if (output_tau .and. trim(radiation_transfer)=='thick' .and. &
                  ((trim(emission_model)=='radio_ff' .and. j==2) .or. &
                   (trim(emission_model)/='radio_ff' .and. trim(emission_model)/='pseudo_current' .and. &
                    ((dat_resolution .and. ((sph_datres_no_doppler .and. j==2) .or. &
                                            ((.not. sph_datres_no_doppler) .and. j==3))) .or. &
                     ((.not. dat_resolution) .and. j==2))))) then
                vname='tau'
              endif
              if (output_absorption_fraction .and. trim(radiation_transfer)=='thick' .and. &
                  ((trim(emission_model)=='radio_ff' .and. ((output_tau .and. j==3) .or. &
                                                           ((.not. output_tau) .and. j==2))) .or. &
                   (trim(emission_model)/='radio_ff' .and. trim(emission_model)/='pseudo_current' .and. &
                    ((dat_resolution .and. sph_datres_no_doppler .and. output_tau .and. j==3) .or. &
                     (dat_resolution .and. sph_datres_no_doppler .and. (.not. output_tau) .and. j==2) .or. &
                     (dat_resolution .and. (.not. sph_datres_no_doppler) .and. output_tau .and. j==4) .or. &
                     (dat_resolution .and. (.not. sph_datres_no_doppler) .and. (.not. output_tau) .and. j==3) .or. &
                     ((.not. dat_resolution) .and. output_tau .and. j==3) .or. &
                     ((.not. dat_resolution) .and. (.not. output_tau) .and. j==2))))) then
                vname='absorption_fraction'
              endif
            else if (datatype=='image_sxr') then
              if (emin_sxr<10 .and. emax_sxr<10) then
                write(vname,'(a,i1,a,i1,a)') "SXR",emin_sxr,"-",emax_sxr,"keV"
              else if (emin_sxr<10 .and. emax_sxr>=10) then
                write(vname,'(a,i1,a,i2,a)') "SXR",emin_sxr,"-",emax_sxr,"keV"
              else
                write(vname,'(a,i2,a,i2,a)') "SXR",emin_sxr,"-",emax_sxr,"keV"
              endif
            else if (datatype=='image_whitelight') then
              write(vname,'(a)')'whitelight'
            else if (datatype=='spectrum_euv') then
              if (spectrum_wl==1354) then
                write(vname,'(a,i4)') "SG",spectrum_wl
              else
                write(vname,'(a,i3)') "EIS",spectrum_wl
              endif
            endif
            write(qunit,'(a,a,a)')&
              '<DataArray type="Float64" Name="',trim(vname),'" format="ascii">'
            write(qunit,'(200(1pe14.6))') ((wc(ixp,ixc1,ixc2,j),ixc1=1,nc1),ixc2=1,nc2)
            write(qunit,'(a)')'</DataArray>'
          enddo
          write(qunit,'(a)')'</CellData>'
          write(qunit,'(a)')'<Points>'
          write(qunit,'(a)')'<DataArray type="Float32" NumberOfComponents="3" format="ascii">'
          do ix2=1,np2
            do ix1=1,np1
              if (datatype=='image_euv' .and. dat_resolution) then
                if (los_phi==0 .and. los_theta==90) then
                  write(qunit,'(3(1pe14.6))') 0.d0,xp(ixp,ix1,ix2,1),xp(ixp,ix1,ix2,2)
                else if (los_phi==90 .and. los_theta==90) then
                  write(qunit,'(3(1pe14.6))') xp(ixp,ix1,ix2,2),0.d0,xp(ixp,ix1,ix2,1)
                else
                  write(qunit,'(3(1pe14.6))') xp(ixp,ix1,ix2,1),xp(ixp,ix1,ix2,2),0.d0
                endif
              else if (datatype=='image_sxr' .and. dat_resolution) then
                if (los_phi==0 .and. los_theta==90) then
                  write(qunit,'(3(1pe14.6))') 0.d0,xp(ixp,ix1,ix2,1),xp(ixp,ix1,ix2,2)
                else if (los_phi==90 .and. los_theta==90) then
                  write(qunit,'(3(1pe14.6))') xp(ixp,ix1,ix2,2),0.d0,xp(ixp,ix1,ix2,1)
                else
                  write(qunit,'(3(1pe14.6))') xp(ixp,ix1,ix2,1),xp(ixp,ix1,ix2,2),0.d0
                endif
              else
                write(qunit,'(3(1pe14.6))') xp(ixp,ix1,ix2,1),xp(ixp,ix1,ix2,2),0.d0
              endif
            enddo
          enddo
          write(qunit,'(a)')'</DataArray>'
          write(qunit,'(a)')'</Points>'
          ! connetivity part
          write(qunit,'(a)')'<Cells>'
          write(qunit,'(a)')'<DataArray type="Int32" Name="connectivity" format="ascii">'
          do ix2=1,nc2
            do ix1=1,nc1
              write(qunit,'(4(i7))') ix1-1+(ix2-1)*np1,ix1+(ix2-1)*np1,&
                                     ix1-1+ix2*np1,ix1+ix2*np1
            enddo
          enddo
          write(qunit,'(a)')'</DataArray>'
          ! offsets data array
          write(qunit,'(a)')'<DataArray type="Int32" Name="offsets" format="ascii">'
          do icel=1,nc
            write(qunit,'(i7)') icel*(2**2)
          enddo
          write(qunit,'(a)')'</DataArray>'
          ! VTK cell type data array
          write(qunit,'(a)')'<DataArray type="Int32" Name="types" format="ascii">'
          ! VTK_LINE=3; VTK_PIXEL=8; VTK_VOXEL=11 -> vtk-syntax
          vtk_type=8
          do icel=1,nc
            write(qunit,'(i2)') vtk_type
          enddo
          write(qunit,'(a)')'</DataArray>'
          write(qunit,'(a)')'</Cells>'
          write(qunit,'(a)')'</Piece>'
        enddo
        write(qunit,'(a)')'</UnstructuredGrid>'
        write(qunit,'(a)')'</VTKFile>'
        close(qunit)
      endif
    end subroutine write_image_vtucc
 
    subroutine dot_product_loc(vec1,vec2,res)
      double precision, intent(in) :: vec1(1:3),vec2(1:3)
      double precision, intent(out) :: res
 
      res=vec1(1)*vec2(1)+vec1(2)*vec2(2)+vec1(3)*vec2(3)
 
    end subroutine dot_product_loc
 
    subroutine cross_product_loc(vec_in1,vec_in2,vec_out)
      double precision, intent(in) :: vec_in1(1:3),vec_in2(1:3)
      double precision, intent(out) :: vec_out(1:3)
 
      vec_out(1)=vec_in1(2)*vec_in2(3)-vec_in1(3)*vec_in2(2)
      vec_out(2)=vec_in1(3)*vec_in2(1)-vec_in1(1)*vec_in2(3)
      vec_out(3)=vec_in1(1)*vec_in2(2)-vec_in1(2)*vec_in2(1)
 
    end subroutine cross_product_loc
 
    subroutine init_vectors_spherical()
      integer :: j
      double precision :: LOS_psi
      double precision :: vec_car(1:3),vec_z(1:3),vec_temp1(1:3),vec_temp2(1:3)
      double precision :: vec_LOS_sph(1:3),vec_xI1_sph(1:3),vec_xI2_sph(1:3)
 
      ! antiparallel to LOS in spherical
      vec_los(1)=1.d0
      vec_los(2)=dpi*los_theta/180.d0
      vec_los(3)=dpi*los_phi/180.d0
      ! LOS in cartesian
      call spherical_to_cartesian(vec_los,vec_car)
      vec_los=-vec_car
 
      ! theta=0 in cartesian
      vec_z(:)=zero
      vec_z(3)=1.d0
 
      ! x direction for image
      if (los_theta==zero) then
        vec_temp1(1)=1.d0
        vec_temp1(2)=dpi/2.d0
        vec_temp1(3)=dpi*los_phi/180.d0
        call spherical_to_cartesian(vec_temp1,vec_car)
        vec_temp1=-vec_car
        call cross_product_loc(vec_temp1,vec_z,vec_xi1)
      else
        call cross_product_loc(vec_los,vec_z,vec_xi1)
      endif
 
      ! y direction for image
      call cross_product_loc(vec_xi1,vec_los,vec_xi2)
 
      ! rotate the image
      vec_temp1=vec_xi1/sqrt(vec_xi1(1)**2+vec_xi1(2)**2+vec_xi1(3)**2)
      vec_temp2=vec_xi2/sqrt(vec_xi2(1)**2+vec_xi2(2)**2+vec_xi2(3)**2)
      los_psi=dpi*image_rotate/180.d0
      vec_xi1=vec_temp1*cos(los_psi)-vec_temp2*sin(los_psi)
      vec_xi2=vec_temp2*cos(los_psi)+vec_temp1*sin(los_psi)
 
      do j=1,3
        if (abs(vec_los(j))<smalldouble) vec_los(j)=zero
        if (abs(vec_xi1(j))<smalldouble) vec_xi1(j)=zero
        if (abs(vec_xi2(j))<smalldouble) vec_xi2(j)=zero
      enddo
 
      call cartesian_to_spherical(vec_los,vec_los_sph)
      call cartesian_to_spherical(vec_xi1,vec_xi1_sph)
      call cartesian_to_spherical(vec_xi2,vec_xi2_sph)
      vec_los_sph(2:3)=vec_los_sph(2:3)*180.d0/dpi
      vec_xi1_sph(2:3)=vec_xi1_sph(2:3)*180.d0/dpi
      vec_xi2_sph(2:3)=vec_xi2_sph(2:3)*180.d0/dpi
 
      if (mype==0) write(*,'(a,f3.1,f6.1,f6.1,a)') ' ray direction (spherical): [',vec_los_sph(1),vec_los_sph(2),vec_los_sph(3),']'
      if (mype==0) write(*,'(a,f3.1,f6.1,f6.1,a)') ' xI1 direction (spherical): [',vec_xi1_sph(1),vec_xi1_sph(2),vec_xi1_sph(3),']'
      if (mype==0) write(*,'(a,f3.1,f6.1,f6.1,a)') ' xI2 direction (spherical): [',vec_xi2_sph(1),vec_xi2_sph(2),vec_xi2_sph(3),']'
 
    end subroutine init_vectors_spherical
 
    subroutine spherical_to_cartesian(vec_sph,vec_car)
      ! angles in rad
      double precision, intent(in) :: vec_sph(1:3)
      double precision, intent(inout) :: vec_car(1:3)
 
      vec_car(1)=vec_sph(1)*dsin(vec_sph(2))*dcos(vec_sph(3))
      vec_car(2)=vec_sph(1)*dsin(vec_sph(2))*dsin(vec_sph(3))
      vec_car(3)=vec_sph(1)*dcos(vec_sph(2))
 
    end subroutine spherical_to_cartesian
 
    subroutine cartesian_to_spherical(vec_car,vec_sph)
      ! angles in rad
      double precision, intent(in) :: vec_car(1:3)
      double precision, intent(inout) :: vec_sph(1:3)
 
      vec_sph(1)=dsqrt(vec_car(1)**2+vec_car(2)**2+vec_car(3)**2)
      vec_sph(2)=dacos(vec_car(3)/vec_sph(1))
      vec_sph(3)=atan2(vec_car(2),vec_car(1))
 
    end subroutine cartesian_to_spherical
 
    subroutine init_vectors_cartesian()
      integer :: j
      double precision :: LOS_psi
      double precision :: vec_z(1:3),vec_temp1(1:3),vec_temp2(1:3)
 
      ! vectors for image coordinate
      vec_los(1)=-cos(dpi*los_phi/180.d0)*sin(dpi*los_theta/180.d0)
      vec_los(2)=-sin(dpi*los_phi/180.d0)*sin(dpi*los_theta/180.d0)
      vec_los(3)=-cos(dpi*los_theta/180.d0)
      do j=1,3
        if (abs(vec_los(j))<=smalldouble) vec_los(j)=zero
      enddo
      vec_z(:)=zero
      vec_z(3)=1.d0
      if (los_theta==zero) then
        vec_xi1(1)=cos(dpi*los_phi/180.d0)
        vec_xi1(2)=sin(dpi*los_phi/180.d0)
        vec_xi1(3)=zero
      else
        call cross_product_loc(vec_los,vec_z,vec_xi1)
      endif
      call cross_product_loc(vec_xi1,vec_los,vec_xi2)
      vec_temp1=vec_xi1/sqrt(vec_xi1(1)**2+vec_xi1(2)**2+vec_xi1(3)**2)
      vec_temp2=vec_xi2/sqrt(vec_xi2(1)**2+vec_xi2(2)**2+vec_xi2(3)**2)
      los_psi=dpi*image_rotate/180.d0
      vec_xi1=vec_temp1*cos(los_psi)-vec_temp2*sin(los_psi)
      vec_xi2=vec_temp2*cos(los_psi)+vec_temp1*sin(los_psi)
 
      do j=1,3
        if (abs(vec_xi1(j))<smalldouble) vec_xi1(j)=zero
        if (abs(vec_xi2(j))<smalldouble) vec_xi2(j)=zero
      enddo
 
      if (mype==0) write(*,'(a,f5.2,f6.2,f6.2,a)') ' LOS vector: [',vec_los(1),vec_los(2),vec_los(3),']'
      if (mype==0) write(*,'(a,f5.2,f6.2,f6.2,a)') ' xI1 vector: [',vec_xi1(1),vec_xi1(2),vec_xi1(3),']'
      if (mype==0) write(*,'(a,f5.2,f6.2,f6.2,a)') ' xI2 vector: [',vec_xi2(1),vec_xi2(2),vec_xi2(3),']'
 
    end subroutine init_vectors_cartesian
 
    subroutine get_cor_image_spherical(x_3D_sph,x_image)
      double precision, intent(in) :: x_3D_sph(1:3)
      double precision, intent(inout) :: x_image(1:2)
      double precision :: res,res_origin
      double precision :: x_3D(1:3)
 
      call spherical_to_cartesian(x_3d_sph,x_3d)
      call dot_product_loc(x_3d,vec_xi1,res)
      x_image(1)=res
      call dot_product_loc(x_3d,vec_xi2,res)
      x_image(2)=res
 
    end subroutine get_cor_image_spherical
 
    subroutine get_cor_image(x_3D,x_image)
      double precision, intent(in) :: x_3D(1:3)
      double precision, intent(inout) :: x_image(1:2)
      double precision :: res,res_origin
 
      call dot_product_loc(x_3d,vec_xi1,res)
      call dot_product_loc(x_origin,vec_xi1,res_origin)
      x_image(1)=res-res_origin
      call dot_product_loc(x_3d,vec_xi2,res)
      call dot_product_loc(x_origin,vec_xi2,res_origin)
      x_image(2)=res-res_origin
 
    end subroutine get_cor_image
 
end module mod_thermal_emission