Télécharger la plaquette Cast3M


fr en

Télécharger puiscp.eso

Retour à la liste

Numérotation des lignes : 

puiscp

  1. C PUISCP    SOURCE    BP208322  15/05/11    21:15:17     8528
  2.       SUBROUTINE PUISCP(IPEV1,IPEV2,IRET,INV,ICOUL)
  3.       IMPLICIT INTEGER(I-N)
  4.       IMPLICIT REAL*8(A-H,O-Z)
  5. C
  6. C=======================================================================
  7. C   =                                                                  =
  8. C   = APPELE PAR PUIS                                                  =
  9. C   =                                                                  =
  10. C   = CONSTRUCTION D'UN OBJET DE TYPE EVOL CONTENANT LE PRODUIT OU LE  =
  11. C   = RAPPORT TERME A TERME DE DEUX OBJETS EVOLUTION DE SOUS-TYPE      =
  12. C   = COMPLEXE                                                         =
  13. C   =                                                                  =
  14. C   = SYNTAXE : PROD =  EVOLF * EVOLV (COUL)                           =
  15. C   =                                                                  =
  16. C   = ON EXECUTE LE PRODUIT TERME A TERME DES ORDONNEES DES DEUX       =
  17. C   = OBJETS EVOLUTION DE SOUS-TYPE COMPLEXE EVOLF ET EVOLV.           =
  18. C   = LES ABSCISSES DE PROD, L'OBJET AINSI CREE, SONT CELLES           =
  19. C   = DE EVOLF ET EVOLV.                                               =
  20. C   =                                                                  =
  21. C   =                                                                  =
  22. C   = CREATION :  4/12/87                                              =
  23. C   = F.ROULLIER                                                       =
  24. C   =                                                                  =
  25. C=======================================================================
  26. C
  27.  
  28. -INC PPARAM
  29. -INC CCOPTIO
  30. -INC SMEVOLL
  31. -INC SMLREEL
  32.       SEGMENT TEMPP
  33.       IMPLIED DR(NPT),DI(NPT),DM(NPT),DP(NPT)
  34.       IMPLIED AA(NPT),AB(NPT),BA(NPT),BB(NPT),DENOM(NPT)
  35.       ENDSEGMENT
  36. C
  37.       CHARACTER*72 TI
  38.       CHARACTER*4 ITYP1,ITYP2
  39. C
  40. C     LES 2 OBJETS EVOLUTION DOIVENT ETRE DE SOUS-TYPE COMPLEXE
  41. C
  42.       MEVOL1=IPEV1
  43.       MEVOL2=IPEV2
  44.       SEGACT MEVOL1,MEVOL2
  45.       ITYP1=MEVOL1.ITYEVO
  46.       ITYP2=MEVOL1.ITYEVO
  47.       IF (ITYP1.EQ.'COMP') GO TO 198
  48.   197 MOTERR(1:8)='EVOLUTIO'
  49.       CALL ERREUR(302)
  50.       SEGDES MEVOL1,MEVOL2
  51.       RETURN
  52. C
  53. C               BOUCLE SUR LES COURBES
  54. C
  55.   198 NC1=MEVOL1.IEVOLL(/1)
  56.       NC2=MEVOL2.IEVOLL(/1)
  57.       IF(NC1.NE.NC2) THEN
  58.       CALL ERREUR(111)
  59.       RETURN
  60.       ENDIF
  61.       NC=NC1
  62. C
  63. C     CREATION DE L'OBJET PRODUIT DE TYPE EVOLUTION (COMPLEXE)
  64. C
  65.       N=NC1
  66.       SEGINI MEVOLL
  67.       IRET=MEVOLL
  68.       TI(1:72)=TITREE
  69.       IEVTEX=TI
  70.       ITYEVO=MEVOL1.ITYEVO
  71. C
  72.       DO 201 IC=1,NC,2
  73.       KEVOL1=MEVOL1.IEVOLL(IC)
  74.       KEVOL2=MEVOL2.IEVOLL(IC)
  75.       SEGACT KEVOL1,KEVOL2
  76. C
  77. C                 TEST DES SOUS-TYPES
  78. C
  79.       ITYP1=KEVOL1.NUMEVY
  80.       ITYP2=KEVOL2.NUMEVY
  81. C
  82.       MLREE1=KEVOL1.IPROGX
  83.       MLREE2=KEVOL2.IPROGX
  84. C
  85. C                 TEST DES LONGUEURS DES 2 SOUS-OBJETS EVOLUTION
  86. C
  87.       SEGACT MLREE1,MLREE2
  88.       L1=MLREE1.PROG(/1)
  89.       L2=MLREE2.PROG(/1)
  90.       IF(L1.EQ.L2) GO TO 10
  91.       CALL ERREUR(337)
  92.       GOTO 400
  93.    10 CONTINUE
  94. C
  95. C                 LES ABSCISSES DOIVENT ETRE IDENTIQUES
  96. C
  97.       CALL VERIPR(MLREE1.PROG,MLREE2.PROG,L1,IRETOU,1.D-2)
  98.       IF(IRETOU.NE.0) GO TO 11
  99.       CALL ERREUR(394)
  100.       GO TO 400
  101.    11 CONTINUE
  102.       SEGDES MLREE1,MLREE2
  103. C
  104. C                 DEFINITION DES PARAMETRES POUR IC
  105. C
  106.       SEGINI KEVOLL
  107.       IEVOLL(IC)=KEVOLL
  108.       TYPX='LISTREEL'
  109.       TYPY='LISTREEL'
  110. c       KEVTEX=TI
  111.       KEVTEX=KEVOL1.KEVTEX
  112. C
  113.       NOMEVX=KEVOL1.NOMEVX
  114.       NOMEVY=KEVOL1.NOMEVY
  115.       NUMEVX=ICOUL
  116.       NUMEVY=KEVOL1.NUMEVY
  117. C
  118. C                 DEFINITION DE PROGX POUR IC
  119. C
  120.       MLREE1=KEVOL1.IPROGX
  121.       SEGACT MLREE1
  122.       JG=L1
  123.       SEGINI MLREEL
  124.       IPROGX=MLREEL
  125.       DO 20 I=1,L1
  126.       PROG(I)=MLREE1.PROG(I)
  127.    20 CONTINUE
  128.       SEGDES KEVOLL,MLREEL,MLREE1
  129.       SEGDES KEVOL1
  130. C
  131. C                 DEFINITION DES PARAMETRES POUR IC+1
  132. C
  133.       SEGINI KEVOLL
  134.       TYPX='LISTREEL'
  135.       TYPY='LISTREEL'
  136.       IEVOLL(IC+1)=KEVOLL
  137.       KEVOL1=MEVOL1.IEVOLL(IC+1)
  138.       SEGACT KEVOL1
  139.       MLREE1=KEVOL1.IPROGX
  140.       SEGACT MLREE1
  141.       KEVTEX=TI
  142. C
  143.       NOMEVX=KEVOL1.NOMEVX
  144.       NOMEVY=KEVOL1.NOMEVY
  145.       NUMEVX=ICOUL
  146.       NUMEVY=KEVOL1.NUMEVY
  147. C
  148. C                 DEFINITION DE PROGX POUR IC+1
  149. C
  150.       JG=L1
  151.       SEGINI MLREEL
  152.       IPROGX=MLREEL
  153.       DO 21 I=1,L1
  154.       PROG(I)=MLREE1.PROG(I)
  155.    21 CONTINUE
  156.       SEGDES KEVOLL,MLREEL,KEVOL1,KEVOL2
  157. C
  158. C
  159.       NPT=L1
  160. C
  161. C
  162.       IF (ITYP1.EQ.'MODU') GO TO 200
  163. C
  164.       SEGINI TEMPP
  165.       KEVOL1=MEVOL1.IEVOLL(IC)
  166.       SEGACT KEVOL1
  167.       MLREE1=KEVOL1.IPROGY
  168.       SEGACT MLREE1
  169.       DO 100 I=1,L1
  170.       AB(I)=MLREE1.PROG(I)
  171.   100 CONTINUE
  172.       SEGDES KEVOL1,MLREE1
  173. C
  174.       KEVOL1=MEVOL1.IEVOLL(IC+1)
  175.       SEGACT KEVOL1
  176.       MLREE1=KEVOL1.IPROGY
  177.       SEGACT MLREE1
  178.       DO 120 I=1,L1
  179.       BB(I)=MLREE1.PROG(I)
  180.   120 CONTINUE
  181.       SEGDES KEVOL1,MLREE1
  182. C
  183.       KEVOL1=MEVOL2.IEVOLL(IC)
  184.       KEVOL2=MEVOL2.IEVOLL(IC+1)
  185.       SEGACT KEVOL1,KEVOL2
  186.       MLREE1=KEVOL1.IPROGY
  187.       MLREE2=KEVOL2.IPROGY
  188.       SEGACT MLREE1,MLREE2
  189.             IF (ITYP2.EQ.'MODU') THEN
  190.       DO 130 I=1,L1
  191.       DM(I)=MLREE1.PROG(I)
  192.       DP(I)=MLREE2.PROG(I)
  193.   130 CONTINUE
  194.       CALL CONVCP(DR,DI,DM,DP,L1,-1)
  195.             ELSE
  196.       DO 131 I=1,L1
  197.       DR(I)=MLREE1.PROG(I)
  198.       DI(I)=MLREE2.PROG(I)
  199.   131 CONTINUE
  200.             ENDIF
  201.       DO 140 I=1,L1
  202.       AA(I)=AB(I)*DR(I)
  203.       AB(I)=AB(I)*DI(I)
  204.       BA(I)=BB(I)*DR(I)
  205.       BB(I)=BB(I)*DI(I)
  206.   140 CONTINUE
  207.       IF (INV.EQ.1) GO TO 142
  208.       DO 143 I=1,L1
  209.       A=MLREE1.PROG(I)
  210.       B=MLREE2.PROG(I)
  211.       DENOM(I)=A*A+B*B
  212.   143 CONTINUE
  213.   142 CONTINUE
  214.       SEGDES KEVOL1,KEVOL2,MLREE1,MLREE2
  215. C
  216. C
  217.       KEVOLL=MEVOLL.IEVOLL(IC)
  218.       SEGACT KEVOLL*MOD
  219.       JG=L1
  220.       SEGINI MLREEL
  221.       IPROGY=MLREEL
  222. C
  223.       IF(INV.EQ.1) THEN
  224.             DO 30 I=1,L1
  225.             PROG(I)=AA(I)-BB(I)
  226.   30        CONTINUE
  227.       ELSE
  228.             DO 31 I=1,L1
  229.                IF(DENOM(I).GT.1.D-20) THEN
  230.                  PROG(I)=(AA(I)+BB(I))/DENOM(I)
  231.                ELSE
  232.                  WRITE(IOIMP,*)' VALEURS NULLES DANS L OBJET EVOLUTION',
  233.      &          'DIVISEUR  :  RESULTAT MIS A 0'
  234.                  PROG(I)=0.D0
  235.                  GOTO 31
  236.                ENDIF
  237.   31        CONTINUE
  238.       ENDIF
  239. C
  240.       SEGDES KEVOLL,MLREEL
  241. C
  242.       KEVOLL=MEVOLL.IEVOLL(IC+1)
  243.       SEGACT KEVOLL*MOD
  244.       JG=L1
  245.       SEGINI MLREEL
  246.       IPROGY=MLREEL
  247. C
  248. C
  249.       IF(INV.EQ.1) THEN
  250.             DO 32 I=1,L1
  251.             PROG(I)=AB(I)+BA(I)
  252.   32        CONTINUE
  253.       ELSE
  254.             DO 33 I=1,L1
  255.                   IF(DENOM(I).GT.1.D-20) THEN
  256.                PROG(I)=(BA(I)-AB(I))/DENOM(I)
  257.                   ELSE
  258.                WRITE(IOIMP,*)' VALEURS NULLES DANS L OBJET EVOLUTION',
  259.      &         'DIVISEUR  :  RESULTAT MIS A 0'
  260.                PROG(I)=0.D0
  261.                GOTO 33
  262.                   ENDIF
  263.   33        CONTINUE
  264.       ENDIF
  265. C
  266.       SEGSUP TEMPP
  267.       SEGDES KEVOLL,KEVOL1,KEVOL2
  268. C
  269.       GO TO 201
  270.  200  CONTINUE
  271.       SEGINI TEMPP
  272.       KEVOL1=MEVOL1.IEVOLL(IC)
  273.       KEVOL2=MEVOL1.IEVOLL(IC+1)
  274.       SEGACT KEVOL1,KEVOL2
  275.       MLREE1=KEVOL1.IPROGY
  276.       MLREE2=KEVOL2.IPROGY
  277.       SEGACT MLREE1,MLREE2
  278.       DO 210 I=1,L1
  279.       AA(I)=MLREE1.PROG(I)
  280.       BB(I)=MLREE2.PROG(I)
  281.   210 CONTINUE
  282.       SEGDES KEVOL1,MLREE1
  283.       SEGDES KEVOL2,MLREE2
  284. C
  285.       KEVOL1=MEVOL2.IEVOLL(IC)
  286.       KEVOL2=MEVOL2.IEVOLL(IC+1)
  287.       SEGACT KEVOL1,KEVOL2
  288.       MLREE1=KEVOL1.IPROGY
  289.       MLREE2=KEVOL2.IPROGY
  290.       SEGACT MLREE1,MLREE2
  291.             IF (ITYP2.EQ.'PREE') THEN
  292.       DO 230 I=1,L1
  293.       DR(I)=MLREE1.PROG(I)
  294.       DI(I)=MLREE2.PROG(I)
  295.   230 CONTINUE
  296.       CALL CONVCP(DR,DI,DM,DP,L1,1)
  297.             ELSE
  298.       DO 231 I=1,L1
  299.       DM(I)=MLREE1.PROG(I)
  300.       DP(I)=MLREE2.PROG(I)
  301.   231 CONTINUE
  302.             ENDIF
  303.            IF (INV.EQ.1) THEN
  304.       DO 240 I=1,L1
  305.       AA(I)=AA(I)*DM(I)
  306.       BB(I)=BB(I)+DP(I)
  307.   240 CONTINUE
  308.            ELSE
  309.       DO 243 I=1,L1
  310.                   IF(DM(I).GT.1.D-20) THEN
  311.                AA(I)=AA(I)/DM(I)
  312.                   ELSE
  313.                WRITE(IOIMP,*)' VALEURS NULLES DANS L OBJET EVOLUTION',
  314.      &         'DIVISEUR  :  RESULTAT MIS A 0'
  315.                AA(I)=0.D0
  316.                   ENDIF
  317.       BB(I)=BB(I)-DP(I)
  318.   243 CONTINUE
  319.            ENDIF
  320.       DO 244 I=1,L1
  321.            IF (BB(I).GT.180.D0) THEN
  322.                    BB(I)=BB(I)-360.D0
  323.            ELSE IF(BB(I).LT.-180.D0) THEN
  324.                    BB(I)=BB(I)+360.D0
  325.            ENDIF
  326.   244 CONTINUE
  327.       SEGDES KEVOL1,KEVOL2,MLREE1,MLREE2
  328. C
  329.       KEVOLL=MEVOLL.IEVOLL(IC)
  330.       SEGACT KEVOLL*MOD
  331.       JG=L1
  332.       SEGINI MLREEL
  333.       IPROGY=MLREEL
  334. C
  335.       DO 330 I=1,L1
  336.       PROG(I)=AA(I)
  337.  330  CONTINUE
  338.       SEGDES KEVOLL,MLREEL
  339. C
  340.       KEVOLL=MEVOLL.IEVOLL(IC+1)
  341.       SEGACT KEVOLL*MOD
  342.       SEGINI MLREEL
  343.       IPROGY=MLREEL
  344. C
  345.       DO 332 I=1,L1
  346.       PROG(I)=BB(I)
  347.  332  CONTINUE
  348.       SEGDES MLREEL
  349. C
  350.       SEGSUP TEMPP
  351.       SEGDES KEVOLL,KEVOL1,KEVOL2
  352. C
  353.       SEGDES MEVOLL,MEVOL1,MEVOL2
  354.   201 CONTINUE
  355. C
  356.   400 CONTINUE
  357.       RETURN
  358.       END
  359.  
  360.  
  361.  
  362.  
  363.  
  364.  
  365.  

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