OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
freimpl.F File Reference
#include "implicit_f.inc"
#include "units_c.inc"
#include "impl1_c.inc"
#include "impl2_c.inc"
#include "parit_c.inc"
#include "com01_c.inc"
#include "com06_c.inc"
#include "buckcom.inc"
#include "scr06_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine freimpl (ikad, key0, kimpl)
subroutine order_dtf (n, rc)

Function/Subroutine Documentation

◆ freimpl()

subroutine freimpl ( integer, dimension(0:*) ikad,
character, dimension(*) key0,
integer kimpl )

Definition at line 40 of file freimpl.F.

41C-----------------------------------------------
42C M o d u l e s
43C-----------------------------------------------
44 USE imp_dyna
45 USE imp_kbcs
46 USE imp_pcg_proj
47 USE imp_spbrm
48 USE message_mod
49 USE names_and_titles_mod, ONLY: ncharline100
50C-----------------------------------------------
51C I m p l i c i t T y p e s
52C-----------------------------------------------
53#include "implicit_f.inc"
54C-----------------------------------------------
55C D u m m y A r g u m e n t s
56C-----------------------------------------------
57 INTEGER IKAD(0:*),KIMPL
58 CHARACTER KEY0(*)*5
59C-----------------------------------------------
60C C o m m o n B l o c k s
61C-----------------------------------------------
62#include "units_c.inc"
63#include "impl1_c.inc"
64#include "impl2_c.inc"
65#include "parit_c.inc"
66#include "com01_c.inc"
67#include "com06_c.inc"
68#include "buckcom.inc"
69#include "scr06_c.inc"
70C-----------------------------------------------
71C E x t e r n a l F u n c t i o n s
72C-----------------------------------------------
73 INTEGER NVAR
74C-----------------------------------------------
75C L o c a l V a r i a b l e s
76C-----------------------------------------------
77 INTEGER I, NBC, K, IKEY,IM,J,NJ,KK
78 CHARACTER TITLE*72, KEY2*5, KEY3*5, KEY4*5
79 CHARACTER(LEN=NCHARLINE100)::CARTE
80C----------------------------------------
81 ikey=kimpl
82 impl_s=0
83 idyna=0
84 iline=0
85 isprb=0
86 isolv=0
87 insolv=0
88 idtc=0
89 im=0
90 ikg=1
91 kz_tol=zero
92 sk_int=zero
93 d_tol=zero
94 lprint=0
95 nprint=0
96 impdeb=0
97 solvnfo=0
98 prstifmat=0
99 prstifmat_tol=zero
100 prstifmat_nc=1
101 prstifmat_it=0
102 impmv=1
103 isigini=0
104 ilintf=0
105 iprec = 0
106 l_lim = 0
107 itol = 0
108 l_tol =zero
109 dt_imp = zero
110 dt_min = zero
111 dt_max = zero
112 imp_rby=0
113 imp_int=0
114 isprn = 1
115C INTP_C = 0
116C -----after debugging on int24 spmd, change defaut to INTP_C=1 (INTP_C=0 suppressed good for maintenance)
117 intp_c = 1
118 l_bfgs = 0
119C IRREF = 0
120 irref = 1
121 iqstat = 0
122 ibuckl = 0
123 iscau = 0
124 imp_lr=0
125 ikproj=0
126 ismdisp = 0
127 IF(ikad(ikey)/=ikad(ikey+1))THEN
128 k=0
129 impl_s=1
130 ncinp=1
131 n_pat = 1
132 imp_chk = 0
133 imp_int7 = 0
134 ittoff = 0
135 scal_dtq = one
136 idy_damp=0
137 iautspc = 1
138 itrmax = 0
139 msg_lvl = 0
140 b_order =0
141 b_mcore =0
142 irefi = 0
143 iline_s = 0
144 nls_lim = 0
145 ls_tol = zero
146 ndiver = 0
147 ikt = 0
148 ndtfix = 0
149 ikpres = 1
150 n_tolu=zero
151 n_tolf=zero
152 n_tole=zero
153 ncy_max = 0
154 rf_min = zero
155 rf_max = zero
156 ipupd = 0
157 tol_div = zero
158 m_vs = 0
159 ipro_s0=0
160 iikgoff = 1
161 m_msg = 0
162 m_order =0
163 m_ocore =0
164 irig_m = 0
165 1160 READ(iusc1,rec=ikad(ikey)+k,fmt='(7X,A,1X,A,1X,A,25X,I10)',err=9990)key2,key3,key4,nbc
166 k=k+1
167C----------------------------
168C Dynamic implicit
169C----------------------------
170 IF(key2(1:4)=='DYNA')THEN
171 IF (idyna==0) idyna=1
172 IF(key3(1:4)=='DAMP')THEN
173 idy_damp=1
174 CALL wriusc2(ikad(ikey)+k,1,key0(ikey))
175 READ(iusc2,*) dampa_imp,dampb_imp
176 ELSE IF(key3(1:3)=='FSI')THEN
177 WRITE(6,*) "ERROR: /IMPL/DYNA/FSI IS A DEPRECATED FEATURE"
178 GOTO 9990
179 ELSE
180 READ(key3,'(I2)')im
181 idyna=max(idyna,im)
182 IF(idyna==1)THEN
183 CALL wriusc2(ikad(ikey)+k,1,key0(ikey))
184 READ(iusc2,*)hht_a
185 ELSEIF(idyna==2)THEN
186 CALL wriusc2(ikad(ikey)+k,1,key0(ikey))
187 READ(iusc2,*)newm_a,newm_b
188 ELSE
189 hht_a =-em20
190 ENDIF
191 ENDIF
192C----------------------------
193C Implicit linear
194C----------------------------
195 ELSEIF(key2(1:4)=='LINE')THEN
196 iline=1
197 IF(key3(1:5)=='inter') THEN
198 READ(KEY4,'(i5)')ILINTF
199 ILINTF = MAX(2,ILINTF)
200 ELSEIF(KEY3(1:5)=='scauc') THEN
201 ISCAU = 1
202 ENDIF
203 ELSEIF(KEY2(1:5)=='monvo')THEN
204 IF(KEY3(1:3)=='off')IMPMV=0
205 ELSEIF(KEY2(1:5)=='sprin')THEN
206 IF(KEY3(1:4)=='nonl')THEN
207 ISPRN = 1
208 ELSEIF(KEY3(1:4)=='line')THEN
209 ISPRN = 0
210 ELSE
211 GOTO 9990
212 ENDIF
213 ELSEIF(KEY2(1:5)=='prepa')THEN
214 READ(KEY3,'(i2)')N_PAT
215 ELSEIF(KEY2(1:5)=='projv')THEN
216 READ(KEY3,'(i2)') M_VS
217 ELSEIF(KEY2(1:5)=='prosi')THEN
218 READ(KEY3,'(i2)') IPRO_S0
219C----------------------------
220C Implicit check
221C----------------------------
222 ELSEIF(KEY2(1:5)=='check')THEN
223 IMP_CHK = 1
224C----------------------------
225C Implicit quasi-static
226C----------------------------
227 ELSEIF(KEY2(1:5)=='qstat')THEN
228 IQSTAT = 1
229 IF(KEY3(1:5)=='dtsca')THEN
230 CALL WRIUSC2(IKAD(IKEY)+K,1,KEY0(IKEY))
231 READ(IUSC2,*)SCAL_DTQ
232 ELSEIF(KEY3(1:5)=='mrigm')THEN
233 IRIG_M = 1
234 CALL WRIUSC2(IKAD(IKEY)+K,1,KEY0(IKEY))
235 READ(IUSC2,*,ERR=520,END=520)E_REF(1),E_REF(2),E_REF(3)
236.AND..AND. IF (E_REF(1)>0E_REF(2)>0E_REF(3)>0) IRIG_M = 2
237 520 CONTINUE
238 ELSE
239 READ(KEY3,'(i2)')IM
240 IQSTAT=MAX(IQSTAT,IM)
241 ENDIF
242C----------------------------
243C spring-back
244C----------------------------
245 ELSEIF(KEY2(1:4)=='sprb')THEN
246 ISPRB=1
247C----------------------------
248C print-out
249C----------------------------
250 ELSEIF(KEY2=='print')THEN
251 IF(KEY3(1:4)=='line')THEN
252 READ(KEY4,'(i5)')LPRINT
253 ELSEIF(KEY3(1:4)=='nonl')THEN
254 READ(key4,'(I5)')nprint
255 ELSEIF(key3(1:4)=='STIF')THEN
256 prstifmat = 1
257 CALL wriusc2(ikad(ikey)+k,1,key0(ikey))
258 READ(iusc2,*)prstifmat_tol,prstifmat_nc,prstifmat_it
259 ELSE
260 GOTO 9990
261 ENDIF
262C----------------------------
263C Linear SOLVER
264C----------------------------
265 ELSEIF(key2(1:4)=='SOLV')THEN
266 READ(key3,'(I2)')isolv
267 CALL wriusc2(ikad(ikey)+k,1,key0(ikey))
268 READ(iusc2,*)iprec,l_lim,itol,l_tol
269 IF (isolv==3) imumpsd=l_lim
270C----------------------------
271C BCS parameters
272C----------------------------
273 ELSEIF(key2(1:4)=='SBCS')THEN
274 IF(key3(1:5)=='MSGLV')THEN
275 READ(key4,'(I2)')msg_lvl
276 ELSEIF(key3(1:5)=='ORDER')THEN
277 READ(key4,'(I2)')b_order
278C-------0 default 1 :MMD 2 :metis
279 ELSEIF(key3(1:5)=='OUTCO')THEN
280 b_mcore=1
281 ELSE
282 GOTO 9990
283 ENDIF
284C----------------------------
285C MUMPS parameters
286C----------------------------
287 ELSEIF(key2(1:5)=='MUMPS')THEN
288 IF(key3(1:5)=='MSGLV')THEN
289 READ(key4,'(I2)')m_msg
290 ELSEIF(key3(1:5)=='ORDER')THEN
291 IF(key4(1:5)=='METIS')THEN
292 m_order = 5
293 ELSEIF(key4(1:4)=='PORD')THEN
294 m_order = 4
295 END IF
296C-------0 default 1 :MMD 2 :metis
297 ELSEIF(key3(1:5)=='OUTCO')THEN
298 m_ocore=1
299 ELSEIF(key3(1:5)=='AUTOC')THEN
300 m_ocore=-1
301 ELSE
302 GOTO 9990
303 ENDIF
304C----------------------------
305C Nonlinear SOLVER
306C----------------------------
307 ELSEIF(key2(1:4)=='NONL')THEN
308 IF(key3(1:5)=='KTANG')THEN
309 ikt = 1
310 ELSEIF(key3(1:5)=='KTFUL')THEN
311 ikt = 2
312 ELSEIF(key3(1:5)=='KTFU8')THEN
313 ikt = 3
314 ELSEIF(key3(1:5)=='KTCON')THEN
315 ikt = 4
316 ELSEIF(key3(1:5)=='PITER')THEN
317 READ(key4,'(I5)') ipupd
318 ELSEIF(key3(1:5)=='SMDIS')THEN
319 ismdisp = 1
320 ELSEIF(key3(1:5)=='SOLVI')THEN
321 solvnfo = 1
322 ELSE
323 READ(key3,'(i2)')INSOLV
324 CALL WRIUSC2(IKAD(IKEY)+K,1,KEY0(IKEY))
325 READ(IUSC2,'(a)')TITLE
326 READ(TITLE,*)N_LIM,NITOL,N_TOL
327 IF (NITOL>10) THEN
328 SELECT CASE (NITOL)
329 CASE(12)
330 READ(TITLE,*)N_LIM,NITOL,N_TOLE,N_TOLF
331 CASE(13)
332 READ(TITLE,*)N_LIM,NITOL,N_TOLE,N_TOLU
333 CASE(23)
334 READ(TITLE,*)N_LIM,NITOL,N_TOLF,N_TOLU
335 CASE(123)
336 READ(TITLE,*)N_LIM,NITOL,N_TOLE,N_TOLF,N_TOLU
337 END SELECT
338 ENDIF !(NITOL>10)
339.AND. IF(NITOL==1IRREF==1) IRREF = 0
340 ENDIF
341 ELSEIF(KEY2(1:5)=='sinit')THEN
342 ISIGINI=1
343 ELSEIF(KEY2(1:5)=='lbfgs')THEN
344 READ(KEY3,'(i5)') L_BFGS
345C----------------------------
346C Step Control
347C----------------------------
348 ELSEIF(KEY2=='dtini')THEN
349 CALL WRIUSC2(IKAD(IKEY)+K,1,KEY0(IKEY))
350 READ(IUSC2,*)DT_IMP
351 ELSEIF(KEY2(1:2)=='dt')THEN
352 IF(KEY3(1:4)=='stop')THEN
353 CALL WRIUSC2(IKAD(IKEY)+K,1,KEY0(IKEY))
354 READ(IUSC2,*)DT_MIN,DT_MAX
355C----------------------------
356C-------------fix point for time step----
357C----------------------------
358 ELSEIF(KEY3(1:4)=='fixp')THEN
359 KK =K
360 DO I=1,NBC
361 READ(IUSC1,REC=IKAD(IKEY)+KK,FMT='(a)',ERR=9990)CARTE
362 CALL WRIUSC2(IKAD(IKEY)+KK,1,KEY0(IKEY))
363 NJ = NVAR(CARTE)
364 IF ((NDTFIX+NJ)>100) THEN
365 NJ = 100-NDTFIX
366 WRITE(ISTDO,*)
367 . ' ** warning ** : maximum 100 fix points permitted '
368 ENDIF
369 READ(IUSC2,*,ERR=9990,END=9990)(DTIMPF(NDTFIX+J),J=1,NJ)
370 KK=KK+1
371 NDTFIX = NDTFIX + NJ
372 ENDDO
373 CALL ORDER_DTF(NDTFIX,DTIMPF)
374 ELSE
375 READ(KEY3,'(i2)')IM
376.AND. IF (IDTC>0IM>0) GOTO 9990
377 IDTC=IM
378 IF(IM==1)THEN
379 CALL WRIUSC2(IKAD(IKEY)+K,1,KEY0(IKEY))
380 READ(IUSC2,*)NL_DTP,SCAL_DTP,NL_DTN,SCAL_DTN
381 ELSEIF(IM==2)THEN
382 CALL WRIUSC2(IKAD(IKEY)+K,1,KEY0(IKEY))
383 READ(IUSC2,*)NL_DTP,ALEN0,NL_DTN,SCAL_DTN,SCAL_DTP
384 ELSEIF(IM==3)THEN
385 CALL WRIUSC2(IKAD(IKEY)+K,1,KEY0(IKEY))
386 READ(IUSC2,*)NL_DTP,ALEN0,NL_DTN,SCAL_DTN,SCAL_DTP,IAL_M,
387 . SCAL_RIKS
388 ELSE
389 GOTO 9990
390 ENDIF
391 ENDIF
392C----------------------------
393C NCYCLE stop
394C----------------------------
395 ELSEIF(KEY2=='ncycl')THEN
396 IF(KEY3(1:4)=='stop')THEN
397 CALL WRIUSC2(IKAD(IKEY)+K,1,KEY0(IKEY))
398 READ(IUSC2,*)NCY_MAX
399 ELSE
400 GOTO 9990
401 ENDIF
402C----------------------------
403C interface Control
404C----------------------------
405 ELSEIF(KEY2(1:5)=='inter')THEN
406 IF(KEY3(1:5)=='ttoff')THEN
407 ITTOFF = 1
408 ELSEIF(KEY3(1:5)=='sint7')THEN
409 READ(KEY4,'(i2)')IMP_INT7
410C-----0 nonlinear, 1: linear 2: constant---
411 IMP_INT7= MIN(2,IMP_INT7)
412C---------will be suppressed in the 14.0.210
413 ELSEIF(KEY3(1:5)=='knonl')THEN
414C-----0 nonlinear, 1: linear ----
415 READ(KEY4,'(i2)')IM
416 INTP_C = -IM -1
417C ELSEIF(KEY3(1:5)=='KCOMP'.AND.INTP_C==0)THEN
418 ELSEIF(KEY3(1:5)=='kcomp')THEN
419c INTP_C = 1
420C-----hide option to activate KG in int24 (/IMPLICIT should be defined in Starter)
421 ELSEIF(KEY3(1:4)=='kgon')THEN
422 IIKGOFF = 0
423 ELSE
424 GOTO 9990
425 ENDIF
426C----------------------------
427C R_ref options
428C----------------------------
429 ELSEIF(KEY2(1:4)=='rref')THEN
430 IRREF = 2
431 IF(KEY3(1:3)=='off') THEN
432 IRREF = 0
433 ELSEIF(KEY3(1:5)=='inter')THEN
434C----- 0 Aggressive, 1: Middle ---- 2--FAIBLE 3 NON-4 NO except 1st ---
435 READ(KEY4,'(i2)')IM
436 IREFI = IM
437 ELSEIF(KEY3(1:5)=='limit')THEN
438 CALL WRIUSC2(IKAD(IKEY)+K,1,KEY0(IKEY))
439 READ(IUSC2,*)RF_MIN,RF_MAX
440 ENDIF
441C----------------------------
442C divergence criteria
443C----------------------------
444 ELSEIF(KEY2(1:5)=='diver')THEN
445 IF(KEY3(1:3)=='tol')THEN
446 CALL WRIUSC2(IKAD(IKEY)+K,1,KEY0(IKEY))
447 READ(IUSC2,*)TOL_DIV
448C-----num. of diver---
449 ELSE
450 READ(KEY3,'(i2)')IM
451 NDIVER = IM
452 IF (NDIVER ==0) NDIVER=-1
453 END IF
454C----------------------------
455C Geometrical stifness
456C----------------------------
457 ELSEIF(KEY2(1:5)=='gstif')THEN
458 IF(KEY3(1:3)=='off')IKG=0
459C----------------------------
460C Geometrical stifness
461C----------------------------
462 ELSEIF(KEY2(1:5)=='pstif')THEN
463 IF(KEY3(1:3)=='off') IKPRES=0
464C----------------------------
465C buckling analysis
466C----------------------------
467 ELSEIF(KEY2=='buckl')THEN
468 READ(KEY3,'(i2)')IBUCKL
469 IF (IBUCKL==0) THEN
470 WRITE(ISTDO,*) ' ** error ** : keyword /impl/buckl obsolete ',
471 . 'using /impl/buckl/1 or /impl/buckl/2'
472 GOTO 9990
473 ENDIF
474 IBUCKL = IBUCKL-1
475 CALL WRIUSC2(IKAD(IKEY)+K,1,KEY0(IKEY))
476 READ(IUSC2,*) EMIN_B, EMAX_B, NBUCK, MSGL_B, MAXSET_B, SHIFT_B
477 IF (SHIFT_B==ZERO) SHIFT_B=EM02
478 SHFTBUCK = SHIFT_B
479 IF (MAXSET_B==0) MAXSET_B=8
480 BNITER=300
481 BINCV=4
482 BMAXNCV=16
483c BMAXNCV=MAX(BINCV,BMAXNCV)
484 BIPRI =MSGL_B
485 BISOLV=1
486C
487 ELSEIF(KEY2(1:5)=='autos')THEN
488 IF(KEY3(1:3)=='off')THEN
489 IAUTSPC=0
490 ELSEIF(KEY3(1:3)=='all')THEN
491 IAUTSPC=2
492 ENDIF
493C----------------------------
494C line_search option
495C--------0=3, 1:energy 2: force --3:AUTO (old)------------------
496 ELSEIF(KEY2(1:5)=='lsear')THEN
497 IF(KEY3(1:3)=='off')THEN
498 ILINE_S = 100
499 ELSE
500 READ(KEY3,'(i2)')iline_s
501 CALL wriusc2(ikad(ikey)+k,1,key0(ikey))
502 READ(iusc2,*)nls_lim,ls_tol
503 ENDIF
504C----------------------------
505C projection for warped shell elements
506C--------0=no proj but keep explicit part 1:doing -1 :no proj, neither for explicit---
507 ELSEIF(key2(1:5)=='shpof')THEN
508 IKPROJ=-1
509C-----------become default-after-----
510 ELSEIF(KEY2(1:5)=='shpon')THEN
511 IKPROJ=1
512C----------------------------
513C OLD CONTROL OPTIONS
514C----------------------------
515 ELSEIF(KEY2(1:5)=='contr')THEN
516 IF(KEY3(1:2)=='dt')THEN
517 IF(KEY4(1:4)=='stop')THEN
518 CALL WRIUSC2(IKAD(IKEY)+K,1,KEY0(IKEY))
519 READ(IUSC2,*)DT_MIN,DT_MAX
520 ELSE
521 READ(KEY4,'(i2)')IM
522 IDTC=IM
523 IF(IM==1)THEN
524 CALL WRIUSC2(IKAD(IKEY)+K,1,KEY0(IKEY))
525 READ(IUSC2,*)NL_DTP,SCAL_DTP,NL_DTN,SCAL_DTN
526 ELSEIF(IM==2)THEN
527 CALL WRIUSC2(IKAD(IKEY)+K,1,KEY0(IKEY))
528 READ(IUSC2,*)NL_DTP,ALEN0,NL_DTN,SCAL_DTN,SCAL_DTP
529 ENDIF
530 ENDIF
531 ELSEIF(KEY3(1:4)=='shel')THEN
532C----------------------------
533C Fictif stifness of Mzz for shell
534C----------------------------
535 CALL WRIUSC2(IKAD(IKEY)+K,1,KEY0(IKEY))
536 READ(IUSC2,*)KZ_TOL
537 ELSEIF(KEY3(1:5)=='inter')THEN
538C----------------------------
539C stifness factor for interface
540C----------------------------
541 CALL WRIUSC2(IKAD(IKEY)+K,1,KEY0(IKEY))
542 READ(IUSC2,*)SK_INT
543 ENDIF
544C----------------------------
545C hide options
546C----------------------------
547 ELSEIF(KEY2(1:5)=='prtol')THEN
548 CALL WRIUSC2(IKAD(IKEY)+K,1,KEY0(IKEY))
549 READ(IUSC2,*)D_TOL
550 ELSEIF(KEY2(1:4)=='nexp')THEN
551 READ(KEY3,'(i5)')NEXP
552 ELSEIF(KEY2=='debug')THEN
553 IMPDEB=1
554 CALL WRIUSC2(IKAD(IKEY)+K,1,KEY0(IKEY))
555 READ(IUSC2,*)NDEB0,NDEB1
556 IF(NDEB0/=0)NDEB0 = NDEB0 + 1
557 NDEB1=MAX(NDEB0,NDEB1+1)
558 ELSEIF(KEY2(1:3)=='del')THEN
559 IF(KEY3(1:5)=='rbody')THEN
560 IMP_RBY=1
561 ELSEIF(KEY3(1:5)=='inter')THEN
562 IMP_INT=1
563 ENDIF
564 ELSEIF(KEY2(1:5)=='itrby')THEN
565C-------max iter for secnd dis calculation with finite rotation---
566 READ(KEY3,'(i3)')ITRMAX
567 ELSEIF(KEY2(1:4)=='lrig')THEN
568 IMP_LR = 1
569 ELSE
570 GOTO 9990
571 ENDIF
572 K=K+NBC
573 IF(IKAD(IKEY)+K/=IKAD(IKEY+1))GO TO 1160
574 IF (IPARIT/=0) THEN
575 IPARIT=0
576 IKG=IKG+5
577 ENDIF
578 ENDIF
579C
580 RETURN
581C
582 9990 CONTINUE
583 CALL ANCMSG(MSGID=73,ANMODE=ANINFO,
584 . C1=KEY0(IKEY))
585 CALL ARRET(0)
max
#define max(a, b)
Definition macros.h:21
imp_dyna
Definition impbufdef_mod.F:314
imp_kbcs
Definition impbufdef_mod.F:471
imp_kbcs::b_mcore
integer b_mcore
Definition impbufdef_mod.F:475
imp_kbcs::msg_lvl
integer msg_lvl
Definition impbufdef_mod.F:475
imp_kbcs::b_order
integer b_order
Definition impbufdef_mod.F:475
imp_pcg_proj
Definition impbufdef_mod.F:646
imp_pcg_proj::m_vs
integer m_vs
Definition impbufdef_mod.F:648
imp_spbrm
Definition impbufdef_mod.F:696
message_mod
Definition message_mod.F:1257
names_and_titles_mod
Definition names_and_titles_mod.F:1002
names_and_titles_mod::ncharline100
integer, parameter ncharline100
Definition names_and_titles_mod.F:1007
wriusc2
subroutine wriusc2(irec, nbc, key0)
Definition wriusc2.F:60

◆ order_dtf()

subroutine order_dtf ( integer n,
rc )

Definition at line 592 of file freimpl.F.

593C----6---------------------------------------------------------------7---------8
594C I m p l i c i t T y p e s
595C-----------------------------------------------
596#include "implicit_f.inc"
597C-----------------------------------------------------------------
598C D u m m y A r g u m e n t s
599C-----------------------------------------------
600 INTEGER N
601 my_real
602 . rc(*)
603C-----------------------------------------------
604C L o c a l V a r i a b l e s
605C-----------------------------------------------
606 INTEGER I,J,II,NN
607 my_real
608 . s(n),smin
609C
610 IF (n==0) RETURN
611C----- In increasing order -----
612 nn =0
613 DO i =1,n
614 IF (rc(i)>zero) THEN
615 nn = nn +1
616 s(nn)= rc(i)
617 ENDIF
618 ENDDO
619 n= nn
620 DO i =1,n
621 smin=s(i)
622 ii=i
623 DO j =i+1,n
624 IF (s(j)<smin) THEN
625 ii=j
626 smin = s(j)
627 ENDIF
628 ENDDO
629 IF (ii/=i) THEN
630 smin =s(i)
631 s(i)=s(ii)
632 s(ii)=smin
633 ENDIF
634 rc(i) = s(i)
635 ENDDO
636C----6---------------------------------------------------------------7---------8
637 RETURN
my_real
#define my_real
Definition cppsort.cpp:32