Télécharger ortho2.eso

Retour à la liste

Numérotation des lignes :

  1. C ORTHO2 SOURCE CHAT 05/01/13 02:06:35 5004
  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. -INC CCOPTIO
  96. *
  97. *
  98. LOGICAL ORTHO
  99. *
  100. PARAMETER (UN = 1.D0)
  101. PARAMETER (RLIM=0.1)
  102. EXTERNAL COMBIN
  103. *
  104. IPLMOX=0
  105. IPLMOY=0
  106. * TAILLE DU PROBLEME:
  107. CALL DIMEN3 (IPRIGI, NBRINC)
  108. IF (IERR .NE. 0) RETURN
  109. PREMOD = PRECIS * (DBLE(NBRINC)**2)
  110. *
  111. CALL MAXIM3 (IPLIS2, IPLACE,UTRUMX)
  112. IF (IERR .NE. 0) RETURN
  113. UTRUMX = ABS(UTRUMX)
  114. *
  115. * ON DONNE AU 'CHPOINT' A ORTHOGONALISER LE MEME ORDRE DE GRANDEUR
  116. * QUE CELUI DES 'CHPOINTS' DU 'LISTCHPO':
  117. CALL NORME2 (IPX0,UTRUMX,IPRIGI, IPX,XTRX,IPLMOX,
  118. C IPLMOY,IPRX)
  119. IF (IERR .NE. 0) RETURN
  120. XTRX1=XTRX
  121. *
  122. DO 100 IB100=1,NFOIS
  123. *
  124. DO 110 IB110=1,LLIST
  125. *
  126. * -- ORTHOGONALISATION --
  127. *
  128. CALL EXTRA4 (IPLIS1,IB110, IPU)
  129. IF (IERR .NE. 0) RETURN
  130. CALL EXTRA1 (IPLIS2,IB110, UTRU)
  131. IF (IERR .NE. 0) RETURN
  132. CALL YTMX (IPX,IPU,IPRIGI, XTRU)
  133. IF (IERR .NE. 0) RETURN
  134. XXTRU = -1.D0 * XTRU / UTRU
  135. CALL COMBIN (IPX,UN,IPU,XXTRU, IPXX)
  136. IF (IERR .NE. 0) RETURN
  137. CALL DTCHPO (IPX)
  138. *
  139. C CALL NORME2 (IPXX,UTRUMX,IPRIGI, IPX,XTRX,
  140. C C IPLMOX,IPLMOY,IPRX)
  141. C IF (IERR .NE. 0) RETURN
  142. C CALL DTCHPO (IPXX)
  143. IPX=IPXX
  144. XTRX1=XTRX1-((XTRU*XTRU)/UTRU)
  145. *
  146. 110 CONTINUE
  147. RNM=ABS(XTRX1/XTRX)
  148. IF(RNM.GE.RLIM) GOTO 1001
  149. NV=LLIST+1
  150. WRITE(IOIMP,1000) NV,RNM
  151. 1000 FORMAT(/40X,'OPERATEUR VIBRA OPTION SIMULTANE',/10X,
  152. C ' DIFFICULTE D ORTHOGONALISER LE ',I5,
  153. C ' IEME VECTEUR NORME APRES ORTHOGONALISATION PAR ',
  154. C ' RAPPORT A LA NORME INITIALE ',E12.5)
  155. 1001 CONTINUE
  156. COEFF=SQRT(1.0E0/RNM)
  157. CALL MUCHPO(IPXX,COEFF,IPX,1)
  158. CALL DTCHPO(IPXX)
  159. XNOR=XTRX1*ABS(XTRX/XTRX1)
  160. * END DO
  161. *
  162. ORTHO = .TRUE.
  163. *
  164. IF (PRECIS .NE. 0.D0) THEN
  165. *
  166. * -- TEST D'ORTHOGONALITE --
  167. *
  168. DO 120 IB120=1,LLIST
  169. *
  170. CALL EXTRA4 (IPLIS1,IB120, IPU)
  171. IF (IERR .NE. 0) RETURN
  172. CALL YTMX (IPX,IPU,IPRIGI, XTRU)
  173. IF (IERR .NE. 0) RETURN
  174. IF (ABS(XTRU) .GT. PREMOD*UTRUMX) THEN
  175. ORTHO = .FALSE.
  176. * --> SORTIE DE BOUCLE N.120
  177. GOTO 122
  178. END IF
  179. *
  180. 120 CONTINUE
  181. * END DO
  182. 122 CONTINUE
  183. *
  184. IF (ORTHO) THEN
  185. * --> SORTIE DE BOUCLE N.100
  186. GOTO 102
  187. END IF
  188. *
  189. END IF
  190. *
  191. 100 CONTINUE
  192. * END DO
  193. 102 CONTINUE
  194. *
  195. IF (.NOT.ORTHO) THEN
  196. INTERR(1) = NFOIS
  197. REAERR(1) = PREMOD
  198. NUMERR = 218
  199. CALL ERREUR (NUMERR)
  200. END IF
  201. *
  202. END
  203.  
  204.  
  205.  

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