Télécharger ortho1.eso

Retour à la liste

Numérotation des lignes :

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

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