lecstack_ply.F

Go to the documentation of this file.

Copyright>        OpenRadioss
Copyright>        Copyright (C) 1986-2025 Altair Engineering Inc.
Copyright>
Copyright>        This program is free software: you can redistribute it and/or modify
Copyright>        it under the terms of the GNU Affero General Public License as published by
Copyright>        the Free Software Foundation, either version 3 of the License, or
Copyright>        (at your option) any later version.
Copyright>
Copyright>        This program is distributed in the hope that it will be useful,
Copyright>        but WITHOUT ANY WARRANTY; without even the implied warranty of
Copyright>        MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
Copyright>        GNU Affero General Public License for more details.
Copyright>
Copyright>        You should have received a copy of the GNU Affero General Public License
Copyright>        along with this program.  If not, see <https://www.gnu.org/licenses/>.
Copyright>
Copyright>
Copyright>        Commercial Alternative: Altair Radioss Software
Copyright>
Copyright>        As an alternative to this open-source version, Altair also offers Altair Radioss
Copyright>        software under a commercial license.  Contact Altair to discuss further if the
Copyright>        commercial version may interest you: https://www.altair.com/radioss/.
!||====================================================================
!||    lecstack_ply           ../starter/source/properties/composite_options/stack/lecstack_ply.f
!||--- called by ------------------------------------------------------
!||    lectur                 ../starter/source/starter/lectur.f
!||--- calls      -----------------------------------------------------
!||    ancmsg                 ../starter/source/output/message/message.F
!||    arret                  ../starter/source/system/arret.F
!||    bidon2                 ../starter/source/system/machine.F
!||    fretitl                ../starter/source/starter/freform.F
!||    fretitl2               ../starter/source/starter/freform.F
!||    hm_option_read_key     ../starter/source/devtools/hm_reader/hm_option_read_key.f
!||    hm_option_start        ../starter/source/devtools/hm_reader/hm_option_start.F
!||    hm_read_stack          ../starter/source/stack/hm_read_stack.F
!||    lcgeo19                ../starter/source/elements/shell/coque/lcgeo19.F
!||    usr2sys                ../starter/source/system/sysfus.F
!||    vdouble                ../starter/source/system/sysfus.F
!||--- uses       -----------------------------------------------------
!||    defaults_mod           ../starter/source/modules/defaults_mod.F90
!||    elbuftag_mod           ../starter/share/modules1/elbuftag_mod.F
!||    hm_option_read_mod     ../starter/share/modules1/hm_option_read_mod.F
!||    message_mod            ../starter/share/message_module/message_mod.F
!||    stack_mod              ../starter/share/modules1/stack_mod.F
!||    submodel_mod           ../starter/share/modules1/submodel_mod.F
!||====================================================================
      SUBROUTINE lecstack_ply(GEO_STACK ,X           ,IX           ,PM          ,ITABM1  ,
     .                       ISKN       ,IGEO_STACK  ,IPM          ,NPC         ,PLD     ,
     .                       UNITAB     ,RTRANS      ,LSUBMODEL    ,IPART       ,IDRAPEID,
     .                       PLY_INFO   ,STACK_INFO  ,NUMGEO_STACK ,NPROP_STACK,DEFAULTS)
C============================================================================
C   M o d u l e s
C-----------------------------------------------
      USE unitab_mod
      USE elbuftag_mod            
      USE submodel_mod
      USE message_mod
      USE stack_mod
      USE hm_option_read_mod
      USE submodel_mod
      USE names_and_titles_mod , ONLY : nchartitle
      USE defaults_mod
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "units_c.inc"
#include      "com04_c.inc"
#include      "param_c.inc"
#include      "scr17_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      TYPE (UNIT_TYPE_),INTENT(IN) ::UNITAB 
      INTEGER IX(*),ITABM1(*),ISKN(LISKN,*),
     .        IGEO_STACK(NPROPGI,NUMSTACK + NUMPLY),IPM(NPROPMI,NUMMAT),NPC(*),
     .        ipart(lipart1,*),idrapeid(*),ply_info(3,numply),
     .        nprop_stack,numgeo_stack(numgeo+numstack)
      my_real geo_stack(npropg,numstack+numply), x(*), pm(npropm,nummat),pld(*),rtrans(ntransf,*)
      TYPE(stack_info_ ) , DIMENSION (1:NPROP_STACK) :: STACK_INFO
      TYPE(SUBMODEL_DATA), DIMENSION(NSUBMOD), INTENT(IN) :: LSUBMODEL
      TYPE(defaults_)    , INTENT(IN)     :: DEFAULTS
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      LOGICAL lFOUND
      CHARACTER(LEN=NCHARTITLE) ::  IDTITL,TITR1
      CHARACTER MESS*40
      INTEGER I, IG,IGTYP,J,IP,ISTRAIN,I8PT,ISK,ITU,IRB,IHON,IHBE,IPLAST,ITHK,K,N,IDS, IUNIT,UID,ISORTH
      INTEGER NSTACK,ISTACK,NUMS,IFLAGUNIT,JPID,N1,SUB_ID,PID1,JPID1,JPID2,NISUB,II,IPOS
      my_real angl,rbid,fac_l,zshift
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
      INTEGER USR2SYS
      DATA MESS/'PID DEFINITION                          '/
C----------------------
C     GEO(3) : ISMSTR
C     GEO(5) : DT (ISMSTR=3 expect for solid elems)
C     GEO(7) : VX  shell/solids ortho - reference vector
C     GEO(8) : VY
C     GEO(9) : VZ
C     GEO(11): ISTRAIN (shell)
C     GEO(12): IGTYP      ->    IGEO(11)
C     GEO(35): ITHK
C     GEO(37): ISHEAR
C     GEO(38): FSHEAR
C     GEO(39): IPLAST
C     GEO(40): IG    v50  ->    IGEO(1)
C     GEO(20:34) : Milieu poreux (bricks)
C     GEO(129): HCLOS (bricks)
C     GEO(130): HTEST (bricks)
C     GEO(131:170): FREE
C     GEO(171): IHBE
C     GEO(212): ANGLE BETWEEN two orthotropy directions (DIR1,DIR2) for 
C               the PID52 with LAW58
C-------------------
C    IGEO(1)  : IG
C    IGEO(2)  : ISK
C    IGEO(3)  : ISEN
C    IGEO(4)  : NIP
C    IGEO(5)  : ISMSTR
C    IGEO(6)  : IREP
C    IGEO(7)  : ITHK
C    IGEO(8)  : ISHEAR
C    IGEO(9)  : IPLAST
C    IGEO(10) : IHBE
C    IGEO(11) : IGTYP
C    IGEO(12) :
C    IGEO(13) : ICPRE
C    IGEO(14) : ICSTR
C    IGEO(15) : IINT
C    IGEO(16) : IFRAM
C    IGEO(17) : ISORTH
C    IGEO(18) : ISH3N
C    IGEO(19) : ICXFEM
C    IGEO(20) : ISROT
C    IGEO(40) : IAD_KNOT
C    IGEO(41) : POLYNOMIAL DEGREE in 1st direction
C    IGEO(42) : POLYNOMIAL DEGREE in 2nd direction
C    IGEO(43) : POLYNOMIAL DEGREE in 3rd direction
C    IGEO(44) : NUMBER OF CONTROL POINTS in 1st direction
C    IGEO(45) : NUMBER OF CONTROL POINTS in 2nd direction
C    IGEO(46) : NUMBER OF CONTROL POINTS in 3rd direction
C    IGEO(47) : INTEGRATION FORMULATION FLAG for PID51 (UNIFORM / GAUSS distribution)
C    IGEO(48) : DRAPE IDENTIFICATION NUMBER
C    IGEO(49) : =1 ORTHOTROPY ANGLE DEFINED AT ELEMENT LEVEL  ( /PROP/TYPE19/51/52 )
C               =2 ORTHOTROPY ANGLE DEFINED AT STACK LEVEL ( /PROP/TYPE19/51/52 )
C=======================================================================
      WRITE(iout,1000)
C----------------------
      sub_id = 0    
      rbid=zero
c----------            
      CALL hm_option_start('/STACK')
      DO i=1,numstack 
        CALL hm_option_read_key(lsubmodel, option_id=ig, unit_id=uid, option_titr=idtitl)
        isorth = 0
        iflagunit = 0
 
        DO iunit=1,unitab%NUNITS
          IF (unitab%UNIT_ID(iunit) == uid) THEN
            iflagunit = 1
            EXIT
          ENDIF
        ENDDO
 
        IF (uid /= 0 .AND. iflagunit == 0) THEN
          CALL ancmsg(msgid=659,anmode=aninfo,msgtype=msgerror,
     .                i1=ig, i2=uid,
     .                c1='STACK', c2='STACK', c3=idtitl)
        ENDIF    
 
!       Stack + ply are belong to /PROP/PCOMPP 
        igtyp = 52  ! belong to /PROP/PCOMP - TYPE52              
C
C new shell property (stack based with multi NPT through one layer 
C---------------
C      GENERIC SHELL
C----------------------
C
C----------------------------------------------------------------
C      COMPOSITE LAYERED SHELL (NEW)
C      LAYERS WITH : -VARIABLE THICKNESS
C                    -VARIABLE MATERIAL  (BUT LAW 25 OR 27 ONLY)
C                    -VARIABLE NUMBER OF INTEGRATION POINTS THROUGH ONE LAYER
C---------------------------------------------------------------- 
          CALL fretitl(idtitl,igeo_stack(npropgi-ltitr+1,i),ltitr)    
          nums = numgeo_stack(numgeo + i)
          CALL hm_read_stack(
     .           geo_stack(1,i) ,igeo_stack(1,i) ,pm       ,ipm      ,iskn     ,
     .           ig             ,rtrans          ,sub_id   ,stack_info(nums)   ,
     .           idtitl         ,unitab          ,lsubmodel,defaults%SHELL )
     
C--------   Variables stored in element buffer        
c----   Shells
C should be done for pccomp
C-------------------------------
C  temporary double storage : GEO() / IGEO() : may be optimized & deleted later 
!!! ---------------------
        igeo_stack(17,i)=isorth
        IF(geo_stack(39,i) /= zero .AND. igeo_stack(9,i) == 0) igeo_stack( 9,i)=nint(geo_stack(39,i))
        IF(geo_stack(171,i) /= zero .AND. igeo_stack(10,i) == 0) igeo_stack(10,i)=nint(geo_stack(171,i))    
C      
      END do!next I
C
C-------------------------------
C  Objet /PLY
C-------------------------------
      i = numstack
      CALL hm_option_start('/PLY')
      DO ii = 1, numply  
         CALL hm_option_read_key(lsubmodel, option_id = ig, unit_id = uid, option_titr = idtitl)
         isorth = 0
         iflagunit = 0
         DO iunit=1,unitab%NUNITS
            IF (unitab%UNIT_ID(iunit) == uid) THEN
               iflagunit = 1
               EXIT
            ENDIF
         ENDDO
c     call BIDON2 to avoid optimization issue on FAC_L variable from compiler (issue
c     observed after global code compilation with -openmp flag
        CALL bidon2(fac_l)
        IF (uid /=0 .AND. iflagunit == 0) THEN
           CALL ancmsg(msgid=659,anmode=aninfo,msgtype=msgerror,
     .                 i1=ig, i2=uid, 
     .                 c1='PLY',c2='PLY',c3=idtitl)
        ENDIF
        igtyp = 19
        i = i + 1   
        ihbe = 0
        igeo_stack( 1,i) = ig
        istack = 1
C
        CALL fretitl(idtitl,igeo_stack(npropgi-ltitr+1,i),ltitr)        
C
        CALL lcgeo19(geo_stack(1,i), igeo_stack(1,i), pm, ipm, unitab, iunit, istack,idrapeid, lsubmodel)
        IF(igeo_stack(4,i) > 10) THEN
           CALL ancmsg(msgid=1146,msgtype=msgerror,anmode=aninfo,i1=ig,c1=idtitl)
           CALL arret(2)
        ENDIF
        ply_info(1,ii) = ig
        ply_info(2,ii) = igeo_stack(4,i)
        ply_info(3,ii) = igeo_stack(101,i)
        igeo_stack(1,i) =ig     
      ENDDO
C
C-------------------------------cy
      nplymax = max(nplymax,numply)
C------------------------------
      DO i = 1, numstack
        geo_stack(100,i) = sqrt(geo_stack(38,i))      ! SHFSR
      END DO
C------------------------------
C
      DO i = 1,numstack
        igtyp=igeo_stack(11,i)
        nums= numgeo_stack(numgeo + i)
        IF(igtyp == 52) THEN
          ! initialization of stack thickness
          geo_stack(1,i) = zero
          !--- generalizing ZSHIFT ! keep only IPOS= 2 as before
          ipos =igeo_stack(99,i) 
          zshift = geo_stack(199, i)
          IF(ipos == 0 )THEN                         
            zshift = - half                           
          ELSEIF(ipos == 3) THEN                      
            zshift = -one                             
          ELSEIF(ipos == 4) THEN                      
            zshift = zero                             
          ENDIF
          geo_stack(199, i) = zshift
          n1 = igeo_stack(4,i)          
          DO j =1 , n1
C ply of stack JPID              
            jpid = stack_info(nums)%PID(j)
            lfound = .false.
            IF(jpid > 0)THEN
              DO k=1,numply
                IF (igeo_stack(1,numstack + k) == jpid) THEN
                    stack_info(nums)%PID(j) = numstack + k
C tag if the ply is in the  stack  
                    ids = igeo_stack(42,numstack  + k)
                    igeo_stack(42 ,numstack + k) = i
                    IF(ids > 0 .AND. ids /= i) THEN 
                       CALL fretitl2(titr1,igeo_stack(npropgi-ltitr+1,numstack+k),ltitr)
                       CALL ancmsg(msgid=1148,msgtype=msgerror,anmode=aninfo_blind_1,
     .                    i1=igeo_stack(1,numstack + k), i2= igeo_stack(1,ids), i3= igeo_stack(1,i),
     .                    c1=titr1, c2='PLY')
                    ENDIF
C update stack thicness
                    geo_stack(1,i) = geo_stack(1,i) + geo_stack(1,numstack + k)
                  lfound = .true.
                  EXIT
                ENDIF
              ENDDO
              IF(.NOT.lfound)THEN
                CALL fretitl2(titr1,igeo_stack(npropgi-ltitr+1,i),ltitr)
                CALL ancmsg(msgid=1149,msgtype=msgerror,anmode=aninfo_blind_1,
     .                      i1=igeo_stack(1,i), i2=jpid,
     .                      c1=titr1, c2='STACK')
              ENDIF
            endif!(JPID > 0)
          END do!next J
C interface substack
          nisub = igeo_stack(44,i) 
          IF (nisub > 0) THEN
            DO j =1 , nisub
              jpid1 = stack_info(nums)%ISUB( 3*(j-1) + 1 )
              jpid2 = stack_info(nums)%ISUB( 3*(j-1) + 2 )
              IF (jpid1 > 0 .OR. jpid2 > 0) THEN
                DO k=1,numply 
                  nstack = 0
                  lfound=.false.
                  IF (igeo_stack(1,numstack + k) == jpid1) THEN
                    stack_info(nums)%ISUB (3*(j-1) + 1) = numstack  + k
                    lfound=.true.
                    EXIT !next J
                  ELSEIF (igeo_stack(1,numstack + k) == jpid2) THEN 
                    stack_info(nums)%ISUB (3*(j-1) + 2) = numstack  + k
                    lfound=.true.
                    EXIT !next J
                  ENDIF
                ENDDO
                IF(.NOT.lfound)THEN
                  CALL fretitl2(titr1,igeo_stack(npropgi-ltitr+1,i),ltitr)
                  CALL ancmsg(msgid=1149,msgtype=msgerror,anmode=aninfo_blind_1,
     .                        i1=igeo_stack(1,i), i2=jpid1,
     .                        c1=titr1, c2='STACK')
                  CALL fretitl2(titr1,igeo_stack(npropgi-ltitr+1,i),ltitr)
                  CALL ancmsg(msgid=1149,msgtype=msgerror,anmode=aninfo_blind_1,
     .                        i1=igeo_stack(1,i), i2=jpid2,
     .                        c1=titr1, c2='STACK')
                ENDIF
              ENDIF ! IF (JPID1 > 0 .OR. JPID2 > 0)
            ENDDO !next J 
          ENDIF ! IF (NISUB > 0)
C
          DO j=1,n1
            jpid = stack_info(nums)%PID(j)
            stack_info(nums)%THK(j)  = geo_stack(1,jpid) 
            stack_info(nums)%DIR(j)  = geo_stack(212,jpid) ! angle (DIR1,DIR2) - for compatibility of law58 with PID51)
            stack_info(nums)%MID(j)  = igeo_stack(101,jpid)
          ENDDO
! 
       ENDIF 
      ENDDO ! DO I = 1, NUMSTACK
C-------------------------------------
C Recherche des ID doubles
C-------------------------------------
      ids = 79
      i = 0
      j = 0
c      CALL ANCNTS(IDS,I)
      CALL vdouble(igeo_stack(1,1),npropgi,numstack,mess,0,rbid)
      CALL vdouble(igeo_stack(1,numstack+1),npropgi,numply,mess,0,rbid)
C
C-----------
      RETURN
C-----------
 1000 FORMAT(//
     & 5x,'    STACK OBJECT FOR PLY-BASED SHELL ELEMENT  SETS'/,
     & 5x,'    ----------------------------------------------'//) 
      END