Télécharger acheck.eso

Retour à la liste

Numérotation des lignes :

  1. C ACHECK SOURCE BP208322 15/10/21 21:15:01 8690
  2. SUBROUTINE ACHECK (IPRIGI,IPMASS,QUAD,SYM,SHIFT,N,FLAG,
  3. & INVER,PIRE,CHOLE,EPSI)
  4.  
  5.  
  6. ***********************************************************************
  7. *
  8. * A C H E C K
  9. *
  10. * FONCTION:
  11. * ---------
  12. *
  13. * VERIFICATION DE LA POSSIBILITE POUR ARPACK DE RESOUDRE +
  14. * CHOIX DE LA MATRICE QUI DEFINIRA LE PRODUIT SCALAIRE DANS ARPACK
  15. * + EVENTUELLE(S) SIMPLIFICATION(S) (CHOLESKY, PROBLEME SYM)
  16. *
  17. *
  18. * PARAMETRES: (E)=ENTREE (S)=SORTIE
  19. * -----------
  20. *
  21. * IPRIGI ENTIER (E) POINTEUR D'UNE RIGIDITE
  22. *
  23. * IPMASS ENTIER (E) POINTEUR D'UNE MASSE
  24. *
  25. * QUAD LOGIQUE (E) PROBLEME QUADRATIQUE OU NON
  26. *
  27. * SYM LOGIQUE (S) PROBLEME SYMETRIQUE OU NON
  28. *
  29. * SHIFT COMPLEX DP (E) FREQUENCE DE SHIFT
  30. *
  31. * N ENTIER (E) DIMENSION DU PROBLEME
  32. *
  33. * FLAG LOGIQUE (S) PROBLEME SOLVABLE OU NON
  34. *
  35. * INVER LOGIQUE (S) .TRUE. -> PRODUIT SCALAIRE X'KX
  36. * .FALSE. -> PRODUIT SCALAIRE X'MX
  37. *
  38. * CHOLE LOGIQUE (S) CHOLESKY NON ALTERNATIVE POSSIBLE
  39. *
  40. * EPSI REEL DP (E) ZERO DE TOLERANCE
  41. *
  42. *
  43. * SOUS-PROGRAMMES APPELES:
  44. * ------------------------
  45. *
  46. * DIAGN1
  47. *
  48. * AUTEUR, DATE DE CREATION:
  49. * -------------------------
  50. *
  51. * PASCAL BOUDA 29 JUIN 2015
  52. *
  53. * LANGAGE:
  54. * --------
  55. *
  56. * FORTRAN 77 & 90
  57. *
  58. ***********************************************************************
  59.  
  60. IMPLICIT INTEGER(I-N)
  61. IMPLICIT REAL*8 (A-H,O-Z)
  62.  
  63. -INC CCOPTIO
  64. -INC SMRIGID
  65.  
  66. INTEGER IPRIGI
  67. INTEGER IPMASS
  68. INTEGER N
  69. LOGICAL QUAD
  70. LOGICAL SYM
  71. LOGICAL FLAG
  72. LOGICAL INVER
  73. LOGICAL PIRE
  74. LOGICAL CHOLE
  75. COMPLEX*16 SHIFT
  76.  
  77.  
  78. INTEGER IPCHOI
  79. INTEGER INEG
  80. INTEGER NRG,NBR,IANTI
  81. COMPLEX*16 ZERO
  82.  
  83.  
  84. ZERO=CMPLX(0.D0,0.D0)
  85.  
  86. * La decomposition de Cholesky n'est pas codee --> CHOLE toujours false
  87. CHOLE=.FALSE.
  88.  
  89. *** Cas lineaire:
  90. * Si le shift est nul, on peut resoudre tous les problemes (matrice de
  91. * masse ou rig utilisée pour le produit scalaire,
  92. * sinon matrice identité)
  93. * Sinon, par defaut, la matrice utilisee pour le produit scalaire est la
  94. * matrice de masse
  95. * Calcul du nombre de termes diagonaux negatifs:
  96. * -si nul, ok
  97. * -sinon on essaie d'echanger les roles
  98. * (-> K pour le produit scalaire)
  99. * -si nouvel echec,le probleme n'est pas solvable
  100. *
  101. *** Cas quadratique:
  102. * K ou M doit être symetrique semi-definie positive pour le produit
  103. *scalaire.
  104. * Plus precisement, il s'agit de la matrice par blocs
  105. * | M 0 | | K 0 |
  106. * | 0 M | ou | 0 K |
  107. * Il n'y a pas de conditions sur les autres matrices
  108.  
  109. FLAG=.FALSE.
  110. INVER=.FALSE.
  111. PIRE=.FALSE.
  112.  
  113. c --on va tester M--
  114. MRIGID=IPMASS
  115. SEGACT MRIGID
  116. NRG = IRIGEL(/1)
  117. NBR = IRIGEL(/2)
  118.  
  119. IF (NRG .GE. 7) THEN
  120. DO i=1,NBR
  121. IANTI=IRIGEL(7,i)
  122. IF (IANTI .GT. 0) THEN
  123. SEGDES MRIGID
  124. GOTO 101
  125. ENDIF
  126. ENDDO
  127. ENDIF
  128.  
  129. SEGDES MRIGID
  130.  
  131. CALL DIAGN1(IPMASS,INEG)
  132. * M def >0 ou semi-def >0
  133. IF (INEG .EQ. 0) THEN
  134. FLAG=.TRUE.
  135. GOTO 200
  136. ENDIF
  137.  
  138. 101 CONTINUE
  139.  
  140.  
  141. c cas M non-symetrique ou M non semi-def >0
  142.  
  143. c IF (SHIFT .NE. ZERO) THEN
  144.  
  145. c --on va tester K--
  146. MRIGID=IPRIGI
  147. SEGACT MRIGID
  148. NRG = IRIGEL(/1)
  149. NBR = IRIGEL(/2)
  150.  
  151. IF (NRG .GE. 7) THEN
  152. DO i=1,NBR
  153. IANTI=IRIGEL(7,i)
  154. IF (IANTI .GT. 0) THEN
  155. SEGDES MRIGID
  156. GOTO 102
  157. ENDIF
  158. ENDDO
  159. ENDIF
  160.  
  161. SEGDES MRIGID
  162.  
  163. CALL DIAGN1(IPRIGI,INEG)
  164. * K def >0 ou semi-def >0
  165. IF (INEG .EQ. 0) THEN
  166. FLAG=.TRUE.
  167. INVER=.TRUE.
  168. GOTO 200
  169. ENDIF
  170.  
  171. c ENDIF
  172.  
  173. 102 CONTINUE
  174. c --cas M et K non-symetrique ou non semi-def >0 --
  175.  
  176.  
  177. *-- cas 'desespere' : aucune matrice n'est bien conditionnee;
  178. * on ne peut resoudre que pour des problemes lineaires a shift nul --
  179. *
  180. * le probleme (matrice A=M^-1*K) n'est (probablement) pas symetrique
  181.  
  182. IF (.NOT. FLAG) THEN
  183. c on peut resoudre avec un shift nul
  184. IF (.NOT. QUAD) THEN
  185. IF (SHIFT .EQ. ZERO) THEN
  186. SYM=.FALSE.
  187. PIRE=.TRUE.
  188. FLAG=.TRUE.
  189. GOTO 300
  190. ENDIF
  191. ENDIF
  192. ENDIF
  193.  
  194.  
  195. 200 CONTINUE
  196. c --on a M ou K symetrique semi-def>0 --
  197.  
  198.  
  199. * Identification du type de probleme :
  200. * -symetrique -> modes propres reels
  201. * -non symetrique -> modes propres reels ou complexes
  202.  
  203. IF (QUAD) THEN
  204. *Le probleme n'est jamais symetrique
  205. SYM=.FALSE.
  206.  
  207. ELSE
  208. *On regarde la symetrie de la matrice non utilisee pour le ps
  209. SYM=.TRUE.
  210.  
  211. c M utilisee pour le ps : on regarde K
  212. IF (.NOT. INVER) THEN
  213. MRIGID=IPRIGI
  214. SEGACT MRIGID
  215. NRG = IRIGEL(/1)
  216. NBR = IRIGEL(/2)
  217. IF (NRG .GE. 7) THEN
  218. DO i=1,NBR
  219. IANTI=IRIGEL(7,i)
  220. IF (IANTI .GT. 0) THEN
  221. SYM=.FALSE.
  222. ENDIF
  223. ENDDO
  224. ENDIF
  225.  
  226. ELSE
  227. c K utilisee pour le ps : on regarde M
  228. * La matrice M doit etre symetrique si on a inverse les roles
  229. MRIGID=IPMASS
  230. SEGACT MRIGID
  231. NRG = IRIGEL(/1)
  232. NBR = IRIGEL(/2)
  233. IF (NRG .GE. 7) THEN
  234. DO i=1,NBR
  235. IANTI=IRIGEL(7,i)
  236. IF (IANTI .GT. 0) THEN
  237. FLAG=.FALSE.
  238. INVER=.FALSE.
  239. PIRE=.FALSE.
  240. GOTO 102
  241. ENDIF
  242. ENDDO
  243. ENDIF
  244.  
  245. ENDIF
  246.  
  247. SEGDES MRIGID
  248.  
  249. ENDIF
  250.  
  251.  
  252.  
  253. 300 CONTINUE
  254.  
  255. c ERREUR !
  256. IF (.NOT.FLAG) THEN
  257.  
  258. WRITE(IOIMP,*) 'VIBR ne peut pas resoudre ce probleme :'
  259. IF(QUAD) THEN
  260. WRITE(IOIMP,*) 'M n est pas symetrique semi-definie positive !'
  261. ELSE
  262. IF(INVER) THEN
  263. IF(SHIFT .NE. ZERO) THEN
  264. WRITE(IOIMP,*) 'K n est pas symetrique semi-definie positive'
  265. WRITE(IOIMP,*) 'ou M n est pas symetrique !'
  266. ELSE
  267. WRITE(IOIMP,*) 'on ne doit pas passer par la !'
  268. CALL ERREUR(5)
  269. ENDIF
  270. ELSE
  271. WRITE(IOIMP,*) 'on ne doit pas passer par la !'
  272. CALL ERREUR(5)
  273. ENDIF
  274. ENDIF
  275. CALL ERREUR(21)
  276. ENDIF
  277.  
  278.  
  279. END
  280.  
  281.  
  282.  
  283.  
  284.  

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