C ORTHNG    SOURCE    CHAT      09/11/25    21:15:18     6548           
      SUBROUTINE ORTHNG (IPX0,IPLIS1,IPLIS2,IPLIS3,LLIST,IPRIGI,
     &                 XNOR,IPRX,IPX,IPLMOX,IPLMOY,XPRECI,IOP)
************************************************************************
*
*                             O R T H N G
*                             -----------
*
* FONCTION:
* ---------
*
*     R-ORTHOGONALISER UN CHPOINT "X" PAR RAPPORT A UNE SUITE DE
*     CHPOINTS "U(I)", "R" ETANT UNE RIGIDITE DONNEE.
*     CAS DE FIGURE OU L'ON CONNAIT DEJA LES PRODUITS "R.U(I)".
*              SPECIFIQUE BOITE VIBRA
*
*     FOURNI EN OUTRE UN VECTEUR NORMALISE ET R*X
* MODE D'APPEL:
* -------------
*
*     CALL ORTHNG (IPX0,IPLIS1,IPLIS2,IPLIS3,LLIST,IPRIGI,
*    &                 XNOR,IPRX,IPX,IPLMOX,IPLMOY)
*
* PARAMETRES:   (E)=ENTREE   (S)=SORTIE
* -----------
*
*     IPX0    ENTIER    (E)  POINTEUR DU CHPOINT A "R-ORTHOGONALISER".
*     IPLIS1  ENTIER    (E)  POINTEUR DU 'LISTCHPO' CONTENANT LES "U(I)"
*     IPLIS2  ENTIER    (E)  POINTEUR DU 'LISTREEL' CONTENANT LES
*                            PRODUITS "U(I).R.U(I)".
*     IPLIS3  ENTIER    (E)  POINTEUR DU 'LISTCHPO' CONTENANT LES
*                            PRODUITS "R.U(I)".
*     LLIST   ENTIER    (E)  NOMBRE DE CHPOINTS "U(I)".
*     IPRIGI  ENTIER    (E)  POINTEUR DE LA 'RIGIDITE' "R".
*                            "R-ORTHOGONALISATION" (POUR PALIER AUX
*                            ERREURS D'ARRONDIS).
*     IPX     ENTIER    (S)  POINTEUR DU CHPOINT "R-ORTHOGONAL" A LA
*                            SUITE DE CHPOINTS.
*     IPRX    ENTIER    (S)  POINTEUR SUR CHPOINT PRODUIT DE RIGI
*                            PAR LE VECTEUR ORTHOGONALISE
*     XNOR    REEL      (S)  NORME DE IPX
*
*     IPLMOX  ENTIER    (E)  POINTEUR SUR LISTMOTS  (UX,...)
*     IPLMOY  ENTIER    (E)  POINTEUR SUR LISTMOTS  (FX,...
*
* LEXIQUE: (ORDRE ALPHABETIQUE)
* --------
*
*     IPRU    ENTIER    POINTEUR D'UN CHPOINT "R.U(I)".
*     IPU     ENTIER    POINTEUR D'UN CHPOINT "U(I)".
*     IPXX    ENTIER    POINTEUR DU CHPOINT "X" A UN CERTAIN STADE DE
*                       TRANSFORMATION.
*     ORTHO   LOGIQUE   INDIQUE PAR "VRAI" OU "FAUX" SI LA
*                       "R-ORTHOGONALISATION" A ETE EFFECTUEE AVEC
*                       SUCCES.
*     PREMOD  REEL DP   PRECISION D'ORTHOGONALISATION, MODULEE EN
*                       FONCTION DE LA TAILLE DU PROBLEME.
*     UTRUMX  REEL DP   MAXIMUM DES PRODUITS U(I)T.R.U(I)
*     UTRU    REEL DP   PRODUIT U(I)T.R.U(I)  ("T" POUR "TRANSPOSE").
*     XTRU    REEL DP   PRODUIT XT.R.U(I)  ("T" POUR "TRANSPOSE").
*
*
* SOUS-PROGRAMMES APPELES:
* ------------------------
*
*     DIMEN3, DTCHPO, ERREUR, EXTRA1, EXTRA4, MAXIM3, NORME2, YTX1.
*
* AUTEUR, DATE DE CREATION:
* -------------------------
*
*     D.    BROCHARD        FEVRIER 1988
*
*
* LANGAGE:
* --------
*
*     FORTRAN77
*
************************************************************************
*
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
-INC CCOPTIO
-INC SMLMOTS
-INC SMLREEL
-INC SMLCHPO
*
      REAL*8 PRECIS
      REAL*8 XTRU,UTRU,UTRUMX,XTRX,PREMOD
*
      LOGICAL ORTHO
*
      PARAMETER (RLIM=0.1)
*
*
      CALL MAXIM3 (IPLIS2,  IPLACE,UTRUMX)
      IF (IERR .NE. 0) RETURN
      UTRUMX = ABS(UTRUMX)
      MLCHPO=IPLIS1
      SEGACT MLCHPO
      MLREEL=IPLIS2
      SEGACT MLREEL
      MLCHP1=IPLIS3
      SEGACT MLCHP1
       IDET=0
       IF((IPLMOX*IPLMOY).EQ.0) THEN
       IPRU=MLCHP1.ICHPOI(1)
       CALL CORRSP(iprigi,IPX0,IPRU,IPLMOX,IPLMOY)
       IDET=1
       END IF
*
*     ON DONNE AU 'CHPOINT' A ORTHOGONALISER LE MEME ORDRE DE GRANDEUR
*     QUE CELUI DES 'CHPOINTS' DU 'LISTCHPO':
C A SUPPR.    CALL NORME2 (IPX0,UTRUMX,IPRIGI,  IPX,XTRX)

      CALL MUCPRI(IPX0,IPRIGI,IPRX)
      IF (IERR .NE. 0) RETURN
      CALL XTY1(IPX0,IPRX,IPLMOX,IPLMOY,XTRRX)
*
      COEFF = SQRT( ABS(UTRUMX / XTRRX) )
      MULTPL = 1
      CALL MUCHPO (IPX0,COEFF,  IPX,MULTPL)
      CALL MUCHPO (IPRX,COEFF,  IPXR,MULTPL)
      IF (IERR .NE. 0) RETURN
      CALL DTCHPO(IPRX)
      IPRX=IPXR
*
      XTRX = ABS(UTRUMX/XTRRX) * XTRRX
*
      XTRX1 = XTRX
      CALL XTY1(IPX,IPX,IPLMOX,IPLMOX,XTX0)
*
      if( iop.eq.0) then
            ideb=1
            ifin=llist
            ipas=1
            xpreca=-1.d0
      elseif(iop.eq.1) then
           ideb=1
           ifin = llist
           ipas = 1
           xpreca=xpreci
      elseif(iop.eq.2) then
           ideb=llist
           ifin = 1
           ipas = -1
           xpreca=xpreci
      elseif(iop.eq.3) then
           ideb=llist
           ifin=max (ideb - 5,1)
           ipas = -1
           xpreca=-1.d0
      else
        call erreur(5)
        return
      endif
        
         iaa=0
         DO 110 IB110=ideb,ifin,ipas
         iaa=iaa+1
*
*           -- ORTHOGONALISATION --
*
      IPU=ICHPOI(IB110)
      UTRU=PROG(IB110)
      IPRU=MLCHP1.ICHPOI(IB110)
            CALL XTY1 (IPX,IPRU,IPLMOX,IPLMOY,  XTRU)
            IF (IERR .NE. 0) RETURN
            XXTRU = -1.D0 * XTRU / UTRU
       
*
*       WRITE(IOIMP,*) IB110,XXTRU,XTRU,UTRU
*
        if (abs(xxtru).lt.xpreca.and.iaa.ne.1) go to 111
      CALL ADCHPO(IPU,IPX,IPXX,XXTRU,1D0)      
      CALL ADCHPO(IPRU,IPRX,IPXR,XXTRU,1D0)
      CALL DTCHPO(IPRX)
      CALL DTCHPO (IPX)
      IPRX=IPXR
      IPX=IPXX
*
*
       XTRX1=XTRX1-((XTRU*XTRU)/UTRU)
*
*
  110       CONTINUE
  111       CONTINUE
*      write(6,*) ' iprx ipx' , iprx, ipx
*
*
            CALL XTY1 (IPX,IPRX,IPLMOX,IPLMOY,  XTRX2)

       RNM=ABS(XTRX1/XTRX)
       IF(RNM.GE.RLIM) GOTO 1001
       NV=LLIST+1
*       WRITE(IOIMP,1000) NV,RNM
1000        FORMAT(/40X,'OPERATEUR VIBRA OPTION SIMULTANE',/10X,
     C ' DIFFICULTE D ORTHOGONALISER  LE ',I5,
     C ' IEME VECTEUR ',/10X,'NORME APRES ORTHOGONALISATION PAR ',
     C ' RAPPORT A LA NORME INITIALE ',E12.5)
1001   CONTINUE
ck      COEFF=SQRT(1.0E0/RNM)
      coeff = 1.e0/sqrt(abs(xtrx2))
      CALL MUCHPO(IPXX,COEFF,IPX,1)
      CALL MUCHPO(IPXR,COEFF,IPRX,1)
      CALL DTCHPO(IPXX)
      CALL DTCHPO(IPXR)
      XNOR=XTRX1*ABS(XTRX/XTRX1)
c            CALL XTY1 (IPX,IPRX,IPLMOX,IPLMOY,  XTRX3)
c       write(6,*) llist,rnm, xtrx2/xtrx,xtrx2,xtrx3,xnor
*
*
*
         ORTHO = .TRUE.
*
      SEGDES MLCHPO
      SEGDES MLCHP1
      SEGDES MLREEL
       IF(IDET.EQ.1) THEN
       MLMOTS =IPLMOX
       MLMOT1 =IPLMOY
       SEGSUP MLMOTS,MLMOT1
       END IF
*
      IF (.NOT.ORTHO) THEN
*        INTERR(1) = NFOIS     VALEUR NON DEFINIS
*        REAERR(1) = PREMOD
        INTERR(1) = 0
        REAERR(1) = 0
         CALL ERREUR (218)
      END IF
       RETURN
      END