Télécharger la plaquette Cast3M


fr en

Télécharger cochpo.eso

Retour à la liste

Numérotation des lignes : 

cochpo

  1. C COCHPO    SOURCE    CB215821  20/11/25    13:21:39     10792          
  2.       SUBROUTINE COCHPO(I0,I1,ITAI,ITAF)
  3.       IMPLICIT INTEGER(I-N)
  4.       IMPLICIT REAL*8(A-H,O-Z)
  5. C    CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  6. C    C CE SUBROUTINE VERIFIE QUE LES CHPOINTI0 ET I1 SONT BIEN IDENTIQUE
  7. C    C EVENTUELLEMENT IL REMET LA LISTE ITAI SOUS LA FORME CORRESPONDANT
  8. C    C A I0
  9. C    C  ECRIT PAR FARVACQUE
  10. C    C  APPELE PAR :FUSOLU
  11. C    C  APPELLE ERREUR(60)
  12. C    CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  13. C
  14. -INC SMELEME
  15.  
  16. -INC PPARAM
  17. -INC CCOPTIO
  18. -INC SMCHPOI
  19. -INC SMSOLUT
  20. -INC SMCOORD
  21. C
  22.       CHARACTER*(LOCOMP) ICOMP
  23.       SEGMENT ICPR(nbpts)
  24.       SEGMENT ICPRR(nbpts)
  25.       SEGMENT ITRAV(4,NSOUP)
  26.       SEGMENT ITRACO(NC)
  27. C
  28. C ITRAV(1,I)=NPOIN (NBRE DE POINTS DANS LE IEME SOUPO)
  29. C ITRAV(2,I)=J : AU MSOUPO I CORRESPOND LE MSOUP1 J
  30. C ITRAV(3,I)=0 : AUCUN CHANGEMENT A APPLIQUER AU MSOUPO I (SINON =1)
  31. C ITRAV(4,I)=ITRACO : CONTIENT LE POINTEUR DU SEGMENT ITRACO
  32. C CCC ITRACO(J)=K : LA COMPOSANTE A LA POSITION J DANS MCHPO1 EST A LA
  33. C CCC  POSITION K DANS MCHPOI
  34. C CCC MCHPOI SERA LA CONFIGURATION FINALE
  35. C
  36.       MCHPOI=I0
  37.       MCHPO1=I1
  38.       SEGACT MCHPO1,MCHPOI
  39.       NSOUP=MCHPO1.IPCHP(/1)
  40.       IF(NSOUP.EQ.IPCHP(/1)) GO TO 1
  41. C     LES 2 CHPOINTS DOIVENT AVOIR LE MEME NOMBRE DE SOUS CHAMPS
  42.       CALL ERREUR(60)
  43.       GO TO 5000
  44.  1    CONTINUE
  45.       SEGINI ITRAV
  46.       SEGINI ICPR
  47.       SEGINI ICPRR
  48.       ICPR1=nbpts
  49.       DO 10 I=1,ICPR1
  50.  10   ICPR(I)=0
  51. C
  52. C *** BOUCLE SUR LES SOUPO DE MCHPOI
  53. C *** DANS ICPR(I) ON MET LE NUMERO DU SOUPO OU SE TROUVE LE POINT I
  54. C *** ICPRR(I)=K SIGNIFIE QUE I EST LE KIEME POINT DU SOUPO
  55. C
  56.       DO 2 I=1,NSOUP
  57.       MSOUPO=IPCHP(I)
  58.       SEGACT MSOUPO
  59.       MELEME=IGEOC
  60.       SEGACT MELEME
  61.       NPOIN=NUM(/2)
  62.       ITRAV(1,I)=NPOIN
  63.       DO 3 IPP=1,NPOIN
  64.       J=NUM(1,IPP)
  65.       ICPR(J)=I
  66.       ICPRR(J)=IPP
  67.  3    CONTINUE
  68.       SEGDES MELEME,MSOUPO
  69.  2    CONTINUE
  70. C
  71.  
  72.       ICHPOI=MCHPOI
  73.       CALL NUHARM(ICHPOI,IFO,IHAR)
  74.       MCHPOI=ICHPOI
  75. C   IFO=1 TOUTES LES HARMONIQUES SONT IDENTIQUES ...
  76. C   ON PEUT METTRE ENSEMBLE DU MODE N ET DU MODE M
  77. C
  78. C***  BOUCLE SUR LES MSOUP1 DE MCHPO1
  79. C
  80.       DO 4 I=1,NSOUP
  81.       MSOUP1=MCHPO1.IPCHP(I)
  82.       SEGACT MSOUP1
  83.       MELEME=MSOUP1.IGEOC
  84.       SEGACT MELEME
  85.       NPOIN=NUM(/2)
  86.       IP1=NUM(1,1)
  87.       ISOUPO=ICPR(IP1)
  88.       IF(ICPRR(IP1).NE.1) ITRAV(3,ISOUPO)=1
  89.       IF(ISOUPO.NE.0)    GO TO 5
  90. C     POINT NON COMMUN AUX 2 CHPOINT
  91.       CALL ERREUR(60)
  92.       GO TO 5000
  93. C
  94.  5    CONTINUE
  95.       IF(NPOIN.EQ.ITRAV(1,ISOUPO)) GO TO 6
  96. C     LES 2 SOUPO N ONT PAS LE MEME NOMBRE DE POINTS
  97.       CALL ERREUR(60)
  98.       GO TO 5000
  99. C
  100.  6    CONTINUE
  101.       ITRAV(2,ISOUPO)=I
  102.       IF(NPOIN.EQ.1) GO TO 9
  103.       DO 8 IPP=2,NPOIN
  104.       IP1=NUM(1,IPP)
  105.       IF(ICPRR(IP1).NE.IPP) ITRAV(3,ISOUPO)=1
  106.       IF(ICPR(IP1).EQ.ISOUPO)GO TO 8
  107. C     POINT NON COMMUN AUX 2 MSOUPO
  108.       CALL ERREUR(60)
  109.       GO TO 5000
  110.  8    CONTINUE
  111.  9    CONTINUE
  112.       MSOUPO=IPCHP(ISOUPO)
  113.       SEGACT MSOUPO
  114.       NC=NOCOMP(/2)
  115.       IF(MSOUP1.NOCOMP(/2).EQ.NC) GO TO 12
  116.       CALL ERREUR(60)
  117. C     PAS LE MEME NOMBRE DE COMPOSANTE
  118.       GO TO 5000
  119.  12   CONTINUE
  120.       SEGINI ITRACO
  121.       DO 13 IC=1,NC
  122.       ICOMP=MSOUP1.NOCOMP(IC)
  123.       IHARM=MSOUP1.NOHARM(IC)
  124.       DO 14 ICC=1,NC
  125.       IF(NOCOMP(ICC).NE.ICOMP) GO TO 14
  126.       IF(IFO.NE.1.AND.NOHARM(ICC).NE.IHARM) GO TO 14
  127.       IF(IC.NE.ICC)ITRAV(3,ISOUPO)=1
  128.       ITRACO(IC)=ICC
  129.       GO TO 13
  130.  14   CONTINUE
  131.       CALL ERREUR(60)
  132. C     N ONT PAS LES MEMES COMPOSANTES
  133.       GO TO 5000
  134.  13   CONTINUE
  135.       ITRAV(4,ISOUPO)=ITRACO
  136.       SEGDES ITRACO
  137. C
  138.       SEGDES MSOUPO,MELEME,MSOUP1
  139.  4    CONTINUE
  140.       SEGDES MCHPO1
  141. C
  142. C
  143.       DO 30 I=1,NSOUP
  144.       IF(ITRAV(3,I).NE.0) GO TO 41
  145.  30   CONTINUE
  146. C     IL N Y A AUCUNE MODIF A FAIRE SUR LES MPOVAL
  147. C
  148.       DO 31 I=1,NSOUP
  149.       IF(ITRAV(2,I).EQ.I) GO TO 31
  150.       GO TO 41
  151.  31   CONTINUE
  152. C     IL N Y A AUCUNE MODIF A FAIRE ON SORT
  153.       ITAF=ITAI
  154.       GO TO 60
  155. C
  156.  41   CONTINUE
  157. C *** SI IVAL=0  IL FAUT SEULEMENT PERMUTER LES MSOUP1
  158. C *** SI IVAL=1 ON DOIT REMPLACER LES MSOUP1 PAR DES MSOUP2
  159. C
  160.       MSOLE1=ITAI
  161.       SEGACT MSOLE1
  162.       LTAB=MSOLE1.ISOLEN(/1)
  163.       N=LTAB
  164.       SEGINI MSOLEN
  165.       DO 42 IT=1,LTAB
  166.       ISOLEN(IT)=MSOLE1.ISOLEN(IT)
  167.  42   CONTINUE
  168.       SEGDES MSOLE1
  169. C
  170.       DO 50 IT=1,LTAB
  171.       MCHPO1=ISOLEN(IT)
  172.       SEGACT MCHPO1
  173.       NSOUPO=NSOUP
  174.       NAT=MCHPO1.JATTRI(/1)
  175.       SEGINI MCHPO2
  176.       MCHPO2.IFOPOI=IFOPOI
  177. *  on reprend les meme attributs
  178.       DO 101 INAT=1,NAT
  179.           MCHPO2.JATTRI(INAT) = MCHPO1.JATTRI(INAT)
  180.  101  CONTINUE
  181. *
  182.       DO 52 IS=1,NSOUPO
  183.       MSOUP1=MCHPO1.IPCHP(ITRAV(2,IS))
  184.       IF(ITRAV(3,IS).NE.0) GO TO 53
  185.       MCHPO2.IPCHP(IS)=MSOUP1
  186.       GO TO 52
  187.  53   CONTINUE
  188.       MSOUPO=IPCHP(IS)
  189.       SEGACT MSOUPO,MSOUP1
  190.       NC=MSOUP1.NOCOMP(/2)
  191.       SEGINI MSOUP2
  192.       MSOUP2.IGEOC=IGEOC
  193.       DO 54 IC=1,NC
  194.       MSOUP2.NOCOMP(IC)=NOCOMP(IC)
  195.       MSOUP2.NOHARM(IC)=NOHARM(IC)
  196.       IF(IFO.EQ.1) MSOUP2.NOHARM(IC)=MSOUP1.NOHARM(IC)
  197.  54   CONTINUE
  198.       MELEME=MSOUP1.IGEOC
  199.       SEGACT MELEME
  200.       MPOVA1=MSOUP1.IPOVAL
  201.       SEGACT MPOVA1
  202.       N=MPOVA1.VPOCHA(/1)
  203.       NC=MPOVA1.VPOCHA(/2)
  204.       SEGINI MPOVAL
  205.       ITRACO=ITRAV(4,IS)
  206.       SEGACT ITRACO
  207.       DO 20 IN=1,N
  208.       DO 20 IC=1,NC
  209.       IP1=ICPRR(NUM(1,IN))
  210.       VPOCHA(IP1,ITRACO(IC))=MPOVA1.VPOCHA(IN,IC)
  211.  20   CONTINUE
  212.       SEGDES ITRACO
  213.       SEGDES MPOVA1,MPOVAL,MELEME
  214.       MSOUP2.IPOVAL=MPOVAL
  215.       SEGDES MSOUP2,MSOUP1,MSOUPO
  216.       MCHPO2.IPCHP(IS)=MSOUP2
  217.  52   CONTINUE
  218.       SEGDES MCHPO2,MCHPO1
  219.       ISOLEN(IT)=MCHPO2
  220.  50   CONTINUE
  221.       SEGDES MSOLEN
  222.       ITAF=MSOLEN
  223. C
  224.  60   CONTINUE
  225.       DO 58 I=1,NSOUP
  226.       ITRACO=ITRAV(4,I)
  227.       SEGSUP ITRACO
  228.  58   CONTINUE
  229.       SEGSUP ITRAV
  230.       SEGSUP ICPR,ICPRR
  231.       SEGDES MCHPOI
  232.  5000 CONTINUE
  233.       RETURN
  234.       END
  235.  
  236.  

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