rkini3.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/.
!||====================================================================
!||    rkini3                 ../starter/source/elements/spring/rkini3.f
!||--- called by ------------------------------------------------------
!||    rinit3                 ../starter/source/elements/spring/rinit3.F
!||--- calls      -----------------------------------------------------
!||    ancmsg                 ../starter/source/output/message/message.F
!||    fretitl2               ../starter/source/starter/freform.f
!||--- uses       -----------------------------------------------------
!||    message_mod            ../starter/share/message_module/message_mod.F
!||====================================================================
      SUBROUTINE rkini3(IFUNCT  ,NPC     ,PLD     ,XK      ,ECROU   , 
     .                  IGEO ,A       ,LSCALE  ,ID,TITR,NOM_OPT)
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE message_mod
      USE names_and_titles_mod , ONLY : nchartitle
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      "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-----------------------------------------------
      INTEGER IFUNCT,NPC(*),IGEO(NPROPGI)
      my_real
     .   xk,ecrou,a,lscale
      my_real
     .   pld(*)
      INTEGER ID,ID1
      CHARACTER(LEN=NCHARTITLE)::TITR,TITR1
      INTEGER NOM_OPT(LNOPT1,*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER NPOINT, J, J1, HARD,NUMPROP
      my_real
     .   a1, b1, a2, b2, xk_ini
C=======================================================================
      numprop=igeo(1)
      xk_ini=xk
 
      IF(ifunct==0) RETURN
        npoint=(npc(ifunct+1)-npc(ifunct))/2
        DO 50 j=2,npoint
        j1=2*(j-2)
        a1=pld(npc(ifunct)+j1)
        b1=pld(npc(ifunct)+j1+1)
        a2=pld(npc(ifunct)+j1+2)
        b2=pld(npc(ifunct)+j1+3)
        xk= max(xk,lscale*(b2-b1)/(a2-a1))
  50    CONTINUE
C
        hard=ecrou
        IF(hard/=0)THEN
          IF(xk_ini<xk)THEN
            CALL fretitl2(titr1,nom_opt(lnopt1-ltitr+1,ifunct),ltitr)
            CALL ancmsg(msgid=506,
     .                  msgtype=msgwarning,
     .                  anmode=aninfo_blind_1,
     .                  i1=id,
     .                  c1=titr,
     .                  r1=xk_ini,
     .                  r2=xk,
     .                  r3=xk,
     .                  i2=npc(nfunct+ifunct+1),
     .                  c2=titr1,
     .                  prmod=msg_cumu)
          ENDIF
        ENDIF
C
      RETURN
      END