
! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
! XX                                                                  XX
! XX  Modules pour trace une carte de la Terre en couleur             XX
! XX  convenablement orientee suivant l'heure TU.                     XX
! XX  Permet de plotter des Terres rondes ou des planispheres.        XX
! XX  Utilise la rogralib pour le plot.                               XX
! XX  P. Robert, 1995 - derniere modif Avril 98                       XX
! XX                    revision Juin  2010 portabilite gfortran      XX
! XX                                                                  XX
! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

!     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX

      subroutine caltrgb1(alt,rr,gg,bb)
c
      real r(10),g(10),b(10)
      save r,g,b
c
c    niveaux  1     2     3     4     5  |  6     7     8     9     10
c    =================================================================
      data r /0.8 , 1.  , 1.  , 0.  , 0.  , 0.  , 0.  , 0.  , 0.  , 0. /
      data g /1.  , 1.  , 0.6 , 1.  , 0.8 , 1.  , 1.  , 0.8 , 0.6 , 0.4/
      data b /1.  , 1.  , 0.  , 0.  , 0.  , 1.  , 1.  , 1.  , 1.  , 1. /
c
c ----------------------------------------------------------------------
c *   correspondance entre une altitude et une couleur pour la terre
c ----------------------------------------------------------------------
c
      niv=1
c
      if(alt.lt. 4000.) niv=2
      if(alt.lt. 2000.) niv=3
      if(alt.lt.  800.) niv=4
      if(alt.lt.  300.) niv=5
      if(alt.lt.    0.) niv=6
      if(alt.lt.-  10.) niv=7
      if(alt.lt.-5000.) niv=8
      if(alt.lt.-5500.) niv=9
      if(alt.lt.-6000.) niv=10
c
      rr=r(niv)
      gg=g(niv)
      bb=b(niv)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine caltrgb2(alt,rr,gg,bb)
c
      real r(10),g(10),b(10)
      save r,g,b
c
c    niveaux  1     2     3     4     5  |  6     7     8     9     10
c    =================================================================
      data r /0.  , 0.  , 0.  , 0.  , 0.  , 0.  , 0.  , 0.  , 0.  , 0. /
      data g /1.  , 1.  , 1.  , 1.  , 1.  , 1.  , 1.  , 0.8 , 0.6 , 0.4/
      data b /0.  , 0.  , 0.  , 0.  , 0.  , 1.  , 1.  , 1.  , 1.  , 1. /
c
c ----------------------------------------------------------------------
c *   correspondance entre une altitude et une couleur pour la terre
c *   on met les continents en vert
c ----------------------------------------------------------------------
c
      niv=1
c
      if(alt.lt. 4000.) niv=2
      if(alt.lt. 2000.) niv=3
      if(alt.lt.  800.) niv=4
      if(alt.lt.  300.) niv=5
      if(alt.lt.    0.) niv=6
      if(alt.lt.-  10.) niv=7
      if(alt.lt.-5000.) niv=8
      if(alt.lt.-5500.) niv=9
      if(alt.lt.-6000.) niv=10
c
      rr=r(niv)
      gg=g(niv)
      bb=b(niv)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine caltrgb3(alt,rr,gg,bb)
c
      real r(2),g(2),b(2)
      save r,g,b
c
c    niveaux  1     2  
c    =================
      data r /0.  , 0. /
      data g /1.  , 0. /
      data b /0.  , 1. /
c
c ----------------------------------------------------------------------
c *   correspondance entre une altitude et une couleur pour la terre
c *   on met les continents en vert et les oceans en bleu  
c ----------------------------------------------------------------------
c
      if(alt.gt. 0.) then
                     niv=1
                     else
                     niv=2
                     endif
c
      rr=r(niv)
      gg=g(niv)
      bb=b(niv)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine crgbico(ir,ig,ib,ico)
c
c     ---------------------------------------------------------------+--
c *   converts_rgb_to_ico
c     ---------------------------------------------------------------+--
c
c     ex: pour (ir,ig,ib)=(127,36,25) -> ico=8332313
c
c     ico est le numero de la couleur parmis les 16 M (256**3)
c
      ico= 65536*ir + 256*ig + ib
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine cicorgb(ico,ir,ig,ib)
c
c     ---------------------------------------------------------------+--
c *   converts_ico_to_rgb
c     ---------------------------------------------------------------+--
c
c     ex: pour ico=8332313 -> (ir,ig,ib)=(127,36,25)
c
      ir= ico/65536
      ig=(ico - ir*65536)/256
      ib= ico - ir*65536 - ig*256
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine crgb255(rr,rg,rb,ir,ig,ib)
c
c ----------------------------------------------------------------------
c *   convertit rgb (0-1) en irgb (0-255)
c ----------------------------------------------------------------------
c
      ir=int(rr*255.)
      ig=int(rg*255.)
      ib=int(rb*255.)
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine reworalti(ifc,alti)
c
      real alti(180,360)
c
c ----------------------------------------------------------------------
c     lecture du fichiers des a	ltitudes de la Terre
c ----------------------------------------------------------------------
c
      print*
      print*, 'Reading World altitude file...'

      close(ifc)
      open (ifc,file='./data/world_data/woralti.data')
c
      do 10 it  =1,180
      do 20 ip10=1,360,10
      read(ifc,100) (alti(it,ip),ip=ip10,ip10+9)
   20 continue
   10 continue
c
      close(ifc)
      print*, 'done.'
c
  100 format(10f7.1)
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine rewormap(ifc,map,imap)
c
      integer map(180,360)
      character*64 fich(3)
      save fich
c
c ----------------------------------------------------------------------
c     lecture des fichiers des cartes du monde
c ----------------------------------------------------------------------
c
      data fich(1)/'./data/world_data/wormap1.data'/
      data fich(2)/'./data/world_data/wormap2.data'/
      data fich(3)/'./data/world_data/wormap3.data'/
c
      if(imap.lt.1.or.imap.gt.3) stop 'imap 1-3 only in rewormap'
c
      print*
      print*, 'Reading World map file #',imap,' ...'
      
      close(ifc)
      open (ifc,file=fich(imap), err=50)
c
      do 10 it  =1,180
      do 20 ip8 =1,360,8
      read(ifc,100) (map(it,ip),ip=ip8,ip8+7)
   20 continue
   10 continue
c
      close(ifc)
      
      print*, 'done.'
      return
      
   50 continue
      print*, '*** worldlib : file ',fich(imap),' not available'
      print*, '*** worldlib : values set to 255'
      
      do 12 it=1,180
      do 22 ip=1,360
      map(it,ip)=255
   22 continue
   12 continue
c
  100 format(8i9)
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
c
      subroutine coworpic(icowor,imagxz,idimag,rep,sunpo)
c
      character*(*) sunpo,rep
c
      integer       icowor(180,360)
      integer       imagxz(idimag,idimag)
c
c     -----------------------------------------------------------------
c     calcul de l'image de la terre projetee dans le GSM ou le GSE
c     le soleil peut etre a gauche (l), a droite (r) plan X-Z seulement
c     ou derriere (b) => plan Y-Z seulement
c
c     ctimpa (rocotlib) doit avoir ete appelle au prealable
c
c     ce module est teste par cowormap
c     -----------------------------------------------------------------
c
      print*
      print*, 'Compute World picture in ',rep,', sun pos. =',sunpo,'...'
      
c *** test des input
c
      if(rep(1:3).ne.'gse'.and.rep(1:3).ne.'gsm') then
                                    print*,'only gse or gsm in coworpic'
                                    stop 'error input coworpic'
                                    endif
c
      if(sunpo(1:1).ne.'r'.and.
     &   sunpo(1:1).ne.'l'.and.
     &   sunpo(1:1).ne.'b'     ) then
                                 print*, 'only r,l or b in cowopic'
                                 stop 'error input coworpic'
                                 endif
c
c *** mise a blanc de l'image
c
      call crgbico_(255,255,255,iblanc)
c
      do 10 ix=1,idimag
      do 10 iz=1,idimag
      imagxz(ix,iz)=iblanc
   10 continue
c
c *** calcul de l'image dans le plan xz
c
      dx=2./float(idimag)
      dy=2./float(idimag)
      dz=2./float(idimag)
c
      do 20 itet=1,180
      do 20 iphi=1,360
c
      tet=float(itet)*3.14159/180.
      phi=float(iphi)*3.14159/180.
c
      call tsphcar(1.,tet,phi,xgeo,ygeo,zgeo)
      if(rep(1:3).eq.'gse') then
                            call tgeogse(xgeo,ygeo,zgeo,xrep,yrep,zrep)
                            else
                            call tgeogsm(xgeo,ygeo,zgeo,xrep,yrep,zrep)
                            endif
c
c *** remplissage de la face visible
c
      ix=int(xrep/dx + float(idimag)/2.) +1
      iy=int(yrep/dx + float(idimag)/2.) +1
      iz=int(zrep/dz + float(idimag)/2.) +1
c
      if(ix.lt. 1)    print*, '***WARNING ! ix=',ix
      if(iy.lt. 1)    print*, '***WARNING ! iy=',iy
      if(iz.lt. 1)    print*, '***WARNING ! iz=',iz

      if(ix.eq. 0) ix=1
      if(iy.eq. 0) iy=1
      if(iz.eq. 0) iz=1

      if(ix.lt.1 .or. iy.lt.1 .or. iz.lt.1) stop "ERROR coworpic"
c
      if(ix.gt.idimag) print*, '***WARNING ! ix=',ix
      if(iy.gt.idimag) print*, '***WARNING ! iy=',iy
      if(iz.gt.idimag) print*, '***WARNING ! iz=',iz

      if(ix.eq. idimag+1) ix=idimag
      if(iy.eq. idimag+1) iy=idimag
      if(iz.eq. idimag+1) iz=idimag

      if(ix.gt.idimag .or. iy.gt.idimag .or. iz.gt.idimag) 
     &                                 stop "ERROR coworpic"
c
c *** soleil a droite, a gauche ou derriere; masquage de la face cachee
c
      if(sunpo(1:1).eq.'r'.and.yrep.gt.0.) go to 20
      if(sunpo(1:1).eq.'l'.and.yrep.lt.0.) go to 20
      if(sunpo(1:1).eq.'b'.and.xrep.lt.0.) go to 20
c
      if(sunpo(1:1).eq.'b') then
                            imagxz(iy,iz)=icowor(itet,iphi)
                            else
                            imagxz(ix,iz)=icowor(itet,iphi)
                            endif
c
   20 continue
c
c *** inversion de l'image pour le soleil a gauche
c
      if(sunpo(1:1).ne.'l') return
c
      do 30 iz=1,idimag
      do 40 ix=1,idimag
      mem=imagxz(ix,iz)
      ix2=idimag-ix+1
      if(ix.ge.ix2) go to 30
      imagxz(ix,iz)=imagxz(ix2,iz)
      imagxz(ix2,iz)=mem
   40 continue
   30 continue
c
      print*, 'done.'
c
      return
      end
c
c     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
c
