Sources Esope | Cast3M

ortho1
C ORTHO1    SOURCE    CHAT      05/01/13    02:06:32     5004
      SUBROUTINE ORTHO1 (IPX0,IPLIS1,IPLIS2,IPLIS3,LLIST,IPRIGI,PRECIS
     &                 ,NFOIS,COMBIN,IPX)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
************************************************************************
*
*                             O R T H O 1
*                             -----------
*
* 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)".
*
* MODE D'APPEL:
* -------------
*
*     CALL ORTHO1 (IPX0,IPLIS1,IPLIS2,IPLIS3,LLIST,IPRIGI,PRECIS
*    &           ,NFOIS,COMBIN,IPX)
*
* 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".
*     PRECIS  REEL DP   (E)  PRECISION DEMANDEE POUR LA
*                            R-ORTHOGONALISATION.
*                            = 0  SI L'ON NE VEUT PAS DE TEST DE
*                            PRECISION.
*                            ON NE VERIFIE PAS QUE "PRECIS >= 0".
*     NFOIS   ENTIER    (E)  NOMBRE DE FOIS QUE L'ON EFFECTUE LA
*                            "R-ORTHOGONALISATION" (POUR PALIER AUX
*                            ERREURS D'ARRONDIS).
*     COMBIN  SUBROUT.  (E)  SOUS-PROGRAMME DE COMBINAISON LINEAIRE DE
*                            2 'CHPOINTS'. 5 ARGUMENTS:
*                            - 'CHPOINT' N.1 ,
*                            - REEL D.P. N.1 ,
*                            - 'CHPOINT' N.2 ,
*                            - REEL D.P. N.2 ,
*                            - 'CHPOINT' COMBINAISON LINEAIRE.
*     IPX     ENTIER    (S)  POINTEUR DU CHPOINT "R-ORTHOGONAL" A LA
*                            SUITE DE CHPOINTS.
*
* 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").
*
* REMARQUES:
* ----------
*
*     PRECISION: LA PRECISION DEMANDEE N'EST PAS PRISE TELLE QUELLE.
*     ELLE EST MODULEE EN FONCTION DE LA TAILLE DU PROBLEME. EN EFFET,
*     ON NE PEUT PAS DEMANDER AUTANT DE PRECISION POUR UN PROBLEME DE
*     GRANDE TAILLE, POUR LEQUEL IL Y A D'AVANTAGE D'ERREURS DE
*     TRONCATURE.
*
*     CE SOUS-PROGRAMME A ETE CREE PAR ANALOGIE AVEC "ORTHO2" ET NE
*     POURRA ETRE TESTE QUE LORSQUE L'OPERATEUR "YTX" EXISTERA.
*
* SOUS-PROGRAMMES APPELES:
* ------------------------
*
*     DIMEN3, DTCHPO, ERREUR, EXTRA1, EXTRA4, MAXIM3, NORME2, YTX1.
*
* AUTEUR, DATE DE CREATION:
* -------------------------
*
*     PASCAL MANIGOT     05 AVRIL 1985
*
*     LE 26 AOUT 1985 (P. MANIGOT): PRECISION MODULEE EN FONCTION DE LA
*     TAILLE DU PROBLEME.
*
* LANGAGE:
* --------
*
*     FORTRAN77
*
************************************************************************
*
 
-INC PPARAM
-INC CCOPTIO
-INC SMLMOTS
*
*
      LOGICAL ORTHO
*
      PARAMETER (UN = 1.D0)
      PARAMETER (RLIM=0.1)
      EXTERNAL COMBIN
*
*     TAILLE DU PROBLEME:
      CALL DIMEN3 (IPRIGI,  NBRINC)
      IF (IERR .NE. 0) RETURN
      PREMOD = PRECIS * (DBLE(NBRINC)**2)
*
      CALL MAXIM3 (IPLIS2,  IPLACE,UTRUMX)
      IF (IERR .NE. 0) RETURN
      UTRUMX = ABS(UTRUMX)
*
*     ON DONNE AU 'CHPOINT' A ORTHOGONALISER LE MEME ORDRE DE GRANDEUR
*     QUE CELUI DES 'CHPOINTS' DU 'LISTCHPO':
       IPLMOX=0
       IPLMOY=0
      CALL NORME2 (IPX0,UTRUMX,IPRIGI,  IPX,XTRX,IPLMOX,
     C IPLMOY,IPRX)
      IF (IERR .NE. 0) RETURN
      XTRX1 = XTRX
*
      DO 100 IB100=1,NFOIS
*
         DO 110 IB110=1,LLIST
*
*           -- ORTHOGONALISATION --
*
            CALL EXTRA4 (IPLIS1,IB110,  IPU)
            IF (IERR .NE. 0) RETURN
            CALL EXTRA1 (IPLIS2,IB110,  UTRU)
            IF (IERR .NE. 0) RETURN
            CALL EXTRA4 (IPLIS3,IB110, IPRU)
            IF (IERR .NE. 0) RETURN
            IF(IB100.EQ.1) CALL CORRSP(iprigi,IPX,IPRU,IPLMOX,IPLMOY)
            CALL XTY1 (IPX,IPRU,IPLMOX,IPLMOY,  XTRU)
            IF (IERR .NE. 0) RETURN
            XXTRU = -1.D0 * XTRU / UTRU
*
*
*
*
111         CALL COMBIN (IPX,UN,IPU,XXTRU,  IPXX)
            IF (IERR .NE. 0) RETURN
            CALL DTCHPO (IPX)
            IPX=IPXX
*
*
       XTRX1=XTRX1-((XTRU*XTRU)/UTRU)
  110       CONTINUE
       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 NORME APRES ORTHOGONALISATION PAR ',
     C ' RAPPORT A LA NORME INITIALE ',E12.5)
1001   CONTINUE
      COEFF=SQRT(1.0E0/RNM)
      CALL MUCHPO(IPXX,COEFF,IPX,1)
      CALL DTCHPO(IPXX)
 
 
*        END DO
*
         ORTHO = .TRUE.
*
         GOTO 100
*
C 112      IF (PRECIS .NE. 0.D0) THEN
*
*           -- TEST D'ORTHOGONALITE --SUPPRIME FEVR.88
*
C           DO 120 IB120=1,LLIST
*
C              CALL EXTRA4 (IPLIS3,IB120, IPRU)
C              IF (IERR .NE. 0) RETURN
C              CALL XTY1 (IPX,IPRU,IPLMOX,IPLMOY,  XTRU)
C              IF (IERR .NE. 0) RETURN
C              IF (ABS(XTRU) .GT. PREMOD*UTRUMX) THEN
C                 ORTHO = .FALSE.
C                 --> SORTIE DE BOUCLE N.120
C                 GOTO 122
C              END IF
C
C 120          CONTINUE
C           END DO
C 122       CONTINUE
*
C           IF (ORTHO) THEN
*              --> SORTIE DE BOUCLE N.100
C              GOTO 102
C           END IF
C
C        END IF
*
  100    CONTINUE
*     END DO
  102 CONTINUE
      MLMOTS =IPLMOX
      MLMOT1 =IPLMOY
      SEGSUP MLMOTS,MLMOT1
*
      IF (.NOT.ORTHO) THEN
         INTERR(1) = NFOIS
         REAERR(1) = PREMOD
         NUMERR = 218
         CALL ERREUR (NUMERR)
      END IF
       RETURN
      END