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  26/08/24    21:15:39     12622          
  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.       ICPR(I)=0
  51.    10 CONTINUE
  52. C
  53. C *** BOUCLE SUR LES SOUPO DE MCHPOI
  54. C *** DANS ICPR(I) ON MET LE NUMERO DU SOUPO OU SE TROUVE LE POINT I
  55. C *** ICPRR(I)=K SIGNIFIE QUE I EST LE KIEME POINT DU SOUPO
  56. C
  57.       DO 2 I=1,NSOUP
  58.       MSOUPO=IPCHP(I)
  59.       SEGACT MSOUPO
  60.       MELEME=IGEOC
  61.       SEGACT MELEME
  62.       NPOIN=NUM(/2)
  63.       ITRAV(1,I)=NPOIN
  64.       DO 3 IPP=1,NPOIN
  65.       J=NUM(1,IPP)
  66.       ICPR(J)=I
  67.       ICPRR(J)=IPP
  68.  3    CONTINUE
  69.       SEGDES MELEME,MSOUPO
  70.  2    CONTINUE
  71. C
  72.  
  73.       ICHPOI=MCHPOI
  74.       CALL NUHARM(ICHPOI,IFO,IHAR)
  75.       MCHPOI=ICHPOI
  76. C   IFO=1 TOUTES LES HARMONIQUES SONT IDENTIQUES ...
  77. C   ON PEUT METTRE ENSEMBLE DU MODE N ET DU MODE M
  78. C
  79. C***  BOUCLE SUR LES MSOUP1 DE MCHPO1
  80. C
  81.       DO 4 I=1,NSOUP
  82.       MSOUP1=MCHPO1.IPCHP(I)
  83.       SEGACT MSOUP1
  84.       MELEME=MSOUP1.IGEOC
  85.       SEGACT MELEME
  86.       NPOIN=NUM(/2)
  87.       IP1=NUM(1,1)
  88.       ISOUPO=ICPR(IP1)
  89.       IF(ICPRR(IP1).NE.1) ITRAV(3,ISOUPO)=1
  90.       IF(ISOUPO.NE.0)    GO TO 5
  91. C     POINT NON COMMUN AUX 2 CHPOINT
  92.       CALL ERREUR(60)
  93.       GO TO 5000
  94. C
  95.  5    CONTINUE
  96.       IF(NPOIN.EQ.ITRAV(1,ISOUPO)) GO TO 6
  97. C     LES 2 SOUPO N ONT PAS LE MEME NOMBRE DE POINTS
  98.       CALL ERREUR(60)
  99.       GO TO 5000
  100. C
  101.  6    CONTINUE
  102.       ITRAV(2,ISOUPO)=I
  103.       IF(NPOIN.EQ.1) GO TO 9
  104.       DO 8 IPP=2,NPOIN
  105.       IP1=NUM(1,IPP)
  106.       IF(ICPRR(IP1).NE.IPP) ITRAV(3,ISOUPO)=1
  107.       IF(ICPR(IP1).EQ.ISOUPO)GO TO 8
  108. C     POINT NON COMMUN AUX 2 MSOUPO
  109.       CALL ERREUR(60)
  110.       GO TO 5000
  111.  8    CONTINUE
  112.  9    CONTINUE
  113.       MSOUPO=IPCHP(ISOUPO)
  114.       SEGACT MSOUPO
  115.       NC=NOCOMP(/2)
  116.       IF(MSOUP1.NOCOMP(/2).EQ.NC) GO TO 12
  117.       CALL ERREUR(60)
  118. C     PAS LE MEME NOMBRE DE COMPOSANTE
  119.       GO TO 5000
  120.  12   CONTINUE
  121.       SEGINI ITRACO
  122.       DO 13 IC=1,NC
  123.       ICOMP=MSOUP1.NOCOMP(IC)
  124.       IHARM=MSOUP1.NOHARM(IC)
  125.       DO 14 ICC=1,NC
  126.       IF(NOCOMP(ICC).NE.ICOMP) GO TO 14
  127.       IF(IFO.NE.1.AND.NOHARM(ICC).NE.IHARM) GO TO 14
  128.       IF(IC.NE.ICC)ITRAV(3,ISOUPO)=1
  129.       ITRACO(IC)=ICC
  130.       GO TO 13
  131.  14   CONTINUE
  132.       CALL ERREUR(60)
  133. C     N ONT PAS LES MEMES COMPOSANTES
  134.       GO TO 5000
  135.  13   CONTINUE
  136.       ITRAV(4,ISOUPO)=ITRACO
  137.       SEGDES ITRACO
  138. C
  139.       SEGDES MSOUPO,MELEME,MSOUP1
  140.  4    CONTINUE
  141.       SEGDES MCHPO1
  142. C
  143. C
  144.       DO 30 I=1,NSOUP
  145.       IF(ITRAV(3,I).NE.0) GO TO 41
  146.  30   CONTINUE
  147. C     IL N Y A AUCUNE MODIF A FAIRE SUR LES MPOVAL
  148. C
  149.       DO 31 I=1,NSOUP
  150.       IF(ITRAV(2,I).EQ.I) GO TO 31
  151.       GO TO 41
  152.  31   CONTINUE
  153. C     IL N Y A AUCUNE MODIF A FAIRE ON SORT
  154.       ITAF=ITAI
  155.       GO TO 60
  156. C
  157.  41   CONTINUE
  158. C *** SI IVAL=0  IL FAUT SEULEMENT PERMUTER LES MSOUP1
  159. C *** SI IVAL=1 ON DOIT REMPLACER LES MSOUP1 PAR DES MSOUP2
  160. C
  161.       MSOLE1=ITAI
  162.       SEGACT MSOLE1
  163.       LTAB=MSOLE1.ISOLEN(/1)
  164.       N=LTAB
  165.       SEGINI MSOLEN
  166.       DO 42 IT=1,LTAB
  167.       ISOLEN(IT)=MSOLE1.ISOLEN(IT)
  168.  42   CONTINUE
  169.       SEGDES MSOLE1
  170. C
  171.       DO 50 IT=1,LTAB
  172.       MCHPO1=ISOLEN(IT)
  173.       SEGACT MCHPO1
  174.       NSOUPO=NSOUP
  175.       NAT=MCHPO1.JATTRI(/1)
  176.       SEGINI MCHPO2
  177.       MCHPO2.IFOPOI=IFOPOI
  178. *  on reprend les meme attributs
  179.       DO 101 INAT=1,NAT
  180.           MCHPO2.JATTRI(INAT) = MCHPO1.JATTRI(INAT)
  181.  101  CONTINUE
  182. *
  183.       DO 52 IS=1,NSOUPO
  184.       MSOUP1=MCHPO1.IPCHP(ITRAV(2,IS))
  185.       IF(ITRAV(3,IS).NE.0) GO TO 53
  186.       MCHPO2.IPCHP(IS)=MSOUP1
  187.       GO TO 52
  188.  53   CONTINUE
  189.       MSOUPO=IPCHP(IS)
  190.       SEGACT MSOUPO,MSOUP1
  191.       NC=MSOUP1.NOCOMP(/2)
  192.       SEGINI MSOUP2
  193.       MSOUP2.IGEOC=IGEOC
  194.       DO 54 IC=1,NC
  195.       MSOUP2.NOCOMP(IC)=NOCOMP(IC)
  196.       MSOUP2.NOHARM(IC)=NOHARM(IC)
  197.       IF(IFO.EQ.1) MSOUP2.NOHARM(IC)=MSOUP1.NOHARM(IC)
  198.  54   CONTINUE
  199.       MELEME=MSOUP1.IGEOC
  200.       SEGACT MELEME
  201.       MPOVA1=MSOUP1.IPOVAL
  202.       SEGACT MPOVA1
  203.       N=MPOVA1.VPOCHA(/1)
  204.       NC=MPOVA1.VPOCHA(/2)
  205.       SEGINI MPOVAL
  206.       ITRACO=ITRAV(4,IS)
  207.       SEGACT ITRACO
  208.       DO 5001 IN=1,N
  209.       DO 20 IC=1,NC
  210.       IP1=ICPRR(NUM(1,IN))
  211.       VPOCHA(IP1,ITRACO(IC))=MPOVA1.VPOCHA(IN,IC)
  212.  20   CONTINUE
  213.  5001 CONTINUE
  214.       SEGDES ITRACO
  215.       SEGDES MPOVA1,MPOVAL,MELEME
  216.       MSOUP2.IPOVAL=MPOVAL
  217.       SEGDES MSOUP2,MSOUP1,MSOUPO
  218.       MCHPO2.IPCHP(IS)=MSOUP2
  219.  52   CONTINUE
  220.       SEGDES MCHPO2,MCHPO1
  221.       ISOLEN(IT)=MCHPO2
  222.  50   CONTINUE
  223.       SEGDES MSOLEN
  224.       ITAF=MSOLEN
  225. C
  226.  60   CONTINUE
  227.       DO 58 I=1,NSOUP
  228.       ITRACO=ITRAV(4,I)
  229.       SEGSUP ITRACO
  230.  58   CONTINUE
  231.       SEGSUP ITRAV
  232.       SEGSUP ICPR,ICPRR
  233.       SEGDES MCHPOI
  234.  5000 CONTINUE
  235.       RETURN
  236.       END
  237.  
  238.  
  239.  

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