Télécharger la plaquette Cast3M


fr en

Télécharger corrsp.eso

Retour à la liste

Numérotation des lignes : 

corrsp

  1. C CORRSP    SOURCE    CB215821  20/11/25    13:22:36     10792          
  2.       SUBROUTINE CORRSP(ipr,IPVEC,IPMX,IPLMOX,IPLMOY)
  3. C
  4. C**********************************************************************
  5. C
  6. C     CE SP APPELE PAR ITINV, SIMUL1 ... PREPARE L OBJET 'LISTMOTS'
  7. C     NECESSAIRE A L OPERATEUR XTY : COUPLE DES NOMS D INCONNUES A
  8. c     ASSOCIER
  9. C
  10. C     IPR    : pointeur sur l'objet RIGIDITE qui définit la dualité
  11. C     IPVEC  : OBJET DE TYPE CHPOINT
  12. C     IPMX   : OBJET DE TYPE CHPOINT
  13. C     IPLMOX : POINTEUR SUR OBJET LISTMOTS UX,UY....
  14. C     IPLMOY : POINTEUR SUR OBJET LISTMOTS FX,FY....
  15. C
  16. C     AUTEUR : D.BROCHARD
  17. C     DATE   : 11/01/88
  18. C
  19. C   BP , novembre 2010 : on supprime l hypothese selon laquelle :
  20. c   " la matrice possede des correspondances sur les inconnues
  21. c   (c'est a dire que la ieme ligne est la duale de la ieme colonne) "
  22. C   => On utilise NOMDD et NOMDU de CCHAMP pour créer l'association
  23. C   "naturelle" entre les inconnues primales et duales (permet dutiliser
  24. C   de matrices creuses commes celles crees par imped par ex.)
  25. C
  26. C*********************************************************************
  27. C
  28. C
  29.       IMPLICIT INTEGER(I-N)
  30.       IMPLICIT  REAL*8(A-H,O-Z)
  31.  
  32. -INC PPARAM
  33. -INC CCOPTIO
  34. -INC CCHAMP
  35.  
  36. -INC SMLMOTS
  37.       pointeur lmopri.mlmots, lmodua.mlmots
  38.  
  39. -INC SMCHPOI
  40. -INC SMRIGID
  41.  
  42.       CHARACTER*(LOCOMP) NOCO
  43. C
  44.       iplmox=0
  45.       iplmoy=0
  46. C
  47. C==== CREATION DE lmopri lmodua QUI DEFINIT LA REGLE D'ASSOCIATION ====
  48. C
  49. C     CREATION BASEE SUR NOMDD et NOMDU de CCHAMP rempli dans bdata.eso
  50. C
  51.       jgn=LOCOMP
  52.       jgm=LNOMDD
  53.       segini,lmopri
  54.       segini,lmodua
  55.       do i=1,jgm
  56.         lmopri.mots(i)=NOMDD(i)
  57.         lmodua.mots(i)=NOMDU(i)
  58.       enddo
  59. c C
  60. c C     CREATION BASEE SUR LA MATRICE FOURNIE (ancienne syntaxe)
  61. c C
  62.        mrigid=ipr
  63.        segact,mrigid
  64.        nbriel=irigel(/2)
  65.        if (irigel(/1).lt.3) then
  66.           write(*,*) 'CORRSP: Information insuffisante dans la RIGIDITE'
  67.           segdes,mrigid
  68.           return
  69.        endif
  70.        itaill=0
  71.        do 1 i=1,nbriel
  72.           descr=irigel(3,i)
  73.           segact,descr
  74.           nbcpri=lisinc(/2)
  75.           nbcdua=lisdua(/2)
  76.           if(nbcpri.ne.nbcdua) then
  77. *            write(*,*) 'CORRSP: Zone',i,' de la RIGIDITE contient des',
  78. *     &                 ' matrices non carrées !!!'
  79.              segdes,descr
  80.              goto 1
  81.           endif
  82.           do 2 ic=1,nbcpri
  83.              if (lisinc(ic).eq.lisdua(ic)) goto 2
  84.              do 6 ij=1,jgm
  85.               if (lmopri.mots(ij).ne.lisinc(ic)) goto 6
  86.               if (lmodua.mots(ij).eq.lisdua(ic)) goto 2
  87.               moterr(1:4) = lmopri.mots(ij)
  88.               moterr(5:8) = lmodua.mots(ij)
  89.               moterr(9:12)= lisdua(ic)
  90.               call erreur(1026)
  91.    6      continue
  92.              if (jgm.eq.0) then
  93.                 jgm=1
  94.                 segadj,lmopri
  95.                 segadj,lmodua
  96.                 lmopri.mots(1)=lisinc(ic)
  97.                 lmodua.mots(1)=lisdua(ic)
  98.              else
  99.                 do 3 ica=1,jgm
  100.                    if(lmopri.mots(ica).eq.lisinc(ic)) goto 2
  101.    3            continue
  102.                 jgm=jgm+1
  103.                 segadj,lmopri
  104.                 segadj,lmodua
  105.                 lmopri.mots(jgm)=lisinc(ic)
  106.                 lmodua.mots(jgm)=lisdua(ic)
  107.              endif
  108.    2      continue
  109.           segdes,descr
  110.    1   continue
  111.        segdes,mrigid
  112. c
  113.       itaill=jgm
  114.  
  115.       if (iimpi.eq.321) then
  116.          do 4 i=1,itaill
  117.             write(*,*) lmopri.mots(i),' <=> ',lmodua.mots(i)
  118.   4      continue
  119.       endif
  120. C
  121. C
  122. C==== CREATION et REMPLISSAGE DE MLMOTS MLMOT2 (= RESULTATS)  ====
  123. C
  124.       JGN=LOCOMP
  125.       JGM=0
  126.       SEGINI MLMOTS,MLMOT2
  127. C
  128. C     ON UTILISE LE CHPOINT PRIMAL
  129.       INU=0
  130.       MCHPO1=IPVEC
  131.       SEGACT MCHPO1
  132.       NSOUP1=MCHPO1.IPCHP(/1)
  133. C
  134.       DO 10 ISOUP1 = 1,NSOUP1
  135.          MSOUP1 = MCHPO1.IPCHP(ISOUP1)
  136.          SEGACT MSOUP1
  137.          NC1 = MSOUP1.NOCOMP(/2)
  138.          DO 20 NCI = 1,NC1
  139. C
  140.             IF(IIMPI.EQ.321) WRITE(IOIMP,*) NCI,MSOUP1.NOCOMP(NCI)
  141. C
  142.             IF(INU.NE.0) GOTO 30
  143.             NOCO = MSOUP1.NOCOMP(1)
  144.             CALL PLACE(lmopri.mots(1),itaill,IPLA,NOCO)
  145.             if(ipla.eq.0) goto 20
  146.             JGM=JGM+1
  147.             SEGADJ MLMOTS
  148.             SEGADJ MLMOT2
  149.             MOTS(JGM) = NOCO
  150.             MLMOT2.MOTS(JGM) = lmodua.mots(IPLA)
  151.             INU = INU+1
  152.             GOTO 20
  153. C
  154. 30          CONTINUE
  155.             NOCO = MSOUP1.NOCOMP(NCI)
  156.             DO 40 I =1,INU
  157.                IF(NOCO.EQ.MOTS(I)) GOTO 20
  158. 40          CONTINUE
  159.             CALL PLACE(lmopri.mots(1),itaill,IPLA,NOCO)
  160.             if (ipla.eq.0) goto 20
  161.             INU =INU+1
  162.             JGM=JGM+1
  163.             SEGADJ MLMOTS
  164.             SEGADJ MLMOT2
  165.             MOTS(JGM) = NOCO
  166.             MLMOT2.MOTS(JGM)= lmodua.mots(IPLA)
  167. 20       CONTINUE
  168.          SEGDES MSOUP1
  169. 10    CONTINUE
  170.       SEGDES MCHPO1
  171. C
  172.       IPLMOX=MLMOTS
  173.       IPLMOY=MLMOT2
  174. C
  175. C
  176. C==== VERIFICATION :
  177. C     LES VARIABLES SONT ELLES BIEN DANS LE CHPOINT DUAL
  178. c
  179. c     rem : il s agit seulement d un message informatif
  180. c           pas d une erreur car on peut avoir u={UX RX LX}
  181. c           et M*u={FX } seulement !
  182. c           ca ne derange pas xty1 a priori...
  183. c       IF(IIMPI.lt.5) GOTO 999
  184. c
  185. c     on peut faire mieux en enlevant les couples "veufs"
  186.  
  187. C==== CREATION et REMPLISSAGE DE MLMOT1 ====
  188.       JGM=0
  189.       SEGINI MLMOT1
  190.       IMU=0
  191.       MCHPOI=IPMX
  192.       SEGACT MCHPOI
  193.       NSOUPO=IPCHP(/1)
  194.       DO 100 ISOUPO=1,NSOUPO
  195. C
  196.          MSOUPO=IPCHP(ISOUPO)
  197.          SEGACT MSOUPO
  198.          NC1 = NOCOMP(/2)
  199.          DO 120 NCI = 1,NC1
  200. C
  201.             IF(IIMPI.EQ.321) WRITE(IOIMP,*) NCI,NOCOMP(NCI)
  202. C
  203.             IF (IMU.NE.0) GOTO 130
  204.             NOCO = NOCOMP(1)
  205.             JGM=JGM+1
  206.             SEGADJ MLMOT1
  207.             MLMOT1.MOTS(JGM)= NOCO
  208.             IMU = IMU+1
  209.             GOTO 120
  210. C
  211. 130         CONTINUE
  212.             NOCO = NOCOMP(NCI)
  213.             DO 140 I =1,IMU
  214.                IF (NOCO.EQ.MLMOT1.MOTS(I)) GOTO 120
  215. 140         CONTINUE
  216.             IMU =IMU+1
  217.             JGM=JGM+1
  218.             SEGADJ MLMOT1
  219.             MLMOT1.MOTS(JGM) = NOCO
  220. 120      CONTINUE
  221.          SEGDES MSOUPO
  222. 100   CONTINUE
  223.       SEGDES MCHPOI
  224. C
  225. C==== COMPARAISON DE MLMOT1 et MLMOT2 ====
  226. c
  227.       JGM1 = MLMOT1.MOTS(/2)
  228.       JGM2 = MLMOT2.MOTS(/2)
  229.       JGM=0
  230.       DO 200 I2=1,JGM2
  231.          DO 210 I1=1,JGM1
  232.             IF (MLMOT2.MOTS(I2).EQ.MLMOT1.MOTS(I1)) GOTO 199
  233. 210      CONTINUE
  234. c        on n a pas retrouvé cette composante
  235.           IF(IIMPI.GE.5)
  236.      &    WRITE(*,1000) (MLMOTS.MOTS(I2)),(MLMOT2.MOTS(I2))
  237. 1000      FORMAT(/4X,'LA COMPOSANTE ',A4,' DUALE DE ',A4,
  238.      &    ' N EST PAS CONTENUE DANS LE SECOND CHPOINT')
  239.           goto 200
  240. 199      CONTINUE
  241. c        on a retrouvé cette composante duale
  242.           JGM=JGM+1
  243.           MLMOTS.MOTS(JGM)=MLMOTS.MOTS(I2)
  244.           MLMOT2.MOTS(JGM)=MLMOT2.MOTS(I2)
  245. 200   CONTINUE
  246.       if(JGM.ne.JGM2) segadj,MLMOTS,MLMOT2
  247.       SEGSUP,MLMOT1
  248. C
  249. C==== MENAGE, MESSAGES et RETOUR ====
  250. c
  251. 999   CONTINUE
  252.       SEGDES MLMOTS,MLMOT2
  253.       segsup lmopri,lmodua
  254. C
  255.       IF (IIMPI.eq.321) then
  256.          WRITE(IOIMP,5000)
  257. 5000     FORMAT(/10X,'SBR CORRSP',//)
  258.          CALL ECLMOT(IPLMOX)
  259.          CALL ECLMOT(IPLMOY)
  260.          CALL ECCHPO(IPVEC,0)
  261.          CALL ECCHPO(IPMX,0)
  262.       endif
  263. C
  264.       RETURN
  265.       END
  266.  
  267.  

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