c     Copyright (C)
c     2010-2013 Université Bordeaux 1
c     2010-2013 Ecole des Mines d'Albi
c     2014-2018 - Mesostar
c     
c     This program is free software; you can redistribute it and/or modify
c     it under the terms of the GNU General Public License as published by
c     the Free Software Foundation; either version 2, or (at your option)
c     any later version.

c     This program is distributed in the hope that it will be useful,
c     but WITHOUT ANY WARRANTY; without even the implied warranty of
c     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
c     GNU General Public License for more details.

c     You should have received a copy of the GNU General Public License
c     along with this program; if not, write to the Free Software
c     Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
c     USA.
c
      program ppart
      implicit none
      include 'mpif.h'
      include 'max.inc'
      include 'param.inc'
      include 'formats.inc'
c
c     Purpose: plane-parallel analytic radiative transfer
c
c     Variables
      character*(Nchar_mx) atm_data_file
      character*(Nchar_mx) ck_data_file
      character*(Nchar_mx) toa_flux_data_file
      character*(Nchar_mx) data_file
      character*(Nchar_mx) options_file
      integer Nw,Nlev,Nlay,Nb
      integer Nq(1:Nb_mx)
      double precision z(0:Nlay_mx)
      double precision pres(0:Nlay_mx)
      double precision Tground,Tspace
      double precision temp(0:Nlay_mx)
      double precision toa_sw(1:Nb_mx)
      double precision lambda_lo(1:Nb_mx)
      double precision lambda_hi(1:Nb_mx)
      double precision w_quad(1:Nb_mx,1:Nq_mx)
      double precision epsilon_ground(1:Nb_mx)
      double precision ck(1:Nlay_mx,1:Nb_mx,1:Nq_mx)
c     temp
      integer lay,band,quad,i,j,ix,ib,ig,iw,wint
      logical wint_found
      integer fband,lband,pidx,first_band,last_band
      double precision mu,k1,k2,x1,x2
      double precision alpha,beta
      integer atm_profile,uan,ref_choice
      logical ai,fullRT
c     
      character*(Nchar_mx) infile
      double precision pressure(1:Nlev_mx)
      double precision temperature(1:Nlev_mx)
      double precision height(1:Nlev_mx)
      double precision x_h2o_nominal(1:Nlay_mx)
      double precision x_h2o_water(1:Nlay_mx,1:Nw_mx)
      double precision lw_emissivity,sw_emissivity
      integer Nb_lw
      double precision nu_lo_lw(1:16)
      double precision nu_hi_lw(1:16)
      integer Ng_lw(1:16)
      double precision w_lw_rrtm(1:16,1:20)
      integer Nb_sw
      double precision nu_lo_sw(1:14)
      double precision nu_hi_sw(1:14)
      integer Ng_sw(1:14)
      double precision w_sw_rrtm(1:14,1:20)
      double precision ka_lw(1:Ngpoints_lw_mx,1:Nlev_mx)
      double precision ka_lw_nominal(1:Ngpoints_lw_mx,1:Nlev_mx)
      double precision ka_lw_water(1:Ngpoints_lw_mx,1:Nlev_mx,1:Nw_mx)
      double precision ka_sw(1:Ngpoints_sw_mx,1:Nlev_mx)
      double precision ka_sw_nominal(1:Ngpoints_sw_mx,1:Nlev_mx)
      double precision ka_sw_water(1:Ngpoints_sw_mx,1:Nlev_mx,1:Nw_mx)
      double precision ks_sw(1:Ngpoints_sw_mx,1:Nlev_mx)
      double precision ks_sw_nominal(1:Ngpoints_sw_mx,1:Nlev_mx)
      double precision ks_sw_water(1:Ngpoints_sw_mx,1:Nlev_mx,1:Nw_mx)
      logical is_nan,is_inf
c     
      double precision ka_moy(1:Nlay_mx,1:Nb_mx)
      double precision si_NER(0:Nlay_mx+1,0:Nlay_mx+1)
      double precision si_budget_from_NERs(1:Nlay_mx)
      double precision si_budget_from_net_fluxes(1:Nlay_mx)
      double precision si_gas_ground(1:Nlay_mx)
      double precision si_gas_space(1:Nlay_mx)
      double precision si_gas_gas(1:Nlay_mx)
      double precision si_upward_flux(0:Nlay_mx)
      double precision si_downward_flux(0:Nlay_mx)
      double precision si_net_flux(0:Nlay_mx)
      character*1 pidx_str1
      double precision tau(1:Nlay_mx)
      double precision NER(0:Nlay_mx+1,0:Nlay_mx+1)
      double precision upward_flux(0:Nlay_mx)
      double precision downward_flux(0:Nlay_mx)
      double precision net_flux(0:Nlay_mx)
      double precision budget_from_NER(1:Nlay_mx)
      double precision budget_from_net_fluxes(1:Nlay_mx)
      double precision gas_ground(1:Nlay_mx)
      double precision gas_space(1:Nlay_mx)
      double precision gas_gas(1:Nlay_mx)
      double precision band_net_flux_toa(1:Nb_mx)
      double precision band_obs_intensity(1:Nb_mx)
      double precision si_obs_intensity
      double precision band_Tb(1:Nb_mx)
      double precision si_Tb
      double precision band_is_NER(0:Nlay_mx,1:Nb_mx)
      double precision band_NER(0:Nlay_mx+1,0:Nlay_mx+1,1:Nb_mx)
      double precision discrete_cf(0:Nlay_mx,1:Nb_mx)
      double precision band_total_budget(1:Nlay_mx,1:Nb_mx)
      double precision band_gas_ground_budget(1:Nlay_mx,1:Nb_mx)
      double precision band_gas_space_budget(1:Nlay_mx,1:Nb_mx)
      double precision band_gas_gas_budget(1:Nlay_mx,1:Nb_mx)
      double precision band_upward_flux(0:Nlay_mx,1:Nb_mx)
      double precision band_downward_flux(0:Nlay_mx,1:Nb_mx)
      double precision band_net_flux(0:Nlay_mx,1:Nb_mx)
c     Debug
      double precision Bs,Fs
      double precision planck_int_wavlng
c     Debug
c     MPICH
      integer ierr,errorcode,np,pindex
      integer stat(MPI_STATUS_SIZE)
      integer code,codep,proc,ret_code
      logical free(1:Nproc_mx)
      logical stopped(1:Nproc_mx)
      logical fpf
      integer nsp
      integer nchunks,chunk
      logical keep_going
      integer quad_idx(1:Nproc_mx)
c     MPICH
c     label
      integer strlen
      character*(Nchar_mx) label
      label='program ppart'

c     MPICH
      call MPI_INIT(ierr)
      if (ierr.NE.MPI_SUCCESS) THEN
         call error(label)
         write(*,*) 'MPI could not be initialized'
         call MPI_ABORT(MPI_COMM_WORLD,errorcode,ierr)
      endif
c     Get 'np', the number of processes
      call MPI_COMM_SIZE(MPI_COMM_WORLD,np,ierr)
      if (np.lt.2) then
         call error(label)
         write(*,*) 'Number of processes is:',np
         write(*,*) 'and it should be greater than 1'
         stop
      endif
      if (np.gt.Nproc_mx) then
         call error(label)
         write(*,*) 'Number of processes is:',np
         write(*,*) 'is greater than Nproc_mx=',Nproc_mx
         stop
      endif
c     Get 'pindex', the index of the current process
      call MPI_COMM_RANK(MPI_COMM_WORLD,pindex,ierr)
c     MPICH

      if (pindex.eq.0) then ! master process
c     reading data.in
         data_file='./data.in'
         call read_data(data_file,
     &        fband,lband,mu,pidx)

c     reading options.in
         options_file='./options.in'
         call read_options(options_file,
     &        atm_profile,uan,ref_choice,
     &        ai,fullRT)

c     Set input data file names according to options
         write(*,*) 'Atmospheric profile and spectral data:'
         if (atm_profile.eq.1) then
            write(*,*) 'standard atmospheric data index:',pidx
            if ((pidx.lt.1).or.(pidx.gt.5)) then
               call error(label)
               write(*,*) 'pidx=',pidx
               write(*,*) 'allowed values: 1-5'
               stop
            else
               if (pidx.eq.1) then
                  write(*,*) 'Tropical'
               else if (pidx.eq.2) then
                  write(*,*) 'Mid-latitude summer'
               else if (pidx.eq.3) then
                  write(*,*) 'Mid-latitude winter'
               else if (pidx.eq.4) then
                  write(*,*) 'Sub-arctic summer'
               else if (pidx.eq.5) then
                  write(*,*) 'Sub-arctic winter'
               endif
               call num2str1(pidx,pidx_str1)
               atm_data_file='./data/std_atm_i'
     &              //pidx_str1(1:strlen(pidx_str1))
     &              //'.txt'
               ck_data_file='./data/std_ck_i'
     &              //pidx_str1(1:strlen(pidx_str1))
     &              //'.txt'
               write(*,*) 'Atmospheric profile will be taken from:'
               write(*,*) atm_data_file(1:strlen(atm_data_file))
               write(*,*) 'Spectral data will be taken from:'
               write(*,*) ck_data_file(1:strlen(ck_data_file))
c     reading atmospheric profile (altitude and temperature levels)
               call read_atm(atm_data_file,Nlay,z,pres,temp,
     &              Tground,Tspace)
c     reading CK data set, narrowband limits, groud emissivity, quadrature weights
               call read_ck(ck_data_file,
     &              Nlay,Nb,Nq,
     &              lambda_lo,lambda_hi,
     &              w_quad,
     &              epsilon_ground,
     &              ck)
            endif
         else if (atm_profile.eq.2) then
            write(*,*) 'user-defined'
c     reading atmospheric and spectral data
            infile='./data/ecrad_opt_prop.txt'
            call read_opt_prop_file(infile,Nw,Nlev,Nlay,
     &           Tground,Tspace,pressure,
     &           temperature,height,x_h2o_nominal,x_h2o_water,
     &           lw_emissivity,sw_emissivity,
     &           Nb_lw,nu_lo_lw,nu_hi_lw,Ng_lw,w_lw_rrtm,
     &           Nb_sw,nu_lo_sw,nu_hi_sw,Ng_sw,w_sw_rrtm,
     &           ka_lw_nominal,ka_lw_water,
     &           ka_sw_nominal,ka_sw_water,
     &           ks_sw_nominal,ks_sw_water)
            do i=0,Nlay
               z(i)=height(i+1)
               pres(i)=pressure(i+1)
               temp(i)=temperature(i+1)
            enddo               ! i
            Nb=Nb_sw
            do band=1,Nb
               lambda_lo(band)=1.0D+4/nu_hi_sw(Nb-band+1)
               lambda_hi(band)=1.0D+4/nu_lo_sw(Nb-band+1)
               epsilon_ground(band)=sw_emissivity
               Nq(band)=Ng_sw(Nb-band+1)
               ig=0
               if (band.lt.Nb) then
                  do ib=1,Nb-band
                     ig=ig+Ng_sw(ib)
                  enddo         ! ib
               endif
               do quad=1,Nq(band)
                  w_quad(band,quad)=w_sw_rrtm(Nb-band+1,quad)
                  ig=ig+1
                  do i=1,Nlay
c     Nominal properties
                     ck(i,band,quad)=ka_sw_nominal(ig,i)
c     Debug
                     call test_nan_dble(ck(i,band,quad),is_nan)
                     call test_inf(ck(i,band,quad),is_inf)
                     if ((ck(i,band,quad).lt.0.0D+0)
     &                    .or.(is_nan).or.(is_inf)) then
                        call error(label)
                        write(*,*) 'ck(',i,',',band,',',quad,')=',
     &                       ck(i,band,quad)
                        stop
                     endif
c     Debug
                     goto 632
c     OR
c     Interpolation of gas optical properties
                     wint_found=.false.
                     do iw=1,Nw-1
                        if ((x_h2o_nominal(i).ge.x_h2o_water(i,iw))
     &                       .and.
     &                       (x_h2o_nominal(i).le.x_h2o_water(i,iw+1)))
     &                       then
                           wint_found=.true.
                           wint=iw
                           goto 531
                        endif
                     enddo      ! iw
 531                 continue
                     if (.not.wint_found) then
                        if (x_h2o_nominal(i).lt.x_h2o_water(i,1)) then
                           wint_found=.true.
                           wint=0
                        endif
                        if (x_h2o_nominal(i).gt.x_h2o_water(i,Nw)) then
                           call error(label)
                           write(*,*) 'x_h2o_nominal(',i,')=',
     &                          x_h2o_nominal(i)
                           write(*,*) '> x_h2o_water(',i,',',Nw,')=',
     &                          x_h2o_water(i,Nw)
                           write(*,*) 'make new tabulation'
                           stop
                        endif
                     endif
                     if (.not.wint_found) then
                        call error(label)
                        write(*,*) 'water interval not found'
                        stop
                     endif
                     if (wint.eq.0) then
                        x1=0.0D+0
                        x2=x_h2o_water(i,1)
                        k1=0.0D+0
                        k2=ka_sw_water(ig,i,1)
                        ck(i,band,quad)=k2/x2*x_h2o_nominal(i)
                     else
                        x1=x_h2o_water(i,wint)
                        x2=x_h2o_water(i,wint+1)
                        k1=ka_sw_water(ig,i,wint)
                        if (k1.lt.0.0D+0) then
                           k1=0.0D+0
                        endif
                        k2=ka_sw_water(ig,i,wint+1)
                        if (k2.lt.0.0D+0) then
                           k2=0.0D+0
                        endif
                        if (k1.eq.k2) then
                           ck(i,band,quad)=k1
                        else
                           alpha=(dlog(k2)-dlog(k1))/(dlog(x2)-dlog(x1))
                           beta=dlog(k1)-alpha*dlog(x1)
                           ck(i,band,quad)=
     &                          dexp(alpha*dlog(x_h2o_nominal(i))+beta)
                        endif
                     endif
c     Debug
                     call test_nan_dble(ck(i,band,quad),is_nan)
                     call test_inf(ck(i,band,quad),is_inf)
                     if ((ck(i,band,quad).lt.0.0D+0)
     &                    .or.(is_nan).or.(is_inf)) then
                        call error(label)
                        write(*,*) 'ck(',i,',',band,',',quad,')=',
     &                       ck(i,band,quad)
                        write(*,*) 'alpha=',alpha
                        write(*,*) 'beta=',beta
                        write(*,*) 'x_h2o_nominal(',i,')=',
     &                       x_h2o_nominal(i)
                        write(*,*) 'x1=',x1,' k1=',k1
                        write(*,*) 'x2=',x2,' k2=',k2
                        write(*,*) 'dlog(x_h2o_nominal)=',
     &                       dlog(x_h2o_nominal(i))
                        write(*,*) 'alpha*dlog(x_h2o_nominal)=',
     &                       alpha*dlog(x_h2o_nominal(i))
                        write(*,*) 'alpha*dlog(x_h2o_nominal)+beta=',
     &                       alpha*dlog(x_h2o_nominal(i))+beta
                        stop
                     endif
c     Debug
 632                 continue
                     if (ck(i,band,quad).lt.1.0D-20) then
                        ck(i,band,quad)=1.0D-20
                     endif
                  enddo         ! i
               enddo            ! quad
            enddo               ! band
         else
            call error(label)
            write(*,*) 'atm_profile=',atm_profile
            write(*,*) 'allowed values: 1, 2'
            stop
         endif
         
c     reading incoming SW flux @ TOA
         toa_flux_data_file='./data/incoming_sw_flux.txt'
         call read_sw_tom_flux(toa_flux_data_file,
     &        Nb,lambda_lo,lambda_hi,toa_sw)
         
c     check consistency of input options
         call check_inconsistencies(atm_profile,uan,
     &        ref_choice,fullRT,
     &        Nb,fband,lband,mu,pidx)

c     set first and last integration narrowbands according to options
         if (uan.eq.1) then
            first_band=1
            last_band=Nb
         else if (uan.eq.2) then
            first_band=fband
            last_band=lband
         else
            call error(label)
            write(*,*) 'uan=',uan
            write(*,*) 'allowed values: 1, 2'
            stop
         endif

c     Computing spectrally integrated results
         write(*,*) 'Spectral integration required for:'
         if (first_band.eq.last_band) then
            write(*,*) 'Interval:',first_band
         else
            write(*,*) 'Intervals:',first_band,'-',last_band
         endif
         write(*,*) 'wavelength=',lambda_lo(first_band),
     &        '-',lambda_hi(last_band),' micrometers'

c     Arrays initialization
         call initialize_rt_results(fullRT,
     &        Nlay,Nb,
     &        si_NER,si_budget_from_NERs,si_budget_from_net_fluxes,
     &        si_gas_ground,si_gas_space,si_gas_gas,
     &        si_upward_flux,si_downward_flux,si_net_flux,
     &        band_net_flux_toa,band_NER,band_is_NER,
     &        band_total_budget,band_gas_ground_budget,
     &        band_gas_space_budget,band_gas_gas_budget,
     &        band_upward_flux,band_downward_flux,band_net_flux)

c     Sending global data to every slave process
         code=1
         do proc=1,np-1
            call MPI_SEND(code,1,MPI_INTEGER
     &           ,proc,1,MPI_COMM_WORLD,ierr)
         enddo ! proc
         call send_global_data_mpibcast(ref_choice,ai,fullRT,Nlay,
     &           lambda_lo,lambda_hi,epsilon_ground,mu,z,
     &           temp,Tground,Tspace,toa_sw)
         write(*,*) '...done'
         write(*,*) 'Now computing...'

c     Spectral integration
         do band=first_band,last_band
c     Debug
            write(*,*) 'band=',band,' [',first_band,'-',last_band,']'
c     Debug
            call set_chunks(Nq(band),np,nchunks)
c     + free all slave processes
            do proc=1,np-1
               free(proc)=.true.
               stopped(proc)=.false.
            enddo
            keep_going=.true.
            chunk=0

            do while (keep_going)
 444           continue
               call find_free_process(free,np-1,fpf,proc)
               if (fpf) then ! a free child process has been found
                  chunk=chunk+1
                  if (chunk.le.nchunks) then
c     Debug
c                     write(*,*) 'chunk index ',chunk,' / ',nchunks
c     Debug
                     quad=chunk
                     quad_idx(proc)=quad
c     Debug
c                     write(*,*) 'quad=',quad,' /',nchunks
c     Debug
c     + array of layers optical thickness
                     do lay=1,Nlay
                        if (atm_profile.eq.1) then
                           tau(lay)=ck(lay,band,quad)
                        else
                           tau(lay)=ck(lay,band,quad)
     &                          *(z(lay)-z(lay-1))
                        endif
c     Debug
c                        write(*,*) 'tau=',tau
c     Debug
                        if (tau(lay).lt.0.0D+0) then
                           call error(label)
                           write(*,*) 'tau(',lay,')=',tau(lay)
                           write(*,*) 'band=',band,' quad=',quad
                           do i=1,Nlay
                              write(*,*) i,tau(i)
                           enddo ! i
                           stop
                        endif
                     enddo      ! lay
c     Debug
c                     if ((band.eq.1).and.(quad.eq.1)) then
c                        do lay=1,Nlay
c                           write(*,*) z(lay),tau(lay)
c                        enddo   ! lay
c                        stop
c                     endif
c     Debug
c
                     code=2     ! means monochromatic computation has to be performed for quadrature index 'quad'
                     call MPI_SEND(code,1,MPI_INTEGER
     &                    ,proc,1,MPI_COMM_WORLD,ierr)
                     call MPI_SEND(band,1,MPI_INTEGER
     &                    ,proc,1,MPI_COMM_WORLD,ierr)
                     call MPI_SEND(tau,Nlay_mx,MPI_DOUBLE_PRECISION
     &                    ,proc,1,MPI_COMM_WORLD,ierr)
                     free(proc)=.false. ! child process index 'proc' is busy
                  else ! chunk>nchunks
                     free(proc)=.false.
                     stopped(proc)=.true.
                     goto 444
                  endif ! chunk
               else             ! no free child process found
                  call stopped_processes(stopped,np-1,nsp)
                  if (nsp.ge.np-1) then
                     keep_going=.false.
                     goto 111
                  else
c     wait for results
                     call MPI_RECV(proc,1,MPI_INTEGER
     &                    ,MPI_ANY_SOURCE,MPI_ANY_TAG,MPI_COMM_WORLD,
     &                    stat,ierr)
                     call MPI_RECV(ret_code,1,MPI_INTEGER
     &                    ,proc,MPI_ANY_TAG,MPI_COMM_WORLD,
     &                    stat,ierr)
                     if (ret_code.eq.1) then ! monochromatic results are now going to be sent
                        call MPI_RECV(NER,(Nlay_mx+2)*(Nlay_mx+2),
     &                       MPI_DOUBLE_PRECISION,proc,MPI_ANY_TAG,
     &                       MPI_COMM_WORLD,stat,ierr)
                        call MPI_RECV(budget_from_NER,Nlay_mx,
     &                       MPI_DOUBLE_PRECISION,proc,MPI_ANY_TAG,
     &                       MPI_COMM_WORLD,stat,ierr)
                        call MPI_RECV(budget_from_net_fluxes,Nlay_mx,
     &                       MPI_DOUBLE_PRECISION,proc,MPI_ANY_TAG,
     &                       MPI_COMM_WORLD,stat,ierr)
                        call MPI_RECV(gas_ground,Nlay_mx,
     &                       MPI_DOUBLE_PRECISION,proc,MPI_ANY_TAG,
     &                       MPI_COMM_WORLD,stat,ierr)
                        call MPI_RECV(gas_space,Nlay_mx,
     &                       MPI_DOUBLE_PRECISION,proc,MPI_ANY_TAG,
     &                       MPI_COMM_WORLD,stat,ierr)
                        call MPI_RECV(gas_gas,Nlay_mx,
     &                       MPI_DOUBLE_PRECISION,proc,MPI_ANY_TAG,
     &                       MPI_COMM_WORLD,stat,ierr)
                        call MPI_RECV(upward_flux,Nlay_mx+1,
     &                       MPI_DOUBLE_PRECISION,proc,MPI_ANY_TAG,
     &                       MPI_COMM_WORLD,stat,ierr)
                        call MPI_RECV(downward_flux,Nlay_mx+1,
     &                       MPI_DOUBLE_PRECISION,proc,MPI_ANY_TAG,
     &                       MPI_COMM_WORLD,stat,ierr)
                        call MPI_RECV(net_flux,Nlay_mx+1,
     &                       MPI_DOUBLE_PRECISION,proc,MPI_ANY_TAG,
     &                       MPI_COMM_WORLD,stat,ierr)
                        free(proc)=.true. ! child process index 'proc' is free again
c     Update results
                        call update_rt_results_ck(fullRT,
     &                       Nlay,band,
     &                       NER,budget_from_NER,budget_from_net_fluxes,
     &                       gas_ground,gas_space,gas_gas,
     &                       upward_flux,downward_flux,net_flux,
     &                       w_quad(band,quad_idx(proc)),
     &                       si_NER,
     &                       si_budget_from_NERs,
     &                       si_budget_from_net_fluxes,
     &                       si_gas_ground,si_gas_space,si_gas_gas,
     &                       si_upward_flux,si_downward_flux,
     &                       si_net_flux,
     &                       band_net_flux_toa,band_NER,band_is_NER,
     &                       band_total_budget,band_gas_ground_budget,
     &                       band_gas_space_budget,band_gas_gas_budget,
     &                       band_upward_flux,band_downward_flux,
     &                       band_net_flux)
                        goto 444
                     else
                        call error(label)
                        write(*,*) 'ret_code=',ret_code
                     endif      ! ret_code
                  endif         ! nsp=np-1
               endif            ! fpf
 111           continue
            enddo               ! while (keep_going)
c     Get the observed intensity from the net flux @ TOA
            call net_flux_toa_to_obs_intensity(band_net_flux_toa(band), ! W/m^2
     &           band_obs_intensity(band)) ! W/m^2/sr
c     Get the brightness temperature from the observed intensity
            call solve_Tb(lambda_lo(band),lambda_hi(band),
     &           band_obs_intensity(band),band_Tb(band))
         enddo ! band
c     stopping all child processes
         do proc=1,np-1
            code=0
            call MPI_SEND(code,1,MPI_INTEGER,proc,1,MPI_COMM_WORLD,ierr)
         enddo

c     Get the global observed intensity from the total net flux @ TOA
         call net_flux_toa_to_obs_intensity(si_net_flux(Nlay), ! W/m^2
     &        si_obs_intensity) ! W/m^2/sr
c     Get the global brightness temperature from the global observed intensity
         call solve_Tb(lambda_lo(first_band),lambda_hi(last_band),
     &        si_obs_intensity,si_Tb) ! K

c     Contribution functions
         call discrete_contribution_function(Nlay,Nb,
     &        first_band,last_band,
     &        z,
     &        band_is_NER,
     &        band_net_flux_toa,
     &        discrete_cf)

c     Production of result files and gnuplot scripts
         call postcalc(atm_profile,pidx,
     &        Nlay,Nb,Nq,first_band,last_band,
     &        lambda_lo,lambda_hi,z,pres,
     &        si_obs_intensity,si_Tb,si_NER,
     &        si_budget_from_NERs,si_budget_from_net_fluxes,
     &        si_gas_ground,si_gas_space,si_gas_gas,
     &        si_upward_flux,si_downward_flux,si_net_flux,
     &        band_net_flux_toa,band_obs_intensity,band_Tb,
     &        band_NER,band_is_NER,discrete_CF,
     &        band_total_budget,band_gas_ground_budget,
     &        band_gas_space_budget,band_gas_gas_budget,
     &        band_upward_flux,band_downward_flux,band_net_flux)
         write(*,*) '...done'
         
      else ! slave processes
 333     continue
c     wait for "codep" from root process
         call MPI_RECV(codep,1,MPI_INTEGER
     &        ,0,MPI_ANY_TAG,MPI_COMM_WORLD,stat,ierr)
c     codep=0 means exit
         if (codep.eq.0) then
            goto 666
c     codep=1 means data reception for solar computation
         else if (codep.eq.1) then
            call receive_global_data_mpibcast(
     &           ref_choice,ai,fullRT,Nlay,
     &           lambda_lo,lambda_hi,epsilon_ground,mu,
     &           z,temp,Tground,Tspace,toa_sw)
c     codep=2 means a monochromatic computation should be run
         else if (codep.eq.2) then
            call MPI_RECV(band,1,MPI_INTEGER
     &           ,0,MPI_ANY_TAG,MPI_COMM_WORLD,stat,ierr)
            call MPI_RECV(tau,Nlay_mx,MPI_DOUBLE_PRECISION
     &           ,0,MPI_ANY_TAG,MPI_COMM_WORLD,stat,ierr)
c     Debug
c            if ((band.eq.1).and.(quad.eq.1)) then
c               do lay=1,Nlay
c                  write(*,*) lay,tau(lay)
c               enddo            ! i
c               stop
c            endif
c     Debug
            call monochromatic_rt(ai,mu,ref_choice,Nlay,
     &           lambda_lo(band),lambda_hi(band),
     &           epsilon_ground(band),
     &           temp,Tground,Tspace,toa_sw(band),tau,
     &           NER,
     &           upward_flux,downward_flux,net_flux,
     &           budget_from_NER,gas_ground,gas_space,gas_gas,
     &           budget_from_net_fluxes)
            
c     sendind results to the process 0
            call MPI_SEND(pindex,1,MPI_INTEGER,0,1,
     &           MPI_COMM_WORLD,ierr)
            call MPI_SEND(1,1,MPI_INTEGER,0,1,
     &           MPI_COMM_WORLD,ierr)
            call MPI_SEND(NER,(Nlay_mx+2)*(Nlay_mx+2),
     &           MPI_DOUBLE_PRECISION,0,1,MPI_COMM_WORLD,ierr)
            call MPI_SEND(budget_from_NER,Nlay_mx,
     &           MPI_DOUBLE_PRECISION,0,1,MPI_COMM_WORLD,ierr)
            call MPI_SEND(budget_from_net_fluxes,Nlay_mx,
     &           MPI_DOUBLE_PRECISION,0,1,MPI_COMM_WORLD,ierr)
            call MPI_SEND(gas_ground,Nlay_mx,
     &           MPI_DOUBLE_PRECISION,0,1,MPI_COMM_WORLD,ierr)
            call MPI_SEND(gas_space,Nlay_mx,
     &           MPI_DOUBLE_PRECISION,0,1,MPI_COMM_WORLD,ierr)
            call MPI_SEND(gas_gas,Nlay_mx,
     &           MPI_DOUBLE_PRECISION,0,1,MPI_COMM_WORLD,ierr)
            call MPI_SEND(upward_flux,Nlay_mx+1,
     &           MPI_DOUBLE_PRECISION,0,1,MPI_COMM_WORLD,ierr)
            call MPI_SEND(downward_flux,Nlay_mx+1,
     &           MPI_DOUBLE_PRECISION,0,1,MPI_COMM_WORLD,ierr)
            call MPI_SEND(net_flux,Nlay_mx+1,
     &           MPI_DOUBLE_PRECISION,0,1,MPI_COMM_WORLD,ierr)
         else ! unknown code
            call error(label)
            write(*,*) 'Unknown codep=',codep
            write(*,*) 'received by process:',pindex
            stop
         endif ! codep
c     wait for a new execution code
         goto 333
 666     continue         
      endif ! pindex
      call MPI_FINALIZE(ierr)

      end
