fr.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/.
!||====================================================================
!||    frv      ../engine/source/materials/mat/mat024/fr.F
!||--- called by ------------------------------------------------------
!||    crit24   ../engine/source/materials/mat/mat024/crit24.F
!||====================================================================
      SUBROUTINE frv(S1,S2,S3,S4,S5,S6,
     .               SM,VK0,VK,ROB,FC,RT,RC,
     .               RCT1,RCT2,AA,AC,BC,BT,
     .               ROK,TOL,FA,NINDEX,INDEX,IBUG,
     .               NEL,SEQ,ICRIT_OUTP)
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER NINDEX, INDEX(NEL),ICRIT_OUTP
      my_real :: FC,RT,RC,RCT1,RCT2,AA,AC,BC,BT,TOL
      my_real, DIMENSION(NEL) :: S1,S2,S3,S4,S5,S6,SM,VK0,ROB,ROK,FA,SEQ
      my_real, DIMENSION(NEL),INTENT(OUT):: VK
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER I, N, NEL, IBUG
      my_real  BB, DF, RF, R2, AJ3, CS3T
C=======================================================================
#include "vectorize.inc"
      DO n = 1,nindex
        i = index(n)
        IF (i > 0) THEN
          IF (sm(i) >= rt-tol ) THEN                                        
            vk(i) = one                                                               
          ELSEIF( sm(i) > rc ) THEN                                            
            vk(i) = one+(one-vk0(i))*(rct1-two*rc*sm(i)+sm(i)**2)/rct2       
          ELSEIF(sm(i) > rok(i))THEN                                              
            vk(i) = vk0(i)                                                           
          ELSE                                                                    
            vk(i) = vk0(i)*(one - ((sm(i)-rok(i))/(rob(i)-rok(i)))**2)                
          ENDIF                                                               
C
          IF (sm(i) > ac/aa) THEN                                           
            fa(i) = half*(sm(i)-ac/aa) / min(bc,bt)/fc           
          ELSEIF (sm(i) <= rob(i)) THEN                                           
            bb = max(bc,bt)                                                  
            df = sqrt(bb*bb-aa*rob(i)+ac)                                   
            rf = (-bb+df)/aa                                                   
            fa(i) = two*rf*(sm(i)-rob(i))/(rob(i)-rok(i))/fc                 
          ELSE                                                                    
            r2 = (s1(i)**2+s2(i)**2+s3(i)**2)+ two*s4(i)**2+two*s5(i)**2       
     .         + two*s6(i)**2                                                   
            IF (ibug == 0) THEN                                                   
              aj3 = s1(i)*s2(i)*s3(i)-s1(i)*s5(i)*s5(i)-s2(i)*s6(i)*s6(i)         
     .            - s3(i)*s4(i)*s4(i) + two*s4(i)*s5(i)*s6(i)                                       
            ELSE   ! old version                               
              aj3 = s1(i)*s2(i)*s3(i)-s1(i)*s5(i)*s5(i)-s2(i)*s6(i)*s6(i)         
     .            - s3(i)*s4(i)*s4(i)                                             
            ENDIF                                                                 
c
            cs3t = half * aj3*(three/(half*max(r2,em20)))**three_half                  
            cs3t = min(one,cs3t)                                                   
            cs3t = max(-one,cs3t)                                                  
            bb = half*((one -cs3t)*bc+(one +cs3t)*bt)                       
            df = sqrt(max(zero,bb*bb-aa*sm(i)+ac,zero))                     
            rf = (-bb+df)/aa                                                   
            fa(i)=(sqrt(r2)-vk(i)*rf)/fc                                          
c
!!            IF (ICRIT_OUTP == 0) THEN ! (EQUIVALENT STRESS)/CTITERION FOR OUTPUT  
!!              SEQ(I) = FA(I)                                               
!!              ICRIT_OUTP = 1                                                      
!!            ENDIF ! IF (ICRIT_OUTP == 0)                                          
          ENDIF                                                                   
c
        ENDIF                                                                   
      ENDDO
c-----------
      RETURN
      END