Télécharger la plaquette Cast3M


fr en

Télécharger tens1.eso

Retour à la liste

Numérotation des lignes : 

tens1

  1. C TENS1     SOURCE    GOUNAND   26/01/16    21:15:15     12450          
  2.       SUBROUTINE TENS1(ICHA,TYCHA,MLMOTS,IOTENS,ICHA1)
  3.       IMPLICIT REAL*8 (A-H,O-Z)
  4.       IMPLICIT INTEGER (I-N)
  5. C***********************************************************************
  6. C NOM         : TENS1
  7. C DESCRIPTION : Opérations sur des tenseurs (unaires pour l'instant)
  8. C
  9. C
  10. C
  11. C LANGAGE     : ESOPE
  12. C AUTEUR      : Stephane GOUNAND (CEA/DES/ISAS/DM2S/SEMT/LTA)
  13. C               mel : gounand@semt2.smts.cea.fr
  14. C***********************************************************************
  15. C APPELES          :
  16. C APPELES (E/S)    :
  17. C APPELES (BLAS)   :
  18. C APPELES (CALCUL) :
  19. C APPELE PAR       :
  20. C***********************************************************************
  21. C SYNTAXE GIBIANE    :
  22. C ENTREES            :
  23. C ENTREES/SORTIES    :
  24. C SORTIES            :
  25. C***********************************************************************
  26. C VERSION    : v1, 28/08/2024, version initiale
  27. C HISTORIQUE : v1, 28/08/2024, creation
  28. C HISTORIQUE :
  29. C HISTORIQUE :
  30. C***********************************************************************
  31. -INC PPARAM
  32. -INC CCOPTIO
  33. -INC CCREEL
  34. -INC SMCHPOI
  35. -INC SMCHAML
  36. -INC SMLMOTS
  37. -INC TMTRAV
  38.       SEGMENT MTRAV1.MTRAV
  39.       SEGMENT MTRCML
  40.       REAL*8 CC(NNIN,N1PTEL,N1EL)
  41.       ENDSEGMENT
  42.       CHARACTER*8 TYCHA,CCCOMP
  43.       segment idxcom(ncomp)
  44. *
  45. C   ENTREEES
  46. C        A(3,3) = MATRICE A DIAGONALISER
  47. C   SORTIES
  48. C        D(3)   =  VALEURS PROPRES D(1) > D(2) ET D(3)=A(3,3)
  49. C        R(3,3) =  RESULTAT DES OPERATIONS TENSORIELLES
  50.       DIMENSION A(3,3),D(3),R(3,3)
  51.       DIMENSION IDXSYM(3,3,3)
  52.       DIMENSION IDXGEN(3,3,3)
  53.       DIMENSION INVSYM(2,6,3)
  54.       DIMENSION INVGEN(2,9,3)
  55.       DATA ((A(I,J),I=1,3),J=1,3) /9*0.D0/
  56.       DATA (D(I),I=1,3) /3*0.D0/
  57.       DATA ((R(I,J),I=1,3),J=1,3) /9*0.D0/
  58.       DATA (((IDXSYM(I,J,K),I=1,1),J=1,1),K=1,1) /1/
  59.       DATA (((IDXSYM(I,J,K),I=1,2),J=1,2),K=2,2) /1,2,2,3/
  60.       DATA (((IDXSYM(I,J,K),I=1,3),J=1,3),K=3,3) /1,2,4,2,3,5,4,5,6/
  61.       DATA (((IDXGEN(I,J,K),I=1,1),J=1,1),K=1,1) /1/
  62.       DATA (((IDXGEN(I,J,K),I=1,2),J=1,2),K=2,2) /1,3,2,4/
  63.       DATA (((IDXGEN(I,J,K),I=1,3),J=1,3),K=3,3) /1,4,7,2,5,8,3,6,9/
  64. *
  65.       DATA (((INVSYM(I,J,K),I=1,2),J=1,1),K=1,1) /1,1/
  66.       DATA (((INVSYM(I,J,K),I=1,2),J=1,3),K=2,2) /1,1,2,1,2,2/
  67.       DATA (((INVSYM(I,J,K),I=1,2),J=1,6),K=3,3)
  68.      $     /1,1,2,1,2,2,3,1,3,2,3,3/
  69.       DATA (((INVGEN(I,J,K),I=1,2),J=1,1),K=1,1) /1,1/
  70.       DATA (((INVGEN(I,J,K),I=1,2),J=1,4),K=2,2) /1,1,1,2,2,1,2,2/
  71.       DATA (((INVGEN(I,J,K),I=1,2),J=1,9),K=3,3)
  72.      $     /1,1,1,2,1,3,2,1,2,2,2,3,3,1,3,2,3,3/
  73. *
  74. *                     1       2        3     4        5        6      7
  75. *     DATA MOTENS/'NORM2','NORMINF','DET','TRACE','INVERSE','IDEN' ,'LOG'
  76. *              8     9      10        11         12         13
  77. *     $     ,'EXP','INVS','ABSOLU','PRINCIPA','RECOMPOS','TRANSPOS'
  78. *              14
  79. *     $     ,'VALP'/
  80. *
  81. * Executable statements
  82. *
  83.       SEGACT MLMOTS
  84.       NCOMP=MOTS(/2)
  85. * Cas entrée scalaire ou vecteur, symétrique, ordre 2, général
  86.       IF (NCOMP.EQ.1) THEN
  87.          IKAS=1
  88.       ELSEIF (NCOMP.EQ.IDIM) THEN
  89.          IKAS=2
  90.       ELSEIF (NCOMP*2.EQ.IDIM*(IDIM+1)) THEN
  91.          IKAS=3
  92.       ELSEIF (NCOMP.EQ.IDIM*IDIM) THEN
  93.          IKAS=4
  94.       ELSEIF (NCOMP.EQ.IDIM*(IDIM+1).AND.IOTENS.EQ.12) THEN
  95.          IKAS=5
  96.       ELSE
  97.          GOTO 9997
  98.       ENDIF
  99. * Nombre de composantes du résultat
  100.       IF (IOTENS.GE.1.AND.IOTENS.LE.4) THEN
  101.          NCOM1=1
  102.       ELSEIF (IOTENS.EQ.11) THEN
  103.          NCOM1=IDIM*(IDIM+1)
  104.       ELSEIF (IOTENS.EQ.12) THEN
  105.          NCOM1=(IDIM*(IDIM+1))/2
  106.       ELSEIF (IOTENS.EQ.14) THEN
  107.          NCOM1=IDIM
  108.       ELSE
  109.          NCOM1=NCOMP
  110.       ENDIF
  111. *      write(ioimp,*) 'tens1: TYCHA,IOTENS,IKAS,NCOMP,NCOM1=',TYCHA
  112. *     $     ,IOTENS,IKAS,NCOMP,NCOM1
  113. *
  114. * Un peu de gestion d'erreur avant la boucle...
  115. *
  116. * Seuls NORM2 et NORMINF disponibles pour les vecteurs
  117.       IF (IKAS.EQ.2.AND.IOTENS.GT.2) THEN
  118. * Option %M1:8 incompatible avec les donnees
  119.          CALL ERREUR(803)
  120.          RETURN
  121.       ENDIF
  122.       IF (IKAS.EQ.4.AND.IOTENS.GT.7.AND.IOTENS.NE.13) THEN
  123. * La matrice doit etre symetrique
  124.          CALL ERREUR(969)
  125.          RETURN
  126.       ENDIF
  127.  
  128.       IF (TYCHA.EQ.'CHPOINT ') THEN
  129.          MCHPOI=ICHA
  130. * Transformation du CHPOINT entré en objet de travail
  131.          CALL CP2TR2(MLMOTS,0,MCHPOI,MTRAV)
  132.          IF (IERR.NE.0) RETURN
  133.          SEGACT MTRAV*MOD
  134.          NNNOE=IGEO(/1)
  135.          IF (NCOM1.NE.NCOMP) THEN
  136.             NNIN=NCOM1
  137.             SEGINI MTRAV1
  138.             DO INNOE=1,NNNOE
  139.                MTRAV1.IGEO(INNOE)=IGEO(INNOE)
  140.             ENDDO
  141.          ELSE
  142.             MTRAV1=MTRAV
  143.          ENDIF
  144.          IF (IOTENS.EQ.11.OR.IOTENS.EQ.14) THEN
  145.             ICMP=0
  146.             CCCOMP='SI'
  147.             DO i=1,IDIM
  148.                WRITE(CCCOMP(3:3),FMT='(I1)') I
  149.                WRITE(CCCOMP(4:4),FMT='(I1)') I
  150.                ICMP=ICMP+1
  151.                MTRAV1.INCO(ICMP)=CCCOMP
  152.                MTRAV1.NHAR(ICMP)=NHAR(1)
  153.             ENDDO
  154.             IF (IOTENS.EQ.11) THEN
  155.                CCCOMP='CO'
  156.                DO i=1,IDIM
  157.                   WRITE(CCCOMP(4:4),FMT='(I1)') I
  158.                   DO j=1,IDIM
  159.                      WRITE(CCCOMP(3:3),FMT='(I1)') J
  160.                      ICMP=ICMP+1
  161.                      MTRAV1.INCO(ICMP)=CCCOMP
  162.                      MTRAV1.NHAR(ICMP)=NHAR(1)
  163.                   ENDDO
  164.                ENDDO
  165.             ENDIF
  166.          ELSEIF (IOTENS.EQ.12) THEN
  167.             ICMP=0
  168.             CCCOMP='G'
  169.             DO i=1,IDIM
  170.                WRITE(CCCOMP(2:2),FMT='(I1)') I
  171.                DO j=1,i
  172.                   WRITE(CCCOMP(3:3),FMT='(I1)') J
  173.                   ICMP=ICMP+1
  174.                   MTRAV1.INCO(ICMP)=CCCOMP
  175.                   MTRAV1.NHAR(ICMP)=NHAR(1)
  176.                ENDDO
  177.             ENDDO
  178.          ELSEIF (IOTENS.GE.1.AND.IOTENS.LE.4) THEN
  179.             MTRAV1.INCO(1)='SCAL'
  180.             MTRAV1.NHAR(1)=NHAR(1)
  181.          ENDIF
  182.       ELSEIF (TYCHA.EQ.'MCHAML') THEN
  183.          MCHELM=ICHA
  184.          NOID=1
  185. * Extrayons les composantes intéressantes
  186. *         write(ioimp,*) 'Avant excoc2' ;
  187. *         CALL ECROBJ('MCHAML  ',MCHELM)
  188. *         call prlist
  189. *         segprt,MLMOTS
  190.          CALL EXCOC2(MCHELM,MLMOTS,MCHEL1,MLMOTS,NOID)
  191.          IF (IERR.NE.0) RETURN
  192. *         write(ioimp,*) 'Apres excoc2' ;
  193. *         CALL ECROBJ('MCHAML  ',MCHEL1)
  194. *         call prlist
  195.          CALL ACTOBJ('MCHAML  ',MCHEL1,1)
  196.          SEGACT,MCHEL1*MOD
  197.          SEGACT MLMOTS
  198.       ELSE
  199.          GOTO 9998
  200.       ENDIF
  201. *      segprt,mtrav
  202. *
  203. *
  204. * La boucle sur les noeuds ou les éléments : on pourra paralléliser ici
  205. *
  206.       IF (TYCHA.EQ.'CHPOINT ') THEN
  207.          DO INNOE=1,NNNOE
  208. * Remplissage des tableaux de travail
  209.             IF (IKAS.EQ.1.OR.IKAS.EQ.2) THEN
  210.                DO I=1,NCOMP
  211.                   A(I,1)=BB(I,INNOE)
  212.                ENDDO
  213.             ELSEIF (IKAS.EQ.3) THEN
  214.                DO J=1,IDIM
  215.                   DO I=1,IDIM
  216.                      A(I,J)=BB(IDXSYM(I,J,IDIM),INNOE)
  217.                   ENDDO
  218.                ENDDO
  219.             ELSEIF (IKAS.EQ.4) THEN
  220.                DO J=1,IDIM
  221.                   DO I=1,IDIM
  222.                      A(I,J)=BB(IDXGEN(I,J,IDIM),INNOE)
  223.                   ENDDO
  224.                ENDDO
  225.             ELSEIF (IKAS.EQ.5) THEN
  226.                ICMP=0
  227.                DO i=1,IDIM
  228.                   ICMP=ICMP+1
  229.                   D(i)=BB(ICMP,INNOE)
  230.                ENDDO
  231.                DO i=1,IDIM
  232.                   DO j=1,IDIM
  233.                      ICMP=ICMP+1
  234.                      R(j,i)=BB(ICMP,INNOE)
  235.                   ENDDO
  236.                ENDDO
  237.             ELSE
  238.                write(ioimp,*) 'ikas=',ikas,' ????'
  239.                MOTERR(1:8)='TENS1'
  240.                call erreur(1039)
  241.                return
  242.             endif
  243. *     On prépare le message d'erreur 49 en cas de déterminant nul pour
  244. *     l'inversion d'une matrice...
  245.             IF (IOTENS.EQ.5) INTERR(1)=IGEO(INNOE)
  246. *
  247. * Faire les opérations tensorielles
  248. *
  249.             CALL TENS2(IOTENS,IKAS,A,D,R)
  250.             IF (IERR.NE.0) RETURN
  251. *
  252.             IF (IOTENS.GE.1.AND.IOTENS.LE.4) THEN
  253.                MTRAV1.BB(1,INNOE)=R(1,1)
  254.                MTRAV1.IBIN(1,INNOE)=1
  255.             ELSEIF (IOTENS.EQ.11.OR.IOTENS.EQ.14) THEN
  256.                ICMP=0
  257.                DO i=1,IDIM
  258.                   ICMP=ICMP+1
  259.                   MTRAV1.BB(ICMP,INNOE)=D(i)
  260.                   MTRAV1.IBIN(ICMP,INNOE)=1
  261.                ENDDO
  262.                IF (IOTENS.EQ.11) THEN
  263.                   DO i=1,IDIM
  264.                      DO j=1,IDIM
  265.                         ICMP=ICMP+1
  266.                         MTRAV1.BB(ICMP,INNOE)=R(j,i)
  267.                         MTRAV1.IBIN(ICMP,INNOE)=1
  268.                      ENDDO
  269.                   ENDDO
  270.                ENDIF
  271.             ELSEIF (IOTENS.EQ.12) THEN
  272.                DO ICOM1=1,NCOM1
  273.                   I=INVSYM(1,ICOM1,IDIM)
  274.                   J=INVSYM(2,ICOM1,IDIM)
  275.                   MTRAV1.BB(ICOM1,INNOE)=A(I,J)
  276.                   MTRAV1.IBIN(ICOM1,INNOE)=1
  277.                ENDDO
  278.             ELSE
  279.                IF (IKAS.EQ.1.OR.IKAS.EQ.2) THEN
  280.                   DO I=1,NCOMP
  281.                      MTRAV1.BB(I,INNOE)=R(I,1)
  282.                      MTRAV1.IBIN(I,INNOE)=1
  283.                   ENDDO
  284.                ELSEIF (IKAS.EQ.3) THEN
  285.                   DO ICOMP=1,NCOMP
  286.                      I=INVSYM(1,ICOMP,IDIM)
  287.                      J=INVSYM(2,ICOMP,IDIM)
  288.                      MTRAV1.BB(ICOMP,INNOE)=R(I,J)
  289.                      MTRAV1.IBIN(ICOMP,INNOE)=1
  290.                   ENDDO
  291.                ELSEIF (IKAS.EQ.4) THEN
  292.                   DO ICOMP=1,NCOMP
  293.                      I=INVGEN(1,ICOMP,IDIM)
  294.                      J=INVGEN(2,ICOMP,IDIM)
  295.                      MTRAV1.BB(ICOMP,INNOE)=R(I,J)
  296.                      MTRAV1.IBIN(ICOMP,INNOE)=1
  297.                   ENDDO
  298.                ELSE
  299.                   write(ioimp,*) 'ikas,iotens=',ikas,iotens,
  300.      $                 ' non prevu ????'
  301.                   goto 9999
  302.                ENDIF
  303.             ENDIF
  304. * Fin de la boucle sur les noeuds
  305.          ENDDO
  306. *     segprt,mtrav
  307.       ELSEIF (TYCHA.EQ.'MCHAML  ') THEN
  308.          N1=MCHEL1.ICHAML(/1)
  309.          DO I1=1,N1
  310.             MCHAML=MCHEL1.ICHAML(I1)
  311.             SEGACT MCHAML
  312.             N2=IELVAL(/1)
  313.             IF (N2.NE.NCOMP) THEN
  314.                write(ioimp,*) ' TENS1 1 MCHEL1,MCHAML,N2,NCOMP=',MCHEL1
  315.      $              ,MCHAML,N2,NCOMP
  316.                write(ioimp,'(10(1X,A))') 'NOMCHE=',(NOMCHE(ii),ii=1,N2)
  317.                write(ioimp,'(10(1X,A))') 'MLMOTS=',(MOTS(ii),ii=1,NCOMP)
  318. * Composante inexistante
  319.                CALL ERREUR(280)
  320.                RETURN
  321.             ENDIF
  322. * Les composantes du chaml ne sont pas forcément dans l'ordre de MLMOTS...
  323.             segini idxcom
  324.             DO ICOMP=1,NCOMP
  325.                call place(nomche(1),ncomp,i2,mots(icomp))
  326.                if (i2.le.0) then
  327.                   write(ioimp,*) ' TENS1 2 MCHEL1,MCHAML,NCOMP,I2='
  328.      $                 ,MCHEL1,MCHAML,NCOMP,I2
  329.                   write(ioimp,'(10(1X,A))') 'NOMCHE=',(NOMCHE(ii),ii=1
  330.      $                 ,NCOMP)
  331.                   write(ioimp,'(10(1X,A))') 'MLMOTS=',(MOTS(ii),ii=1
  332.      $                 ,NCOMP)
  333.                   goto 9999
  334.                endif
  335.                idxcom(ICOMP)=i2
  336.             ENDDO
  337.             N1EL=0
  338.             N1PTEL=0
  339.             N2EL=0
  340.             N2PTEL=0
  341.             DO ICOMP=1,NCOMP
  342.                i2=idxcom(icomp)
  343.                IF (TYPCHE(I2).NE.'REAL*8') THEN
  344.                   MOTERR(1:8)='MCHAML'
  345.                   MOTERR(9:16)=TYPCHE(I2)
  346. * 131 2               On n'attend pas un objet de type %m1:8 de sous-type %m9:16
  347.                   CALL ERREUR(131)
  348.                   RETURN
  349.                ENDIF
  350.                MELVAL=IELVAL(I2)
  351.                SEGACT MELVAL
  352.                N1EL=MAX(N1EL,VELCHE(/2))
  353.                N1PTEL=MAX(N1PTEL,VELCHE(/1))
  354.             ENDDO
  355.             IF (NCOM1.EQ.NCOMP) THEN
  356.                SEGINI,MCHAM1=MCHAML
  357.             ELSE
  358.                N2=NCOM1
  359.                SEGINI,MCHAM1
  360.             ENDIF
  361.             IF (IOTENS.GE.1.AND.IOTENS.LE.4) THEN
  362.                MCHAM1.NOMCHE(1)='SCAL'
  363.                MCHAM1.TYPCHE(1)='REAL*8'
  364.             ELSEIF (IOTENS.EQ.11.OR.IOTENS.EQ.14) THEN
  365.                ICMP=0
  366.                CCCOMP='SI'
  367.                DO i=1,IDIM
  368.                   ICMP=ICMP+1
  369.                   WRITE(CCCOMP(3:3),FMT='(I1)') I
  370.                   WRITE(CCCOMP(4:4),FMT='(I1)') I
  371.                   MCHAM1.NOMCHE(ICMP)=CCCOMP
  372.                   MCHAM1.TYPCHE(ICMP)='REAL*8'
  373.                ENDDO
  374.                IF (IOTENS.EQ.11) THEN
  375.                   CCCOMP='CO'
  376.                   DO i=1,IDIM
  377.                      WRITE(CCCOMP(4:4),FMT='(I1)') I
  378.                      DO j=1,IDIM
  379.                         WRITE(CCCOMP(3:3),FMT='(I1)') J
  380.                         ICMP=ICMP+1
  381.                         MCHAM1.NOMCHE(ICMP)=CCCOMP
  382.                         MCHAM1.TYPCHE(ICMP)='REAL*8'
  383.                      ENDDO
  384.                   ENDDO
  385.                ENDIF
  386.             ELSEIF (IOTENS.EQ.12) THEN
  387.                ICMP=0
  388.                CCCOMP='G'
  389.                DO i=1,IDIM
  390.                   WRITE(CCCOMP(2:2),FMT='(I1)') I
  391.                   DO j=1,i
  392.                      WRITE(CCCOMP(3:3),FMT='(I1)') J
  393.                      ICMP=ICMP+1
  394.                      MCHAM1.NOMCHE(ICMP)=CCCOMP
  395.                      MCHAM1.TYPCHE(ICMP)='REAL*8'
  396.                   ENDDO
  397.                ENDDO
  398.             ENDIF
  399.             NNIN=max(NCOM1,NCOMP)
  400.             SEGINI MTRCML
  401.             DO ICOMP=1,NCOMP
  402.                i2=idxcom(icomp)
  403.                MELVAL=IELVAL(I2)
  404.                J1PTEL=VELCHE(/1)
  405.                J1EL=VELCHE(/2)
  406.                DO I1EL=1,N1EL
  407.                   DO I1PTEL=1,N1PTEL
  408.                      CC(ICOMP,I1PTEL,I1EL)=VELCHE(MIN(I1PTEL,J1PTEL)
  409.      $                    ,MIN(I1EL,J1EL))
  410.                   ENDDO
  411.                ENDDO
  412.             ENDDO
  413. *
  414.             DO I1EL=1,N1EL
  415.                DO I1PTEL=1,N1PTEL
  416. * Remplissage des tableaux de travail
  417.                   IF (IKAS.EQ.1.OR.IKAS.EQ.2) THEN
  418.                      DO I=1,NCOMP
  419.                         A(I,1)=CC(I,I1PTEL,I1EL)
  420.                      ENDDO
  421.                   ELSEIF (IKAS.EQ.3) THEN
  422.                      DO J=1,IDIM
  423.                         DO I=1,IDIM
  424.                            A(I,J)=CC(IDXSYM(I,J,IDIM),I1PTEL,I1EL)
  425.                         ENDDO
  426.                      ENDDO
  427.                   ELSEIF (IKAS.EQ.4) THEN
  428.                      DO J=1,IDIM
  429.                         DO I=1,IDIM
  430.                            A(I,J)=CC(IDXGEN(I,J,IDIM),I1PTEL,I1EL)
  431.                         ENDDO
  432.                      ENDDO
  433.                   ELSEIF (IKAS.EQ.5) THEN
  434.                      ICMP=0
  435.                      DO i=1,IDIM
  436.                         ICMP=ICMP+1
  437.                         D(i)=CC(ICMP,I1PTEL,I1EL)
  438.                      ENDDO
  439.                      DO i=1,IDIM
  440.                         DO j=1,IDIM
  441.                            ICMP=ICMP+1
  442.                            R(j,i)=CC(ICMP,I1PTEL,I1EL)
  443.                         ENDDO
  444.                      ENDDO
  445.                   ELSE
  446.                      write(ioimp,*) 'ikas=',ikas,' ????'
  447.                      GOTO 9999
  448.                   endif
  449. *
  450. * Faire les opérations tensorielles
  451. *
  452.                   CALL TENS2(IOTENS,IKAS,A,D,R)
  453.                   IF (IERR.NE.0) RETURN
  454. *
  455.                   IF (IOTENS.GE.1.AND.IOTENS.LE.4) THEN
  456.                      CC(1,I1PTEL,I1EL)=R(1,1)
  457.                   ELSEIF (IOTENS.EQ.11.OR.IOTENS.EQ.14) THEN
  458.                      ICMP=0
  459.                      DO i=1,IDIM
  460.                         ICMP=ICMP+1
  461.                         CC(ICMP,I1PTEL,I1EL)=D(i)
  462.                      ENDDO
  463.                      IF (IOTENS.EQ.11) THEN
  464.                         DO i=1,IDIM
  465.                            DO j=1,IDIM
  466.                               ICMP=ICMP+1
  467.                               CC(ICMP,I1PTEL,I1EL)=R(j,i)
  468.                            ENDDO
  469.                         ENDDO
  470.                      ENDIF
  471.                   ELSEIF (IOTENS.EQ.12) THEN
  472.                      DO ICOM1=1,NCOM1
  473.                         I=INVSYM(1,ICOM1,IDIM)
  474.                         J=INVSYM(2,ICOM1,IDIM)
  475.                         CC(ICOM1,I1PTEL,I1EL)=A(I,J)
  476.                      ENDDO
  477.                   ELSE
  478.                      IF (IKAS.EQ.1.OR.IKAS.EQ.2) THEN
  479.                         DO I=1,NCOMP
  480.                            CC(I,I1PTEL,I1EL)=R(I,1)
  481.                         ENDDO
  482.                      ELSEIF (IKAS.EQ.3) THEN
  483.                         DO ICOMP=1,NCOMP
  484.                            I=INVSYM(1,ICOMP,IDIM)
  485.                            J=INVSYM(2,ICOMP,IDIM)
  486.                            CC(ICOMP,I1PTEL,I1EL)=R(I,J)
  487.                         ENDDO
  488.                      ELSEIF (IKAS.EQ.4) THEN
  489.                         DO ICOMP=1,NCOMP
  490.                            I=INVGEN(1,ICOMP,IDIM)
  491.                            J=INVGEN(2,ICOMP,IDIM)
  492.                            CC(ICOMP,I1PTEL,I1EL)=R(I,J)
  493.                         ENDDO
  494.                      ELSE
  495.                         write(ioimp,*) 'ikas,iotens=',ikas,iotens,
  496.      $                       ' non prevu ????'
  497.                         goto 9999
  498.                      ENDIF
  499.                   ENDIF
  500. * Fin de la boucle sur les noeuds et éléments
  501.                ENDDO
  502. * Fin de la boucle sur les éléments
  503.             ENDDO
  504.             DO ICOM1=1,NCOM1
  505.                SEGINI MELVA1
  506.                DO I1EL=1,N1EL
  507.                   DO I1PTEL=1,N1PTEL
  508.                      MELVA1.VELCHE(I1PTEL,I1EL)=CC(ICOM1,I1PTEL,I1EL)
  509.                   ENDDO
  510.                ENDDO
  511.                IF (NCOMP.EQ.NCOM1) THEN
  512.                   I2=IDXCOM(ICOM1)
  513.                   MCHAM1.IELVAL(I2)=MELVA1
  514.                ELSE
  515.                   MCHAM1.IELVAL(ICOM1)=MELVA1
  516.                ENDIF
  517.             ENDDO
  518.             segsup idxcom
  519.             SEGSUP MTRCML
  520.             MCHEL1.ICHAML(I1)=MCHAM1
  521. *     Fin de la boucle sur les sous-zones
  522.          ENDDO
  523.       ELSE
  524.          GOTO 9998
  525.       ENDIF
  526. *
  527. * Transformation des objets de travail en champs
  528. *
  529.       IF (TYCHA.EQ.'CHPOINT ') THEN
  530.          CALL CRECHP(MTRAV1,MCHPO1)
  531.          SEGSUP MTRAV1
  532.          IF (NCOM1.NE.NCOMP) THEN
  533.             SEGSUP MTRAV
  534.          ENDIF
  535.          CALL COMBNA(MCHPOI,0,INAT,IATTR)
  536.          MCHPO1.JATTRI(1)=IATTR
  537.          ICHA1=MCHPO1
  538.       ELSEIF (TYCHA.EQ.'MCHAML  ') THEN
  539.          ICHA1=MCHEL1
  540.       ELSE
  541.          GOTO 9998
  542.       ENDIF
  543. *
  544. * Normal termination
  545. *
  546.       RETURN
  547. *
  548. * Format handling
  549. *
  550. *
  551. * Error handling
  552. *
  553.  9997 CONTINUE
  554. * 980 2
  555. * L'objet %m1:8 n'a pas le bon nombre de composantes
  556.       MOTERR(1:8)='LISTMOTS'
  557.       CALL ERREUR(980)
  558.       RETURN
  559.  9998 CONTINUE
  560. * On ne veut pas d'objet de type %m1:8
  561.       MOTERR(1:8)=TYCHA
  562.       CALL ERREUR(39)
  563.       RETURN
  564.  9999 CONTINUE
  565.       MOTERR(1:8)='TENS1'
  566.       call erreur(1039)
  567.       return
  568. *
  569.  
  570. * End of subroutine TENS1
  571. *
  572.       END
  573.  
  574.  

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