laser2_8F_source.html

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/.

!||====================================================================

!||    laser2         ../engine/source/loads/laser/laser2.F

!||--- called by ------------------------------------------------------

!||    laser1         ../engine/source/loads/laser/laser1.F

!||--- calls      -----------------------------------------------------

!||    initbuf        ../engine/share/resol/initbuf.F

!||    interp         ../engine/source/tools/curve/interp.F

!||--- uses       -----------------------------------------------------

!||    elbufdef_mod   ../common_source/modules/mat_elem/elbufdef_mod.F90

!||    initbuf_mod    ../engine/share/resol/initbuf.F

!||====================================================================


      SUBROUTINE laser2(NL ,N1   ,N2   ,IFUNC    ,IAFUNC ,

     .                 LAS ,XLAS ,X    ,ELBUF_TAB,PM     ,

     .                 WA  ,IPARG,IXQ  ,TF       ,NPF    ,

     .                 WFEXT)

C-----------------------------------------------

C   M o d u l e s

C-----------------------------------------------

      USE initbuf_mod

      USE elbufdef_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      "com01_c.inc"

#include      "com06_c.inc"

#include      "com08_c.inc"

#include      "param_c.inc"

C-----------------------------------------------

C   D u m m y   A r g u m e n t s

C-----------------------------------------------

      INTEGER NL, N1, N2, IFUNC, IAFUNC

      INTEGER LAS(2,*), IPARG(NPARG,*), IXQ(7,*), NPF(*)

      my_real XLAS(*),X(3,*),WA(3,*),TF(*),PM(NPROPM,*)

      TYPE(elbuf_struct_), TARGET, DIMENSION(NGROUP) :: ELBUF_TAB

      DOUBLE PRECISION, INTENT(INOUT) :: WFEXT

C-----------------------------------------------

C   L o c a l   V a r i a b l e s

C-----------------------------------------------

      INTEGER IL, NG, I, NEL, NFT, II, NP1, NPOINT, IC, NELC, NB1C, NFTC, M4C, M13C,MX, M11C

      INTEGER  MTN,IAD,ITY,NPT,JALE,ISMSTR,

     .   JEUL,JTUR,JTHE,JLAG,NVAUX,JMULT,JHBE,JIVF,JPOR,JPLA,JCLOSE,

     .   irep,iint,igtyp,jcvt,isrot,israt,isorth,isorthg,icsen,ifailure,

     .   jsms

      my_real

     .   chaleur, fi, alpha, z1, z2, z3, z4, zz, t, ddfi,

     .   dfi, de, bid, rhoc, c0, zm, zmc, y1, y2, y3, y4,

     .   d, vm, dar, fi0, vol, xkzz, rhoa2, rho0,

     .   a1,a2,aire,atom,af,tc, dfi1, xk0,hnuk,xk,rho,z,te,tscal,fifun

      TYPE(g_bufel_)  ,POINTER :: GBUF

      TYPE(L_BUFEL_)  ,POINTER :: LBUF

C-----------------------------------------------

       chaleur = xlas(1)

       fi      = xlas(2)

       alpha   = xlas(3)

       xk0     = xlas(4)

       hnuk    = xlas(5)

       dar     = xlas(6)

       tscal   = xlas(7)

C

       IF(ifunc > 0) THEN

         tscal  = tscal*tt

         npoint = (npf(ifunc+1)-npf(ifunc))/2

         CALL interp(tf(npf(ifunc)),tscal,npoint,fifun,bid)

         fi     = fi * fifun

       ENDIF

       fi0 = fi

C

       i = 1

       mx = 1

       NULLIFY(gbuf)

       te =zero

       tscal = zero

       vol = zero

       z1 = zero

       z2 = zero

       z3 = zero

       z4 = zero

       zz = zero

       jsms = 0

C------------------------------------------------------------

       DO 200 il=1,nl

         ng   =  las(1,il)

         i    =  las(2,il)

         gbuf => elbuf_tab(ng)%GBUF

         lbuf => elbuf_tab(ng)%BUFLY(1)%LBUF(1,1,1)


         CALL initbuf(

     1     iparg   ,ng      ,

     2     mtn     ,nel     ,nft     ,iad     ,ity     ,

     3     npt     ,jale    ,ismstr  ,jeul    ,jtur    ,

     4     jthe    ,jlag    ,jmult   ,jhbe    ,jivf    ,

     5     nvaux   ,jpor    ,jcvt    ,jclose  ,jpla    ,

     6     irep    ,iint    ,igtyp   ,israt   ,isrot   ,

     7     icsen   ,isorth  ,isorthg ,ifailure,jsms    )


        ii = i + nft

        z1 = x(3,ixq(2,ii))

        z2 = x(3,ixq(3,ii))

        z3 = x(3,ixq(4,ii))

        z4 = x(3,ixq(5,ii))

        zz = half * (abs(z1 - z3) + abs(z2 - z4))

C-------------------------------------------------------------

C ABSORPTION DE LA LUMIERE LASER DANS LE PLASMA  BREMSTRALUNG

C-------------------------------------------------------------

        rho      = gbuf%RHO(i)

        vol      = gbuf%VOL(i)

        te       = gbuf%TEMP(i)

        z        = lbuf%Z(i)

        mx       = ixq(1,ii)

        atom     = pm(37,mx)

        rho0     = pm(1,mx)

C

        rhoa2    = (rho/atom)**2

        xk       = xk0  * rhoa2 * (z / hnuk)**3 / sqrt(te)

        xkzz     = xk * (one - exp(-hnuk/te)) * zz

        rhoa2    = ((rho-rho0)/atom)**2

        IF(te<=ep04) xkzz = xkzz + dar * rhoa2 * zz

C

        ddfi     = (one - exp(-xkzz))

        dfi      = fi * ddfi

        fi       = fi - dfi

        de       = dfi * dt2 / zz

C

        gbuf%EINT(i) = gbuf%EINT(i) + de

        wfext    = wfext + de * vol

C

        wa(1,il) = zz

        wa(2,il) = ddfi

C

  200  CONTINUE

C

C-------------------------------------------------------------

C ABSORPTION DE LA LUMIERE LASER DANS LA CIBLE => VAPORISATION

C-------------------------------------------------------------

C

       IF(iafunc>0)THEN

        np1    = npf(iafunc)

        npoint =(npf(iafunc+1)-np1)/2

        t      = te*tscal

        CALL interp(tf(np1),t,npoint,af,bid)

        alpha  = alpha * af

       ENDIF

       dfi     = alpha * fi

       fi      = fi - dfi

       de      = dfi * dt2 / zz

C

       gbuf%EINT(i) = gbuf%EINT(i) + de

       wfext   = wfext + de * vol

C-------------------------

C VITESSE DE VAPORISATION

C-------------------------

       il       = nl+1

       ng       = las(1,il)

       ic       = las(2,il)

c

       gbuf     => elbuf_tab(ng)%GBUF

c

       nelc     = iparg(2,ng)

       nb1c     = iparg(4,ng)

       nftc     = iparg(3,ng)

       ii       = ic + nftc

       m4c      = nb1c+8*nelc+ic-1

       m11c     = nb1c+12*nelc+ic-1

       m13c     = nb1c+14*nelc+ic-1


       rhoc     = gbuf%RHO(ic)

       c0       = gbuf%EPSD(ic)


       zm       = z1 + z2 + z3 + z4

       z1       = x(3,ixq(2,ii))

       z2       = x(3,ixq(3,ii))

       z3       = x(3,ixq(4,ii))

       z4       = x(3,ixq(5,ii))

       zmc      = z1 + z2 + z3 + z4

       y1       = x(2,ixq(2,ii))

       y2       = x(2,ixq(3,ii))

       y3       = x(2,ixq(4,ii))

       y4       = x(2,ixq(5,ii))

       a1       = y2*(z3-z4)+y3*(z4-z2)+y4*(z2-z3)

       a2       = y2*(z4-z1)+y4*(z1-z2)+y1*(z2-z4)

       aire     = (a1+a2)/two


       tc       = gbuf%TEMP(ic)

       dfi1     = pm(75,mx) * (two*(te - tc)/zz) / dt2


       d        = (dfi+dfi1) / (rhoc*chaleur)


       vm       = d * aire * rhoc * fourth

       IF(zmc>zm) vm = -vm

       wa(3,n1) = wa(3,n1) + vm

       wa(3,n2) = wa(3,n2) + vm

C-------------------------

C PRESSION DE CIBLE

C-------------------------

c       NB2 = NB1+NEL

c       M2  = NB2+6*I-6

c       SY  = BUFEL(M2)

c       SZ  = BUFEL(M2+1)

c       SX  = BUFEL(M2+2)

c       P   = -(SX+SY+SZ) * THIRD

c       DP  = RHOC*C0*D

c       DP  = MIN(DP,P)

c       DP  = MAX(DP,ZERO)

c       SX  = -P + DP * HALF

c       SY  = -P + DP * HALF

c       SZ  = -P - DP

C

C-------------------------

C REFLEXION DU RAYON LASER

C-------------------------

C

      DO il=nl,1,-1

C-------------------------------------------------------------

C ABSORPTION DE LA LUMIERE LASER DANS LE PLASMA  BREMSTRALUNG

C-------------------------------------------------------------

        ng           = las(1,il)

        i            = las(2,il)

        gbuf         => elbuf_tab(ng)%GBUF

        zz           = wa(1,il)

        ddfi         = wa(2,il)

        dfi          = fi * ddfi

        fi           = fi - dfi

        de           = dfi * dt2 / zz

        gbuf%EINT(i) = gbuf%EINT(i) + de

        vol          = gbuf%VOL(i)

        wfext        = wfext + de * vol

      ENDDO

C-------------------------

      RETURN


      END

C

!||====================================================================

!||    laser3         ../engine/source/loads/laser/laser2.F

!||--- called by ------------------------------------------------------

!||    laser1         ../engine/source/loads/laser/laser1.F

!||--- calls      -----------------------------------------------------

!||    initbuf        ../engine/share/resol/initbuf.f

!||    interp         ../engine/source/tools/curve/interp.f

!||--- uses       -----------------------------------------------------

!||    elbufdef_mod   ../common_source/modules/mat_elem/elbufdef_mod.F90

!||    initbuf_mod    ../engine/share/resol/initbuf.F

!||====================================================================


      SUBROUTINE laser3(NL ,IFUNC ,

     .                 LAS ,XLAS ,X    ,ELBUF_TAB ,PM     ,

     .                 IPARG,IXQ  ,TF    ,NPF   ,WFEXT )

C-----------------------------------------------

C   M o d u l e s

C-----------------------------------------------

      USE initbuf_mod

      USE elbufdef_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      "com01_c.inc"

#include      "com06_c.inc"

#include      "com08_c.inc"

#include      "param_c.inc"

C-----------------------------------------------

C   D u m m y   A r g u m e n t s

C-----------------------------------------------

      INTEGER NL, IFUNC

      INTEGER LAS(2,*), IPARG(NPARG,*), IXQ(7,*), NPF(*)

      my_real

     .   XLAS(*),X(3,*),TF(*),PM(NPROPM,*)

      TYPE(ELBUF_STRUCT_), TARGET, DIMENSION(NGROUP) :: ELBUF_TAB

      DOUBLE PRECISION,INTENT(INOUT) :: WFEXT

C-----------------------------------------------

C   L o c a l   V a r i a b l e s

C-----------------------------------------------

      INTEGER IL, NG, I, NEL, NFT, II,

     .   npoint,

     .   mx

      INTEGER  MTN,IAD,ITY,NPT,JALE,ISMSTR,

     .   JEUL,JTUR,JTHE,JLAG,NVAUX,JMULT,JHBE,JIVF,JPOR,JPLA,JCLOSE,

     .   irep,iint,igtyp,jcvt,isrot,israt,isorth,isorthg,icsen,ifailure,

     .   jsms

      my_real

     .   fi, z1, z2, z3, z4, zz,

     .   dfi, de, bid, y1, y2, y3, y4,

     .   vol, rho0,

     .   tscal,fifun,

     .   rho,te,enerlim,ener

      TYPE(g_bufel_)  ,POINTER :: GBUF

C=======================================================================

      ENERLIM   = xlas(1)

      fi        = xlas(2)

      tscal     = xlas(7)

C

       IF(ifunc > 0) THEN

         tscal = tscal*tt

         npoint=(npf(ifunc+1)-npf(ifunc))/2

         CALL interp(tf(npf(ifunc)),tscal,npoint,fifun,bid)

         fi = fi * fifun

       ENDIF

C

      jsms = 0

      dfi  = zero

C-------------------------------------------------------------

      DO il=1,nl

        ng   = las(1,il)

        i    = las(2,il)

        gbuf => elbuf_tab(ng)%GBUF

        CALL initbuf(iparg    ,ng      ,

     2     mtn     ,nel     ,nft     ,iad     ,ity     ,

     3     npt     ,jale    ,ismstr  ,jeul    ,jtur    ,

     4     jthe    ,jlag    ,jmult   ,jhbe    ,jivf    ,

     5     nvaux   ,jpor    ,jcvt    ,jclose  ,jpla    ,

     6     irep    ,iint    ,igtyp   ,israt   ,isrot   ,

     7     icsen   ,isorth  ,isorthg ,ifailure,jsms    )

        ii   = i + nft

        mx   = ixq(1,ii)

        ener = gbuf%EINT(i)

        rho  = gbuf%RHO(i)

        vol  = gbuf%VOL(i)

        te   = gbuf%TEMP(i)

        rho0 = pm(1,mx)

        IF(ener<enerlim)THEN

          z1           = x(3,ixq(2,ii))

          z2           = x(3,ixq(3,ii))

          z3           = x(3,ixq(4,ii))

          z4           = x(3,ixq(5,ii))

          y1           = x(2,ixq(2,ii))

          y2           = x(2,ixq(3,ii))

          y3           = x(2,ixq(4,ii))

          y4           = x(2,ixq(5,ii))

          zz           = half * (abs(z1 - z3) + abs(z2 - z4))

          de           = dfi * dt2 / zz      !warning DFI is zero : need to be validated, may be wrong

          gbuf%EINT(i) = gbuf%EINT(i) + de

          wfext        = wfext + de * vol

          EXIT !and return

        ENDIF

      ENDDO

C-----------

      RETURN


      END


alpha
#define alpha
Definition eval.h:35

interp
subroutine interp(tf, tt, npoint, f, tg)
Definition interp.F:35

laser3
subroutine laser3(nl, ifunc, las, xlas, x, elbuf_tab, pm, iparg, ixq, tf, npf, wfext)
Definition laser2.F:272

laser2
subroutine laser2(nl, n1, n2, ifunc, iafunc, las, xlas, x, elbuf_tab, pm, wa, iparg, ixq, tf, npf, wfext)
Definition laser2.F:38

initbuf_mod
Definition initbuf.F:160

initbuf_mod::initbuf
subroutine initbuf(iparg, ng, mtn, llt, nft, iad, ity, npt, jale, ismstr, jeul, jtur, jthe, jlag, jmult, jhbe, jivf, mid, jpor, jcvt, jclose, jpla, irep, iint, igtyp, israt, isrot, icsen, isorth, isorthg, ifailure, jsms)
Definition initbuf.F:261

resol
subroutine resol(timers, element, nodes, coupling, af, iaf, iskwn, neth, ipart, nom_opt, kxx, ixx, ixtg, ixs, ixq, ixt, ixp, ixr, ifill, mat_elem, ims, npc, ibcl, ibfv, idum, las, laccelm, nnlink, lnlink, iparg, dd_iad, igrv, iexlnk, kinet, ipari, nprw, iconx, npby, lpby, lrivet, nstrf, ljoint, nodpor, monvol, ilink, llink, linale, neflsw, nnflsw, icut, cluster, itask, inoise, thke, damp, pm, skews, geo, eani, bufmat, bufgeo, bufsf, w, veul, fill, dfill, alph, wb, dsave, asave, msnf, tf, forc, vel, fsav, fzero, xlas, accelm, agrv, fr_wave, failwave, parts0, elbuf, rwbuf, sensors, rwsav, rby, rivet, secbuf, volmon, lambda, wa, fv, partsav, uwa, val2, phi, segvar, r, crflsw, flsw, fani, xcut, anin, tani, secfcum, bufnois, idata, rdata, iframe, kxsp, ixsp, nod2sp, ispsym, ispcond, xframe, spbuf, xspsym, vspsym, pv, fsavd, ibvel, lbvel, wasph, w16, isphio, lprtsph, lonfsph, vsphio, fbvel, lagbuf, ibcslag, iactiv, dampr, gjbufi, gjbufr, rbmpc, ibmpc, sphveln, nbrcvois, nbsdvois, lnrcvois, lnsdvois, nercvois, nesdvois, lercvois, lesdvois, npsegcom, lsegcom, nporgeo, ixtg1, npbyl, lpbyl, rbyl, igeo, ipm, madprt, madsh4, madsh3, madsol, madnod, madfail, iad_rby, fr_rby, fr_wall, iad_rby2, fr_rby2, iad_i2m, fr_i2m, addcni2, procni2, iadi2, fr_mv, iadmv2, fr_ll, fr_rl, iadcj, fr_cj, fr_sec, iad_sec, iad_cut, fr_cut, rg_cut, newfront, fr_mad, fxbipm, fxbrpm, fxbnod, fxbmod, fxbglm, fxbcpm, fxbcps, fxblm, fxbfls, fxbdls, fxbdep, fxbvit, fxbacc, fxbelm, fxbsig, fxbgrvi, fxbgrvr, eigipm, eigibuf, eigrpm, lnodpor, fr_i18, graphe, iflow, rflow, lgrav, dd_r2r, fasolfr, fr_lagf, llagf, lprw, icontact, rcontact, sh4tree, sh3tree, ipadmesh, padmesh, msc, mstg, inc, intg, ptg, iskwp, nskwp, isensp, nsensp, iaccp, naccp, ipart_state, acontact, pcontact, factiv, sh4trim, sh3trim, mscnd, incnd, ibfflux, fbfflux, rbym, irbym, lnrbym, icodrbym, ibcv, fconv, ibftemp, fbftemp, iad_rbym, fr_rbym, weight_rm, ms_ply, zi_ply, inod_pxfem, iel_pxfem, iadc_pxfem, adsky_pxfem, icode_ply, icodt_ply, iskew_ply, admsms, madclnod, nom_sect, mcpc, mcptg, dmelc, dmeltg, mssa, dmels, mstr, dmeltr, msp, dmelp, msrt, dmelrt, ibcr, fradia, res_sms, table, irbe2, lrbe2, iad_rbe2, fr_rbe2, phie, msf, procne_pxfem, iadsdp_pxfem, iadrcp_pxfem, icfield, lcfield, cfield, msz2, diag_sms, iloadp, lloadp, loadp, inod_crk, iel_crk, iadc_crk, adsky_crk, cne_crk, procne_crk, iadsdp_crk, iadrcp_crk, ibufssg_io, ibc_ply, dmint2, ibordnode, elbuf_tab, por, nodedge, iad_edge, fr_edge, fr_nbedge, crknodiad, lgauge, gauge, igaup, ngaup, nodlevxf, dd_r2r_elem, nodglobxfe, sph2sol, sol2sph, irst, dmsph, wagap, xfem_tab, elcutc, nodenr, kxfenod2elc, enrtag, rthbu f, kxig3d, ixig3d, knot, wige, wsmcomp, stack, cputime_mp_glob, cputime_mp, tab_ump, poin_ump, sol2sph_typ, irunn_bis, addcsrect, iad_frnor, fr_nor, procnor, iad_fredg, fr_edg, drape_sh4n, drape_sh3n, tab_mat, nativ0_sms, multi_fvm, segquadfr, ms_2d, h3d_data, subsets, igrnod, igrbric, igrquad, igrsh4n, igrsh3n, igrtruss, igrbeam, igrspring, igrpart, igrsurf, forneqs, nloc_dmg, iskwp_l, knotlocpc, knotlocel, pinch_data, tag_skins6, ale_connectivity, xcell, xface, ne_nercvois, ne_nesdvois, ne_lercvois, ne_lesdvois, ibcscyc, lbcscyc, t_monvol, id_global_vois, face_vois, dynain_data, fcont_max, ebcs_tab, diffusion, kloadpinter, loadpinter, dgaploadint, drapeg, user_windows, output, interfaces, dt, loads, python, dpl0cld, vel0cld, ndamp_vrel, id_damp_vrel, fr_damp_vrel, ndamp_vrel_rbyg, names_and_titles, unitab, liflow, lrflow, glob_therm, pblast, rbe3)
Definition resol.F:633

initbuf
subroutine initbuf(iparg, ng, mtn, llt, nft, iad, ity, npt, jale, ismstr, jeul, jtur, jthe, jlag, jmult, jhbe, jivf, jpor, jcvt, jclose, jpla, irep, iint, igtyp, israt, isrot, icsen, isorth, isorthg, ifailure)
Definition initbuf.F:38