OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
hm_read_visc_prony.F File Reference
#include "implicit_f.inc"
#include "units_c.inc"
#include "com04_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine hm_read_visc_prony (visc, ivisc, ntable, table, mat_id, unitab, lsubmodel)
subroutine lm_least_square_prony (mat_id, nprony, table, fct_id, xgscale, ygscale, g, beta, cost, deriv, ishape, ginfini)
subroutine lm_least_square_prony_2 (mat_id, nprony, table, fct_ids, xgs_scale, ygs_scale, fct_idl, xgl_scale, ygl_scale, g, beta, cost, deriv, ishape, ginfini)
recursive subroutine qsort (a, idx, first, last)

Function/Subroutine Documentation

◆ hm_read_visc_prony()

subroutine hm_read_visc_prony ( type (visc_param_), intent(inout) visc,
integer, intent(in) ivisc,
integer, intent(in) ntable,
type (ttable), dimension(ntable), intent(inout) table,
integer, intent(in) mat_id,
type (unit_type_), intent(in) unitab,
type (submodel_data), dimension(*), intent(in) lsubmodel )

Definition at line 42 of file hm_read_visc_prony.F.

44C-----------------------------------------------
45C M o d u l e s
46C-----------------------------------------------
47 USE visc_param_mod
48 USE unitab_mod
49 USE message_mod
50 USE submodel_mod
51 USE hm_option_read_mod
52 USE table_mod
53C-----------------------------------------------
54C I m p l i c i t T y p e s
55C-----------------------------------------------
56#include "implicit_f.inc"
57C-----------------------------------------------
58C C o m m o n B l o c k s
59C-----------------------------------------------
60#include "units_c.inc"
61C-----------------------------------------------
62C D u m m y A r g u m e n t s
63C-----------------------------------------------
64 INTEGER ,INTENT(IN) :: IVISC
65 INTEGER ,INTENT(IN) :: NTABLE
66 INTEGER ,INTENT(IN) :: MAT_ID
67 TYPE (VISC_PARAM_) ,INTENT(INOUT) :: VISC
68 TYPE (UNIT_TYPE_) ,INTENT(IN) :: UNITAB
69 TYPE (SUBMODEL_DATA),INTENT(IN) :: LSUBMODEL(*)
70 TYPE (TTABLE) ,INTENT(INOUT) :: TABLE(NTABLE)
71C-----------------------------------------------
72C L o c a l V a r i a b l e s
73C-----------------------------------------------
74 INTEGER :: I,NUPARAM,NIPARAM,NPRONY,NUVAR,IMOD,ITAB,ISHAPE,
75 . FctID_G,FctID_K,FctID_Gs,FctID_Ks,FctID_Gl,FctID_Kl
76 my_real :: g(100),beta(100),k(100),betak(100)
77 my_real :: kv,costfg,costfk,derivg,derivk,ginfini,kinfini,
78 . xgscale,xkscale,xgscale_unit,xkscale_unit,
79 . ygscale,ykscale,ygscale_unit,ykscale_unit,
80 . xgs_scale,ygs_scale,xgs_scale_unit,ygs_scale_unit,
81 . xgl_scale,ygl_scale,xgl_scale_unit,ygl_scale_unit,
82 . xks_scale,yks_scale,xks_scale_unit,yks_scale_unit,
83 . xkl_scale,ykl_scale,xkl_scale_unit,ykl_scale_unit
84C
85 LOGICAL :: IS_AVAILABLE,IS_ENCRYPTED
86C=======================================================================
87 is_encrypted = .false.
88 is_available = .false.
89
90 CALL hm_option_is_encrypted(is_encrypted)
91C======================================
92 visc%ILAW = ivisc
93C
94 ! Table initialization
95 g(1:100) = zero
96 beta(1:100) = zero
97 k(1:100) = zero
98 betak(1:100) = zero
99
100C
101 !IFLAG = 0 this flag was dedicated to keep old fomrulation for version older than
102 ! 1st Card - Flags and prony order
103 CALL hm_get_intv ('Model_Order' ,nprony ,is_available,lsubmodel)
104 CALL hm_get_floatv ('MAT_K' ,kv ,is_available,lsubmodel,unitab)
105 CALL hm_get_intv ('MAT_Itab' ,itab ,is_available,lsubmodel)
106 IF (itab > 2) itab = 0
107 CALL hm_get_intv ('MAT_Ishape' ,ishape ,is_available,lsubmodel)
108C
109 IF (nprony == 0) CALL ancmsg(msgid=2026,msgtype=msgerror,
110 . anmode=aninfo_blind_1,i1=mat_id)
111C
112 IF (ishape > 1) ishape = 0
113C
114 ! 2nd Card - Input depending on flags
115 ! =======================================================================================
116 ! Tabulated inputs
117 ! =======================================================================================
118 ! -> Itab = 1 : functions of time
119 IF (itab == 1) THEN
120 !----------------------------------------------------------------------------------
121 ! -> Shear modulus VS time
122 !----------------------------------------------------------------------------------
123 CALL hm_get_intv ('Fct_G' ,fctid_g,is_available,lsubmodel)
124 CALL hm_get_floatv ('XGscale',xgscale,is_available,lsubmodel,unitab)
125 IF (xgscale == zero) THEN
126 CALL hm_get_floatv_dim('XGscale',xgscale_unit,is_available, lsubmodel, unitab)
127 xgscale = one * xgscale_unit
128 ENDIF
129 CALL hm_get_floatv ('YGscale',ygscale ,is_available,lsubmodel,unitab)
130 IF (ygscale == zero) THEN
131 CALL hm_get_floatv_dim('YGscale' ,ygscale_unit,is_available, lsubmodel, unitab)
132 ygscale = one * ygscale_unit
133 ENDIF
134 !----------------------------------------------------------------------------------
135 ! -> Bulk modulus VS time
136 !----------------------------------------------------------------------------------
137 CALL hm_get_intv ('Fct_K' ,fctid_k,is_available,lsubmodel)
138 CALL hm_get_floatv ('XKscale',xkscale,is_available,lsubmodel,unitab)
139 IF (xkscale == zero) THEN
140 CALL hm_get_floatv_dim('XKscale',xkscale_unit,is_available, lsubmodel, unitab)
141 xkscale = one * xkscale_unit
142 ENDIF
143 CALL hm_get_floatv ('YKscale',ykscale ,is_available,lsubmodel,unitab)
144 IF (ykscale == zero) THEN
145 CALL hm_get_floatv_dim('YKscale' ,ykscale_unit,is_available, lsubmodel, unitab)
146 ykscale = one * ykscale_unit
147 ENDIF
148 !----------------------------------------------------------------------------------------
149 ! Fit Prony series parameters to approximate tabulated functions by Least Squares method
150 !----------------------------------------------------------------------------------------
151 IF ((fctid_g > 0).AND.(nprony > 0)) THEN
152 CALL lm_least_square_prony(mat_id ,nprony ,table ,fctid_g ,xgscale ,ygscale ,
153 . g ,beta ,costfg ,derivg ,ishape ,ginfini )
154 ENDIF
155 IF ((fctid_k > 0).AND.(kv == zero).AND.(nprony > 0)) THEN
156 CALL lm_least_square_prony(mat_id ,nprony ,table ,fctid_k ,xkscale ,ykscale ,
157 . k ,betak ,costfk ,derivk ,ishape ,kinfini )
158 ENDIF
159 ! -> Itab = 2 ! loss and storage moduli as functions of frequencies
160 ELSEIF (itab == 2) THEN
161 !----------------------------------------------------------------------------------
162 ! -> Shear storage modulus VS frequency
163 !----------------------------------------------------------------------------------
164 CALL hm_get_intv ('Fct_Gs' ,fctid_gs ,is_available,lsubmodel)
165 CALL hm_get_floatv ('XGs_scale' ,xgs_scale ,is_available,lsubmodel,unitab)
166 IF (xgs_scale == zero) THEN
167 CALL hm_get_floatv_dim('XGs_scale',xgs_scale_unit,is_available, lsubmodel, unitab)
168 xgs_scale = one * xgs_scale_unit
169 ENDIF
170 CALL hm_get_floatv ('YGs_scale' ,ygs_scale ,is_available,lsubmodel,unitab)
171 IF (ygs_scale == zero) THEN
172 CALL hm_get_floatv_dim('YGs_scale',ygs_scale_unit,is_available, lsubmodel, unitab)
173 ygs_scale = one * ygs_scale_unit
174 ENDIF
175 !----------------------------------------------------------------------------------
176 ! -> Shear loss modulus VS frequency
177 !----------------------------------------------------------------------------------
178 CALL hm_get_intv ('Fct_Gl' ,fctid_gl ,is_available,lsubmodel)
179 CALL hm_get_floatv ('XGl_scale' ,xgl_scale ,is_available,lsubmodel,unitab)
180 IF (xgl_scale == zero) THEN
181 CALL hm_get_floatv_dim('XGl_scale',xgl_scale_unit,is_available, lsubmodel, unitab)
182 xgl_scale = one * xgl_scale_unit
183 ENDIF
184 CALL hm_get_floatv ('YGl_scale' ,ygl_scale ,is_available,lsubmodel,unitab)
185 IF (ygl_scale == zero) THEN
186 CALL hm_get_floatv_dim('YGl_scale',ygl_scale_unit,is_available, lsubmodel, unitab)
187 ygl_scale = one * ygl_scale_unit
188 ENDIF
189 !----------------------------------------------------------------------------------
190 ! -> Bulk Storage Modulus vs Frequency
191 !----------------------------------------------------------------------------------
192 CALL hm_get_intv ('Fct_Ks' ,fctid_ks ,is_available,lsubmodel)
193 CALL hm_get_floatv ('XKs_scale' ,xks_scale ,is_available,lsubmodel,unitab)
194 IF (xks_scale == zero) THEN
195 CALL hm_get_floatv_dim('XKs_scale',xks_scale_unit,is_available, lsubmodel, unitab)
196 xks_scale = one * xks_scale_unit
197 ENDIF
198 CALL hm_get_floatv ('YKs_scale' ,yks_scale ,is_available,lsubmodel,unitab)
199 IF (yks_scale == zero) THEN
200 CALL hm_get_floatv_dim('YKs_scale',yks_scale_unit,is_available, lsubmodel, unitab)
201 yks_scale = one * yks_scale_unit
202 ENDIF
203 !----------------------------------------------------------------------------------
204 ! -> Bulk loss modulus VS frequency
205 !----------------------------------------------------------------------------------
206 CALL hm_get_intv ('Fct_Kl' ,fctid_kl ,is_available,lsubmodel)
207 CALL hm_get_floatv ('XKl_scale' ,xkl_scale ,is_available,lsubmodel,unitab)
208 IF (xkl_scale == zero) THEN
209 CALL hm_get_floatv_dim('XKl_scale',xkl_scale_unit,is_available, lsubmodel, unitab)
210 xkl_scale = one * xkl_scale_unit
211 ENDIF
212 CALL hm_get_floatv ('YKl_scale' ,ykl_scale ,is_available,lsubmodel,unitab)
213 IF (ykl_scale == zero) THEN
214 CALL hm_get_floatv_dim('YKl_scale',ykl_scale_unit,is_available, lsubmodel, unitab)
215 ykl_scale = one * ykl_scale_unit
216 ENDIF
217 !----------------------------------------------------------------------------------------
218 ! Fit Prony series parameters to approximate tabulated functions by Least Squares method
219 !----------------------------------------------------------------------------------------
220 IF ((fctid_gs > 0).AND.(fctid_gl > 0).AND.(nprony > 0)) THEN
221 CALL lm_least_square_prony_2(mat_id ,nprony ,table ,fctid_gs ,xgs_scale,ygs_scale,
222 . fctid_gl ,xgl_scale,ygl_scale,g ,beta ,costfg ,
223 . derivg ,ishape ,ginfini )
224 ENDIF
225 IF ((fctid_ks > 0).AND.(fctid_kl > 0).AND.(nprony > 0).AND.(kv == zero)) THEN
226 CALL lm_least_square_prony_2(mat_id ,nprony ,table ,fctid_ks ,xks_scale,yks_scale,
227 . fctid_kl ,xkl_scale,ykl_scale,k ,betak ,costfk ,
228 . derivk ,ishape ,kinfini )
229 ENDIF
230 ! =======================================================================================
231 ! Classical input
232 ! =======================================================================================
233 ! -> Itab = 0 ! classical input of prony series
234 ELSE
235 ishape = 0
236 IF(nprony > 0) THEN
237 DO i=1,nprony
238 CALL hm_get_float_array_index('Fport1' ,g(i) ,i,is_available,lsubmodel,unitab)
239 CALL hm_get_float_array_index('Fporp1' ,beta(i) ,i,is_available,lsubmodel,unitab)
240 CALL hm_get_float_array_index('Ki' ,k(i) ,i,is_available,lsubmodel,unitab)
241 CALL hm_get_float_array_index('Beta_ki',betak(i),i,is_available,lsubmodel,unitab)
242 ENDDO
243 ENDIF
244 ENDIF
245C
246 ! Taking into account the infinite value shape (+ 1 prony function with beta = 0)
247 IF ((itab /= 0) .AND. (ishape == 1)) THEN
248 nprony = nprony + 1
249 ENDIF
250c-------------------------------------------------
251c Storing parameters in UPARAM/IPARAM tables
252c-------------------------------------------------
253
254 nuvar = 7*nprony
255 niparam = 2
256 nuparam = 4*nprony + 1
257 ALLOCATE (visc%UPARAM(nuparam))
258 ALLOCATE (visc%IPARAM(niparam))
259 visc%NUVAR = nuvar
260 visc%NUPARAM = nuparam
261 visc%NIPARAM = niparam
262
263 imod = 0
264 visc%UPARAM(1) = kv
265 DO i=1,nprony
266 visc%UPARAM(1 + i) = g(i)
267 visc%UPARAM(1 + nprony + i) = beta(i)
268 visc%UPARAM(1 + 2*nprony + i) = k(i)
269 visc%UPARAM(1 + 3*nprony + i) = betak(i)
270 IF (k(i) > zero) imod = 1
271 ENDDO
272 visc%IPARAM(1) = nprony
273 visc%IPARAM(2) = imod
274c-----------------------------------------------------------------------
275c Output
276c-----------------------------------------------------------------------
277 IF (is_encrypted)THEN
278 WRITE(iout,'(5X,A,//)')'CONFIDENTIAL DATA'
279 ELSE
280C
281 IF(nprony > 0) THEN
282 WRITE(iout,1000)
283 IF(imod == 0) THEN
284 WRITE(iout,1100) kv,nprony-ishape
285 IF (itab > 0) THEN
286 WRITE(iout,1500) itab,ishape
287 IF (ishape == 1) WRITE(iout,3000) ginfini
288 IF (itab == 1) THEN
289 WRITE(iout,1600) fctid_g,xgscale,ygscale,costfg,derivg
290 ELSEIF (itab == 2) THEN
291 WRITE(iout,2000) fctid_gs,xgs_scale,ygs_scale,
292 . fctid_gl,xgl_scale,ygl_scale,
293 . costfg,derivg
294 ENDIF
295 ENDIF
296 DO i=1,nprony-ishape
297 WRITE(iout,1150) i
298 WRITE(iout,1200) g(i+ishape),beta(i+ishape)
299 ENDDO
300 ELSE
301 WRITE(iout,1300) nprony-ishape
302 IF (itab > 0) THEN
303 WRITE(iout,1500) itab,ishape
304 IF (itab == 1) THEN
305 IF (ishape == 1) WRITE(iout,3000) ginfini
306 WRITE(iout,1600) fctid_g,xgscale,ygscale,costfg,derivg
307 IF (ishape == 1) WRITE(iout,3500) kinfini
308 WRITE(iout,1800) fctid_k,xkscale,ykscale,costfk,derivk
309 ELSEIF (itab == 2) THEN
310 IF (ishape == 1) WRITE(iout,3000) ginfini
311 WRITE(iout,2000) fctid_gs,xgs_scale,ygs_scale,
312 . fctid_gl,xgl_scale,ygl_scale,
313 . costfg,derivg
314 IF (ishape == 1) WRITE(iout,3500) kinfini
315 WRITE(iout,2500) fctid_ks,xks_scale,yks_scale,
316 . fctid_kl,xkl_scale,ykl_scale,
317 . costfk,derivk
318 ENDIF
319 ENDIF
320 DO i=1,nprony-ishape
321 WRITE(iout,1150) i
322 WRITE(iout,1200) g(i+ishape),beta(i+ishape)
323 WRITE(iout,1400) k(i+ishape),betak(i+ishape)
324 ENDDO
325 ENDIF
326 ENDIF
327 ENDIF
328C-----------
329 1000 FORMAT(
330 & 5x,' PRONY SERIES MODEL :' ,/,
331 & 5x,' --------------------- ' ,/)
332 1100 FORMAT(
333 & 5x,'BULK MODULUS FOR VISCO ELASTIC MATERIAL . . . . . . . . . . . . . . . =',1pg20.13/
334 & 5x,'ORDER OF PRONY SERIES . . . . . . . . . . . . . . . . . . . . . . . . =',i10/)
335 1150 FORMAT(
336 & 5x,' ----------------------------------------------------------------------'/
337 & 5x,' PARAMETERS FOR PRONY FUNCTION NUMBER #',i10/
338 & 5x,' ----------------------------------------------------------------------'/)
339 1200 FORMAT(
340 & 5x,'SHEAR RELAXATION G MODULUS . . . . . . . . . . . . . . . . . . . . . = '1pg20.13/
341 & 5x,'BETA DECAY SHEAR MODULUS . . . . . . . . . . . . . . . . . . . . . . =',1pg20.13)
342 1300 FORMAT(
343 & 5x,'ORDER OF PRONY SERIES . . . . . . . . . . . . . . . . . . . . . . . . =',i10//)
344 1400 FORMAT(
345 & 5x,'BULK RELAXATION K MODULUS . . . . . . . . . . . . . . . . . . . . . . = '1pg20.13/
346 & 5x,'BETAK DECAY BULK MODULUS . . . . . . . . . . . . . . . . . . . . . . =',1pg20.13//)
347 1500 FORMAT(
348 & 5x,'TABULATED PRONY SERIES FLAG . . . . . . . . . . . . . . . . . . . . .=',i10/
349 & 5x,' ITAB=1 FITTING FROM MODULUS VS TIME CURVES'/
350 & 5x,' ITAB=2 FITTING FROM STORAGE AND LOSS MODULI VS FREQUENCY CURVES'/
351 & 5x,'SHAPE PRONY SERIES FLAG . . . . . . . . . . . . . . . . . . . . . . .=',i10/
352 & 5x,' ISHAPE=0 WITHOUT INFINITE MODULUS (DEFAULT)'/
353 & 5x,' ISHAPE=1 WITH INFINITE MODULUS'/)
354 1600 FORMAT(
355 & 5x,'LEAST SQUARE FITTING FROM SHEAR MODULUS G FUNCTION ID. . . . . . . . .= 'i10/
356 & 5x,'TIME SCALE FACTOR FOR SHEAR MODULUS . . . . . . . . . . . . . . . . .= '1pg20.13/
357 & 5x,'SCALE FACTOR FOR SHEAR MODULUS . . . . . . . . . . . . . . . . . . . .= '1pg20.13/
358 & 5x,'FINAL COST FUNCTION VALUE . . . . . . . . . . . . . . . . . . . . . .= '1pg20.13/
359 & 5x,'FINAL DERIVATIVE VALUE . . . . . . . . . . . . . . . . . . . . . . . .= '1pg20.13/)
360 1800 FORMAT(
361 & 5x,'LEAST SQUARE FITTING FROM BULK MODULUS K FUNCTION ID . . . . . . . . .= 'i10/
362 & 5x,'TIME SCALE FACTOR FOR BULK MODULUS . . . . . . . . . . . . . . . . . .= '1pg20.13/
363 & 5x,'SCALE FACTOR FOR BULK MODULUS . . . . . . . . . . . . . . . . . . . .= '1pg20.13/
364 & 5x,'FINAL COST FUNCTION VALUE . . . . . . . . . . . . . . . . . . . . . .= '1pg20.13/
365 & 5x,'FINAL DERIVATIVE VALUE . . . . . . . . . . . . . . . . . . . . . . . .= '1pg20.13/)
366 2000 FORMAT(
367 & 5x,'LEAST SQUARE FITTING FROM STORAGE SHEAR MODULUS GL FUNCTION ID . . . .= 'i10/
368 & 5x,'FREQUENCY SCALE FACTOR FOR STORAGE SHEAR MODULUS . . . . . . . . . . .= '1pg20.13/
369 & 5x,'SCALE FACTOR FOR STORAGE SHEAR MODULUS . . . . . . . . . . . . . . . .= '1pg20.13/
370 & 5x,'LEAST SQUARE FITTING FROM LOSS SHEAR MODULUS GS FUNCTION ID . . . . .= 'i10/
371 & 5x,'FREQUENCY SCALE FACTOR FOR LOSS SHEAR MODULUS . . . . . . . . . . . .= '1pg20.13/
372 & 5x,'SCALE FACTOR FOR LOSS SHEAR MODULUS FUNCTION . . . . . . . . . . . . .= '1pg20.13/
373 & 5x,'FINAL COST FUNCTION VALUE . . . . . . . . . . . . . . . . . . . . . .= '1pg20.13/
374 & 5x,'FINAL DERIVATIVE VALUE . . . . . . . . . . . . . . . . . . . . . . . .= '1pg20.13/)
375 2500 FORMAT(
376 & 5x,'LEAST SQUARE FITTING FROM STORAGE BULK MODULUS KL FUNCTION ID . . . .= 'i10/
377 & 5x,'FREQUENCY SCALE FACTOR FOR STORAGE BULK MODULUS . . . . . . . . . . .= '1pg20.13/
378 & 5x,'SCALE FACTOR FOR STORAGE BULK MODULUS . . . . . . . . . . . . . . . .= '1pg20.13/
379 & 5x,'LEAST SQUARE FITTING FROM LOSS BULK MODULUS GS FUNCTION ID . . . . . .= 'i10/
380 & 5x,'FREQUENCY SCALE FACTOR FOR LOSS BULK MODULUS . . . . . . . . . . . . .= '1pg20.13/
381 & 5x,'SCALE FACTOR FOR LOSS BULK MODULUS FUNCTION . . . . . . . . . . . . .= '1pg20.13/
382 & 5x,'FINAL COST FUNCTION VALUE . . . . . . . . . . . . . . . . . . . . . .= '1pg20.13/
383 & 5x,'FINAL DERIVATIVE VALUE . . . . . . . . . . . . . . . . . . . . . . . .= '1pg20.13/)
384 3000 FORMAT(
385 & 5x,'SHEAR MODULUS INFINITE VALUE GINF . . . . . . . . . . . . . . . . . .= '1pg20.13/)
386 3500 FORMAT(
387 & 5x,'BULK MODULUS INFINITE VALUE KINF . . . . . . . . . . . . . . . . . . .= '1pg20.13/)
388
389 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
hm_get_float_array_index
subroutine hm_get_float_array_index(name, rval, index, is_available, lsubmodel, unitab)
Definition hm_get_float_array_index.F:105
hm_get_floatv
subroutine hm_get_floatv(name, rval, is_available, lsubmodel, unitab)
Definition hm_get_floatv.F:418
hm_get_floatv_dim
subroutine hm_get_floatv_dim(name, dim_fac, is_available, lsubmodel, unitab)
Definition hm_get_floatv_dim.F:161
hm_get_intv
subroutine hm_get_intv(name, ival, is_available, lsubmodel)
Definition hm_get_intv.F:528
hm_option_is_encrypted
subroutine hm_option_is_encrypted(is_encrypted)
Definition hm_option_is_encrypted.F:288
lm_least_square_prony
subroutine lm_least_square_prony(mat_id, nprony, table, fct_id, xgscale, ygscale, g, beta, cost, deriv, ishape, ginfini)
Definition hm_read_visc_prony.F:404
lm_least_square_prony_2
subroutine lm_least_square_prony_2(mat_id, nprony, table, fct_ids, xgs_scale, ygs_scale, fct_idl, xgl_scale, ygl_scale, g, beta, cost, deriv, ishape, ginfini)
Definition hm_read_visc_prony.F:660
hm_option_read_mod
Definition hm_option_read_mod.F:412
message_mod
Definition message_mod.F:1257
submodel_mod
Definition submodel_mod.F:717
table_mod
Definition table_mod.F:113
unitab_mod
Definition unitab_mod.F:517
ancmsg
subroutine ancmsg(msgid, msgtype, anmode, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, r1, r2, r3, r4, r5, r6, r7, r8, r9, c1, c2, c3, c4, c5, c6, c7, c8, c9, prmode)
Definition message.F:895

◆ lm_least_square_prony()

subroutine lm_least_square_prony ( integer, intent(in) mat_id,
integer, intent(in) nprony,
type(ttable), dimension(ntable) table,
integer, intent(in) fct_id,
xgscale,
ygscale,
dimension(100) g,
dimension(100) beta,
cost,
deriv,
integer, intent(in) ishape,
ginfini )

Definition at line 402 of file hm_read_visc_prony.F.

404C-----------------------------------------------
405C M o d u l e s
406C-----------------------------------------------
407 USE table_mod
408 USE message_mod
409C-----------------------------------------------
410C I m p l i c i t T y p e s
411C-----------------------------------------------
412#include "implicit_f.inc"
413#include "com04_c.inc"
414C-----------------------------------------------
415C Dummy arguments
416C-----------------------------------------------
417 INTEGER, INTENT(IN) :: NPRONY,FCT_ID,MAT_ID,ISHAPE
418 my_real
419 . xgscale,ygscale,cost,deriv,ginfini
420 my_real, DIMENSION(100) :: g,beta
421 TYPE(TTABLE) TABLE(NTABLE)
422C-----------------------------------------------
423C Local arguments
424C-----------------------------------------------
425 INTEGER I,II,INFO,SIZE_TIME,NITER
426 INTEGER, DIMENSION(:), ALLOCATABLE :: IPIV
427 DOUBLE PRECISION ::
428 . RI2,RI2_OLD,MXVALT,MXVALY,LAMBDA,
429 . JACTDY_N2,RHO,NU,DENOM
430 DOUBLE PRECISION, PARAMETER :: EPS1 = 1.0d-8
431 DOUBLE PRECISION, PARAMETER :: EPS2 = 1.0d-10
432 DOUBLE PRECISION, PARAMETER :: ALPHA = 0.5d0
433 DOUBLE PRECISION, PARAMETER :: MXITER = 10000
434 DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: XI,FXI,DELTAY,JACTDY,YI,TIME,
435 . XI_TR,FXI_TR,VECT,MU
436 DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE :: JAC,JACTJAC,JACT,ID
437 LOGICAL :: CONV,FOUND
438C
439 ! Find the function and recover the experimental data
440 found = .false.
441 size_time = 0
442 DO i = 1,ntable
443 IF (table(i)%NOTABLE == fct_id) THEN
444 ! Number of data points
445 size_time = SIZE(table(i)%X(1)%VALUES)
446 ALLOCATE(yi(size_time),time(size_time))
447 ! Recovering data (time and modulus)
448 DO ii = 1,size_time
449 time(ii) = table(i)%X(1)%VALUES(ii)*xgscale
450 yi(ii) = table(i)%Y%VALUES(ii)*ygscale
451 ENDDO
452 ! Normalizing the curves to improve the optimization
453 mxvalt = maxval(time)
454 mxvaly = maxval(yi)
455 ! Considering infinite value shape
456 IF (ishape == 1) THEN
457 ginfini = yi(size_time)/mxvaly
458 ELSE
459 ginfini = zero
460 ENDIF
461 time = time/mxvalt
462 yi = yi/mxvaly
463 found = .true.
464 EXIT
465 ENDIF
466 ENDDO
467 IF (.NOT.found) THEN
468 CALL ancmsg(msgid=1928,msgtype=msgerror,
469 . anmode=aninfo_blind_1,i1=mat_id,i2=fct_id)
470 ENDIF
471C
472 ! Order of prony series to high for the number of data points
473 IF (2*nprony >= size_time) THEN
474 CALL ancmsg(msgid=1921,msgtype=msgerror,
475 . anmode=aninfo_blind_1,i1=mat_id,i2=nprony,
476 . i3=size_time,i4=floor(size_time/two))
477 ENDIF
478C
479 ! Allocation and initialization of the vectors
480 ALLOCATE(xi(2*nprony),xi_tr(2*nprony),jac(size_time,2*nprony),fxi(size_time),
481 . deltay(size_time),jactjac(2*nprony,2*nprony),id(2*nprony,2*nprony),
482 . jactdy(2*nprony),ipiv(2*nprony),jact(2*nprony,size_time),fxi_tr(size_time),
483 . vect(2*nprony),mu(2*nprony))
484C
485 ! Initialization of parameters value
486 DO i = 1,nprony
487 xi(2*i-1) = one/(i+ishape)
488 xi(2*i) = i-1+ishape
489 ENDDO
490C
491 ! Identity matrix
492 id = zero
493 DO i = 1,2*nprony
494 id(i,i) = one
495 ENDDO
496C
497 ! Initialization of the residues
498 fxi(:) = ginfini
499 DO i = 1,size_time
500 DO ii = 1,nprony
501 fxi(i) = fxi(i) + xi(2*ii-1)*exp(-xi(2*ii)*time(i))
502 jac(i,2*ii-1) = -exp(-xi(2*ii)*time(i))
503 jac(i,2*ii) = time(i)*xi(2*ii-1)*exp(-xi(2*ii)*time(i))
504 ENDDO
505 ENDDO
506 deltay = yi - fxi
507C
508 ! Computation of the squared sum of residues
509 ri2 = dot_product(deltay,deltay)
510C
511 ! Initialization of the damping parameter and the convergence criterion
512 lambda = maxval(jac)
513 nu = two
514 conv = .false.
515 niter = 0
516C
517 !-------------------------------------------------------------------------------------
518 ! Levenberg Marquardt Algorithm + Line-search
519 !-------------------------------------------------------------------------------------
520#ifndef WITHOUT_LINALG
521 DO WHILE ((.NOT.conv).AND.(niter<mxiter))
522C
523 ! a) Compute the Jacobian matrix products
524 ! -> Transpose of Jacobian matrix
525 jact = transpose(jac)
526 ! -> JtJ product
527 jactjac = matmul(jact,jac)
528 ! -> Adding the damping parameter
529 jactjac = jactjac + lambda*id
530 ! -> Compute the gradient of residues
531 jactdy = -matmul(jact,deltay)
532c
533 ! b) Compute the trial values of XI
534 CALL dgesv(2*nprony, 1, jactjac, 2*nprony, ipiv, jactdy , 2*nprony, info)
535 xi_tr = xi + jactdy
536C
537 ! Checking convergence
538 IF (sqrt(dot_product(jactdy,jactdy)) <= eps2*(sqrt(dot_product(xi,xi))+eps2)) THEN
539 conv = .true.
540 ELSE
541 ! c) Compute the trial values of the function
542 fxi_tr(:) = ginfini
543 DO i = 1,size_time
544 DO ii = 1,nprony
545 fxi_tr(i) = fxi_tr(i) + xi_tr(2*ii-1)*exp(-xi_tr(2*ii)*time(i))
546 ENDDO
547 ENDDO
548 ! d) Computation of the squared sum of residues
549 ri2_old = ri2
550 ri2 = dot_product(yi-fxi_tr,yi-fxi_tr)
551C
552 ! Compute gain ration
553 vect = matmul(jact,deltay)
554 vect = lambda*jactdy - vect
555 denom = dot_product(jactdy,vect)
556 rho = (ri2_old - ri2) / max(denom,em20)
557C
558 ! e) Update parameters
559 ! -> Step accepted
560 IF ((rho > zero).AND.(info == 0)) THEN
561 ! Update damping parameter
562 lambda = lambda*max(third,one-(two*rho-one)**3)
563 nu = two
564 ! Update XI vector with line search to be sure that XI >= ZERO
565 ! -> Compute the MU vector
566 DO i = 1,2*nprony
567 IF (jactdy(i)>=zero) THEN
568 mu(i) = one
569 ELSE
570 mu(i) = min(one,((one-alpha)/(-jactdy(i)))*xi(i))
571 ENDIF
572 xi(i) = xi(i) + mu(i)*jactdy(i)
573 ENDDO
574 ! Update FXI vector
575 fxi(:) = ginfini
576 DO i = 1,size_time
577 DO ii = 1,nprony
578 fxi(i) = fxi(i) + xi(2*ii-1)*exp(-xi(2*ii)*time(i))
579 ENDDO
580 ENDDO
581 ! Update residue vector
582 deltay = yi - fxi
583 ri2 = dot_product(deltay,deltay)
584 ! Update the Jacobian matrix
585 jac = zero
586 DO i = 1,size_time
587 DO ii = 1,nprony
588 jac(i,2*ii-1) = -exp(-xi(2*ii)*time(i))
589 jac(i,2*ii) = time(i)*xi(2*ii-1)*exp(-xi(2*ii)*time(i))
590 ENDDO
591 ENDDO
592 jact = transpose(jac)
593 ! -> Step not accepted
594 ELSE
595 ! Update damping parameter
596 lambda = lambda*nu
597 nu = nu*two
598 ENDIF
599C
600 ! f) Computing the convergence criterion
601 jactdy = two*matmul(jact,deltay)
602 jactdy_n2 = sqrt(dot_product(jactdy,jactdy))
603 IF (jactdy_n2 < eps1) conv = .true.
604c
605 ! g) Increasing the iteration number
606 niter = niter + 1
607c
608 ENDIF
609C
610 ENDDO
611#else
612 conv = .false.
613 WRITE(6,*) "Error: Blas/Lapack required"
614#endif
615
616C
617 ! Algorithm has not converged
618 IF (niter == mxiter .OR. .NOT.conv) THEN
619 CALL ancmsg(msgid=1926,msgtype=msgerror,
620 . anmode=aninfo_blind_1,i1=mat_id)
621 ! Solutions values must be checked
622 ELSEIF (abs(jactdy_n2)>eps1 .OR. maxval(xi)>ep20 .OR. minval(xi)<em20) THEN
623 CALL ancmsg(msgid=1927,msgtype=msgwarning,
624 . anmode=aninfo_blind_1,i1=mat_id)
625 ENDIF
626C
627 ! Storage of the results in Prony parameters (accounting for normalizing values)
628 g = zero
629 beta = zero
630 IF (ishape == 1) THEN
631 ginfini = ginfini*mxvaly
632 g(1) = ginfini
633 beta(1) = zero
634 ENDIF
635 DO i = 1,nprony
636 g(i+ishape) = xi(2*i-1)*mxvaly
637 beta(i+ishape) = xi(2*i)/mxvalt
638 ENDDO
639 cost = ri2
640 deriv = jactdy_n2
641C
642 ! Deallocation of tables
643 DEALLOCATE(xi,xi_tr,jac,fxi,deltay,jactjac,id,jactdy,ipiv,jact,fxi_tr,vect,yi,time,mu)
alpha
#define alpha
Definition eval.h:35
dgesv
subroutine dgesv(n, nrhs, a, lda, ipiv, b, ldb, info)
DGESV computes the solution to system of linear equations A * X = B for GE matrices
Definition dgesv.f:122
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
id
initmumps id
Definition multiplerhs_example.m:4

◆ lm_least_square_prony_2()

subroutine lm_least_square_prony_2 ( integer, intent(in) mat_id,
integer, intent(in) nprony,
type(ttable), dimension(ntable) table,
integer, intent(in) fct_ids,
xgs_scale,
ygs_scale,
integer, intent(in) fct_idl,
xgl_scale,
ygl_scale,
dimension(100) g,
dimension(100) beta,
cost,
deriv,
integer, intent(in) ishape,
ginfini )

Definition at line 657 of file hm_read_visc_prony.F.

660C-----------------------------------------------
661C M o d u l e s
662C-----------------------------------------------
663 USE table_mod
664 USE message_mod
665C-----------------------------------------------
666C I m p l i c i t T y p e s
667C-----------------------------------------------
668#include "implicit_f.inc"
669#include "com04_c.inc"
670C-----------------------------------------------
671C Dummy arguments
672C-----------------------------------------------
673 INTEGER, INTENT(IN) :: NPRONY,FCT_IDS,FCT_IDL,MAT_ID,ISHAPE
674 my_real
675 . xgs_scale,ygs_scale,xgl_scale,ygl_scale,cost,deriv,ginfini
676 my_real, DIMENSION(100) :: g,beta
677 TYPE(TTABLE) TABLE(NTABLE)
678C-----------------------------------------------
679C Local arguments
680C-----------------------------------------------
681 INTEGER I,II,INFO,SIZE_FREQ,NITER,ITABS,ITABL,FLAG,
682 . SIZE_FREQS,SIZE_FREQL,K
683 INTEGER, DIMENSION(:), ALLOCATABLE :: IPIV,IDX
684 DOUBLE PRECISION ::
685 . RI2,RI2_OLD,LAMBDA,JACTDY_N2,
686 . RHO,NU,DENOM,MXFREQ,MXNORM
687 DOUBLE PRECISION, PARAMETER :: EPS1 = 1.0d-8
688 DOUBLE PRECISION, PARAMETER :: EPS2 = 1.0d-10
689 DOUBLE PRECISION, PARAMETER :: ALPHA = 0.5d0
690 DOUBLE PRECISION, PARAMETER :: MXITER = 10000
691 DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: XI,FXIS,FXIL,DELTAYS,DELTAYL,
692 . JACTDY,YIS,YIL,FREQ,XI_TR,FXIS_TR,
693 . FXIL_TR,VECT,MU,FREQS,FREQL,YIS_TEMP,
694 . YIL_TEMP
695 DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE :: JACS,JACL,JACTJAC,JACST,JACLT,ID,WEIGHT
696 LOGICAL :: CONV
697C
698 ! Finding the functions for Storage and Loss moduli
699 itabs = 0
700 itabl = 0
701 DO i = 1,ntable
702 IF (table(i)%NOTABLE == fct_ids) itabs = i
703 IF (table(i)%NOTABLE == fct_idl) itabl = i
704 IF (itabs /= 0 .AND. itabl /= 0) EXIT
705 ENDDO
706 IF (itabs == 0) THEN
707 CALL ancmsg(msgid=1924,msgtype=msgerror,
708 . anmode=aninfo_blind_1,i1=mat_id,i2=fct_ids)
709 ENDIF
710 IF (itabl == 0) THEN
711 CALL ancmsg(msgid=1925,msgtype=msgerror,
712 . anmode=aninfo_blind_1,i1=mat_id,i2=fct_idl)
713 ENDIF
714C
715 ! --------------------------------------------------------------------------
716 ! Recover the experimental data and unifying the abscissa vector if needed
717 ! --------------------------------------------------------------------------
718 ! -> Temporary data storage
719 ! --------------------------------------------------------------------
720 size_freqs = SIZE(table(itabs)%X(1)%VALUES)
721 size_freql = SIZE(table(itabl)%X(1)%VALUES)
722 ALLOCATE(freqs(size_freqs),yis_temp(size_freqs),
723 . freql(size_freql),yil_temp(size_freql))
724 freqs(1:size_freqs) = table(itabs)%X(1)%VALUES(1:size_freqs)*xgs_scale
725 yis_temp(1:size_freqs) = table(itabs)%Y%VALUES(1:size_freqs)*ygs_scale
726 freql(1:size_freql) = table(itabl)%X(1)%VALUES(1:size_freql)*xgl_scale
727 yil_temp(1:size_freql) = table(itabl)%Y%VALUES(1:size_freql)*ygl_scale
728C
729 ! -> Number of abscissa is the same
730 ! --------------------------------------------------------------------
731 flag = 0
732 size_freq = 0
733 IF (size_freqs == size_freql) THEN
734 ! If there is no difference at all between abscissa
735 IF (sqrt(dot_product(freqs-freql,freqs-freql))<em08) THEN
736 flag = 0
737 size_freq = size_freqs
738 ALLOCATE(freq(size_freq),yis(size_freq),yil(size_freq))
739 mxfreq = maxval(freqs)
740 DO ii = 1, size_freq
741 freq(ii) = freqs(ii)*(hundred/mxfreq)
742 yis(ii) = yis_temp(ii)
743 yil(ii) = yil_temp(ii)
744 ENDDO
745 ! If they have the same number but different value
746 ELSE
747 flag = 1
748 ENDIF
749 ENDIF
750 ! -> Abscissa are not the same
751 ! --------------------------------------------------------------------
752 IF (size_freq /= size_freql .OR. flag == 1) THEN
753 ! -> Counting the total number of abscissa without duplicate identical values
754 !----------------------------------------------------------------------------
755 size_freq = size_freqs + size_freql
756 DO i = 1,size_freql
757 flag = 0
758 DO ii = 1,size_freqs
759 IF (abs(freqs(ii)-freql(i))<em08) THEN
760 flag = 1
761 ENDIF
762 ENDDO
763 IF (flag == 1) size_freq = size_freq - 1
764 ENDDO
765 ! -> Allocating and filling tables
766 !----------------------------------------------------------------------------
767 ALLOCATE(idx(size_freq),freq(size_freq),yis(size_freq),yil(size_freq))
768 freq(1:size_freqs) = freqs(1:size_freqs)
769 k = 0
770 DO i = 1,size_freql
771 flag = 0
772 DO ii = 1,size_freqs
773 IF (abs(freqs(ii)-freql(i))<em08) THEN
774 flag = 1
775 k = k + 1
776 ENDIF
777 ENDDO
778 IF (flag == 0) freq(size_freqs+i-k) = freql(i)
779 ENDDO
780 ! -> Sorting abscissa
781 !--------------------
782 DO ii = 1,size_freq
783 idx(ii) = ii
784 ENDDO
785 CALL qsort(freq,idx,1,size_freq)
786 mxfreq = maxval(freq)
787 freq = freq*(hundred/mxfreq)
788 freqs = freqs*(hundred/mxfreq)
789 freql = freql*(hundred/mxfreq)
790 ! -> Data interpolation with new abscissa
791 !----------------------------------------------------------------------------
792 ii = 1
793 DO i = 1,size_freq
794 IF (freq(i)<freqs(1)) THEN
795 yis(i) = yis_temp(1) + ((yis_temp(2)-yis_temp(1))/(freqs(2)-freqs(1)))*(freq(i)-freqs(1))
796 ELSEIF (freq(i)>freqs(size_freqs)) THEN
797 yis(i) = yis_temp(size_freqs-1) + ((yis_temp(size_freqs)-yis_temp(size_freqs-1))/
798 . (freqs(size_freqs)-freqs(size_freqs-1)))*(freq(i)-freqs(size_freqs-1))
799 ELSE
800 IF (freq(i)>freqs(ii+1)) THEN
801 ii = ii + 1
802 ii = min(ii,size_freqs-1)
803 ENDIF
804 yis(i) = yis_temp(ii) + ((yis_temp(ii+1)-yis_temp(ii))/(freqs(ii+1)-freqs(ii)))*(freq(i)-freqs(ii))
805 ENDIF
806 ENDDO
807 ii = 1
808 DO i = 1,size_freq
809 IF (freq(i)<freql(1)) THEN
810 yil(i) = yil_temp(1) + ((yil_temp(2)-yil_temp(1))/(freql(2)-freql(1)))*(freq(i)-freql(1))
811 ELSEIF (freq(i)>freql(size_freql)) THEN
812 yil(i) = yil_temp(size_freql-1) + ((yil_temp(size_freql)-yil_temp(size_freql-1))/
813 . (freql(size_freql)-freql(size_freql-1)))*(freq(i)-freql(size_freql-1))
814 ELSE
815 IF (freq(i)>freql(ii+1)) THEN
816 ii = ii + 1
817 ii = min(ii,size_freql-1)
818 ENDIF
819 yil(i) = yil_temp(ii) + ((yil_temp(ii+1)-yil_temp(ii))/(freql(ii+1)-freql(ii)))*(freq(i)-freql(ii))
820 ENDIF
821 ENDDO
822 ENDIF
823C
824 ! Order of prony series to high for the number of data points
825 IF (2*nprony >= size_freq) THEN
826 CALL ancmsg(msgid=1921,msgtype=msgerror,
827 . anmode=aninfo_blind_1,i1=mat_id,i2=nprony,
828 . i3=size_freq,i4=int(size_freq/two))
829 ENDIF
830C
831 ! Allocation and initialization of the vectors
832 ALLOCATE(xi(2*nprony),xi_tr(2*nprony),jacs(size_freq,2*nprony),jacl(size_freq,2*nprony),
833 . fxis(size_freq),fxil(size_freq),deltays(size_freq),deltayl(size_freq),
834 . jactjac(2*nprony,2*nprony),id(2*nprony,2*nprony),jactdy(2*nprony),ipiv(2*nprony),
835 . jacst(2*nprony,size_freq),jaclt(2*nprony,size_freq),fxis_tr(size_freq),
836 . fxil_tr(size_freq),vect(2*nprony),mu(2*nprony),weight(size_freq,size_freq))
837C
838 ! Initialization of parameters value
839 DO i = 1,nprony
840 xi(2*i-1) = yis(1)/(i+ishape)
841 xi(2*i) = i-1+ishape
842 ENDDO
843C
844 ! Identity matrix
845 id = zero
846 DO i = 1,2*nprony
847 id(i,i) = one
848 ENDDO
849C
850 ! Considering infinite value shape
851 IF (ishape == 1) THEN
852 ginfini = yis(1)
853 ELSE
854 ginfini = zero
855 ENDIF
856C
857 ! Weight matrix
858 weight = zero
859 mxnorm = max(maxval(yis),maxval(yil))
860 DO i = 1,size_freq
861 weight(i,i) = one/(mxnorm**2)
862 ENDDO
863C
864 ! Initialization of the Prony series and the residues
865 fxis(:) = ginfini
866 fxil(:) = zero
867 DO i = 1,size_freq
868 DO ii = 1,nprony
869 ! Storage modulus series
870 fxis(i) = fxis(i) + ((xi(2*ii-1)*(freq(i)**2))/(xi(2*ii)**2 + freq(i)**2))
871 jacs(i,2*ii-1) = -(freq(i)**2)/(xi(2*ii)**2 + freq(i)**2)
872 jacs(i,2*ii) = two*xi(2*ii-1)*xi(2*ii)*(freq(i)**2)/((xi(2*ii)**2 + freq(i)**2)**2)
873 ! Loss modulus series
874 fxil(i) = fxil(i) + ((xi(2*ii-1)*xi(2*ii)*freq(i))/(xi(2*ii)**2 + freq(i)**2))
875 jacl(i,2*ii-1) = -(freq(i)*xi(2*ii))/(xi(2*ii)**2 + freq(i)**2)
876 jacl(i,2*ii) = xi(2*ii-1)*freq(i)*((xi(2*ii)**2 - freq(i)**2)/(xi(2*ii)**2 + freq(i)**2)**2)
877 ENDDO
878 ENDDO
879 deltays = yis - fxis
880 deltayl = yil - fxil
881C
882 ! Computation of the squared sum of residues
883 ri2 = ((one/mxnorm)**2)*(dot_product(deltays,deltays) + dot_product(deltayl,deltayl))
884C
885 ! Initialization of the damping parameter and the convergence criterion
886 lambda = maxval(jacs) + maxval(jacl)
887 nu = two
888 conv = .false.
889 niter = 0
890 jactdy_n2 = zero
891C
892 !-------------------------------------------------------------------------------------
893 ! Levenberg Marquardt Algorithm + Line-search
894 !-------------------------------------------------------------------------------------
895#ifndef WITHOUT_LINALG
896 DO WHILE ((.NOT.conv).AND.(niter<mxiter))
897C
898 ! a) Compute the Jacobian matrix products
899 ! -> Transpose of Jacobian matrix
900 jacst = transpose(jacs)
901 jaclt = transpose(jacl)
902 ! -> JtJ product
903 jactjac = matmul(jacst,matmul(weight,jacs))
904 jactjac = jactjac + matmul(jaclt,matmul(weight,jacl))
905 ! -> Adding the damping parameter
906 jactjac = jactjac + lambda*id
907 ! -> Compute the gradient of residues
908 jactdy = -matmul(jacst,matmul(weight,deltays))
909 jactdy = jactdy - matmul(jaclt,matmul(weight,deltayl))
910c
911 ! b) Compute the trial values of XI
912 CALL dgesv(2*nprony, 1, jactjac, 2*nprony, ipiv, jactdy , 2*nprony, info)
913 xi_tr = xi + jactdy
914C
915 ! Checking convergence
916 IF (sqrt(dot_product(jactdy,jactdy)) <= eps2*(sqrt(dot_product(xi,xi))+eps2)) THEN
917 conv = .true.
918 ELSE
919 ! c) Compute the trial values of the function
920 fxis_tr(:) = ginfini
921 fxil_tr(:) = zero
922 DO i = 1,size_freq
923 DO ii = 1,nprony
924 fxis_tr(i) = fxis_tr(i) + ((xi_tr(2*ii-1)*(freq(i)**2))/(xi_tr(2*ii)**2 + freq(i)**2))
925 fxil_tr(i) = fxil_tr(i) + ((xi_tr(2*ii-1)*xi_tr(2*ii)*freq(i))/(xi_tr(2*ii)**2 + freq(i)**2))
926 ENDDO
927 ENDDO
928 ! d) Computation of the squared sum of residues
929 ri2_old = ri2
930 ri2 = ((one/mxnorm)**2)*(dot_product((yis-fxis_tr),(yis-fxis_tr)) +
931 . dot_product((yil-fxil_tr),(yil-fxil_tr)))
932C
933 ! Compute gain ratio
934 vect = matmul(jacst,matmul(weight,deltays)) + matmul(jaclt,matmul(weight,deltayl))
935 vect = lambda*jactdy - vect
936 denom = dot_product(jactdy,vect)
937 rho = (ri2_old - ri2) / max(denom,em20)
938C
939 ! e) Update parameters
940 ! -> Step accepted
941 IF ((rho > zero).AND.(info == 0)) THEN
942 ! Update damping parameter
943 lambda = lambda*max(third,one-(two*rho-one)**3)
944 nu = two
945 ! Update XI vector
946 ! -> Compute the MU vector for line search
947 DO i = 1,2*nprony
948 IF (jactdy(i)>=zero) THEN
949 mu(i) = one
950 ELSE
951 mu(i) = min(one,((one-alpha)/(-jactdy(i)))*xi(i))
952 ENDIF
953 xi(i) = xi(i) + mu(i)*jactdy(i)
954 ENDDO
955 ! Update FXI vector
956 fxis(:) = ginfini
957 fxil(:) = zero
958 DO i = 1,size_freq
959 DO ii = 1,nprony
960 fxis(i) = fxis(i) + ((xi(2*ii-1)*(freq(i)**2))/(xi(2*ii)**2 + freq(i)**2))
961 fxil(i) = fxil(i) + ((xi(2*ii-1)*xi(2*ii)*freq(i))/(xi(2*ii)**2 + freq(i)**2))
962 ENDDO
963 ENDDO
964 ! Update residue vector
965 deltays = yis - fxis
966 deltayl = yil - fxil
967 ri2 = ((one/mxnorm)**2)*(dot_product(deltays,deltays) + dot_product(deltayl,deltayl))
968 ! Update the Jacobian matrix
969 jacs = zero
970 DO i = 1,size_freq
971 DO ii = 1,nprony
972 jacs(i,2*ii-1) = -(freq(i)**2)/(xi(2*ii)**2 + freq(i)**2)
973 jacs(i,2*ii) = two*xi(2*ii-1)*xi(2*ii)*(freq(i)**2)/((xi(2*ii)**2 + freq(i)**2)**2)
974 jacl(i,2*ii-1) = -(freq(i)*xi(2*ii))/(xi(2*ii)**2 + freq(i)**2)
975 jacl(i,2*ii) = xi(2*ii-1)*freq(i)*((xi(2*ii)**2 - freq(i)**2)/(xi(2*ii)**2 + freq(i)**2)**2)
976 ENDDO
977 ENDDO
978 jacst = transpose(jacs)
979 jaclt = transpose(jacl)
980 ! -> Step not accepted
981 ELSE
982 ! Update damping parameter
983 lambda = lambda*nu
984 nu = nu*two
985 ENDIF
986C
987 ! f) Computing the convergence criterion
988 jactdy = two*matmul(jacst,matmul(weight,deltays)) + two*matmul(jaclt,matmul(weight,deltayl))
989 jactdy_n2 = sqrt(dot_product(jactdy,jactdy))
990 IF (jactdy_n2 < eps1) conv = .true.
991c
992 ! g) Increasing the iteration number
993 niter = niter + 1
994c
995 ENDIF
996C
997 ENDDO
998#else
999 conv = .false.
1000 WRITE(6,*) "Error: Blas/Lapack required"
1001#endif
1002
1003C
1004 ! Algorithm has not converged
1005 IF (niter == mxiter .OR. .NOT.conv) THEN
1006 CALL ancmsg(msgid=1926,msgtype=msgerror,
1007 . anmode=aninfo_blind_1,i1=mat_id)
1008 ! Solutions values must be checked
1009 ELSEIF (abs(jactdy_n2)>eps1 .OR. maxval(xi)>ep10 .OR. minval(xi)<em10) THEN
1010 CALL ancmsg(msgid=1927,msgtype=msgwarning,
1011 . anmode=aninfo_blind_1,i1=mat_id)
1012 ENDIF
1013C
1014 ! Storage of the results in Prony parameters (accounting for normalizing values)
1015 g = zero
1016 beta = zero
1017 IF (ishape == 1) THEN
1018 g(1) = ginfini
1019 beta(1) = zero
1020 ENDIF
1021 DO i = 1,nprony
1022 g(i+ishape) = xi(2*i-1)
1023 beta(i+ishape) = xi(2*i)*(mxfreq/hundred)
1024 ENDDO
1025 cost = ri2
1026 deriv = jactdy_n2
1027C
1028 ! Deallocation of tables
1029 DEALLOCATE(xi,xi_tr,jacs,jacl,fxis,fxil,deltays,deltayl,jactjac,id,jactdy,ipiv,
1030 . jacst,jaclt,fxis_tr,fxil_tr,vect,mu,freqs,yis_temp,freql,yil_temp)
1031 IF (ALLOCATED(idx)) DEALLOCATE(idx)
qsort
recursive subroutine qsort(a, idx, first, last)
Definition hm_read_visc_prony.F:1043

◆ qsort()

recursive subroutine qsort ( double precision, dimension(*), intent(inout) a,
integer, dimension(*), intent(inout) idx,
integer, intent(in) first,
integer, intent(in) last )

Definition at line 1042 of file hm_read_visc_prony.F.

1043C-----------------------------------------------
1044C I m p l i c i t T y p e s
1045C-----------------------------------------------
1046#include "implicit_f.inc"
1047C-----------------------------------------------
1048C D u m m y A r g u m e n t s
1049C-----------------------------------------------
1050 DOUBLE PRECISION, INTENT(INOUT) :: A(*)
1051 INTEGER, INTENT(IN) :: FIRST, LAST
1052 INTEGER, INTENT(INOUT) :: IDX(*)
1053C-----------------------------------------------
1054C L o c a l V a r i a b l e s
1055C-----------------------------------------------
1056 DOUBLE PRECISION ::
1057 . X, T
1058 INTEGER :: I, J, I1
1059C-----------------------------------------------
1060C P r e - C o n d i t i o n
1061C-----------------------------------------------
1062 IF(first>last)RETURN
1063C-----------------------------------------------
1064C S o u r c e L i n e s
1065C-----------------------------------------------
1066 x = a( (first + last) / 2 )
1067 i = first
1068 j = last
1069 DO
1070 DO WHILE (a(i) < x)
1071 i = i + 1
1072 ENDDO
1073 DO WHILE(x < a(j))
1074 j = j - 1
1075 ENDDO
1076 IF (i >= j) EXIT
1077 t = a(i)
1078 a(i) = a(j)
1079 a(j) = t
1080 i1 = idx(i)
1081 idx(i) = idx(j)
1082 idx(j) = i1
1083 i = i + 1
1084 j = j - 1
1085 ENDDO
1086 IF (first < i - 1) CALL qsort(a, idx, first, i - 1)
1087 IF (j + 1 < last) CALL qsort(a, idx, j + 1, last)