      FUNCTION ArcMe(Latitude)
c,<901226.1130>
C     ==============
C
C     Calcul de la longueur de l'Arc de Meridien
C     Latitude en Radians , Resultat en metres
C
      Implicit none
C
      REAL*8 Alpha,ArcMe,Beta,Constante,Delta,Gamma,J2,J4,J6,J8,
     *    Latitude,U,V
C
      DATA Alpha/0.0050761277D0/,Beta/0.0000429451D0/,
     *    Constante/6399936.608D0/,Delta/0.0000000013D0/,
     *    Gamma/0.0000001696D0/
C
      V=DCOS(Latitude)
      U=V*DSIN(Latitude)
      V=V**2
      J2=Latitude+U
      J4=(3.*J2+2.*U*V)/4.
      J6=(5.*J4+2.*U*V**2)/3.
      J8=(7.*J6+4.*U*V**3)/8.
C
      ArcMe=Constante*(Latitude-Alpha*J2+Beta*J4-Gamma*J6+Delta*J8)
C
      END
      FUNCTION ArcMer(Ellips,Latitude1,Latitude2)
c,<901226.1130>
C     ===============
C
C     Calcul de l'arc de meridien entre 2 latitudes donnees
C
C->   Ellips(2) - a0,e2 parametres de l'ellipsoide
C->   ArcMer= arc de Latitude1 a Latitude2
C
      Implicit None
C
      INTEGER No
C
      REAL*8 ArcMer,b(8),Beta0,Beta2,Beta4,Beta6,Beta8,e1,Ellips(2),
     *    Latitude1,Latitude2,p1,p2,p3,p4,s1
C
      s1=1.
      e1=1.-Ellips(2)
      b(1)=Ellips(1)*e1
      DO No=1,4
          s1=s1*Ellips(2)*(2*No+1)/(2*No)
          b(2*No)=Ellips(1)*e1*s1
      ENDDO
C
      Beta0=b(1)+.5*b(2)+3./8.*b(4)+5./16.*b(6)+35./128.*b(8)
      Beta2=.5*(b(2)+b(4))+15./32.*b(6)+28./64.*b(8)
      Beta4=1./8.*b(4)+3./16.*b(6)+28./128.*b(8)
      Beta6=1./32.*b(6)+4./64.*b(8)
      Beta8=1./128.*b(8)
C
      p1=Beta0*(Latitude2-Latitude1)
      p2=.5*Beta2*(DSIN(2.*Latitude2)-DSIN(2.*Latitude1))
      p3=.25*Beta4*(DSIN(4.*Latitude2)-DSIN(4.*Latitude1))
      p4=1./6.*Beta6*(DSIN(6.*Latitude2)-DSIN(6.*Latitude1))
C
      ArcMer=p1-p2+p3-p4
C
      END
      FUNCTION DdDmd(Degres_Decimaux)
c,<901226.1130>
C     ==============
C
C     Conversion Deg. decimaux --> Deg. Min. Decimales (DDDMM.MM)
C
      Implicit None
C
      INTEGER Nb_Degres
C
      REAL*8 DdDmd,Degres_Decimaux
C
      Nb_Degres=Degres_Decimaux
C
      DdDmd=Nb_Degres*100.+(Degres_Decimaux-Nb_Degres)*60.
C
      END
      FUNCTION DdDms(Degres_Decimaux)
c,<901226.1130>
C     ==============
C
C     Conversion des Degres Decimaux en Degres Minutes Secondes sous la
C         forme DDDMM.SEC
C
      Implicit None
C
      INTEGER Minute,Nb_Degres
C
      REAL*8 DdDms,Degres_Decimaux,Reste,Seconde
C
      Nb_Degres=Degres_Decimaux
C
      Reste=(Degres_Decimaux-Nb_Degres)*60.
      Minute=Reste
C
      Seconde=Reste-Minute
C
      DdDms=Nb_Degres*100.+Minute+Seconde/100.*60.
C
      END
      FUNCTION DdRad(Degres_Decimaux)
c,<901226.1130>
C     ==============
C
C     Conversion de Degres_Decimaux en Radian
C
      Implicit none
C
      REAL*8 DdRad,Degres_Decimaux
C
      REAL*8 Conv_Deg_Rad,Pi,Conv_Grad_Rad
C
      COMMON /Constante/Conv_Deg_Rad,Pi,Conv_Grad_Rad
C
C     Conv_Deg_Rad=DATAN(1.D0)/45.
C
      DdRad=Conv_Deg_Rad*Degres_Decimaux
C
      END
      FUNCTION DmdDd(Deg_Mn_Decimale)
c,<901226.1130>
C     =============
C
C     Conversion Deg. Min. Decimales (DDDMM.MM) --> Deg. Decimaux
C
      Implicit None
C
      INTEGER Nb_Degres
C
      REAL*8 Deg_Mn_Decimale,DmdDd,Mn_Decimale
C
      Nb_Degres=Deg_Mn_Decimale/100.
      DmdDd=Nb_Degres
C
      Mn_Decimale=Deg_Mn_Decimale-Nb_Degres*100.
      DmdDd=DmdDd+Mn_Decimale/60.
C
      END
      FUNCTION DmdRad(Deg_Mn_Decimale)
c,<901226.1130>
C     ===============
C
C     Conversion Deg. Min. Decimales (DDDMM.MM) --> Radian
C
      Implicit None
C
      REAL*8 Deg_Mn_Decimale,DmdDd,DmdRad
C
      REAL*8 Conv_Deg_Rad,Pi,Conv_Grad_Rad
C
      COMMON /Constante/Conv_Deg_Rad,Pi,Conv_Grad_Rad
C
C     Conv_Deg_Rad=DATAN(1.D0)/45.
C
      DmdRad=DmdDd(Deg_Mn_Decimale)*Conv_Deg_Rad
C
      END
      FUNCTION DmsDd(Deg_Mn_Sec)
c,<901226.1130>
C     ==============
C
C     Conversion Deg Min Sec (DDDNb_Minutes.Seconde) --> Deg Decimaux
C
      Implicit None
C
      INTEGER Nb_Minutes,Nb_Degres
C
      REAL*8 Deg_Mn_Sec,DmsDd,Mn_Decimale,Seconde
C
      Nb_Degres=Deg_Mn_Sec/100.
      DmsDd=Nb_Degres
C
      Mn_Decimale=Deg_Mn_Sec-Nb_Degres*100.
      Nb_Minutes=Mn_Decimale
C
      Seconde=Mn_Decimale-Nb_Minutes
C
      Mn_Decimale=Nb_Minutes+Seconde*100./60.
      DmsDd=DmsDd+Mn_Decimale/60.
C
      END
      SUBROUTINE GeLam(Longitude,Latitude,X_Lambert,Y_Lambert,
C     ================
     *    No_Systeme)
c,<901226.1130>
C
C     Conversion Geographique (Radians)  -  Lambert (Metres)
C
C     CALL InitG(No_Systeme) initialise le systeme
C
      Implicit None
C
      INTEGER No_Systeme,No_Systeme_Ref
C
      REAL*8 Constante_Lamb,Delta_Long_Ref,Lat_Croissante,
     *    Lat_Croiss_Ref,Lat_Conforme,Latitude,Latitude_Ref,Longitude,
     *    Longitude_Ref,R,R0,Sinus_Lat_Ref,X_Lambert_Ref,X_Lambert,
     *    Y_Lambert_Ref,Y_Lambert
C
      COMMON /GLAM/Sinus_Lat_Ref,X_Lambert_Ref,Y_Lambert_Ref,R0,
     *    Longitude_Ref,Lat_Croiss_Ref,Delta_Long_Ref,No_Systeme_Ref
C
      IF(No_Systeme.NE.No_Systeme_Ref)CALL InitG(No_Systeme)
C
      Constante_Lamb=(Longitude-Longitude_Ref-Delta_Long_Ref)*
     *    Sinus_Lat_Ref
C
      CALL LACRE(Latitude,Lat_Conforme,Lat_Croissante)
C
      R=R0*DEXP((Lat_Croiss_Ref-Lat_Croissante)*Sinus_Lat_Ref)
C
      X_Lambert=X_Lambert_Ref+R*DSIN(Constante_Lamb)
      Y_Lambert=Y_Lambert_Ref+R0-R*DCOS(Constante_Lamb)
C
      END
      SUBROUTINE geotm(Ellips,Param_Projection,Longitude_Rad,
C     ================
     *    Latitude_Rad,X_Cart,Y_Cart)
c,<901226.1130>
C
C->   geographiques -> transverse Mercator
C->   Ellips(2) - a0,e2   : parametres de l'Ellipsoide
C->   Param_Projection(5) : cml,fi0,rk0 : long,lat et facteur d'echelle
C                                         point central
C->                         x0,y0       : constantes point central
C->   Longitude1,Latitude_Rad --> X_Cart,Y_Cart
C->   source j. pagarete
C
      Implicit None
C->
      REAL*8 a0,ArcMer,c,c2,c4,c6,e2,Ellips(2),Latitude_Rad,Longitude1,
     *    Longitude2,Longitude_Rad,Param_Projection(5),qr,qr2,qr3,rk1,
     *    rk2,rk3,rk4,rk5,rk6,rn,rp,s,sigma,t,t2,t4,t6,w,X_Cart,Y_Cart
C
      a0=Ellips(1)
      e2=Ellips(2)
      Longitude1=Longitude_Rad-Param_Projection(1)
      sigma=ArcMer(Ellips,Param_Projection(2),Latitude_Rad)
      s=DSIN(Latitude_Rad)
      w=DSQRT(1.-e2*s*s)
      rn=a0/w
      qr=(w*w)/(1.-e2)
      qr2=qr*qr
      qr3=qr2*qr
      c=DCOS(Latitude_Rad)
      rp=rn*c
      t=s/c
      Longitude2=Longitude1*Longitude1
      c2=c*c*Longitude2
      c4=c2*c2
      c6=c4*c2
      t2=t*t
      t4=t2*t2
      t6=t4*t2
      rk1=qr-t2
      rk2=rk1+4.*qr2
      rk3=qr*(14.-58.*t2)+40.*t2+t4-9.
      rk4=(8.*qr3*(11.-24.*t2)-28.*qr2*(1.-6.*t2)+qr*(1.-32.*t2)-2.*t2)*
     *    qr+t4
      rk5=61.-479.*t2+179.*t4-t6
      rk6=1385.-3111.*t2+543.*t4-t6
      Y_Cart=sigma+.5*rp*Longitude2*s*(1.+c2*rk2/12.+c4*rk4/360.+c6*rk6/
     *    20160.)
      Y_Cart=Param_Projection(3)*Y_Cart+Param_Projection(5)
      X_Cart=Param_Projection(3)*rp*Longitude1*(1.+c2*rk1/6.+c4*rk3/120.
     *    +c6*rk5/5040.)+Param_Projection(4)
C
      end
      SUBROUTINE Geo_Glr(Longitude_Rad,Latitude_Rad,X_Glr,Y_Glr)
c,
C     ==================
c    *    <901226.1130>
C
C-    geographiques (Radians) -> Gauss Laborde Reunion (Metres)
C
      Implicit None
C
      LOGICAL Init
C
      REAL*8 DmdRad,Ellips(2),Latitude_Rad,Longitude_Rad,
     *    Param_Projection(5),RadDmd,X_Glr,Y_Glr
C
C-    Ellipsoide international a0,e2
C
      DATA Ellips/6378200.d0,0.00669342162d0/
C
C-    Projection Gauss laborde Reunion
C     long - lat du centre de Projection facteur d'echelle + x0,y0
C
      DATA Param_Projection/5532.d0,-2107.d0,1.d0,1.6d5,5.d4/
C
      Param_Projection(1)=DmdRad(Param_Projection(1))
      Param_Projection(2)=DmdRad(Param_Projection(2))
C
      CALL geotm(Ellips,Param_Projection,Longitude_Rad,Latitude_Rad,
     *    X_Glr,Y_Glr)
C
      Param_Projection(1)=RadDmd(Param_Projection(1))
      Param_Projection(2)=RadDmd(Param_Projection(2))
C
      END
      SUBROUTINE Glr_Geo(X_Glr,Y_Glr,Longitude_Rad,Latitude_Rad)
c,
C     ==================
c    *    <901226.1130>
C
C-    Gauss Laborde Reunion (Metres) -> geographiques (Radians)
C
      Implicit None
C
      REAL*8 DmdRad,Ellips(2),Latitude_Rad,Longitude_Rad,
     *    Param_Projection(5),RadDmd,X_Glr,Y_Glr
C
C-    Ellipsoide international a0,e2
C
      DATA Ellips/6378200.d0,0.00669342162d0/
C
C-    Projection Gauss laborde Reunion
C     long - lat du centre de Projection facteur d'echelle + x0,y0
C
      DATA Param_Projection/5532.d0,-2107.d0,1.d0,1.6d5,5.d4/
C
      Param_Projection(1)=DmdRad(Param_Projection(1))
      Param_Projection(2)=DmdRad(Param_Projection(2))
C
      CALL tmgeo(Ellips,Param_Projection,X_Glr,Y_Glr,Longitude_Rad,
     *    Latitude_Rad)
C
      Param_Projection(1)=RadDmd(Param_Projection(1))
      Param_Projection(2)=RadDmd(Param_Projection(2))
C
      END
      FUNCTION GradRad(Grade)
c,<901226.1130>
C     ================
C
C     Conversion de Grades en Radian
C
      Implicit none
C
      REAL*8 Grade,GradRad
C
      REAL*8 Conv_Deg_Rad,Pi,Conv_Grad_Rad
C
      COMMON /Constante/Conv_Deg_Rad,Pi,Conv_Grad_Rad
C
C     Conv_Deg_Rad=DATAN(1.D0)/50.
C
      GradRad=Conv_Grad_Rad*Grade
C
      END
      SUBROUTINE GUTM(Longitude,Latitude,X_UTM,Y_UTM,No_Fuseau_UTM)
c,
C     ===============
c    *    <901226.1130>
C
C     Conversion Geographique (Radian)  -  UTM (metres)
C
C     Longitude et Latitude en Radians.
C     No_Fuseau_UTM=(Longitude+186.)/6.
C     Utilise le Sspg ArcMe
C
      Implicit None
C
      INTEGER No_Fuseau_UTM
C
      REAL*8 ArcMe,Constante_UTM,Cosinus,DdRad,ECOXI,Eta,Eprim,GN,
     *    Latitude,Longitude,Longitud_Relativ,X_UTM,XI,Y_UTM
C
      DATA Constante_UTM/6399936.608D0/,Eprim/0.0822688896073373D0/
C
      Longitud_Relativ=Longitude-DdRad(No_Fuseau_UTM*6.D0-183.D0)
      Cosinus=DCOS(Latitude)
C
      XI=Cosinus*DSIN(Longitud_Relativ)
      XI=0.5*DLOG((1.+XI)/(1.-XI))
C
      Eta=DATAN(DSIN(Latitude)/(Cosinus*DCOS(Longitud_Relativ)))-
     *    Latitude
      GN=Constante_UTM/DSQRT(1.+(Eprim*Cosinus)**2)
      ECOXI=(Eprim*Cosinus*XI)**2
C
      X_UTM=500000.+0.9996*GN*XI*(1.+ECOXI/6.)
C
      Y_UTM=0.9996*(GN*Eta*(1.+ECOXI/2.)+ArcMe(Latitude))
C
      END
      SUBROUTINE InitG(No_Systeme)
c,<901226.1130>
C     ================
C
C     Initialise les constantes de conversion Geographiques - Lambert
C         No_Systeme de 1 a 10
C
      Implicit None
C
      INTEGER No_Systeme,No_Systeme_Ref

      REAL*8 DdRad,Delta_Long_Ref,GradRad,Lat_Croiss_Ref,
     *    Lat_Conforme_Ref,Latitude_Ref,Longitude_Ref,Sinus_Lat_Ref,R0,
     *    Param_Projection(6,10),X_Lambert_Ref,Y_Lambert_Ref
C
      COMMON /GLAM/Sinus_Lat_Ref,X_Lambert_Ref,Y_Lambert_Ref,R0,
     *    Longitude_Ref,Lat_Croiss_Ref,Delta_Long_Ref,No_Systeme_Ref
C
      DATA Param_Projection /
C Syst  Latitude_Ref  R0              Longitude_Ref   X    Y   DELT
C                                                   Lambert_Ref
C
C    1                  France   Nord
C
     *  55.D0, 5457616.68D0, 0.D0,     0.6D6,        0.2D6, 2.3372292D0,
C
C    2                  France   Centre
C
     *  52.D0, 5999695.77D0, 0.D0,     0.6D6,        0.2D6, 2.3372292D0,
C
C    3                  France   Sud
C
     *  49.D0, 6591905.08D0, 0.D0,     0.6D6,        0.2D6, 2.3372292D0,
C
C    4                  France   Corse
C
     *46.85D0, 7053300.18D0, 0.D0, 234.538D0, 185861.369D0, 2.3372292D0,

C
C    5                  Nord     Maroc
C
     *  37.D0,9716290.594D0,-6.D0,     0.5D6,        0.3D6,        0.D0,
C
C    6                  Sud      Maroc
C
     *  33.D0,11187308.682D0,-6.D0,    0.5D6,        0.3D6,        0.D0,
C
C    7                  Nord     Algerie
C
     *  40.D0,8785951.541D0, 3.D0,      5.D5,         3.D5,        0.D0,
C
C    8                  Sud      Algerie
C
     *  37.D0,9716290.594D0, 3.D0,      5.D5,         3.D5,        0.D0,
C
C    9                  Nord     Tunisie
C
     *  40.D0,8785951.541D0,11.D0,      5.D5,         3.D5,        0.D0,
C
C   10                  Sud      Tunisie
C
     *  37.D0,9716290.594D0,11.D0,      5.D5,         3.D5,        0.D0/
C
      No_Systeme_Ref=No_Systeme
      X_Lambert_Ref=Param_Projection(4,No_Systeme)
      Y_Lambert_Ref=Param_Projection(5,No_Systeme)
      R0=Param_Projection(2,No_Systeme)
C
      Latitude_Ref=GradRad(Param_Projection(1,No_Systeme))
      Longitude_Ref=GradRad(Param_Projection(3,No_Systeme))
      Delta_Long_Ref=DdRad(Param_Projection(6,No_Systeme))
      Sinus_Lat_Ref=DSIN(Latitude_Ref)
C
      CALL LACRE(Latitude_Ref,Lat_Conforme_Ref,Lat_Croiss_Ref)
C
      END
      SUBROUTINE LACRE(Latitude,Lat_Conforme,Lat_Croissante)
c,
C     ================
c     *    <901226.1130>
C
C     Sspg de calcul de Latitude Conforme et de Latitude Croissante
C
C     Calcul de la Latitude conforme Lat_Conforme
C     Calcul de la Latitude Croissante Ellipsoidique Lat_Croissante
C     Donnees et Resultats en Radians
C
      Implicit None
C
      REAL*8 Constante,Lat_Conforme,Lat_Croissante,Latitude,Teta,Valeur
C
      DATA Constante/0.0824832568D0/
C
      Valeur=0.5*Latitude
      Teta=DTAN(Valeur)
      Valeur=2.*Constante*Teta/(1.+Teta**2)
      Valeur=0.5*Constante*DLOG((1.+Valeur)/(1.-Valeur))
      Lat_Croissante=DLOG((1.+Teta)/(1.-Teta))-Valeur
      Valeur=DTANH(0.5*Valeur)
      Lat_Conforme=2.*DATAN((Teta-Valeur)/(1.-Valeur*Teta))
C
      END
      SUBROUTINE LamGe(X_Lambert,Y_Lambert,Longitude,Latitude,
C     ================
     *    No_Systeme)
c,<901226.1130>
C
C     Conversion Lambert (Metres)  -  Geographiques (Radians)
C     CALL InitG(No_Systeme)  Initialise le systeme
C     Ellipsoide de CLARKE IGN
C
      Implicit None
C
      INTEGER No_Systeme,No_Systeme_Ref
C
      REAL*8 Delta_Long_Ref,Latitude,Lat_Crois_Ref,Lat_Croissante,
     *    Longitude,Longitude_Ref,R,R0,RLAC,Sinus_Lat_Ref,X_Lambert,
     *    X_Lambert_Ref,Y_Lambert,Y_Lambert_Ref
C
      COMMON /GLAM/Sinus_Lat_Ref,X_Lambert_Ref,Y_Lambert_Ref,R0,
     *    Longitude_Ref,Lat_Crois_Ref,Delta_Long_Ref,No_Systeme_Ref
C
      IF(No_Systeme.NE.No_Systeme_Ref)CALL InitG(No_Systeme)
C
      Longitude=X_Lambert-X_Lambert_Ref
      Latitude=R0-(Y_Lambert-Y_Lambert_Ref)
      R=Latitude*DSQRT(1.+(Longitude*Longitude)/(Latitude*Latitude))
      Longitude=Longitude_Ref+DATAN(Longitude/Latitude)/Sinus_Lat_Ref
      Lat_Croissante=Lat_Crois_Ref+DLOG(R0/R)/Sinus_Lat_Ref
      Lat_Croissante=DTANH(0.5D0*Lat_Croissante)
C
      Latitude=RLAC(Lat_Croissante)
      Longitude=Longitude+Delta_Long_Ref
C
      END
      FUNCTION RadDd(Radian)
c,<901226.1130>
C     ==============
C
C     Conversion de radians en degres decimaux
C
      Implicit None
C
      REAL*8 RadDd,Radian
C
      REAL*8 Conv_Deg_Rad,Pi,Conv_Grad_Rad
C
      COMMON /Constante/Conv_Deg_Rad,Pi,Conv_Grad_Rad
C
C     Conv_Deg_Rad=DATAN(1.D0)/45.
C
      RadDd=Radian/Conv_Deg_Rad
C
      END
      FUNCTION RadDmd(Radian)
c,<901226.1130>
C     ===============
C
C     Conversion de Radians en Degres Minutes decimales
C
      Implicit None
C
      REAL*8 DdDmd,RadDmd,Radian
C
      REAL*8 Conv_Deg_Rad,Pi,Conv_Grad_Rad
C
      COMMON /Constante/Conv_Deg_Rad,Pi,Conv_Grad_Rad
C
C     Conv_Deg_Rad=datan(1.d0)/45.
C
      RadDmd=DdDmd(Radian/Conv_Deg_Rad)
C
      END
      FUNCTION RLAC(Tangente_Lat_xxx)
c,<901226.1130>
C     =============
C
C     Fonction inverse du sspg LACRE
C     Calcul retour de latitude croissante ou de latitude conforme
C
C         Tangente_Lat_xxx=TAN(Lat_Conforme/2.)=TANH(Lat_Croissante/2.)
C
C     Resultat : Latitude en Radians
C
      Implicit None
C
      INTEGER Nb
C
      REAL*8 Constante,Q,RLAC,Tangente_Lat_xxx,Teta
C
      DATA Constante/0.0824832568D0/
C
      Teta=Tangente_Lat_xxx
      DO Nb=1,3
          Q=2.*Constante*Teta/(1.+Teta**2)
          Q=DTANH(0.25*Constante*DLOG((1.+Q)/(1.-Q)))
          Teta=(Tangente_Lat_xxx+Q)/(1.+Q*Tangente_Lat_xxx)
      ENDDO
C
      RLAC=2.*DATAN(Teta)
C
      END
      SUBROUTINE tmgeo(Ellips,Param_Projection,X_Cart,Y_Cart,
C     ================
     *    Longitude_Rad,Latitude_Rad)
c,<901226.1130>
C
C->   transverse Mercator -> geogrphiques
C->   Ellips - a0,e2 - parametres de l'Ellipsoide
C->   Param_Projection - cm0,fi0,rk0,x0,y0
C-    coordonnes du point central et facteur d'echelle
C->   X_Cart,Y_Cart --> Longitude_Rad,Latitude_Rad
C->          metres --> radians
C
      Implicit None
C
      INTEGER No
C     INTEGER LU_1
C
      REAL*8 a0,c,dLatitude,dLongitude,dist,dist2,dx,dy,e2,Ellips(2),
     *    Latitude_Rad,Longitude_Rad,prec2,Param_Projection(5),qr,rn,rp,
     *    s,w,X_Cart,xe,Y_Cart,ye
C
C     COMMON /LUecran/LU_1
C
      a0=Ellips(1)
      e2=Ellips(2)
      prec2=0.0001
      No=0
C
C->   on obtient une approximation de Longitude_Rad et Latitude_Rad par
C         une formule standard
C
      CALL tmgeo1(Ellips,Param_Projection,X_Cart,Y_Cart,Longitude_Rad,
     *    Latitude_Rad)
   10 CALL geotm(Ellips,Param_Projection,Longitude_Rad,Latitude_Rad,xe,
     *    ye)
      dx=X_Cart-xe
      dy=Y_Cart-ye
C     IF(No.EQ.0)WRITE(LU_1,*)'dx dy --> ',dx,dy
      s=DSIN(Latitude_Rad)
      w=DSQRT(1.-e2*s*s)
      rn=a0/w
      qr=(w*w)/(1.-e2)
      c=DCOS(Latitude_Rad)
      rp=rn*c
      dLatitude=dy*qr/rn
      dLongitude=dx/rp
      Latitude_Rad=Latitude_Rad+dLatitude
      Longitude_Rad=Longitude_Rad+dLongitude
      No=No+1
      IF(No.LE.20)then
          dist2=dx*dx+dy*dy
          if(dist2.GT.prec2)GO TO 10
C     ELSE
C         WRITE(LU_1,*)' tmgeo : pas de convergence '
      ENDIF
C
      END
      SUBROUTINE tmgeo1(Ellips,Param_Projection,X_Cart,Y_Cart,
C     =================
     *    Longitude_Rad,Latitude_Rad)
c,<901226.1130>
C
C->   transverse Mercator --> geographiques
C->   formule directe approchee (utilisee dans tmgeo)
C->   l'erreur n'excede pas 2 metres dans un fuseau de +- 10 deg
C->   adapte de utmgr pour des Ellipsoides variables
C->   a0,e2 - parametres de l'Ellipsoide
C->   cm0,fi0,rk0 - long,lat point central et facteur d'echelle
C->   X_Cart,Y_Cart --> Longitude_Rad,Latitude_Rad
C
      Implicit None
C
      real*8 a0,a1,a2,ArcMer,cofip,cophi,e2,ecofi,ecxn2,Ellips(2),eprim,
     *    eprim2,eta,expxi,gn,gphi,Latitude_Rad,Longitude_Rad,phi,phipr,
     *    Param_Projection(5),siphi,vm2,x,X_Cart,xi,y,Y_Cart
c
      EQUIVALENCE (cofip,ecxn2),(gphi,expxi),(vm2,ecofi)
C
C-    gain de place ?
C
      a0=Ellips(1)
      e2=Ellips(2)
      eprim2=e2/(1.-e2)
      eprim=DSQRT(eprim2)
      a1=a0/DSQRT(1.-e2)
      a2=a0*DSQRT(1.+eprim2)
      y=Y_Cart-Param_Projection(5)
      y=y/Param_Projection(3)
      x=(X_Cart-Param_Projection(4))/Param_Projection(3)
      phi=y/a2+Param_Projection(2)
      siphi=DSIN(phi)
      cophi=DCOS(phi)
      ecofi=eprim*cophi
      gn=a1/DSQRT(1.+ecofi**2)
      y=y-ArcMer(Ellips,Param_Projection(2),phi)
      xi=x/gn
      ecxn2=(ecofi*xi)**2
      xi=xi*(1.-ecxn2/6.)
      eta=(y/gn)*(1.-ecxn2/2.)
      phipr=phi+eta
      cofip=DCOS(phipr)
      expxi=DEXP(xi)
      Longitude_Rad=DATAN((expxi**2-1.)/(2.*expxi*cofip))
      gphi=DATAN(DCOS(Longitude_Rad)*DSIN(phipr)/cofip)
      vm2=1.+ecofi**2-1.5*eprim*siphi*ecofi*(gphi-phi)
      Longitude_Rad=Longitude_Rad+Param_Projection(1)
      Latitude_Rad=phi+vm2*(gphi-phi)
C
      END
      SUBROUTINE TRANSF(X_Init,Y_Init,X_Final,Y_Final,No_Systeme_Init,
C     =================
     *    No_Systeme_Final,No_Ref_Init,No_Ref_Final)
c,<1.1>
C
C     Conversion de coordonnees
C              X_Init,Y_Init      en       X_Final,Y_Final
C         No_Systeme_Init  -  No_Systeme_Final
C              1      2       3       4       5       6
C             UTM    DMS     DD      DMD     LAM     GLR
C     No_Ref_Init,No_Ref_Final Parametres supplementaires (No Lambert
C         ou Fuseau UTM)
C     Dans le cas des Geographiques : Deplacement du meridien origine
C              1      2       3       4       5
C             GRNW   PARIS   ROME    .....    ......
C
      IMPLICIT None
C
      INTEGER LU_1,No_Ref_Final,No_Ref_Init,No_Reference,
     *    No_Systeme_Final,No_Systeme_Init
C
      REAL*8 DdDmd,DdDms,DdRad,DmdDd,DmsDd,Longitude_Ref(5),RadDd,
     *    X_Init,X_Final,X_Inter,Y_Init,Y_Final,Y_Inter
C
      REAL*8 Conv_Deg_Rad,Pi,Conv_Grad_Rad
C
      COMMON /Constante/Conv_Deg_Rad,Pi,Conv_Grad_Rad
C
      DATA No_Reference/0/,Longitude_Ref/0.D0,2.3372292D0,12.452222D0,
     *    0.D0,0.D0/
C
C     Initialisation unique via le Common Constante sinon la mettre dans
C         TRANSG ou TRANSF suivant le programme :
C             GEODIS et PARNU (GEO) : TRANSG
C             COORD  et HYPO        : TRANSF
C
      Pi=4.*DATAN(1.D0)
      Conv_Deg_Rad=Pi/180.
      Conv_Grad_Rad=Pi/200.
C
      IF(No_Systeme_Init.EQ.No_Systeme_Final)GO TO 90
   10 GO TO (20,30,40,50,60,70),No_Systeme_Init
C
      WRITE(*,'("Transf : Systeme initial indefini")')
      RETURN
C
   20 CALL UTMGR(X_Init*1000.,Y_Init*1000.,X_Inter,Y_Inter,No_Ref_Init)
C
      GO TO 80
C
   30 X_Final=DmsDd(X_Init)+Longitude_Ref(No_Ref_Init)
      Y_Final=DmsDd(Y_Init)
      GO TO 100
C
   40 X_Final=X_Init+Longitude_Ref(No_Ref_Init)
      Y_Final=Y_Init
      GO TO 100
C
   50 X_Final=DmdDd(X_Init)+Longitude_Ref(No_Ref_Init)
      Y_Final=DmdDd(Y_Init)
      GO TO 100
C
   60 CALL LamGe(1000.*X_Init,1000.*Y_Init,X_Inter,Y_Inter,No_Ref_Init)
      GO TO 80
C
   70 CALL Glr_Geo(1000.*X_Init,1000.*Y_Init,X_Inter,Y_Inter)
C
   80 X_Final=RadDd(X_Inter)
      Y_Final=RadDd(Y_Inter)
      GO TO 100
C
   90 IF(No_Ref_Init.NE.No_Ref_Final)GO TO 10
      X_Final=X_Init
      Y_Final=Y_Init
      RETURN
C
  100 GO TO (110,120,130,140,150,160),No_Systeme_Final
C
      WRITE(*,'("Transf :  Systeme final indefini")')
      RETURN
C
  110 IF(No_Ref_Final.NE.0)No_Reference=No_Ref_Final
      IF(No_Reference.EQ.0)No_Reference=(X_Final+186.)/6.
      No_Ref_Final=No_Reference
C
      CALL GUTM(DdRad(X_Final),DdRad(Y_Final),X_Inter,Y_Inter,
     *    No_Reference)
      GO TO 170
C
  120 X_Final=DdDms(X_Final-Longitude_Ref(No_Ref_Final))
      Y_Final=DdDms(Y_Final)
      RETURN
C
  130 X_Final=X_Final-Longitude_Ref(No_Ref_Final)
      RETURN
C
  140 X_Final=DdDmd(X_Final-Longitude_Ref(No_Ref_Final))
      Y_Final=DdDmd(Y_Final)
      RETURN
C
  150 CALL GeLam(DdRad(X_Final),DdRad(Y_Final),X_Inter,Y_Inter,
     *    No_Ref_Final)
      GO TO 170
C
  160 CALL Geo_Glr(DdRad(X_Final),DdRad(Y_Final),X_Inter,Y_Inter)
C
  170 X_Final=X_Inter/1000.
      Y_Final=Y_Inter/1000.
C
      END
      SUBROUTINE UTMGR(X_UTM,Y_UTM,Longitude,Latitude,No_Fuseau_Ref)
c,
C     ================
c    *    <901226.1130>
C
C     Conversion Coordonnees UTM en Geographiques
C
C     Donnees en Metres , Resultats en Radians
C     Origine des longitudes : le meridien international
C     Definition normale de la projection mais Y_UTM est negatif dans
C         l'hemisphere sud , prendre ABS(Y_UTM) pour avoir le NORTHING
C         habituel
C
C     Longitude_Ref est la longitude du meridien central du fuseau
C
      Implicit None
C
      INTEGER No_Fuseau_Ref
C
      REAL*8 ArcMe,C,COFIP,CoPhi,DdRad,ECOFI,ECXN2,Eprim,Eta,EXPXI,GN,
     *    GPhi,Latitude,Longitude,Longitude_Ref,Phi,PhiPr,SiPhi,VM2,X,
     *    X_UTM,XI,Y,Y_UTM
C
      EQUIVALENCE(COFIP,ECXN2),(GPhi,EXPXI),(VM2,ECOFI)
C
      DATA C/6399936.608D0/,Eprim/0.0822688896073373D0/
C
      Longitude_Ref=DdRad(No_Fuseau_Ref*6.D0-183.)
      Y=DABS(Y_UTM)
C
C     IF(Y_UTM.LT.0.0)Y=-Y_UTM-10000000.
C
      Y=Y/0.9996
      Phi=Y/6366197.724
      SIPhi=DSIN(Phi)
      COPhi=DCOS(Phi)
      ECOFI=Eprim*COPhi
      GN=C/DSQRT(1.+ECOFI**2)
      X=(X_UTM-500000.)/0.9996
      Y=Y-ArcMe(Phi)
      XI=X/GN
      ECXN2=(ECOFI*XI)**2
      XI=XI*(1.-ECXN2/6.)
      Eta=(Y/GN)*(1.-ECXN2/2.)
      PhiPR=Phi+Eta
      COFIP=DCOS(PhiPR)
      EXPXI=DEXP(XI)
      Longitude=DATAN((EXPXI**2-1.)/(2.*EXPXI*COFIP))
      GPhi=DATAN(DCOS(Longitude)*DSIN(PhiPR)/COFIP)
      VM2=1.+ECOFI**2-1.5*Eprim*SIPhi*ECOFI*(GPhi-Phi)
      Longitude=Longitude+Longitude_Ref
      Latitude=Phi+VM2*(GPhi-Phi)
      IF(Y_UTM.LT.0.)Latitude=-Latitude
C
      END


**********************************************************************
**********************************************************************
      subroutine numstar(nlens,lensmax,lensdata,levelmax,indlens)
*
* for every lens: calculates number of cell in every level and
* compresses these numbers in one integer in vector indlens(nlens),
* then sorts lenses according to this number
*
* (upper left - 0, upper right - 1, lower left - 2, lower right - 3)
*
*
*    example:
*
*         level:       1      2      3       4      5     ..    levelmax
*    position  :       1      0      2       2      1     ..       2
*  indlens(.) =        1*4**(levelmax-1) +
*			      0*4**(levelmax-2)+
*			     	      2*4**(levelmax-3)+
*   							...
*   							        +2*4**0
* input :
*        nlens           - number of lenses
*        lensmax         - maximum possible number of lenses
*        lensdata(1:3,i) - lens coordinates
*        levelmax   	 - maximum possible number of levels
*
*
* output: indlens(1:nlens) - numbers of cells in different
*                                levels, compressed (cf. example above)
*
*
* called in:
*           main
*
* use of subroutines:
*           sort
*
* use of functions:
*           none
*					October 31, 1991; J. Wambsganss
*
      implicit none
      external sort
      integer debug,lensmax,nlens,ilens,indlens(lensmax),index,ndum
     &,levelmax,fourpow(30),i,ii
*
      double precision xl,yl,lensdata(3,lensmax),stamin,stadif
     &,dumxmin,dumymin,dumdif,xratio, yratio,xcomp,ycomp
*
      common/leng/stamin,stadif
      common/test/debug
*
*
*
      xcomp   = 0.5
      ycomp   = 0.5
*
      do i = 1,levelmax
        fourpow(i) = 4**(i-1)
      enddo
*
* loop over all lenses: numbers are calculated according to the cell
* position in different levels:
*
      do ilens = 1,nlens
	 xl      = lensdata(1,ilens)
	 yl      = lensdata(2,ilens)
  	 index   = 0
      	 dumxmin = stamin
      	 dumymin = stamin
      	 dumdif  = stadif
*
         do ii = 1,levelmax
            xratio = (xl-dumxmin)/dumdif
            yratio = (yl-dumymin)/dumdif
            dumdif = dumdif/2.0
            ndum   = 0
            if(xratio.gt.xcomp)then
                ndum    = ndum + 1
                dumxmin = dumxmin + dumdif
            endif
            if(yratio.lt.ycomp)then
                ndum    = ndum + 2
            else
                dumymin = dumymin + dumdif
            endif
            index = index + ndum*fourpow(levelmax-ii+1)
	 enddo
*
 	 indlens(ilens) = index
      enddo
*
*  sorts all lenses accoring to indlens(i):
*
      if(nlens.gt.1)then
 	 call sort(nlens,indlens,lensdata,3)
      endif
*
      return
      end


c       this file contains the following user-callable routines:
c
c
c       routine iddr_rid computes the ID, to a specified rank,
c       of a matrix specified by a routine for applying its transpose
c       to arbitrary vectors. This routine is randomized.
c
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c
c
c
        subroutine iddr_rid(m,n,matvect,p1,p2,p3,p4,krank,list,proj)
c
c       computes the ID of a matrix "a" specified by
c       the routine matvect -- matvect must apply the transpose
c       of the matrix being ID'd to an arbitrary vector --
c       i.e., the present routine lists in list the indices
c       of krank columns of a such that
c
c       a(j,list(k))  =  a(j,list(k))
c
c       for all j = 1, ..., m; k = 1, ..., krank, and
c
c                       min(m,n,krank)
c       a(j,list(k))  =     Sigma      a(j,list(l)) * proj(l,k-krank)(*)
c                            l=1
c
c                     +  epsilon(j,k-krank)
c
c       for all j = 1, ..., m; k = krank+1, ..., n,
c
c       for some matrix epsilon, dimensioned epsilon(m,n-krank),
c       whose norm is (hopefully) minimized by the pivoting procedure.
c
c       input:
c       m -- number of rows in the matrix to be ID'd
c       n -- number of columns in the matrix to be ID'd
c       matvect -- routine which applies the transpose
c                  of the matrix to be ID'd to an arbitrary vector;
c                  this routine must have a calling sequence
c                  of the form
c
c                  matvect(m,x,n,y,p1,p2,p3,p4),
c
c                  where m is the length of x,
c                  x is the vector to which the transpose
c                  of the matrix is to be applied,
c                  n is the length of y,
c                  y is the product of the transposed matrix and x,
c                  and p1, p2, p3, and p4 are user-specified parameters
c       p1 -- parameter to be passed to routine matvect
c       p2 -- parameter to be passed to routine matvect
c       p3 -- parameter to be passed to routine matvect
c       p4 -- parameter to be passed to routine matvect
c       krank -- rank of the ID to be constructed
c
c       output:
c       list -- indices of the columns in the ID
c       proj -- matrix of coefficients needed to interpolate
c               from the selected columns to the other columns
c               in the original matrix being ID'd;
c               proj doubles as a work array in the present routine, so
c               proj must be at least m+(krank+3)*n real*8 elements
c               long
c
c       _N.B._: The algorithm used by this routine is randomized.
c               proj must be at least m+(krank+3)*n real*8 elements
c               long.
c
c       reference:
c       Halko, Martinsson, Tropp, "Finding structure with randomness:
c            probabilistic algorithms for constructing approximate
c            matrix decompositions," SIAM Review, 53 (2): 217-288,
c            2011.
c
        implicit none
        integer m,n,krank,list(n),lw,ix,lx,iy,ly,ir,lr
        real*8 p1,p2,p3,p4,proj(m+(krank+3)*n)
        external matvect
c
c
c       Allocate memory in w.
c
        lw = 0
c
        ir = lw+1
        lr = (krank+2)*n
        lw = lw+lr
c
        ix = lw+1
        lx = m
        lw = lw+lx
c
        iy = lw+1
        ly = n
        lw = lw+ly
c
c
        call iddr_ridall0(m,n,matvect,p1,p2,p3,p4,krank,
     1                    list,proj(ir),proj(ix),proj(iy))
c
c
        return
        end
c
c
c
c
        subroutine iddr_ridall0(m,n,matvect,p1,p2,p3,p4,krank,
     1                          list,r,x,y)
c
c       routine iddr_ridall serves as a memory wrapper
c       for the present routine
c       (see iddr_ridall for further documentation).
c
        implicit none
        integer j,k,l,m,n,krank,list(n)
        real*8 x(m),y(n),p1,p2,p3,p4,r(krank+2,n)
        external matvect
c
c
c       Set the number of random test vectors to 2 more than the rank.
c
        l = krank+2
c
c       Apply the transpose of the original matrix to l random vectors.
c
        do j = 1,l
c
c         Generate a random vector.
c
          call id_srand(m,x)
c
c         Apply the transpose of the matrix to x, obtaining y.
c
          call matvect(m,x,n,y,p1,p2,p3,p4)
c
c         Copy y into row j of r.
c
          do k = 1,n
            r(j,k) = y(k)
          enddo ! k
c
        enddo ! j
c
c
c       ID r.
c
        call iddr_id(l,n,r,krank,list,y)
c
c
        return
        end


      subroutine evol_BB_hgd_adv(ctfmp,n_BB,n_DLamx,n_beta,np1_BB,np1_DL
     &amx,np1_beta,x,Nx,advc,eta,ht,hx,myzero,phys_bdy,res)
      implicit none
      integer i
      integer Nx
      real*8 advc
      real*8 eta
      real*8 ht
      real*8 hx
      real*8 myzero
      real*8 ctfmp(Nx)
      real*8 n_BB(Nx)
      real*8 n_DLamx(Nx)
      real*8 n_beta(Nx)
      real*8 np1_BB(Nx)
      real*8 np1_DLamx(Nx)
      real*8 np1_beta(Nx)
      real*8 x(Nx)
      integer phys_bdy(2)
      real*8 res(Nx)
      real*8 qb
      if (phys_bdy(1) .eq. 1) then
      do i=1, 1, 1
      qb = -0.1D1 * myzero * x(i)
      res(i)=qb
      end do
      endif
      do i=2, Nx-1, 1
      qb = np1_BB(i) - 0.2D1 / (eta * ht + 0.2D1) * ht * ((-0.1D1 * n_BB
     #(i) + np1_BB(i)) / ht - 0.2500000000000000D0 * advc * np1_beta(i)
     #* (-0.1D1 * np1_BB(i - 1) + np1_BB(i + 1)) / hx / ctfmp(i) + 0.500
     #0000000000000D0 * eta * np1_BB(i) - 0.5000000000000000D0 * np1_DLa
     #mx(i) - 0.2500000000000000D0 * advc * n_beta(i) * (-0.1D1 * n_BB(i
     # - 1) + n_BB(i + 1)) / hx / ctfmp(i) + 0.5000000000000000D0 * eta
     #* n_BB(i) - 0.5000000000000000D0 * n_DLamx(i))
      res(i)=qb
      end do
      if (phys_bdy(2) .eq. 1) then
      do i=Nx, Nx, 1
      qb = -0.1D1 * myzero * x(i)
      res(i)=qb
      end do
      endif
      END


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2021 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine distattach_2d(xig,etg,pneigh,pnode,a,p,ratio,nterms)
!
!     calculates the distance between the node with coordinates
!     in "pnode" and the node with local coordinates xig and etg
!     in a face described by "nterms" nodes with coordinates
!     in pneigh
!
      implicit none
!
      integer nterms,i,j
!
      real*8 ratio(9),pneigh(3,*),pnode(3),a,xi,et,xig,etg,p(3),
     &  xip,xim,etp,etm,xim2,etm2,a2,xi2,et2
!
      if(nterms.eq.3) then
         if(xig+etg.le.0.d0) then
            ratio(2)=(xig+1.d0)/2.d0
            ratio(3)=(etg+1.d0)/2.d0
         else
            ratio(2)=(1.d0-etg)/2.d0
            ratio(3)=(1.d0-xig)/2.d0
         endif
         ratio(1)=1.d0-ratio(2)-ratio(3)
      elseif(nterms.eq.4) then
         xip=(1.d0+xig)/4.d0
         xim=(1.d0-xig)/4.d0
         etp=1.d0+etg
         etm=1.d0-etg
         ratio(1)=xim*etm
         ratio(2)=xip*etm
         ratio(3)=xip*etp
         ratio(4)=xim*etp
      elseif(nterms.eq.6) then
         if(xig+etg.le.0.d0) then
            xi=(xig+1.d0)/2.d0
            et=(etg+1.d0)/2.d0
         else
            xi=(1.d0-etg)/2.d0
            et=(1.d0-xig)/2.d0
         endif
         a=1.d0-xi-et
         a2=2.d0*a
         xi2=2.d0*xi
         et2=2.d0*et
         ratio(1)=a*(a2-1.d0)
         ratio(2)=xi*(xi2-1.d0)
         ratio(3)=et*(et2-1.d0)
         ratio(4)=xi2*a2
         ratio(5)=xi2*et2
         ratio(6)=et2*a2
      elseif(nterms.eq.8) then
         xip=1.d0+xig
         xim=1.d0-xig
         xim2=xip*xim/2.d0
         etp=1.d0+etg
         etm=1.d0-etg
         etm2=etp*etm/2.d0
         ratio(5)=xim2*etm
         ratio(6)=xip*etm2
         ratio(7)=xim2*etp
         ratio(8)=xim*etm2
         xim=xim/4.d0
         xip=xip/4.d0
         ratio(1)=xim*etm*(-xig-etp)
         ratio(2)=xip*etm*(xig-etp)
         ratio(3)=xip*etp*(xig-etm)
         ratio(4)=xim*etp*(-xig-etm)
      else
         write(*,*) '*ERROR in distattach_2d: case with ',nterms
         write(*,*) '       terms is not covered'
         call exit(201)
      endif
!
!     calculating the position in the face
!
      do i=1,3
         p(i)=0.d0
         do j=1,nterms
            p(i)=p(i)+ratio(j)*pneigh(i,j)
         enddo
      enddo
!
!     calculating the distance
!
      a=(pnode(1)-p(1))**2+(pnode(2)-p(2))**2+(pnode(3)-p(3))**2
!
      return
      end


C * * * * * * * * * * * * * * * * * * * * * * * * *
C --- DRIVER FOR RADAU5 ON CUSP PROBLEM
C * * * * * * * * * * * * * * * * * * * * * * * * *
        IMPLICIT REAL*8 (A-H,O-Z)
C --- PARAMETERS FOR RADAU5 (FULL JACOBIAN)
        PARAMETER (ND=96,LWORK=4*ND*ND+12*ND+20,LIWORK=3*ND+20)
        DIMENSION Y(ND),WORK(LWORK),IWORK(LIWORK)
C -------- END PARAMETER LIST --------
        REAL*4 TARRAY(2),TRESULT
        COMMON/NERVES/NNERV
        COMMON/DIFFCOEF/DIFFUS
        EXTERNAL FCUSP,JCUSP,SOLOUT
c ------ FILE DE DONNEES ----------
        OPEN(8,FILE='res_rad5')
        REWIND 8
C --- LOOP FOR DIFFERENT TOLERANCES
        NTOLMN=2
        NTOLMX=10
        NTOLDF=4
        NRLOOP=(NTOLMX-NTOLMN)*NTOLDF+1
        TOLST=0.1D0**NTOLMN
        TOLFC=0.1D0**(1.D0/NTOLDF)
        DO 30 NTOL=1,NRLOOP
c -------- INITIAL CONSTANTES --------
        NNERV=32
        DIFFUS=1.D0*NNERV*NNERV/144.D0
        N=3*NNERV
C --- COMPUTE THE JACOBIAN SWITCH
        IJAC=0
C --- JACOBIAN IS A FULL MATRIX
        MLJAC=3
        MUJAC=3
C --- DIFFERENTIAL EQUATION IS IN EXPLICIT FORM
        IMAS=0
C --- OUTPUT ROUTINE IS NOT USED DURING INTEGRATION
        IOUT=0
C ---------- VAL INIT ------------
        X=0.D0
        XEND=1.1D0
        ANERV=NNERV
        DEL=2.D0*3.14159265358979324D0/ANERV
        DO 25 INERV=1,NNERV
            Y(3*INERV-2)=0.D0
            Y(3*INERV-1)=-2.D0*COS(INERV*DEL)
  25        Y(3*INERV)=2.D0*SIN(INERV*DEL)
C --- REQUIRED TOLERANCE
        RTOL=TOLST
        ATOL=RTOL
        ITOL=0
C --- INITIAL STEP SIZE
        H=1.0D-6
C --- SET DEFAULT VALUES
        DO 10 I=1,20
  10    WORK(I)=0.D0
        DO 12 I=1,20
  12    IWORK(I)=0
C --- ENDPOINT OF INTEGRATION
        XEND=1.1D0
        CALL DTIME(TARRAY,TRESULT)
C --- CALL OF THE SUBROUTINE RADAU5
        CALL RADAU5(N,FCUSP,X,Y,XEND,H,
     &                  RTOL,ATOL,ITOL,
     &                  FCUSP,IJAC,MLJAC,MUJAC,
     &                  FCUSP,IMAS,MLMAS,MUMAS,
     &                  SOLOUT,IOUT,
     &                  WORK,LWORK,IWORK,LIWORK,RPAR,IPAR,IDID)
C --- PRINT SOLUTION
        CALL DTIME(TARRAY,TRESULT)
      DO 20 I=1,N
        WRITE (8,*) Y(I)
  20   CONTINUE
C --- PRINT STATISTICS
        WRITE(8,*)TARRAY(1)
        WRITE (8,*)(IWORK(J),J=14,20)
        WRITE(6,*)' ***** TOL=',RTOL,'  ELAPSED TIME=',TARRAY(1),' ****'
        WRITE (6,91) (IWORK(J),J=14,20)
 91     FORMAT(' fcn=',I5,' jac=',I4,' step=',I4,
     &        ' accpt=',I4,' rejct=',I3,' dec=',I4,
     &        ' sol=',I5)
           write (6,*) y(1),y(n/2),y(n)
C -------- NEW TOLERANCE ---
        IF (TARRAY(1).GT.500.) STOP
        TOLST=TOLST*TOLFC
 30     CONTINUE
        STOP
        END
C
        SUBROUTINE SOLOUT (NR,XOLD,X,Y,CONT,LRC,N,RPAR,IPAR,IRTRN)
        IMPLICIT REAL*8 (A-H,O-Z)
        DIMENSION Y(N),CONT(LRC)
           WRITE (6,99) X,Y(1),Y(2),NR-1
 99     FORMAT(1X,'X =',F6.2,'    Y =',2F18.7,'    NSTEP =',I4)
        RETURN
        END


      SUBROUTINE SPLINT(XA,YA,Y2A,N,X,Y)
      implicit double precision (a-h,o-z)
      DIMENSION XA(N),YA(N),Y2A(N)
      KLO=1
      KHI=N
1     IF (KHI-KLO.GT.1) THEN
        K=(KHI+KLO)/2
        IF(XA(K).GT.X)THEN
          KHI=K
        ELSE
          KLO=K
        ENDIF
      GOTO 1
      ENDIF
      H=XA(KHI)-XA(KLO)
      IF (H.EQ.0.) PAUSE 'Bad XA input.'
      A=(XA(KHI)-X)/H
      B=(X-XA(KLO))/H
      Y=A*YA(KLO)+B*YA(KHI)+
     *      ((A**3-A)*Y2A(KLO)+(B**3-B)*Y2A(KHI))*(H**2)/6.d0
      RETURN
      END


!    Copyright (C) 2012 The SPEED FOUNDATION
!    Author: Ilario Mazzieri
!
!    This file is part of SPEED.
!
!    SPEED is free software; you can redistribute it and/or modify it
!    under the terms of the GNU Affero General Public License as
!    published by the Free Software Foundation, either version 3 of the
!    License, or (at your option) any later version.
!
!    SPEED is distributed in the hope that it will be useful, but
!    WITHOUT ANY WARRANTY; without even the implied warranty of
!    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
!    Affero General Public License for more details.
!
!    You should have received a copy of the GNU Affero General Public License
!    along with SPEED.  If not, see <http://www.gnu.org/licenses/>.

!> @brief Find a root of a polynomial of degree n.
!! @author Ilario Mazzieri
!> @date September, 2013 - Creation
!> @version 1.0
!> @param[in] x1 left bound of the interval [x1,x2]
!> @param[in] x2 right bound of the interval [x1,x2]
!> @param[in] xacc  acceleration parameter
!> @param[in] n  polynomial degree
!> @param[out] FIND_ROOT_POL  zero of the polynomial function of order n

      real*8 function FIND_ROOT_POL(x1,x2,xacc,n)

      use speed_exit_codes

      implicit real*8(a-h,o-z)

      parameter (jmax=1000)

      call GET_LEGENDRE_VALUE(p2,fmid,p1,p1der,n,x2)
      call GET_LEGENDRE_VALUE(p2,f,p1,p1der,n,x1)

      if (f*fmid .ge. 0.d0) then
        write(*,*) 'root non-bracketed !'
        call EXIT(EXIT_ROOT)
      endif

      if (f .lt. 0.d0) then
        FIND_ROOT_POL = x1
        dx = x2 - x1
      else
        FIND_ROOT_POL = x2
        dx = x1 - x2
      endif

      do j = 1,jmax
        dx = 0.5d0*dx
        xmid = FIND_ROOT_POL + dx
        call GET_LEGENDRE_VALUE(p2,fmid,p1,p1der,n,xmid)
        if (fmid .le. 0.d0) FIND_ROOT_POL = xmid

        if (dabs(dx) .lt. xacc .and. dabs(fmid) .le. xacc) then
          FIND_ROOT_POL = xmid
          return
        endif

      enddo

      end function FIND_ROOT_POL


program networks_main
  use networks
  real(dp) :: ohd(6,6), dist(6)
  integer  :: prev(6)

  ohd = inf(1_i1)
  do i = 1, 6
    ohd(i,i) = 0
  end do

  ohd(1,2) = 40
  ohd(1,3) = 15
  ohd(2,3) = 20
  ohd(2,4) = 10
  ohd(2,5) = 25
  ohd(3,4) = 100
  ohd(2,6) = 6
  ohd(5,6) = 8

  ohd(2,1) = 40
  ohd(3,1) = 15
  ohd(3,2) = 20
  ohd(4,2) = 10
  ohd(5,2) = 25
  ohd(4,3) = 100
  ohd(6,2) = 6
  ohd(6,5) = 8

  call dijkstra(ohd, 1, dist, prev)
  print*, dist
  print*, prev
end program networks_main


!==============================================================================!
  real function Normalized_Residual(ni, mat_a, x, r, norm)
!------------------------------------------------------------------------------!
!   Calculates normalized residuals.                                           !
!------------------------------------------------------------------------------!
!----------------------------------[Modules]-----------------------------------!
  use Const_Mod
  use Comm_Mod
  use Matrix_Mod
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  integer           :: ni
  type(Matrix_Type) :: mat_a
  real              :: x(:), r(:)  !  [A]{x}={r}
  real, optional    :: norm        !  optional number for normalization
!-----------------------------------[Locals]-----------------------------------!
  real    :: error, x_max, x_min
  integer :: i
!==============================================================================!

  ! Compute error normalizing it with main diagonal in the system matrix
  error = 0.0
  do i = 1, ni
    error = error + r(i)**2 / mat_a % val(mat_a % dia(i))**2
  end do
  call Comm_Mod_Global_Sum_Real(error)
  error = sqrt(error)

  ! Normalize it with absolute values of the unknown
  if(.not. present(norm)) then
    x_min = minval(x(1:ni))
    x_max = maxval(x(1:ni))
  else
    x_min = 0.0
    x_max = norm
  endif
  call Comm_Mod_Global_Min_Real(x_min)
  call Comm_Mod_Global_Max_Real(x_max)

  ! Create a plateau for very small sources and values
  if( (x_max-x_min) < NANO .and. error < NANO ) then
    error = PICO
  else
    error = error / (x_max - x_min + TINY)
  end if

  Normalized_Residual = error

  end function


module topog_regularization_mod

!  produces regularized topography according to Lindberg and Broccoli,
!  J. of Climate vol 9, no 11 pg. 2641-2659 (1996)

!  Originally coded by Charles Jackson
!  Modified for FMS by Peter Phillipps

use             fms_mod, only: mpp_pe, mpp_root_pe, error_mesg, FATAL, &
                               write_version_number

use             mpp_mod, only: mpp_chksum

use       constants_mod, only: pi

use      transforms_mod, only: compute_gaussian, compute_legendre, &
                               trans_grid_to_spherical, trans_spherical_to_grid,          &
                               get_sin_lat, get_wts_lat, transforms_are_initialized,      &
                               get_lon_max, get_lat_max, get_num_fourier, get_fourier_inc,&
                               get_num_spherical, get_grid_domain, get_spec_domain,       &
                               grid_domain, spectral_domain, area_weighted_global_mean

use     mpp_domains_mod, only: mpp_global_field

implicit none
private

character(len=128), parameter :: version = &
'$Id: topog_regularization.f90,v 13.0 2006/03/28 21:17:37 fms Exp $'

character(len=128), parameter :: tagname = &
'$Name: latest $'

public :: compute_lambda, regularize

integer, parameter :: itmax=1000
real,    parameter :: tolerance = 1.e-5

integer :: is, ie, js, je, ms, me, ns, ne
integer :: lon_max, lat_max, num_fourier, num_spherical, fourier_inc, nmax

real,    allocatable, dimension(:,:  ) :: smoothed_field_tmp, rough, cost_field
real,    allocatable, dimension(:    ) :: wts_lat_global, sin_lat_global, facm, sin_facm
complex, allocatable, dimension(:,:  ) :: Dnm, anm, bnm, Hnm, DR2, DelAnm, DelBnm

logical :: module_is_initialized=.false.

character(len=8) :: chtmp1, chtmp2

contains

!============================================================================================

subroutine compute_lambda(ocean_topog_smoothing, ocean_mask, unsmoothed_field, lambda, actual_fraction_smoothed)

real,    intent(in) :: ocean_topog_smoothing
logical, intent(in), dimension(:,:) :: ocean_mask
real,    intent(in), dimension(:,:) :: unsmoothed_field
real,    intent(out) :: lambda, actual_fraction_smoothed

real :: lambda_1, lambda_2, fraction_smoothed_1, fraction_smoothed_2
real :: tol_lambda = .001
integer :: it_lambda, itmax_lambda=20

if(.not.module_is_initialized) then
  call topog_regularization_init(ocean_mask)
endif

if(any(shape(unsmoothed_field) /= (/ie-is+1,je-js+1/))) then
  write(chtmp1,'(2i4)') shape(unsmoothed_field)
  write(chtmp2,'(2i4)')  (/ie-is+1,je-js+1/)
  call error_mesg('compute_lambda', &
    'Input argument unsmoothed_field has incorrect dimensions. shape(unsmoothed_field)='//chtmp1//'  Should be '//chtmp2,FATAL)
endif

lambda_1 = 1.e-7
lambda_2 = 2.e-7
call regularize(lambda_1, ocean_mask, unsmoothed_field, smoothed_field_tmp, fraction_smoothed_1)
if(abs(ocean_topog_smoothing-fraction_smoothed_1) < tol_lambda) then
  lambda = lambda_1
  actual_fraction_smoothed = fraction_smoothed_1
  goto 20
endif
call regularize(lambda_2, ocean_mask, unsmoothed_field, smoothed_field_tmp, fraction_smoothed_2)
if(abs(ocean_topog_smoothing-fraction_smoothed_2) < tol_lambda) then
  lambda = lambda_2
  actual_fraction_smoothed = fraction_smoothed_2
  goto 20
endif
if(fraction_smoothed_1 > ocean_topog_smoothing .or. fraction_smoothed_2 > ocean_topog_smoothing) then
  call error_mesg('compute_lambda', &
     'Iterative scheme for computing lambda may not work unless initial values of lambda_1 and lambda_2 are reduced.', FATAL)
endif
lambda_1 = ((fraction_smoothed_2-ocean_topog_smoothing)*lambda_1 + &
            (ocean_topog_smoothing-fraction_smoothed_1)*lambda_2)/(fraction_smoothed_2-fraction_smoothed_1)
if(lambda_1 < 0.) then
  call error_mesg('compute_lambda', &
    'Iterative scheme for finding lambda will not work unless initial values of lambda_1 and lambda_2 are reduced.', FATAL)
endif
call regularize(lambda_1, ocean_mask, unsmoothed_field, smoothed_field_tmp, fraction_smoothed_1)
do it_lambda=1,itmax_lambda
  if(abs(ocean_topog_smoothing-fraction_smoothed_1) < tol_lambda) then
    lambda = lambda_1
    actual_fraction_smoothed = fraction_smoothed_1
    goto 20
  endif
  lambda_2 = ((fraction_smoothed_2-ocean_topog_smoothing)*lambda_1 + &
              (ocean_topog_smoothing-fraction_smoothed_1)*lambda_2)/(fraction_smoothed_2-fraction_smoothed_1)
  if(lambda_2 < 0.) then
    write(chtmp1,'(i8)') it_lambda
    call error_mesg('compute_lambda', &
        'Iterative scheme for finding lambda failed. lambda went negative on iteration number'//chtmp1, FATAL)
  endif
  call regularize(lambda_2, ocean_mask, unsmoothed_field, smoothed_field_tmp, fraction_smoothed_2)
  if(abs(ocean_topog_smoothing-fraction_smoothed_2) < tol_lambda) then
    lambda = lambda_2
    actual_fraction_smoothed = fraction_smoothed_2
    goto 20
  endif
  lambda_1 = ((fraction_smoothed_2-ocean_topog_smoothing)*lambda_1 + &
              (ocean_topog_smoothing-fraction_smoothed_1)*lambda_2)/(fraction_smoothed_2-fraction_smoothed_1)

  call regularize(lambda_1, ocean_mask, unsmoothed_field, smoothed_field_tmp, fraction_smoothed_1)
enddo
call error_mesg('compute_lambda','Cannot converge on a value of lambda. Perhaps more interations are needed.', FATAL)
20 continue

return
end subroutine compute_lambda
!============================================================================================

subroutine regularize(lambda, ocean_mask, unsmoothed_field, smoothed_field, fraction_smoothed)

real,    intent(in) :: lambda
logical, intent(in),  dimension(:,:) :: ocean_mask
real,    intent(in),  dimension(:,:) :: unsmoothed_field
real,    intent(out), dimension(size(ocean_mask,1), size(ocean_mask,2)) :: smoothed_field
real,    intent(out) :: fraction_smoothed

real :: converg, cost, oldcost, lamcost, lamcosti
integer :: m, n, it

if(.not.module_is_initialized) then
  call topog_regularization_init(ocean_mask)
endif

if(any(shape(unsmoothed_field) /= (/ie-is+1,je-js+1/))) then
  write(chtmp1,'(2i4)') shape(unsmoothed_field)
  write(chtmp2,'(2i4)')  (/ie-is+1,je-js+1/)
  call error_mesg('regularize', &
   'Input argument unsmoothed_field has incorrect dimensions. shape(unsmoothed_field)='//chtmp1//'  Should be '//chtmp2,FATAL)
endif

if(is /= 1 .or. ie /= lon_max) then
  call error_mesg('regularize', &
    'subroutine regularize is not yet coded for 2-d decomposition. It was assumed that it will never be needed.',FATAL)
endif

Hnm=cmplx(0.,0.)
do n=ns,nmax
  do m=ms,me
    Hnm(m,n)=1./(1.+lambda*Dnm(m,n)*((n+m)*(n+m+1))**2)
  enddo
enddo

bnm=cmplx(0.,0.)
call trans_grid_to_spherical(unsmoothed_field,bnm)

!    anm (equation 6.3)

anm = cmplx(0.,0.)
do n=ns,nmax
  do m=ms,me
    anm(m,n)=bnm(m,n)/(1.+lambda*((n+m)*(n+m+1))**2)
  enddo
enddo

DelAnm = cmplx(0.,0.)
do n=ns,nmax
  do m=ms,me
    DelAnm(m,n)=(n+m)*(n+m+1)*anm(m,n)
  enddo
enddo

call trans_spherical_to_grid(DelAnm,rough)

converg=1.
cost=0.

DelBnm = cmplx(0.,0.)
do it=1,itmax
  if (abs(converg) < tolerance) goto 60

! rough is zeroed out over land
  where(.not.ocean_mask)
    rough = 0.
  end where

! Do an iteration of smoothing
  call trans_grid_to_spherical(rough,DR2)
  do n=ns,nmax
    do m=ms,me
      DR2(m,n)=(n+m)*(n+m+1)*DR2(m,n)
    enddo
  enddo

  do n=ns,nmax
    do m=max(ms,1),me
      anm(m,n)=(anm(m,n)+Hnm(m,n)*(bnm(m,n)-anm(m,n))-lambda*Hnm(m,n)*DR2(m,n))*sin_facm(m)/facm(m)
    enddo
  enddo
  if(ms == 0) then
    do n=ns,nmax
      anm(0,n)=anm(0,n)+Hnm(0,n)*(bnm(0,n)-anm(0,n))-lambda*Hnm(0,n)*DR2(0,n)
    enddo
  endif

! transform the smoothed field to grid
  call trans_spherical_to_grid(anm,smoothed_field)

! compute cost function (eq. 6.4)
  do n=ns,nmax
    do m=ms,me
      DelAnm(m,n)=(n+m)*(n+m+1)*anm(m,n)
    enddo
  enddo
  call trans_spherical_to_grid(DelAnm,rough)
  where(ocean_mask)
    cost_field = (unsmoothed_field-smoothed_field)**2 + lambda*rough**2
  else where
    cost_field = 0.
  end where
  oldcost=cost
  cost = area_weighted_global_mean(cost_field)

  if (it > 1) then
    converg=(oldcost-cost)/oldcost
  endif
enddo
call error_mesg('regularize','Failure to converge',FATAL)
60 continue

do n=ns,nmax
  do m=ms,me
    DelBnm(m,n)=(n+m)*(n+m+1)*bnm(m,n)
  enddo
enddo
call trans_spherical_to_grid(DelBnm,rough)
where(ocean_mask)
  cost_field = rough**2
else where
  cost_field = 0.
end where
lamcosti = area_weighted_global_mean(cost_field)
call trans_spherical_to_grid(DelAnm,rough)
where(ocean_mask)
  cost_field = rough**2
else where
  cost_field = 0.
end where
lamcost = area_weighted_global_mean(cost_field)
fraction_smoothed = 1. - lamcost/lamcosti

if(mpp_pe() == mpp_root_pe()) then
  print '("Message from subroutine regularize: lambda=",1pe16.8,"  fraction_smoothed=",1pe16.8)',lambda,fraction_smoothed
endif

return
end subroutine regularize
!===================================================================================
subroutine topog_regularization_init(ocean_mask)

logical, intent(in), dimension(:,:) :: ocean_mask
integer :: m, i, j
real,    allocatable, dimension(:,:,:) :: legendre_global, legendre
logical, allocatable, dimension(:,:) :: ocean_mask_global

call write_version_number(version, tagname)

if(.not.transforms_are_initialized()) then
  call error_mesg('topog_regularization_init','Transforms are not initialized',FATAL)
endif

call get_grid_domain(is, ie, js, je)
call get_spec_domain(ms, me, ns, ne)

if(any(shape(ocean_mask) /= (/ie-is+1,je-js+1/))) then
  write(chtmp1,'(2i4)') shape(ocean_mask)
  write(chtmp2,'(2i4)')  (/ie-is+1,je-js+1/)
  call error_mesg('topog_regularization_init', &
     'Input argument ocean_mask has incorrect dimensions. shape(ocean_mask)='//chtmp1//'  Should be '//chtmp2,FATAL)
endif

call get_lon_max(lon_max)
call get_lat_max(lat_max)
call get_num_fourier(num_fourier)
call get_num_spherical(num_spherical)
call get_fourier_inc(fourier_inc)

nmax = min(num_fourier,ne)

allocate(sin_lat_global(lat_max))
allocate(wts_lat_global(lat_max))
call get_sin_lat(sin_lat_global)
call get_wts_lat(wts_lat_global)

allocate(facm    (ms:me))
allocate(sin_facm(ms:me))
do m=ms,me
  facm(m) = pi*m/(2.*num_fourier)
  sin_facm(m) = sin(facm(m))
enddo

allocate(Dnm(ms:me,ns:ne),    Hnm(ms:me,ns:ne),    bnm(ms:me,ns:ne), anm(ms:me,ns:ne))
allocate(DR2(ms:me,ns:ne), DelAnm(ms:me,ns:ne), DelBnm(ms:me,ns:ne))
allocate(smoothed_field_tmp(is:ie,js:je), rough(is:ie,js:je), cost_field(is:ie,js:je))

allocate(legendre_global(0:num_fourier,0:num_spherical,lat_max/2))
allocate(legendre(ms:me, ns:ne, lat_max/2))
call compute_legendre(legendre_global, num_fourier, fourier_inc, num_spherical, -sin_lat_global(1:lat_max/2), lat_max/2)
legendre = legendre_global(ms:me,ns:ne,:)

allocate(ocean_mask_global(lon_max,lat_max))
call mpp_global_field(grid_domain, ocean_mask, ocean_mask_global)
Dnm=cmplx(0.,0.)
do i=1,lon_max
  do j=1,lat_max/2
    if(ocean_mask_global(i,j)) then
      Dnm = Dnm + wts_lat_global(j)*legendre(:,:,j)**2
    endif
  enddo
  do j=lat_max/2+1,lat_max
    if(ocean_mask_global(i,j)) then
      Dnm = Dnm + wts_lat_global(j)*legendre(:,:,lat_max+1-j)**2
    endif
  enddo
enddo
deallocate(legendre_global, legendre, ocean_mask_global)
Dnm = Dnm/lon_max

module_is_initialized = .true.
return

end subroutine topog_regularization_init
!===================================================================================

end module topog_regularization_mod


C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C   SOLVER : Conjugate gradient Squared              11.02.97
C            (d'après Templates)
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE CGS(N, x, b, A, IA, JA, ALU, JLU, JU,
     #                    epsilon,it_max,r,r2,p,p2,q,q2,v,u,
     #                    IFLAG,ierr)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      DIMENSION A(*), ALU(*), IA(*), JA(*), JLU(*), JU(*),
     #          b(N), x(N),
     #          r(N), r2(N), p(N), p2(N),
     #          q(N), q2(N), v(N), u(N)
C
C------------------------------------------------------------
C
C     Compute r0 & tol
C     ----------------
      CALL SMMV(N, A, IA, JA, x, r)
      CALL VectSub(N, b, r, r)
C
      residu=VectNorm(N,r)
      tol=epsilon*residu
C
C     Choose r20 = r0
C     ---------------
      CALL VectAssign(N,r2,r)
C
      j=0
      open(UNIT = 1, FILE = 'ite.m', STATUS = 'unknown')
C
C------------------------------------------------------------
C     Boucle principale
C------------------------------------------------------------
C
 10   j=j+1
      WRITE(1,*)'residu4(',j,')=',residu,';'
C
      WRITE(*,210)j, residu
C
C     Calcul du rho et test du breakdown
C     ----------------------------------
      rho=ProdScal(N,r,r2)
      IF (rho.EQ.(0.0D0)) THEN
         WRITE(*,*)'Breakdown!'
         ierr=1
         GOTO 999
      ENDIF
C
C     Calcul de la direction de recherche
C     -----------------------------------
      IF (j.EQ.1) THEN
         CALL VectAssign(N,u,r)
         CALL VectAssign(N,p,r)
      ELSE
         beta=(rho/rho2)
         DO i=1,N
            u(i) = r(i) + beta * q(i)
            p(i) = u(i) + beta * (q(i) + beta * p(i))
         ENDDO
      ENDIF
C
C     Préconditionnement
C     ------------------
      IF(IFLAG.NE.0) THEN
         CALL lusol(n, p, p2, alu, jlu, ju)
      ELSE
         CALL VectAssign(N,p2,p)
      ENDIF
C
      CALL SMMV(N, A, IA, JA, p2, v)
C
C     Calcul de alpha
C     ---------------
      alpha=ProdScal(N,r2,v)
      alpha=rho/alpha
C
C     Calcul de q
C     -----------
      DO i=1,N
         q(i)=u(i)-alpha*v(i)
         u(i)=u(i)+q(i)
      ENDDO
C
C     Préconditionnement
C     ------------------
      IF(IFLAG.NE.0) THEN
         CALL lusol(n, u, u, alu, jlu, ju)
      ENDIF
C
      CALL SMMV(N, A, IA, JA, u, q2)
C
C     Mise à jour de la solution et des résidus
C     -----------------------------------------
      DO i=1,N
         x(i)  = x(i)  + alpha  * u(i)
         r(i)  = r(i)  - alpha  * q2(i)
      ENDDO
C
      rho2=rho
C
C     Teste la convergence
C     --------------------
      residu=VectNorm(N,r)
      IF(residu.LT.tol) THEN
         WRITE(*,*)'Convergence!'
         ierr=0
         GOTO 999
      ENDIF
      IF(j.EQ.it_max) THEN
         WRITE(*,*)'it_max atteint!'
         ierr=1
         GOTO 999
      ENDIF
C
      GOTO 10
C------------------------------------------------------------
 999  close(unit=1)
      RETURN
C
 210  FORMAT(' Iteration :',T14,I4,'   Residu :',T32,D22.15)
C
      END


!> It is not recommended to use the `zeros/ones` function,
!>  it is recommended to use `allocate(array(dim1, dim2, ..), source=0.0/1.0)`.
program demo_linalg_zerosones
    use forlab_linalg, only: zeros, ones
    use forlab_io, only: disp

    real, allocatable :: zero(:, :), one(:, :)
    real, allocatable :: array(:, :)

    zero = zeros(1, 2)
    one  = ones (2, 1)

    call disp(zero, "zeros: ")
    call disp(one , "ones : ")

    call disp(ones(2, 2)/2, "!attention: `ones(2, 2)/2` is like `1/2 == 0`")

    array = zeros(2, 2)
    call disp(array, "array with zeros: ")

    array = ones (2, 2)
    call disp(array, "array with ones :")

end program demo_linalg_zerosones


C SKRDEM program: SDASKR demonstration program
C-----------------------------------------------------------------------
C
C***BEGIN PROLOGUE  SKRDEM
C***DATE WRITTEN   020813     (YYMMDD)
C***REVISION DATE  021217   Added JROOT output value in Problem 2.
C***AUTHORS  Linda R. Petzold and Alan C. Hindmarsh
C             LAWRENCE LIVERMORE NATIONAL LABORATORY
C             LIVERMORE, CA    94550
C***PURPOSE  Quick check for routine SDASKR.
c***DESCRIPTION
C       Demonstration program for SDASKR.
C       This version is in single precision.
C
C       SDASKR is used to solve two simple problems,
C       one nonstiff and one intermittently stiff.
C       If the errors are too large, or other difficulty occurs,
C       a warning message is printed.  All output is on unit LUN.
C
C       To run the demonstration problems with full printing,
C       set KPRINT = 3.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  SDASKR,RES1,RT1,RES2,JAC2,RT2
C***END PROLOGUE SKRDEM
C
C-----------------------------------------------------------------------
C
      IMPLICIT REAL (A-H,O-Z)
      EXTERNAL RES1, RT1, RES2, JAC2, RT2
      INTEGER IDID, IOUT, IWORK, JROOT, INFO, JTYPE,
     *   KROOT, LENIW, LENRW, LIW, LRW, LUN, NEQ, NERR, NRT,
     *   NRE, NREA, NRTE, NJE, NST
      REAL ATOL, ER, ERO, ERRT, RTOL, RWORK,
     *   T, TOUT, TZERO, Y, YT
      DIMENSION Y(2), YPRIME(2), RTOL(2), ATOL(2),
     *   RWORK(100), IWORK(100), JROOT(2), INFO(20)
      COMMON /LOCAL/NEQ
C
      LUN = 6
      KPRINT = 3
      IPASS = 1
      NERR = 0
C-----------------------------------------------------------------------
C First problem.
C The initial value problem is..
C   dY/dT = ((2*LOG(Y) + 8)/T - 5)*Y,  Y(1) = 1,  1 .LE. T .LE. 6
C The solution is  Y(T) = EXP(-T**2 + 5*T - 4), YPRIME(1) = 3
C The two root functions are..
C   R1(T,Y,Y') = dY/dT  (with root at T = 2.5),
C   R2(T,Y,Y') = LOG(Y) - 2.2491  (with roots at T = 2.47 and 2.53)
C-----------------------------------------------------------------------
C Set all input parameters and print heading.
      DO 10 I = 1,20
 10      INFO(I) = 0
      NEQ = 1
      T = 1.0E0
      Y(1) = 1.0E0
      TOUT = 2.0E0
      RTOL(1) = 0.0E0
      ATOL(1) = 1.0E-6
      LRW = 100
      LIW = 100
      IDID = 0
C
C Set INFO(11) = 1 if SDASKR is to compute the initial YPRIME, and
C generate an initial guess for YPRIME.  Otherwise, set INFO(11) = 0
C and supply the correct initial value for YPRIME.
C
      INFO(11) = 0
      YPRIME(1) = 3.0E0
C
C Note: JTYPE indicates the Jacobian type:
C       JTYPE = 1 ==> Jacobian is dense and user-supplied
C       JTYPE = 2 ==> Jacobian is dense and computed internally
C
      JTYPE = 2
      INFO(5) = 2 - JTYPE
      NRT = 2
      IF (KPRINT .GE. 2) WRITE (LUN,110) RTOL(1),ATOL(1),JTYPE
 110  FORMAT(' SKRDEM: Demonstration Program for SDASKR'///
     1       ' Problem 1..'//
     2       ' Problem is  dY/dT = ((2*LOG(Y)+8)/T - 5)*Y,  Y(1) = 1'/
     3       ' Solution is  Y(T) = EXP(-T**2 + 5*T - 4)'/
     4       ' Root functions are..'/
     5       ' R1 = dY/dT  (root at T = 2.5)'/
     6       ' R2 = LOG(Y) - 2.2491  (roots at T = 2.47 and T = 2.53)'/
     7       ' RTOL =',E10.1,'   ATOL =',E10.1,'   JTYPE =',I3/)
     8
C
C Call SDASKR in loop over TOUT values = 2, 3, 4, 5, 6.
      ERO = 0.0E0
      DO 180 IOUT = 1,5
C
 120    CALL SDASKR (RES1,NEQ,T,Y,YPRIME,TOUT,
     *               INFO,RTOL,ATOL,IDID,
     *               RWORK,LRW,IWORK,LIW,RPAR,IPAR,JDUM,PSDUM,
     *               RT1,NRT,JROOT)
C
C Print Y and error in Y, and print warning if error too large.
        YT = EXP(-T*T + 5.0E0*T - 4.0E0)
        ER = Y(1) - YT
        IF (KPRINT .GT. 2) WRITE (LUN,130) T,Y(1),ER
 130    FORMAT(' At t =',E15.7,5X,'y =',E15.7,5X,'error =',E12.4)
        IF (IDID .LT. 0) GO TO 185
        ER = ABS(ER)/ATOL(1)
        ERO = MAX(ERO,ER)
        IF (ER .LT. 1000.0E0) GO TO 140
        IF (KPRINT .GE. 2) THEN
          IPASS = 0
          WRITE (LUN,135)
        ENDIF
 135    FORMAT(//' WARNING.. Error exceeds 1000 * tolerance'//)
        NERR = NERR + 1
 140    CONTINUE
        IF (IDID .NE. 5) GO TO 175
C
C If a root was found, write results and check root location.
C Then return to SDASKR to continue the integration.
        IF (KPRINT .GT. 2) WRITE (LUN,150) T,JROOT(1),JROOT(2)
 150    FORMAT(/'      Root found at t =',E15.7,5X,'JROOT =',2I5)
        IF (JROOT(1) .NE. 0) ERRT = T - 2.5E0
        IF (JROOT(2) .NE. 0 .AND. T .LE. 2.5E0) ERRT = T - 2.47E0
        IF (JROOT(2) .NE. 0 .AND. T .GT. 2.5E0) ERRT = T - 2.53E0
        IF (KPRINT .GT. 2) WRITE (LUN,160) ERRT
 160    FORMAT('      Error in t location of root is',E12.4/)
        IF (ABS(ERRT) .LT. 1.0E-3) GO TO 170
        IF (KPRINT .GE. 2) THEN
           IPASS = 0
           WRITE (LUN,165)
        ENDIF
 165    FORMAT(//' WARNING.. Root error exceeds 1.0E-3'//)
        NERR = NERR + 1
 170    CONTINUE
        GO TO 120
C
C If no root found, increment TOUT and loop back.
 175    TOUT = TOUT + 1.0E0
 180    CONTINUE
C
C Problem complete.  Print final statistics.
 185  CONTINUE
      IF (IDID .LT. 0) NERR = NERR + 1
      NST = IWORK(11)
      NRE = IWORK(12)
      NJE = IWORK(13)
      NRTE = IWORK(36)
      LENRW = 0
      LENIW = 0
      NREA = NRE
      IF (JTYPE .EQ. 2) NRE = NRE + NEQ*NJE
C
      IF (KPRINT .GT. 2) WRITE (LUN,190) NST,NRE,NREA,NJE,NRTE,ERO
 190  FORMAT(/' Final statistics for this run..'/
     *       ' number of steps =',I5/
     *       ' number of Gs    =',I5/
     *       ' (excluding Js)  =',I5/
     *       ' number of Js    =',I5/
     *       ' number of Rs    =',I5/
     *       ' error overrun   =',E10.2)
C
C-----------------------------------------------------------------------
C Second problem (Van Der Pol oscillator).
C The initial value problem is..
C   dY1/dT = Y2,  dY2/dT = 100*(1 - Y1**2)*Y2 - Y1,
C   Y1(0) = 2,  Y2(0) = 0,  0 .LE. T .LE. 200
C   Y1PRIME(0) = 0, Y2PRIME(0) = -2
C The root function is  R(t,Y,Y') = Y1.
C An analytic solution is not known, but the zeros of Y1 are known
C to 15 figures for purposes of checking the accuracy.
C-----------------------------------------------------------------------
C
C Reset INFO array
C
      DO 195 I = 1,20
 195     INFO(I) = 0
C
C Set tolerance parameters and print heading.
C Note that INFO(2) is set to 1, indicating that RTOL and ATOL
C are arrays.  Each entry of RTOL and ATOL must then be defined.
C
      INFO(2) = 1
      RTOL(1) = 1.0E-6
      RTOL(2) = 1.0E-6
      ATOL(1) = 1.0E-6
      ATOL(2) = 1.0E-4
      IF (KPRINT .GE. 2) WRITE (LUN,200) RTOL(1),ATOL(1),ATOL(2)
 200  FORMAT(/80('-')//' Problem 2.. Van Der Pol oscillator'//
     *       ' Problem is dY1/dT = Y2,  dY2/dT = 100*(1-Y1**2)*Y2 - Y1'/
     *       '            Y1(0) = 2,  Y2(0) = 0'/
     *       ' Root function is  R(T,Y,YP) = Y1'/
     *       ' RTOL =',E10.1,'   ATOL =',2E10.1)
C
C Note: JTYPE indicates the Jacobian type:
C       JTYPE = 1 ==> Jacobian is dense and user-supplied
C       JTYPE = 2 ==> Jacobian is dense and computed internally
C
C Loop over JTYPE = 1, 2.  Set remaining parameters and print JTYPE.
      DO 290 JTYPE = 1,2
C
C     Set INFO(1) = 0 to indicate start of a new problem
C     Set INFO(5) = 2-JTYPE to tell SDASKR the Jacobian type.
C
      INFO(1) = 0
      INFO(5) = 2-JTYPE
      NEQ = 2
      T = 0.0E0
      Y(1) = 2.0E0
      Y(2) = 0.0E0
      YPRIME(1) = 0.E0
      YPRIME(2) = -2.0E0
      TOUT = 20.0E0
      NRT = 1
      IF (KPRINT .GT. 2) WRITE (LUN,210) JTYPE
 210  FORMAT(/80('.')//' Solution with JTYPE =',I2/)
C
C Call SDASKR in loop over TOUT values = 20, 40, ..., 200.
      DO 270 IOUT = 1,10
C
 220    CALL SDASKR (RES2,NEQ,T,Y,YPRIME,TOUT,
     *               INFO,RTOL,ATOL,IDID,
     *               RWORK,LRW,IWORK,LIW,RPAR,IPAR,JAC2,PSDUM,
     *               RT2,NRT,JROOT)
C
C Print Y1 and Y2.
        IF (KPRINT .GT. 2) WRITE (LUN,230) T,Y(1),Y(2)
 230    FORMAT(' At t =',E15.7,5X,'y1 =',E15.7,5X,'y2 =',E15.7)
        IF (IDID .LT. 0) GO TO 275
        IF (IDID .NE. 5) GO TO 265
C
C If a root was found, write results and check root location.
C Then return to SDASKR to continue the integration.
        IF (KPRINT .GT. 2) WRITE (LUN,240) T,JROOT(1)
 240    FORMAT(/'      Root found at t =',E15.7,'  JROOT =',I3)
        KROOT = INT(T/81.2E0 + 0.5E0)
        TZERO = 81.17237787055E0 + DFLOAT(KROOT-1)*81.41853556212E0
        ERRT = T - TZERO
        IF (KPRINT .GT. 2) WRITE (LUN,250) ERRT
 250    FORMAT('      Error in t location of root is',E12.4/)
        IF (ERRT .LT. 1.0E0) GO TO 260
        IF (KPRINT .GE. 2) THEN
          IPASS = 0
          WRITE (LUN,255)
        ENDIF
 255    FORMAT(//' WARNING.. Root error exceeds 1.0'//)
        NERR = NERR + 1
 260    CONTINUE
        GO TO 220
C
C If no root found, increment TOUT and loop back.
 265    TOUT = TOUT + 20.0E0
 270    CONTINUE
C
C Problem complete.  Print final statistics.
 275  CONTINUE
      IF (IDID .LT. 0) NERR = NERR + 1
      NST = IWORK(11)
      NRE = IWORK(12)
      NJE = IWORK(13)
      NRTE = IWORK(36)
      LENRW = 0
      LENIW = 0
      NREA = NRE
      IF (JTYPE .EQ. 2) NRE = NRE + NEQ*NJE
      IF (KPRINT .GE. 2) WRITE (LUN,280) NST,NRE,NREA,NJE,NRTE
 280  FORMAT(/' Final statistics for this run..'/
     *       ' number of steps =',I5/
     *       ' number of Gs    =',I5/
     *       ' (excluding Js)  =',I5/
     *       ' number of Js    =',I5/
     *       ' number of Rs    =',I5)
 290  CONTINUE
C
C
      IF (KPRINT .GE. 2) WRITE (LUN,300) NERR
 300  FORMAT(/80('-')//' Number of errors encountered =',I3)
C
      IF (NERR .GT. 0) IPASS = 0
      IF ((IPASS .EQ. 1) .AND. (KPRINT .GT. 1)) WRITE (LUN,700)
      IF ((IPASS .EQ. 0) .AND. (KPRINT .NE. 0)) WRITE (LUN,800)
 700  FORMAT (/,' **********SDASKR passed all tests**********')
 800  FORMAT (/,' **********SDASKR failed some tests*********')
      STOP
      END
C
      SUBROUTINE RES1(T,Y,YPRIME,CJ,DELTA,IRES,RPAR,IPAR)
      IMPLICIT REAL (A-H,O-Z)
      COMMON /LOCAL/NEQ
      DIMENSION Y(NEQ), YPRIME(NEQ), DELTA(NEQ)
C
C     Check Y to make sure that it is valid input.
C     If Y is less than or equal to zero, this is invalid input.
C
      IF (Y(1) .LE. 0.0E0) THEN
         IRES = -1
         RETURN
      ELSE
C
C        Call F1 to obtain F(T,Y)
C
         CALL F1(NEQ,T,Y,DELTA)
C
C        Form G = Y' - F(T,Y)
C
         DO 10 I = 1,NEQ
            DELTA(I) = YPRIME(I) - DELTA(I)
 10      CONTINUE
      ENDIF
C
      RETURN
      END
C
      SUBROUTINE F1 (NEQ, T, Y, YDOT)
      IMPLICIT REAL (A-H,O-Z)
      INTEGER NEQ
      REAL T, Y, YDOT
      DIMENSION Y(1), YDOT(1)
      YDOT(1) = ((2.0E0*LOG(Y(1)) + 8.0E0)/T - 5.0E0)*Y(1)
      RETURN
      END
C
      SUBROUTINE RT1 (NEQ, T, Y, YP, NRT, RVAL, RPAR, IPAR)
      IMPLICIT REAL (A-H,O-Z)
      INTEGER NEQ, NRT
      REAL T, Y, RVAL
      DIMENSION RVAL(2)
      RVAL(1) = YP
      RVAL(2) = LOG(Y) - 2.2491E0
      RETURN
      END
C
      SUBROUTINE RES2(T,Y,YPRIME,CJ,DELTA,IRES,RPAR,IPAR)
      IMPLICIT REAL (A-H,O-Z)
      COMMON /LOCAL/NEQ
      DIMENSION Y(NEQ), YPRIME(NEQ), DELTA(NEQ)
C
C     CALL F2 TO OBTAIN F(T,Y)
C
      CALL F2(NEQ,T,Y,DELTA)
C
C     FORM G = Y' - F(T,Y)
C
      DO 10 I = 1,NEQ
 10      DELTA(I) = YPRIME(I) - DELTA(I)
C
      RETURN
      END
C
      SUBROUTINE F2 (NEQ, T, Y, YDOT)
      IMPLICIT REAL (A-H,O-Z)
      INTEGER NEQ
      REAL T, Y, YDOT
      DIMENSION Y(2), YDOT(2)
      YDOT(1) = Y(2)
      YDOT(2) = 100.0E0*(1.0E0 - Y(1)*Y(1))*Y(2) - Y(1)
      RETURN
      END
C
      SUBROUTINE JAC2 (T, Y, YPRIME, PD, CJ, RPAR, IPAR)
      IMPLICIT REAL (A-H,O-Z)
      INTEGER NEQ,  NROWPD
      REAL T, Y, PD
      PARAMETER (NROWPD=2)
      DIMENSION Y(2), PD(NROWPD,2)
      COMMON /LOCAL/NEQ
C
C First define the Jacobian matrix for the right-hand side
C of the ODE: Y' = F(T,Y) , i.e. dF/dY.
C
      PD(1,1) = 0.0E0
      PD(1,2) = 1.0E0
      PD(2,1) = -200.0E0*Y(1)*Y(2) - 1.0E0
      PD(2,2) = 100.0E0*(1.0E0 - Y(1)*Y(1))
C
C Next update the Jacobian with the right-hand side to form the
C DAE Jacobian: CJ*dR/dY' + dR/dY = CJ*I - dF/dY.
C
      PD(1,1) = CJ - PD(1,1)
      PD(1,2) =    - PD(1,2)
      PD(2,1) =    - PD(2,1)
      PD(2,2) = CJ - PD(2,2)
C
      RETURN
      END
C
      SUBROUTINE RT2 (NEQ, T, Y, YP, NRT, RVAL, RPAR, IPAR)
      IMPLICIT REAL (A-H,O-Z)
      INTEGER NEQ, NRT
      REAL T, Y, RVAL
      DIMENSION Y(2), YP(2), RVAL(1)
      RVAL(1) = Y(1)
      RETURN
      END


! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
!
! test ptr reshape (F2003) with derived types

	program test
	implicit none
	parameter (n = 3)
	integer n
	type nested_pointer
	real, pointer :: diag2(:)
	end type nested_pointer
	type pointers
	real, pointer :: base_array(:), diagonal(:)
	real, pointer :: matrix(:,:)
	type(nested_pointer) :: np
	character, pointer :: cp(:)
	character,pointer :: cp2(:)
	character(len=3), pointer :: cp4(:)
	end type pointers
	type(pointers) :: ptrs
	character(len=3), pointer :: cp3(:)
	character(len=24) :: exp_test12
        character(len=24) :: rslt_test12
	integer expect(12)
	integer result(12)
	integer test1(n,n)
        integer test2(n)
	integer test3(n)
	integer test4(n)
	integer test5(n)
	integer shapeArr(2)
	character, target :: test10(8)
	character(len=3), target :: test12(8)
	integer i,j
	data test10 /'z','y','x','v','u','t','s','r'/
	data test12 /'abc','def','ghi','jkl','mno','pqr','stu','vwx'/

	exp_test12 = 'abcdefghijklmnopqrstuvwx'
	rslt_test12 = ''
	allocate(ptrs%base_array(n*n))
	expect = .true.
	result = .false.
	shapeArr(1) = n
	shapeArr(2) = n
	do i=1,n*n
	  ptrs%base_array(i) = i-1
	enddo
	test1 = reshape(ptrs%base_array,shapeArr)
	ptrs%matrix(1:n,1:n) => ptrs%base_array
	result(1) = all(ptrs%matrix .eq. test1)
	ptrs%diagonal(1:n) => ptrs%base_array(::n+1)
	test2 = ptrs%base_array(::n+1)
	result(2) = all(ptrs%diagonal .eq. test2)
	ptrs%diagonal(n-1:) => ptrs%base_array(::n+1)
	test3 = ptrs%base_array(::n+1)
	result(3) = all(ptrs%diagonal .eq. test3)
	ptrs%diagonal(1:n) => ptrs%base_array(n*n:1:-(n+1))
	result(4) = all(ptrs%diagonal .eq. test2(n:1:-1))
	ptrs%np%diag2(n:1) => ptrs%diagonal
	result(5) = all(ptrs%np%diag2 .eq. test2)
	ptrs%diagonal(n:1) => ptrs%diagonal
	result(6) = all(ptrs%diagonal .eq. test2)
	ptrs%diagonal(n:1) => ptrs%base_array(n*n:1:-(n+1))
	result(7) = all(ptrs%diagonal .eq. test2)
	ptrs%diagonal(1:n) => ptrs%matrix(:,n)
	test4 = ptrs%matrix(:,n)
	result(8) = all(ptrs%diagonal .eq. test4)
	ptrs%diagonal(1:) => ptrs%matrix(n,:)
	test5 = ptrs%matrix(n,:)
	result(9) = all(ptrs%diagonal .eq. test5)
	ptrs%cp2 => test10
	ptrs%cp(8:1) => ptrs%cp2
	result(10) = all(ptrs%cp .eq. test10(8:1:-1))
	ptrs%cp(4:8) => ptrs%cp
	result(11) = all(ptrs%cp .eq. test10(8:4:-1))
	ptrs%cp4(8:1) => test12(8:1:-1)
	cp3(1:8) => ptrs%cp4
	rslt_test12 = cp3(1)//cp3(2)//cp3(3)//cp3(4)//cp3(5)//cp3(6)//cp3(7)//cp3(8)
	result(12) = rslt_test12 .eq. exp_test12

	call check(result,expect,12)
	end