Télécharger la plaquette Cast3M


fr en

Télécharger prtens.eso

Retour à la liste

Numérotation des lignes : 

prtens

  1. C PRTENS    SOURCE    GOUNAND   25/10/23    21:15:07     12386          
  2.       SUBROUTINE PRTENS()
  3.       IMPLICIT REAL*8 (A-H,O-Z)
  4.       IMPLICIT INTEGER (I-N)
  5. C***********************************************************************
  6. C NOM         : PRTENS
  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 SMCHPOI
  34. -INC SMLMOTS
  35. *
  36.       PARAMETER (NOTENS=13)
  37.       CHARACTER*8 MOTENS(NOTENS),TYCHA
  38.       CHARACTER*(LOCOMP) MOCOMP,CCCOMP
  39. C
  40.       DATA MOTENS/'NORM2','NORMINF','DET','TRACE','INVERSE','IDEN','LOG'
  41.      $     ,'EXP','INVS','ABSOLU','PRINCIPA','RECOMPOS','TRANSPOS'/
  42. *
  43. * Executable statements
  44. *
  45. * Mot-clé
  46.       CALL LIRMOT(MOTENS,-NOTENS,IOTENS,1)
  47.       IF(IERR.NE.0) RETURN
  48. *      write(ioimp,*) 'MOTENS,IOTENS=',MOTENS(IOTENS),IOTENS
  49. * Lecture du champ
  50.       TYCHA='CHPOINT '
  51.       CALL LIROBJ(TYCHA,ICHA,0,IRET)
  52.       IF (IRET.EQ.0) THEN
  53.          TYCHA='MCHAML  '
  54.          CALL LIROBJ(TYCHA,ICHA,1,IRET)
  55.          IF(IERR.NE.0) RETURN
  56.       ENDIF
  57.       CALL ACTOBJ(TYCHA,ICHA,1)
  58. *
  59.       DO 1000 ITRY=1,2
  60. * Lecture des noms de composantes
  61.          CALL LIROBJ('LISTMOTS',MLMOTS,ITRY-1,ILMOTS)
  62.          IF (ILMOTS.EQ.0) THEN
  63.             IF (TYCHA.EQ.'CHPOINT') THEN
  64.                CALL EXTR11(ICHA,MLMOTS)
  65.                IF(IERR.NE.0) RETURN
  66.             ELSEIF (TYCHA.EQ.'MCHAML') THEN
  67.                CALL EXTR17(ICHA,MLMOTS)
  68.                IF(IERR.NE.0) RETURN
  69.             ELSE
  70. * On ne veut pas d'objet de type %m1:8
  71.                MOTERR(1:8)=TYCHA
  72.                CALL ERREUR(39)
  73.                RETURN
  74.             ENDIF
  75. * Recomposition
  76.             IF (IOTENS.EQ.12) THEN
  77.                JGM=IDIM*(IDIM+1)
  78.                JGN=LOCOMP
  79.                SEGINI MLMOT1
  80.                ICMP=0
  81.                CCCOMP='SI'
  82.                DO i=1,IDIM
  83.                   WRITE(CCCOMP(3:3),FMT='(I1)') I
  84.                   WRITE(CCCOMP(4:4),FMT='(I1)') I
  85.                   ICMP=ICMP+1
  86.                   MLMOT1.MOTS(ICMP)=CCCOMP
  87.                ENDDO
  88.                CCCOMP='CO'
  89.                DO i=1,IDIM
  90.                   WRITE(CCCOMP(4:4),FMT='(I1)') I
  91.                   DO j=1,IDIM
  92.                      WRITE(CCCOMP(3:3),FMT='(I1)') J
  93.                      ICMP=ICMP+1
  94.                      MLMOT1.MOTS(ICMP)=CCCOMP
  95.                   ENDDO
  96.                ENDDO
  97. * Verifions la présence de toutes les composantes dans la liste devinee
  98.                ICMP=0
  99.                DO I=1,MOTS(/2)
  100.                   CALL PLACE (MLMOT1.MOTS,MLMOT1.MOTS(/2),IPLAC,MOTS(I))
  101.                   IF (IPLAC.NE.0) ICMP=ICMP+1
  102.                ENDDO
  103. *         write(ioimp,*) 'ICMP=',ICMP
  104.                IF (ICMP.NE.MOTS(/2)) THEN
  105.                   SEGSUP MLMOT1
  106.                   MLMOT1=0
  107.                ENDIF
  108.             ELSE
  109.                CALL GUESCO(TYCHA,MLMOTS,MLMOT1)
  110.             ENDIF
  111.             IF(IERR.NE.0) RETURN
  112.             SEGSUP MLMOTS
  113.             MLMOTS=MLMOT1
  114.             IF (MLMOTS.EQ.0) THEN
  115.                GOTO 1000
  116.             ELSE
  117.                if (IIMPI.NE.0) THEN
  118.                   write(ioimp,*) 'On a devine les composantes :'
  119.                   write(ioimp,'(10(1X,A))') 'MLMOTS=',(MOTS(i),i=1
  120.      $                 ,MOTS(/2))
  121.                endif
  122.                GOTO 1001
  123.             ENDIF
  124.          ENDIF
  125.  1000 CONTINUE
  126.  1001 CONTINUE
  127. * Pour le message d'erreur 803 éventuellement appelé dans tens1
  128.       MOTERR(1:8)=MOTENS(IOTENS)
  129.       CALL TENS1(ICHA,TYCHA,MLMOTS,IOTENS,ICHA1)
  130.       IF(IERR.NE.0) RETURN
  131. *
  132.       IF (ILMOTS.EQ.0) SEGSUP MLMOTS
  133. *
  134.       CALL ACTOBJ(TYCHA,ICHA1,1)
  135.       CALL ECROBJ(TYCHA,ICHA1)
  136. *
  137. * Normal termination
  138. *
  139.       RETURN
  140. *
  141. * Format handling
  142. *
  143. *
  144. * Error handling
  145. *
  146. *
  147. * End of subroutine PRTENS
  148. *
  149.       END
  150.  
  151.  

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