Télécharger la plaquette Cast3M


fr en

Télécharger ortho2.eso

Retour à la liste

Numérotation des lignes : 

ortho2

  1. C ORTHO2    SOURCE    PV        21/12/18    07:15:10     11240          
  2.       SUBROUTINE ORTHO2 (IPX0,IPLIS1,IPLIS2,LLIST,IPRIGI,PRECIS,NFOIS
  3.      &                 ,COMBIN,IPX)
  4.       IMPLICIT INTEGER(I-N)
  5.       IMPLICIT REAL*8 (A-H,O-Z)
  6. ************************************************************************
  7. *
  8. *                             O R T H O 2
  9. *                             -----------
  10. *
  11. * FONCTION:
  12. * ---------
  13. *
  14. *     R-ORTHOGONALISER UN CHPOINT "X" PAR RAPPORT A UNE SUITE DE
  15. *     CHPOINTS "U(I)", "R" ETANT UNE RIGIDITE DONNEE.
  16. *     CAS DE FIGURE OU L'ON NE CONNAIT PAS LES PRODUITS "R.U(I)".
  17. *
  18. * MODE D'APPEL:
  19. * -------------
  20. *
  21. *     CALL ORTHO2 (IPX0,IPLIS1,IPLIS2,LLIST,IPRIGI,PRECIS,NFOIS
  22. *    &           ,COMBIN,IPX)
  23. *
  24. * PARAMETRES:   (E)=ENTREE   (S)=SORTIE
  25. * -----------
  26. *
  27. *     IPX0    ENTIER    (E)  POINTEUR DU CHPOINT A "R-ORTHOGONALISER".
  28. *     IPLIS1  ENTIER    (E)  POINTEUR DU 'LISTCHPO' CONTENANT LES "U(I)"
  29. *     IPLIS2  ENTIER    (E)  POINTEUR DU 'LISTREEL' CONTENANT LES
  30. *                            PRODUITS "U(I).R.U(I)".
  31. *     LLIST   ENTIER    (E)  NOMBRE DE CHPOINTS "U(I)".
  32. *     IPRIGI  ENTIER    (E)  POINTEUR DE LA 'RIGIDITE' "R".
  33. *     PRECIS  REEL DP   (E)  PRECISION DEMANDEE POUR LA
  34. *                            R-ORTHOGONALISATION.
  35. *                            = 0  SI L'ON NE VEUT PAS DE TEST DE
  36. *                            PRECISION.
  37. *                            ON NE VERIFIE PAS QUE "PRECIS >= 0".
  38. *     NFOIS   ENTIER    (E)  NOMBRE DE FOIS QUE L'ON EFFECTUE LA
  39. *                            "R-ORTHOGONALISATION" (POUR PALIER AUX
  40. *                            ERREURS D'ARRONDIS).
  41. *     COMBIN  SUBROUT.  (E)  SOUS-PROGRAMME DE COMBINAISON LINEAIRE DE
  42. *                            2 'CHPOINTS'. 5 ARGUMENTS:
  43. *                            - 'CHPOINT' N.1 ,
  44. *                            - REEL D.P. N.1 ,
  45. *                            - 'CHPOINT' N.2 ,
  46. *                            - REEL D.P. N.2 ,
  47. *                            - 'CHPOINT' COMBINAISON LINEAIRE.
  48. *     IPX     ENTIER    (S)  POINTEUR DU CHPOINT "R-ORTHOGONAL" A LA
  49. *                            SUITE DE CHPOINTS.
  50. *
  51. * LEXIQUE: (ORDRE ALPHABETIQUE)
  52. * --------
  53. *
  54. *     IPU     ENTIER    POINTEUR D'UN CHPOINT "U(I)".
  55. *     IPXX    ENTIER    POINTEUR DU CHPOINT "X" A UN CERTAIN STADE DE
  56. *                       TRANSFORMATION.
  57. *     ORTHO   LOGIQUE   INDIQUE PAR "VRAI" OU "FAUX" SI LA
  58. *                       "R-ORTHOGONALISATION" A ETE EFFECTUEE AVEC
  59. *                       SUCCES.
  60. *     PREMOD  REEL DP   PRECISION D'ORTHOGONALISATION, MODULEE EN
  61. *                       FONCTION DE LA TAILLE DU PROBLEME.
  62. *     UTRUMX  REEL DP   MAXIMUM DES PRODUITS U(I)T.R.U(I)
  63. *     UTRU    REEL DP   PRODUIT U(I)T.R.U(I)  ("T" POUR "TRANSPOSE").
  64. *     XTRU    REEL DP   PRODUIT XT.R.U(I)  ("T" POUR "TRANSPOSE").
  65. *
  66. * REMARQUES:
  67. * ----------
  68. *
  69. *     PRECISION: LA PRECISION DEMANDEE N'EST PAS PRISE TELLE QUELLE.
  70. *     ELLE EST MODULEE EN FONCTION DE LA TAILLE DU PROBLEME. EN EFFET,
  71. *     ON NE PEUT PAS DEMANDER AUTANT DE PRECISION POUR UN PROBLEME DE
  72. *     GRANDE TAILLE, POUR LEQUEL IL Y A D'AVANTAGE D'ERREURS DE
  73. *     TRONCATURE.
  74. *
  75. * SOUS-PROGRAMMES APPELES:
  76. * ------------------------
  77. *
  78. *     DIMEN3, DTCHPO, ERREUR, EXTRA1, EXTRA4, MAXIM3, NORME2, YTMX.
  79. *
  80. * AUTEUR, DATE DE CREATION:
  81. * -------------------------
  82. *
  83. *     PASCAL MANIGOT     05 AVRIL 1985
  84. *
  85. *     LE 26 AOUT 1985 (P. MANIGOT): PRECISION MODULEE EN FONCTION DE LA
  86. *     TAILLE DU PROBLEME.
  87. *
  88. * LANGAGE:
  89. * --------
  90. *
  91. *     FORTRAN77
  92. *
  93. ************************************************************************
  94. *
  95.  
  96. -INC PPARAM
  97. -INC CCOPTIO
  98. *
  99. *
  100.       LOGICAL ORTHO
  101. *
  102.       PARAMETER (UN = 1.D0)
  103.       PARAMETER (RLIM=0.1)
  104.       EXTERNAL COMBIN
  105. *
  106.       ortho=.false.
  107.       IPLMOX=0
  108.       IPLMOY=0
  109. *     TAILLE DU PROBLEME:
  110.       CALL DIMEN3 (IPRIGI,  NBRINC)
  111.       IF (IERR .NE. 0) RETURN
  112.       PREMOD = PRECIS * (DBLE(NBRINC)**2)
  113. *
  114.       CALL MAXIM3 (IPLIS2,  IPLACE,UTRUMX)
  115.       IF (IERR .NE. 0) RETURN
  116.       UTRUMX = ABS(UTRUMX)
  117. *
  118. *     ON DONNE AU 'CHPOINT' A ORTHOGONALISER LE MEME ORDRE DE GRANDEUR
  119. *     QUE CELUI DES 'CHPOINTS' DU 'LISTCHPO':
  120.       CALL NORME2 (IPX0,UTRUMX,IPRIGI,  IPX,XTRX,IPLMOX,
  121.      C IPLMOY,IPRX)
  122.       IF (IERR .NE. 0) RETURN
  123.       XTRX1=XTRX
  124. *
  125.       DO 100 IB100=1,NFOIS
  126. *
  127.          DO 110 IB110=1,LLIST
  128. *
  129. *           -- ORTHOGONALISATION --
  130. *
  131.             CALL EXTRA4 (IPLIS1,IB110,  IPU)
  132.             IF (IERR .NE. 0) RETURN
  133.             CALL EXTRA1 (IPLIS2,IB110,  UTRU)
  134.             IF (IERR .NE. 0) RETURN
  135.             CALL YTMX (IPX,IPU,IPRIGI,  XTRU)
  136.             IF (IERR .NE. 0) RETURN
  137.             XXTRU = -1.D0 * XTRU / UTRU
  138.             CALL COMBIN (IPX,UN,IPU,XXTRU,  IPXX)
  139.             IF (IERR .NE. 0) RETURN
  140.             CALL DTCHPO (IPX)
  141. *
  142. C           CALL NORME2 (IPXX,UTRUMX,IPRIGI,  IPX,XTRX,
  143. C    C      IPLMOX,IPLMOY,IPRX)
  144. C           IF (IERR .NE. 0) RETURN
  145. C           CALL DTCHPO (IPXX)
  146.             IPX=IPXX
  147.           XTRX1=XTRX1-((XTRU*XTRU)/UTRU)
  148. *
  149.   110       CONTINUE
  150.        RNM=ABS(XTRX1/XTRX)
  151.        IF(RNM.GE.RLIM) GOTO 1001
  152.        NV=LLIST+1
  153.        WRITE(IOIMP,1000) NV,RNM
  154. 1000        FORMAT(/40X,'OPERATEUR VIBRA OPTION SIMULTANE',/10X,
  155.      C ' DIFFICULTE D ORTHOGONALISER  LE ',I5,
  156.      C ' IEME VECTEUR NORME APRES ORTHOGONALISATION PAR ',
  157.      C ' RAPPORT A LA NORME INITIALE ',E12.5)
  158. 1001   CONTINUE
  159.       COEFF=SQRT(1.0E0/RNM)
  160.       CALL MUCHPO(IPXX,COEFF,IPX,1)
  161.       CALL DTCHPO(IPXX)
  162.       XNOR=XTRX1*ABS(XTRX/XTRX1)
  163. *        END DO
  164. *
  165.          ORTHO = .TRUE.
  166. *
  167.          IF (PRECIS .NE. 0.D0) THEN
  168. *
  169. *           -- TEST D'ORTHOGONALITE --
  170. *
  171.             DO 120 IB120=1,LLIST
  172. *
  173.                CALL EXTRA4 (IPLIS1,IB120, IPU)
  174.                IF (IERR .NE. 0) RETURN
  175.                CALL YTMX (IPX,IPU,IPRIGI,  XTRU)
  176.                IF (IERR .NE. 0) RETURN
  177.                IF (ABS(XTRU) .GT. PREMOD*UTRUMX) THEN
  178.                   ORTHO = .FALSE.
  179. *                 --> SORTIE DE BOUCLE N.120
  180.                   GOTO 122
  181.                END IF
  182. *
  183.   120          CONTINUE
  184. *           END DO
  185.   122       CONTINUE
  186. *
  187.             IF (ORTHO) THEN
  188. *              --> SORTIE DE BOUCLE N.100
  189.                GOTO 102
  190.             END IF
  191. *
  192.          END IF
  193. *
  194.   100    CONTINUE
  195. *     END DO
  196.   102 CONTINUE
  197. *
  198.       IF (.NOT.ORTHO) THEN
  199.          INTERR(1) = NFOIS
  200.          REAERR(1) = PREMOD
  201.          NUMERR = 218
  202.          CALL ERREUR (NUMERR)
  203.       END IF
  204. *
  205.       END
  206.  
  207.  
  208.  
  209.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales