Télécharger arpale.eso

Retour à la liste

Numérotation des lignes :

  1. C ARPALE SOURCE PV 15/11/25 21:15:02 8707
  2. SUBROUTINE ARPALE (IPRTRA,IPMAUP,QUAD)
  3.  
  4.  
  5.  
  6. ***********************************************************************
  7. *
  8. * A R P A L E
  9. *
  10. * FONCTION:
  11. * ---------
  12. *
  13. * INITIALISATION DU VECTEUR RESIDUEL D'ARPACK
  14. * (Cinematiquement Admissible a 0)
  15. *
  16. *
  17. * PARAMETRES: (E)=ENTREE (S)=SORTIE
  18. * -----------
  19. *
  20. *
  21. * IPRTRA ENTIER (E) POINTEUR DES OPERATEURS DE TRAVAIL
  22. *
  23. * IPMAUP ENTIER (E/S) POINTEUR DES ELEMENTS ARPACK
  24. *
  25. *
  26. * SOUS-PROGRAMMES APPELES:
  27. * ------------------------
  28. *
  29. * TDRAND,ARCORC,MUCPRI,RESOU1,LDMT,CHV3,ALEAT1
  30. *
  31. * AUTEUR, DATE DE CREATION:
  32. * -------------------------
  33. *
  34. * PASCAL BOUDA 29 JUIN 2015
  35. *
  36. * LANGAGE:
  37. * --------
  38. *
  39. * FORTRAN 77 & 90
  40. *
  41. ************************************************************************
  42.  
  43. IMPLICIT INTEGER(I-N)
  44. IMPLICIT REAL*8 (A-H,O-Z)
  45.  
  46. -INC CCOPTIO
  47. -INC SMCHPOI
  48. -INC SMRIGID
  49. -INC SMVECTD
  50. -INC TARWORK
  51.  
  52. SEGMENT idemen(0)
  53.  
  54. INTEGER IPRTRA
  55. INTEGER IPMAUP
  56. LOGICAL QUAD
  57.  
  58. INTEGER IPRIGI, IPMASS, IPKSIM
  59. REAL*8 VA
  60. INTEGER IPCHO
  61. INTEGER IPCHP1,IPCHP2
  62. INTEGER NOID,NOEN
  63.  
  64. SEGINI IDEMEN
  65. IDEMEN(**)=0
  66. NOID=0
  67. NOEN=1
  68.  
  69.  
  70. MAUP=IPMAUP
  71. SEGACT MAUP*MOD
  72.  
  73.  
  74. ************************************************************************
  75. * CAS QUADRATIQUE
  76. ************************************************************************
  77.  
  78. *pas de conditions particulières pour le vecteur initial
  79. *(pour l'instant ?)
  80.  
  81. IF (QUAD) THEN
  82.  
  83. DO i=1,resid(/1)
  84. CALL TDRAND(VA)
  85. resid(i)=VA
  86. ENDDO
  87.  
  88. GOTO 999
  89.  
  90. ENDIF
  91.  
  92.  
  93. ************************************************************************
  94. * CAS LINEAIRE
  95. ************************************************************************
  96.  
  97. MRITRA=IPRTRA
  98. SEGACT MRITRA
  99.  
  100. MRIGID=RIGI(1)
  101. SEGACT MRIGID
  102. IPCHO=ICHOLE
  103. SEGDES MRIGID
  104.  
  105. ****************************************
  106. *Creation d'un vecteur aleatoire primal*
  107. ****************************************
  108. IPRIGI=RIGI(1)
  109. IPMASS=RIGI(2)
  110. IPKSIM=RIGI(4)
  111. CALL ALEAT1(IPRIGI,IPCHP1)
  112.  
  113. ************************************************************
  114. *Calcul du nombre d'inconnues vraies (ddl's sans relations)*
  115. ************************************************************
  116.  
  117. NDDL = 0
  118. NDLX = 0
  119.  
  120. MCHPOI = IPCHP1
  121.  
  122.  
  123.  
  124. SEGACT MCHPOI
  125. NSOUS = IPCHP(/1)
  126.  
  127. DO ISOUS = 1, NSOUS
  128. MSOUPO = IPCHP(ISOUS)
  129. SEGACT MSOUPO
  130. MPOVAL = IPOVAL
  131. SEGACT MPOVAL
  132. NN = VPOCHA(/1)
  133. NC1 = VPOCHA(/2)
  134. NDDL = NDDL + NN*NC1
  135. DO INC = 1,NC1
  136. IF (NOCOMP(INC) .EQ. 'LX ') NDLX = NDLX + NN
  137. ENDDO
  138. SEGDES MSOUPO, MPOVAL
  139. ENDDO
  140.  
  141. SEGDES MCHPOI
  142.  
  143. NDDL = NDDL - NDLX - (NDLX/2)
  144.  
  145. IF (IIMPI.GE.1) THEN
  146. WRITE(IOIMP,*) NDDL, 'INCONNUES SONT SANS RELATIONS'
  147. ENDIF
  148.  
  149. *Ajustement de la taille des segments si necessaire (modification du
  150. *de la dimension de la base d'Arnoldi
  151.  
  152. IF (v(/2) .GT. NDDL) THEN
  153.  
  154. ndim=resid(/1)
  155. ncv=NDDL
  156. lipntr=ipntr(/1)
  157. lworkl=workl(/1)
  158. lnev=dr(/1)
  159.  
  160. SEGADJ MAUP
  161.  
  162. ENDIF
  163.  
  164. *****************************
  165. *Creation du residu initial *
  166. *****************************
  167.  
  168. MAUP=IPMAUP
  169. SEGACT MAUP*MOD
  170.  
  171. *en fonction du type de probleme, on realise une iteration d'Arnoldi;
  172. *voir documentation de ARPITL.ESO et ARPTIQ.ESO pour plus de details
  173.  
  174.  
  175. IF (iparam(7) .EQ. 3) THEN
  176.  
  177. CALL MUCPRI (IPCHP1,IPMASS,IPCHP2)
  178. *Mise a zero des inconnues en FPI : certainement inutile ?
  179. CALL ARCORC (IPCHP2,15)
  180.  
  181. ELSEIF (iparam(7) .EQ. 4) THEN
  182.  
  183. CALL MUCPRI (IPCHP1,IPRIGI,IPCHP2)
  184. *Mise a sero des inconnues en FLX
  185. CALL ARCORC (IPCHP2,10)
  186. *Mise a zero des inconnues en FPI : certainement inutile ?
  187. CALL ARCORC (IPCHP2,15)
  188.  
  189. ENDIF
  190.  
  191. IDEMEN(1)=IPCHP2
  192.  
  193.  
  194. IF (bmat .EQ. 'G') THEN
  195.  
  196. IF (SYME(4) .EQ. 0) THEN
  197. CALL RESOU1 (IPKSIM,IDEMEN,NOID,NOEN,1.D-18,0)
  198. ELSEIF (SYME(4) .EQ. 1) THEN
  199. CALL LDMT (IPKSIM,IDEMEN,NOID,NOEN,1.D-18)
  200. ENDIF
  201. IF (IERR.NE.0) RETURN
  202.  
  203. ELSEIF (bmat .EQ. 'I') THEN
  204.  
  205. IF (SYME(1) .EQ. 0) THEN
  206. CALL RESOU1 (IPRIGI,IDEMEN,NOID,NOEN,1.D-18,0)
  207. ELSEIF (SYME(1) .EQ. 1) THEN
  208. CALL LDMT (IPRIGI,IDEMEN,NOID,NOEN,1.D-18)
  209. ENDIF
  210. IF (IERR.NE.0) RETURN
  211.  
  212. ENDIF
  213.  
  214.  
  215. IPCHP1=IDEMEN(1)
  216.  
  217.  
  218.  
  219. *transformation en vecteur primal
  220. CALL CHV3 (IPCHO,IPCHP1,IPVEC,1)
  221.  
  222. MVECTD=IPVEC
  223. SEGACT MVECTD
  224. *Stockage du vecteur residu
  225. DO i=1,resid(/1)
  226. resid(i)=VECTBB(i)
  227. ENDDO
  228.  
  229. SEGSUP MVECTD
  230.  
  231.  
  232. SEGDES MRITRA
  233.  
  234.  
  235. 999 CONTINUE
  236.  
  237.  
  238.  
  239. IPMAUP=MAUP
  240. SEGDES MAUP
  241.  
  242.  
  243. END
  244.  
  245.  
  246.  
  247.  
  248.  
  249.  
  250.  
  251.  
  252.  
  253.  
  254.  
  255.  
  256.  
  257.  
  258.  
  259.  

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