!-------------------------------------- LICENCE BEGIN ------------------------------------
!Environment Canada - Atmospheric Science and Technology License/Disclaimer,
!                     version 3; Last Modified: May 7, 2008.
!This is free but copyrighted software; you can use/redistribute/modify it under the terms
!of the Environment Canada - Atmospheric Science and Technology License/Disclaimer
!version 3 or (at your option) any later version that should be found at:
!http://collaboration.cmc.ec.gc.ca/science/rpn.comm/license.html
!
!This software 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 above mentioned License/Disclaimer for more details.
!You should have received a copy of the License/Disclaimer along with this software;
!if not, you can write to: EC-RPN COMM Group, 2121 TransCanada, suite 500, Dorval (Quebec),
!CANADA, H9P 1J3; or send e-mail to service.rpn@ec.gc.ca
!-------------------------------------- LICENCE END --------------------------------------
!

      SUBROUTINE M1QN2A (SIMUL,PROSCA,N,X,F,G,DXMIN,DF1,EPSG, 1,1
     /     IMPRES,IO,MODE,NITER,NSIM,M,
     /     D,GG,AUX,ALPHA,YBAR,SBAR,IZS,RZS,DZS)
C---- 
C     
C     CODE D'OPTIMISATION PROPREMENT DIT
C     
C---- 
C     
C     ARGUMENTS
C     
      INTEGER N,IMPRES,IO,MODE,NITER,NSIM,M,IZS(1)
      REAL*8 X(N),F,G(N),DXMIN,DF1,EPSG,D(N),GG(N),AUX(N),
     /     ALPHA(M),YBAR(N,M),SBAR(N,M),RZS(1)
      DOUBLE PRECISION DZS(1)
      EXTERNAL SIMUL,PROSCA
C     
C     VARIABLES LOCALES
C     
      INTEGER I,ITER,MODERL,ISIM,JMIN,JMAX,INDIC
      REAL*8 R1,T,TMIN,TMAX,GNORM,EPS1,PRECON,FF
      DOUBLE PRECISION PS,PS2,HP0
C     
C---- PARAMETRES
C     
      REAL*8 RM1,RM2
      PARAMETER (RM1=0.0001,RM2=0.9)
      REAL*8 PI
      PARAMETER (PI=3.1415927)
C     
C---- INITIALISATION
C     
      ITER=0
      ISIM=1
      CALL PROSCA (N,G,G,PS,IZS,RZS,DZS)
      GNORM=PS
      GNORM=SQRT(GNORM)
      IF (IMPRES.GE.1) WRITE (IO,900) F,GNORM
 900  FORMAT (5X,"F         = ",E15.8
     /     /5X,"NORM OF G = ",E15.8)
C     
C     ---- DIRECTION DE DESCENTE INITIALE
C     (AVEC MISE A L'ECHELLE)
C     
      PRECON=2.*DF1/GNORM**2
      DO 10 I=1,N
         D(I)=-G(I)*PRECON
 10   CONTINUE
      IF (IMPRES.GE.5) WRITE(IO,899) PRECON
 899  FORMAT (/" M1QN2A: DESCENT DIRECTION -G: PRECON = ",E10.3)
      IF (IMPRES.EQ.3) THEN
         WRITE(IO,901)
         WRITE(IO,9010)
      ENDIF
      IF (IMPRES.EQ.4) WRITE(IO,901)
C     
C     ---- INITIALISATION POUR MLIS0
C     
      TMAX=1.E+20
      CALL PROSCA (N,D,G,HP0,IZS,RZS,DZS)
C     
C     ---- INITIALISATION POUR DD
C     
      JMIN=1
      JMAX=0
C     
C---- DEBUT DE L'ITERATION. ON CHERCHE X(K+1) DE LA FORME X(K) + T*D,
C     AVEC T > 0. ON CONNAIT D.
C     
C     DEBUT DE LA BOUCLE: ETIQUETTE 100,
C     SORTIE DE LA BOUCLE: GOTO 1000.
C     
 100  ITER=ITER+1
      IF (IMPRES.LT.0) THEN
         IF(MOD(ITER,-IMPRES).EQ.0) THEN
            INDIC=1
            CALL SIMUL (INDIC,N,X,F,G,IZS,RZS,DZS)
            GOTO 100
         ENDIF
      ENDIF
      IF (IMPRES.GE.5) WRITE(IO,901)
 901  FORMAT (/1X,79("-"))
      IF (IMPRES.GE.4) WRITE(IO,9010)
 9010 FORMAT (1X)
      IF (IMPRES.GE.3) WRITE (IO,902) ITER,ISIM,F,HP0
 902  FORMAT (" M1QN2: ITER ",I3,", SIMUL ",I3,
     /     ", F=",E15.8,", H'(0)=",D12.5)
      DO 101 I=1,N
         GG(I)=G(I)
 101  CONTINUE
      FF=F
C     
C     ---- RECHERCHE LINEAIRE ET NOUVEAU POINT X(K+1)
C     
      IF (IMPRES.GE.5) WRITE (IO,903)
 903  FORMAT (/" M1QN2: LINE SEARCH")
C     
C     ---- CALCUL DE TMIN
C     
      TMIN=0.
      DO 200 I=1,N
         TMIN=MAX(TMIN,ABS(D(I)))
 200  CONTINUE
      TMIN=DXMIN/TMIN
      T=1.
      R1=HP0
C     
      CALL MLIS0 (N,SIMUL,PROSCA,X,F,R1,T,TMIN,TMAX,D,G,RM2,RM1,
     /     IMPRES,IO,MODERL,ISIM,NSIM,AUX,IZS,RZS,DZS)
C     
C     ---- MLIS0 RENVOIE LES NOUVELLES VALEURS DE X, F ET G
C     
      IF (MODERL.NE.0) THEN
         IF (MODERL.LT.0) THEN
C     
C     ---- CALCUL IMPOSSIBLE
C     T, G: OU LES CALCULS SONT IMPOSSIBLE
C     X, F: CEUX DU T_GAUCHE (DONC F <= FF)
C     
            MODE=MODERL
         ELSEIF (MODERL.EQ.1) THEN
C     
C     ---- DESCENTE BLOQUEE SUR TMAX
C     [SORTIE RARE (!!) D'APRES LE CODE DE MLIS0]
C     
            MODE=3
            IF (IMPRES.GE.1) WRITE(IO,904) ITER
 904        FORMAT (/" >>> M1QN2 (ITERATION ",I3,
     /           "): LINE SEARCH BLOCKED ON TMAX: "
     /           "DECREASE THE SCALING")
         ELSEIF (MODERL.EQ.4) THEN
C     
C     ---- NSIM ATTEINT
C     X, F: CEUX DU T_GAUCHE (DONC F <= FF)
C     
            MODE=5
         ELSEIF (MODERL.EQ.5) THEN
C     
C     ---- ARRET DEMANDE PAR L'UTILISATEUR (INDIC = 0)
C     X, F: CEUX EN SORTIE DU SIMULATEUR
C     
            MODE=0
         ELSEIF (MODERL.EQ.6) THEN
C     
C     ---- ARRET SUR DXMIN OU APPEL INCOHERENT
C     X, F: CEUX DU T_GAUCHE (DONC F <= FF)
C     
            MODE=6
         ENDIF
         GOTO 1000
      ENDIF
C     
C     ---- TESTS D'ARRET
C     
      CALL PROSCA(N,G,G,PS,IZS,RZS,DZS)
      EPS1=PS
      EPS1=SQRT(EPS1)/GNORM
C     
      IF (IMPRES.GE.5) WRITE (IO,905) EPS1
 905  FORMAT (/" M1QN2: STOPPING CRITERION ON G: ",E12.5)
      IF (EPS1.LT.EPSG) THEN
         MODE=1
         GOTO 1000
      ENDIF
      IF (ITER.EQ.NITER) THEN
         MODE=4
         IF (IMPRES.GE.1) WRITE (IO,906) ITER
 906     FORMAT (/" >>> M1QN2 (ITERATION ",I3,
     /        "): MAXIMAL NUMBER OF ITERATIONS")
         GOTO 1000
      ENDIF
      IF (ISIM.GE.NSIM) THEN
         MODE=5
         IF (IMPRES.GE.1) WRITE (IO,907) ITER,ISIM
 907     FORMAT (/" >>> M1QN2 (ITERATION ",I3,"): ",I6,
     /        " SIMULATIONS (MAXIMAL NUMBER REACHED)")
         GOTO 1000
      ENDIF
C     
C     ---- MISE A JOUR DE LA MATRICE
C     
      JMAX=JMAX+1
      IF (ITER.GT.M) THEN
         JMIN=JMIN+1
         IF (JMIN.GT.M) JMIN=JMIN-M
         IF (JMAX.GT.M) JMAX=JMAX-M
      ENDIF
C     
C     ---- Y, S ET (Y,S)
C     
      DO 400 I=1,N
         SBAR(I,JMAX)=T*D(I)
         YBAR(I,JMAX)=G(I)-GG(I)
 400  CONTINUE
      CALL PROSCA (N,YBAR(1,JMAX),SBAR(1,JMAX),PS,IZS,RZS,DZS)
      R1=PS
      IF (R1.LE.0.) THEN
         MODE=7
         IF (IMPRES.GE.1) WRITE (IO,908) ITER,R1
 908     FORMAT (/" >>> M1QN2 (ITERATION ",I2,
     /        "): THE SCALAR PRODUCT (Y,S) = ",E12.5
     /        /27X,"IS NOT POSITIVE")
         GOTO 1000
      ENDIF
C     
C     ---- PRECON: FACTEUR DE MISE A L'ECHELLE
C     
      CALL PROSCA (N,YBAR(1,JMAX),YBAR(1,JMAX),PS,IZS,RZS,DZS)
      PRECON=R1/PS
      IF (IMPRES.GE.5) WRITE (IO,909) R1,PRECON
 909  FORMAT (/' M1QN2: MATRIX UPDATE: (Y,S) = ',E10.3,
     /     ', OREN-SPEDICATO = ',E10.3)
C     
C     ---- YBAR, SBAR
C     
      R1=SQRT(1./R1)
      DO 410 I=1,N
         SBAR(I,JMAX)=R1*SBAR(I,JMAX)
         YBAR(I,JMAX)=R1*YBAR(I,JMAX)
 410  CONTINUE
C     
C     ---- CALCUL DE LA NOUVELLE DIRECTION DE DESCENTE D = - H.G
C     
      DO 510 I=1,N
         D(I)=-G(I)
 510  CONTINUE
      CALL DD1 (PROSCA,N,M,D,JMIN,JMAX,
     /     PRECON,ALPHA,YBAR,SBAR,IZS,RZS,DZS)
C     
C     ---- TEST: LA DIRECTION D EST-ELLE DE DESCENTE ?
C     HP0 SERA UTILISE PAR MLIS0
C     
      CALL PROSCA (N,D,G,HP0,IZS,RZS,DZS)
      IF (HP0.GE.0.D+0) THEN
         MODE=7
         IF (IMPRES.GE.1) WRITE (IO,910) ITER,HP0
 910     FORMAT (/" >>> M1QN2 (ITERATION ",I2,"): "
     /        /5X," THE SEARCH DIRECTION D IS NOT A",
     /        "DESCENT DIRECTION: (G,D) = ",D12.5)
         GOTO 1000
      ENDIF
      IF (IMPRES.GE.5) THEN
         CALL PROSCA (N,G,G,PS,IZS,RZS,DZS)
         PS=DSQRT(PS)
         CALL PROSCA (N,D,D,PS2,IZS,RZS,DZS)
         PS2=DSQRT(PS2)
         PS=HP0/PS/PS2
         PS=DMIN1(-PS,1.D+0)
         PS=DACOS(PS)
         R1=PS
         R1=R1*180./PI
         WRITE (IO,911) R1
 911     FORMAT (/" M1QN2: DESCENT DIRECTION D: ",
     /        "ANGLE(-G,D) = ",F5.1," DEGREES")
      ENDIF
C     
C---- ON POURSUIT LES ITERATIONS
C     
      GOTO 100
C     
C     RETOUR
C     
 1000 EPSG=EPS1
      NITER=ITER
      NSIM=ISIM
      RETURN
      END