deSolve/0000755000175100001440000000000013132171175011672 5ustar hornikusersdeSolve/inst/0000755000175100001440000000000013131751003012640 5ustar hornikusersdeSolve/inst/CITATION0000754000175100001440000000214112613502567014012 0ustar hornikuserscitHeader("To cite package 'deSolve' in publications use:") citEntry(entry="Article", title = "Solving Differential Equations in R: Package deSolve", author = personList(as.person("Karline Soetaert"), as.person("Thomas Petzoldt"), as.person("R. Woodrow Setzer")), journal = "Journal of Statistical Software", volume = "33", number = "9", pages = "1--25", year = "2010", CODEN = "JSSOBK", ISSN = "1548-7660", URL = "http://www.jstatsoft.org/v33/i09", DOI = "10.18637/jss.v033.i09", keywords = "ordinary differential equations, partial differential equations, differential algebraic equations, initial value problems, R, FORTRAN, C", textVersion = paste("Karline Soetaert, Thomas Petzoldt, R. Woodrow Setzer (2010).", "Solving Differential Equations in R: Package deSolve.", "Journal of Statistical Software, 33(9), 1--25.", "URL http://www.jstatsoft.org/v33/i09/", "DOI 10.18637/jss.v033.i09") ) deSolve/inst/doc/0000755000175100001440000000000013131751000013402 5ustar hornikusersdeSolve/inst/doc/compiledCode.pdf0000644000175100001440000102321713131751001016473 0ustar hornikusers%PDF-1.5 % 1 0 obj << /Type /ObjStm /Length 4729 /Filter /FlateDecode /N 86 /First 722 >> stream x\]w6Ҿ6=/YǩvNDl$ѕ$} )Qw=L`0x,f0ɤ bFDBfIbfֲXF8ĄPL+qY$"$"E15EUE6u1ݔX[ &#p4nf 7H2H1ecL aZB2m A͐;Y+4m:!u !ăqa" #mYY,`5AXĢfBQ5[CDLB?iVLѵs_.I>0mW>KoPp]!7]򶘳Gd򶘦 v1(l jgiiGOB0[s^foاeg>Ϯ]:Aqqǧb>^G:g2O',}c6_|F.dc쌳o*.t6Bo!j<-_l^ =;;anE%A₋߲Qa2/'휝y8 eWg7|m%I:YRG|S+XJ8GcQNL{#o|1ED~f27hnʲQTŸV6oDBsGeU%=UYj\%\o̵fEIaUy腋*EUC^TBJ8m(Q'HRV:1y jmlBwdx<r>BA?|.]d#<ruGPJDϺ(/JORG/U>ecw@-@͖ ŵjP.oɐ폲 MU΍>"^OV$\ӯ1/F!(ݏY~s[2G)?|3>S^p0jwc<&͂ػ'p{R+%T"jܸC/i/棃 bpzC#e6} { ۚmu SATϟ|~ӢV Vooak ̀~0F󐯿zY J ч-j] eLQ@:Bo2TKR-U BIQre0T't\ƒI\#sZںoڐ>O!L~ğ1`Wbچ=xٳw; jbȞ>~GQrD˓um&ڥJiܑ]=g0ddH, }oqs&8iirMjn,sɻ|;9, Ȟ6=e]vAzTϊ=.k= .J>9r0{Moǭ9/c͑ ޤ;ytPھd>h}|N~z{vv|Ԁw/~bh'D[K`KSʸm_Vg+#sy|#xBCbK[Nc[wd#'o؍'}}.{re >Cߩ_JMjgij{f<{v|5޶0NqGn%Ё X8;zzFRR*PkV(skx*4|W]`Vl̉tuvDw`?8|>٨?bX?xILjljKϔ iw0Xjp2+zp!zBBKD<\=V\7R7p-N עpk"ĕh~uvj=asлG-5xHqx s=ҟN ڮ v,~{DzwHgqͯp:v", Pb֡Ĵa57FwӫɈknr◃;5Щ}f:4!aKMm϶l>cmIڻ2b?797-2l(G|23Rie<˚YQ+&tʧuiiZyIXi=ofղ--irj;Ж19*}(i;U4O/6aŘs*mdf92CΫgxi'#h|FCgIog)/ZɎTnIZbOzh=n~лD) |M(5Ti3+:1em"J*+7E7/ԱI^=T;!#(H?ґHghȿi'HÞ޿*ljҎnl~sDc^T/!5 %my4ˆN0#zs/1Fb. 7qsz?*@VTLO0UoXTߌ^|{-^PR 7Q,7a{I[`yЭRݖw).btx,o ;(& [>}h-)( ^f6 ^pҁw ;J ܣy: cÈO@ai> nd& NL$I*閳0H PG/qjv;fZC&9J+bb֛ qy54&uH(73ПST_ {30G/.^]ܾnwr UŝNrnūYNo,qrmxCAR/6꿛lLGL˰UUvoc]-0ѱ|aSp n,-o kޡ^_;0>>c6). G0HD@EG@ՉSB xUcEH ,9DZ::>w+`; L6?[c ׻!im2]#ݪD/I7YN°EC{NadwipS|-*Ja""ء~X=is ~L~!R{\_2e|'nvf͒nBê7a;Vk2{^ Оj]NQug~~g 0}vuU~q~{^2\щendstream endobj 88 0 obj << /Subtype /XML /Type /Metadata /Length 1731 >> stream GPL Ghostscript 9.20 differential equation solvers, compiled code, performance, FORTRAN, C 2017-07-13T22:03:12+02:00 2017-07-13T22:03:12+02:00 LaTeX with hyperref package R Package deSolve, Writing Code in Compiled LanguagesKarline Soetaert, Thomas Petzoldt, R. Woodrow Setzer endstream endobj 89 0 obj << /Type /ObjStm /Length 2310 /Filter /FlateDecode /N 86 /First 758 >> stream xZkoFb>X~E;,46i,ʒ#Yg}II. 3y̽w.,J&cQ1PJ shXtL gR#V".$SRPLiSA0LKoQLTpLH"hTd:ZN0i})KHŌ4%5 Vc4u(Xz䘱4lf\L L&X̬$HwP(eP 2khuFQpX^cfֆ@ D3dEӀ 񡀚Ԗ9cN(01 79H*`H249Bi%h +Z8i/C (bR4h (H(P'!`'>! #HZςT`y" /*+8IłNh3,DI:i %jw9P%𠫣{ jJ18H^ DJALJ㧟?'#1MxѪBa?<p5S?FO1w/M|hW~i1d45{??2N'FsfO+ZgA8MϊQ<Իm"ߛyT Nףy10r1oM{R5: 5<9?y./L#'YjXQ:宔WuRj)[ѧlm6}2?V)U5v6ydn(N:̆A^0S+Ze>֢nMCMMSKIu4a'֘o>>/.ve::mFt܊`!(q6KY:DuKKr3X_@˦fZL ,\Ҟlk)ÝMݢvHE!EWHЃ Z–-dzA2 D*~uU3[pxcFi \3ᓆd}[G6MAvGTۣSUE*k2Uy\$%TA)9&&#]Fy!Mf E%a9\FiĴ")Zdڐ,HW( &u}q7a]2;$3R3SQn'0p.It g/ec7t/ߟи,< RNkra\`'ttTpm'h&kN.ݴkOTϴn#ޤ-WHn)ݞ{Mp6λ`ؠܚ6͢i@uHcE 5;Vc+^x y8tg*mDFi#Z '6զU}Hj)tJ֚ D<@+:}Šp ܆Ot26fζI?-xK&>QTm4ҿ6Xu4R>gW{Wo\Bp }Otde*5yCZ2CjӒylXEl7 ؂X\:'o-;qfOvF6<=CsRwL'87X#S12fXA0ݸzJnhۄ]u^]9CrW[UNd'(_N.{T`^LegԿG߲I\ۭFfP !# _|/޼)0|]~OEG}.N<ލ~&>b6E~m!w5~h(`F7]}2FW>ۓblנ$$zQ\]폔Jy&GeC棯fy-> stream xZrF}߯ǤRJ.֮d'[~IHFB H)~$.$m+Y.`0}H`&odaW2%~s׃fA/eR*D <ӽQYGg"I#q{TL 9Q3%-&FÔ4LEǔՂ` Z'0 N L+hbh,&405dfK!Pfê"2c$&KuN2񟒊Jjf9YiKǬϬ%20 A7H'% D8!R:Gl\ Y XO,u"y)LkIe4MkCgiϼt{ґy9 7}DH \C?P)GֳtgACK"qNd]P 8hĀ V!ETֱHZ*\Ӝ,%yb 1Joe]d6:K_c6z q )f3. (bҼˌ'ULђ~Ȫ_Yξ:aϟ!x7_ 597ݼe]9I.m4=Fnv5g-`oHJpi^SW4tߏjc'?:|Y5/7_UGiV%w*XZÊ{au#lrOsl2_d% -@I'ӃMPAk`PV_q|u(7iMCyOJEHӘq2/?@پbyN3_^. O^=0:k%R6W-`(?\wf͵~~7=]Jn80>}PuZ=b{)2v .o''+%otc7ݪ,P]L7#3 Kղ^e>-,-=fepB={/w$_0aר'Tq |:'UG?_116կ~Lqxd>'+)Hw(2hEr6pۯکOD(p7P:Mٌe[CiM|׎k0k_CNیj4cF3~M-z@yoF{l`m|lzboؒaيm+lUeD{yR|㴻GҚկc8(wx A,y(]'NjDWMV mov8ʹI)jW5"Q`pWŝ<:(GSBHRLjP"nR\2QzY5&x2H>\  IY{6L䖾T@!{=M}o;d:;A jё]zwxՁV7gA՞o-vNQ )a9*Ƿ?{y )d>EyR.͉r!R-|L;$VVdh)HFÕ[3T5*"][1>U$Hβ (MGh6=,^.`6ʭztQrM^e7_,Y19)g9^ /}3ZͿ飌!-2GokEnG>t;l vendstream endobj 263 0 obj << /Filter /FlateDecode /Length 6285 >> stream x\[su~G\e牑ۉJI8@H)KzΥ{t VUr}|FF/nET34uSsqs7:ns T:X6Jzs~{^bɦ>7|v旅w8% fgeǝ:bi{0n]0~ 2fr6ռ\-CmKx`?]޾~{:;Z9xiO٘*v{l+o7{o|e>J5Nv<[dWf &mx] okj~&ϯqT)ŸGfu]~IFN$ڧ=ǿhr=5^XxaI^` v]f!8yyO%dL1HwW% YI:[8|5Kr=m%kS#!|H^[lz`v&'b9$_N) THEOYe4rhe9FZp wiŇaulQΒؕGV=2S<-o؈Ey jP#1 rx0h)&s ˂ۿlwl_ nk2 6//7܏͠r* 򟻄v>DlnߊvF Kd2e‚X " Xg=_<EumJjЃ7/\q6A=`:d7=t~MINoWBBrAfHN8MC;g8`Q~{ 13r7g/#ɇLƣ#q;‰=88 'Z |#{b~6NEQt3]`}yHփe:@sËTq 1M JBwx%" rb9] *'föV HoRl`$f)S6W]W70 mmbګ6m5[ S4'!E]0_6G_X++Gځny[ uGy{W|QvbŤj#u\x\ \$ylԘPC|0ā)1(&gC QG0ΛXX"k fSB-6xĆ[Gy@<{dxsݫ$9@N7l6N-%eU֌]8VK*3J$Uf5 ru8w02eb j3sF$/8Gfax72R'＆MT>rtʼH2mR@&̂|(E cKzZ.Q v]QeoaB/ְw-j@YP#8$BS$yWlt`O]!շdNf-VI!,IUC~φ(i)*GZaLd9H*P|b  2uK/XĩD#u / bf?,`U P?`]0Bu`9p ctq^bIkrܕT' iL[Lx;7;9PaƖ%0L" F}*]`34^Gf_T "3P{5͛~9ɩ9? d3g@/Fc?d{P!F -ɤh6QFB"zy#"-|L!JLz8+ z@/=g"PIx#Ep72 y)*@T3)a=gsFrmq/fNb/ѹ1"HeTa1%Ih}`c 25l7O\NckMvO$Srv'qQ8{ &]y颴J]+G-7S0E]58Eg^F1jw2 [u6>UF2:€zʮ 0O_-/#iUxfzW9xPxBb؉J n]oFxQ=J6MT9q5Zh\̲Ru%zee<%jGB5e~JY崟u8Ji@ĖAm=_?0P=b k'i."e#:Zo:}K驵v,U僪+\>𽮐^9ڈ/p bt @3yk.\4p4C+ ;*'?e- ^ sfT$q 5g_~Yom6xنpX|OaIݒT[1\-,R3},56jW̩&G4'qWS ֈYo$rT]1g^* 0M}ZGI G&hj! :>s+oi@ŷ.yRӐԢcDEw2V!.E2ɷZSȡZFvͮo1ސQX,OG+ ̡e/y po{efl{P0'Y00bCDŲTfz dQ%3 f':޵K'>",xx)-uO1i)296G{NۣH"R->;t>t@]˂Q{36'/ddEaBMNA$ck^qps:Y7w)7 !V(9 ێ26QrHTf(.s{YJt$0cZOh0%S2nhx#HDzuJS8+*vԱcS)D Bnt A'uN"!ى?B5u0 iCB h֒ Q:>ו^)\ME4!i^@%1ks2,UH~1ϘBԡ#K45Ci+DUSjضL(=?Lf&kRoZp~;ʺxXC["K/-~E)Ǽ2ߖ ˉ!)ӋP)>9x8ueNhDNEГG~^7+T^Z߱8jc=4I[A5 lĴX]emӯ~>dy[$e>7K1nd|E_`UH_5"Wg9Ӱ\&+RByc)tyEezQ_"v'&!a71<XJ0K&pܡXn7əJ"C-S]p{: ޭrU爽IQ 5BZL#iS YGO"W9QK@z*yjC8>aM[BIlPJ3w-بMz"9=TZS Œѣ;M_@o 2&r=d)==8&xCr1E|qu;r`WHy2!-;Tn?k91r˹Irݤ}-iSbظ^tZ1K|rP,ƯVglA+ YOo^u z_ķ4 ^CZ!^!BFVE  _P:$t^K2|h% ękAAȆj*AKz9ak '};evwZ""^57$ܰm~ S;\_ITz|>qTFrs_YM~K |lL{fY:e˾G+nUd ,Aȇ-ڍoo6VUt&")?endstream endobj 264 0 obj << /Filter /FlateDecode /Length 5104 >> stream x\[od7rN^ zi{e Ngg miFF-K#{ YdxNi,?>VOۣ=uӑ=SgUǧS}qq?>}{4X#&Mgz~|sI)m7چtY .M_l> 6v-OS}#- %k1 ~S)3$e|׻+cSvMwb<%_ht۾fNt[܄|q5`3?ymp^~|N[87`QTg*pIX2t d@>"-I|W9;T] жC6dsv^qwdAҾx7A`|CB8}Pt|fxׄf=زL{[a2>$N꘢&h_\cXbȳ^lDu ;ڋ 2[\I35(ba @K4~zҼ KfLq7$֮'6a_*g<^Fw.?'q+ׂ;?`DB?Vybl\Qbx4#ir-y6=mNN|9[r)e5yD̦(X{qtY 9@I_e-禮՞E=Dw]q?HtqAHPFuQ\E!z6#^+ 0ihD;b`ߑSw8( "K;l:t $mrqt{Ӽ>.̠ԖF4Ff% @<LdYS{BUpnym}Ff08wr`0n㞘@B~َb) @E0fU 'dQ"ob @FR_>Vj@(Do6YWm(0S1r2Cs Cw0ݦ3ɱP1b?R%~ܐӤX{l @H0, ugΊ3l9$!a<2`(qpӚC})I&ShEG8q @辿k Ll :п|墯8z9wέclәܤ`ٹVϚ({^&.2gM !r:8GFLM7Й Y%߯Mޱi*NRD/=ARrw) P`\g)Hy#m0m ~ֺ`(kCXHB{5$2T 79<]%Y4p$#L;]_R7X 96b8vӗy+vv%0l؉F#?]J'3X)Ȑ[ꇒHCDI}ΩHy+hRHdXf ,/B0Tm4~t"dxVb&qC&@%ID_ 1Y-a0;Η^T+nYތlAA=h&dh^7ek~Y ] J5[Pw'a#(q3ߐ~ܜ{4@ܰ5 ɆFY{?zZco0o 6Ē,CJWG: ǿ=Bo x 90\Xw0_cn=H׀n.ǻ - g6P[.0悝{qs?LuG]~"7fkz#A@3o%@ {ۮj8kP.U=g*hOg3|W *0*JOO78A;R5* 0uͻ,bU:b#fr@V0|bp{b0Iha^32>] WkjMzj^h%q 躋0zky4VӬ{%{}U&xhlRmrtR6- o/Eе]@NB|L"}CJ ^R2c[jG~;}~+A.=ǒ"yv8}S51q6TpC+)z\^ sv'7BM^O-: (5u'.6?m9(+|R)ӫnWVq' A~?:ZaZ)AZّ[$@|&ޖ 5#V+nͷ LxCkjZ5Z.J]k>k_n^ּiͷyۚuDuwf>߂*5UZwvp`YpgK /Ec-jJ]$db+Zt޵98V"ӦzTI*:GM.x)ڐ,bA\ǢˇB[Ն˾xvo#n(/ܗ\Z]Y۟h J)I&)ۿ}~[bV"6Y-rbw3w ȡ+ D^N^d 3-a 4fȥ+NcYã<ܽɏr"mq].N|f8da旁hr;@t^̮o5ܚ.Y;7fӚ㷋cgV~6 T%ȥ7rYc$kΫh`䑛0zjOhOGUendstream endobj 265 0 obj << /Filter /FlateDecode /Length 3595 >> stream x[[o\~#CϦc/nii& p\`/+-;3!gRd( cjHsfxz!F'9?zȋ#.?ŧ5QD8~vʅta.cvq|~x֎.a} FE9-Wb1D;QEPH#a8]?9|KN8+G!D1u5pVh6fM082wp 2F MqXW]=|T$9l V~ {Ͱ;+>A HC`0Ac3K F)`!cjxT*כ,;-YH.eԓ/89G`11rv oMњ_V08@!"F&*y]Jo'|WIYI(;:!&^"u%X64/TZ/0UrRYB%%+6%MSfA -P,wI) B- 8TG8@ 4dsfl&{#̅i 5BL|~|͑[őƌ,Ώs{8;`jE/ap9lr2]B))2I8B9+,nݢ9 "yg*%O6O\ `7|#⧴OKSBՈvY cmr)t B1 [ţv8cIu/yL(:M%ݨ L;>#u7~|_J^vG+yZ([ KeSSz==;ۋm>V}Ew/*v_LZ=fƾ|VRPo]ƻ ,|4ҼN7g'mwBuq`Sp=26=!til/HoQRĪ_W*wC6N!߰~ ,{3^ykދA2B)[Ul8LL- f2t}z2]ϳJT1di d "+U+ J`CfHfaa+6}2s@N@Ђ:Ӛ֖)>KV F "=/8xv.DcO5JP'RmcjTc#p9Lp4MS; +DH]!M  m sDVCGp:{mBwwH/Aثk{2D q^#g2AΘteK}̫>fr~,%HM\,A_}EG@Y!Gͼ;5rԌBIex u18.Wӆʋ@ NҾ$CWFt[(U׎q,,Y47;e$KB+ {5ɲ*HEBT:>6挭i' `-=QʪɶhÚ44#Î*2o-0P==~wt_nǭFILmMPbqQI ޯos:Bn~2AlVk6ŵ(f}WZ dƎɲ@vهv*?(A1HA[W9pfJHE^&DRC'rzmؿN.WIVol3(Q-݁t 3)[0:f*JE ukW{miGNʳJ œX(Z7-$==dO ̽7-sT:@ H]zسT]gV%Wt3nŐNw2&`:هmc¨ƽ6'tU?BEnpQ*ׁD7S;Yii 0< x~tY;HbK*4ULfmvjeK;w`t4ۍ C`i\/!^CLFNe|lWΟY:7kUvęej-UX{`A6GT(9.:pW75k׏KdJ\6skRTWukai4ty jXr{"wi&6yϾcH.7|YajVi ȕu gu(.k.I ۪MqAz`i@Ia3vņEDtc(Z֝5)̈́f|A%~s>e4 Q)цE<{HXy:FJ5ik@+K$Y)7!b3}Y&4ϝz?ҼLD(d\*\<1?,$k$ЬQ} gvi^9~~YC}iξx̯/++MWW&7/WUJs{fLw*d':o %endstream endobj 266 0 obj << /Filter /FlateDecode /Length 6424 >> stream x]Ys$~GtSv+#AC4H6njǿ~3( Q*r(ˆ#4`5 G"/o(7}uuؼ;?&j_#jx2FYzUn v?oaTѨ(N>hwTzp M#aN8;G!b1h{!SZ h1-M" C +^ &9v1J-A9 Cp.uA*+89L F!Fgz6=Jox*Ԏ;!b0~ CH˷͚|\"m0JAXd V  0t1N.DC2?!sx~ ~8og; t6lvڎ9ALcn=nL N0J ۼF+Uva8^Wb0Go`"M7.7ok]m~ͻmwEihC$& \k-5zO<3 u{'xD{Dȡ qȡS^t~Z erdЇ>wq8Cbk2aAy^I gkcam;иz8Fh.h /.`nh|2`!0N(xM$a:28FAi(I t4ct~z&6{. > gH豊%!aFhEoNèNcW`({~kvԼbz-Ucm>ڼ_~O_t SPPڼތ׌0fyg>u;{S?ncWL""}Ǥ T5z)'muWl͹V ԲZlB/Aɠ8MxPdp4"ؘs<*0c*GI /jR2Bf`}$,jfrl’inF3'ype(ֈNt!I{>rFz=mk/قaLYE$i*+$;2>7!= w7*,L9Oo"64[| ׁYosH`qE3tmQ*]#pl#Fҹx}q>։=RmxMÌ]%` :T#qL\ASgLWM l.KO&AZ@i6B <4'THHc1o5"7P..S[̿_qe<89_lj6nbP{:v0M5XG "]NoOOߝʹLo,ؗ-n*fLs䌊@ԸwY% loG+IZ E㐶.8p%Nwn1\|8+Cu ,@8P1ds|2aGY(#?dH ,k2󦾖ԙs˶jaqQ_so>=s> qrz:ե!3]ㅡ-SΆY%wk*2T}aD1@S XM׎. vw`Ï|j:!v 89Goݒa(̰ŹFWV*YT/[Th9)F雂Y<>[- Dv $̛!JrEG1"-*Yț锅g$[ml\SMshP~n $'@xvIB"2Bf2@NL\ {B V)}JET&H$ ,@9&؉owߠM_j$8y*Խ9rڠ:_0uz?{Og֟ޠiQ2}y(?z=v0dq\iѢd)BY\R"yo醡-(E&njHAjMd;?ϛT Oa9f疌,?c$ƱINd\wgt%PUbYWf'[JɑbZYclnb-xS$\tQkqCQ١4+#:KڒMDpCc]3+Ѵ*i>6LrRqxZ mu::l]c (šo$ RU>bNr ]$lgo7-ZG9t.K ߦmS NЉ;' P+D3#ݒVMƄ ^S,xr'P D8s4LrzKyrA I^V 0c2Xvi?}-E2p 7q,f5]3u,}HT ӞE^{|$`8~ј't:,G:3mPs Е//Ǩ|=~ɗ )bPahkN 5ERs:p.(f5FĠ^-KCG3; X&;n6s?MmlpA4Ft#.&|gS@5%h/48z^fQ6Mih"݆m_c KbT,KLO\_!&+L&hyunu-&~QOjl}wvO 00tl'tWeHDMi Ǯqo;)B7F徸c:_^ T@%l+ b7%h{%5MX86|< D aUg Xv~im5EF-ҍ{1:0+j}WSmSpj^A>SR?Gt|lݒa{#BC "ku =F锚!zhf.S1S47F>GrձގQ>n)I& &<:ޢG2";9Ta,8`0$ vS.+0 >5,*|FK;+5D3̅>Z+iG>_u57z#u`ai`> PhAx8Xzv~>iR/Tz)'Wj=S .Uɗn"Du:'ހUC"@L|ggz3wdt>c}THmV?+G ݄Qr<?M ^ި;A+`1vU'!}OB+Z4>ŭ`>H@tgRYop}uZ.$ OO`q566$n1h<[n|Q(״ c`o"m/dg[J'/I%%Lh8[RKzPDL|ٺ_,fzf%6-^T6 K |[dz J<2w^WFS-m>,J$H ~*l({@G' crR`^&9CGYȟ3铟]E%P@ p؝pN^đ$3oxEdDP9hjG30HkI泌ާ۩w=F^B cjD^G`=dWį vzLiʺt$ <9@L~{d 9̲>-ܷ%bBIaG_޻5.u`89s10w+"a ~gFzJ`okU TB'F,L7ۉZzMc-jSuAMl@<&<ƚ8|^ep%-Sox%1y- 3r_J-=dT~J`XO5Jä135  I?lӵC7 \"ri@Zu 7&͇ڼXua9B9-u+]}J7-o1=4FÛz o`tIqP1>" ڕ;8-y$jzg_ǿObU$f$^I#[.> RGŪ]#}K|B1VIO:4?C|xXU, bj6IR!*!ͻD Cg+z㳧OhE^)X@FmSO$%EMrkMrm4 On+f$kTM/%Q`niHpBs\t ׼‡*<ŒvS韋'wЇp،ڼj4/ɥ$Z)("T7nT,18B-(kc__`}AˬwI %N6ftiy- ΠDeOZoET@<6o)36KX _蒑bna <,IѲڙɀ[u3ioboӪ塀2fJs62=NRz]saGu+1QX$eKQ䤑R4CTn!k'iRz4,tiWx\7]:`.|c9")nuKNendstream endobj 267 0 obj << /Filter /FlateDecode /Length 4767 >> stream x<ێDZ?b4O 0.O&/C+[<ř ,/Aaa 5b -h?.M(\I 1[^@F6}B ]qe0櫍@M]QN^ٔ.{ϓI|!E=G%E?xWd 9}rj}C@_`k Υ  W n\1x o"2xe{?1xshi1?1\픊R ^5'c [ofM>0i. vͳܤ8 y*G)WƢ6t796IGaY H8 (zY@Y$aĵwj@7w ŔG7i^GYž!B 6Z l+`֧m26n} aPW .GX!JRȠv\rsQNLxIm'"fJdP}κ*> r ׅD95~T΃"bMJdVۛހSg|2"&4u|$y{D?0 6x'^(Y}G_t}?ROz$@,Uh )%!uo![ \aϛb|[…i)/Mzݏ+'Q٫ܰƎ,@$bP~3}B6˞-[/l0TZba<Ж0AC:~>q7'{l2K!^A6U#eҠlo4o)qՠE\<R9 jѹY=)PzMte;FJfn_ )Ix4'0 0L"wA(lw~'m6V=6dRǒ2k[3LAlM{VX=&j񲳳3'$Žz1 Wnx ~NE m}Ŵɀ8Ju{0AbՆm^p՚p:ZG91`sG)aJ;2\R9 `ܨq? MCuF;cO N%.-Aâ"P+f*#S:t]r!8,ө3'iG] uŕKqOg*1?Ldv/%+AEmɽ$ ^$&]m4#"@xhCUȬ:NsVYvG NkSފ1x1BmC?0x];7y\&H$}`)&m4""K|DV]⡹mvZ3:<ͫFŷn^ 1tI!K̩I"RoD5"Yy䕝["mƙZ0{FH i*3&bb5J0$*rgKkLۑŒv15?5-xAQ@ uw;0",Q5G:+Ir`Ec0t4 :`2Xʰ?.wpݪɻ ApՆ i>?˴Ⱦ2\KE [ϊlz)(ȧ(>]kna ^;]_Q9--ʞ|Z?8LxS # @/3.l"s>gU֘rgb #hENl-)?sf% LɉHtt]0U-u.BT$㳕<(cL0bP[>^eZ3B#+cKSię%EBTP끐rBҦWDleԋV YT.Qqu%<:9-L2L %7O4$,9 lUVnʑWY!w?9 ǜpW V8ymՈ^?^- + ]2Ѻ 1Զ-s4`8i;!؝tQUAVAi3˨4&N& ۺy'uonGuaBg MU̻ݰ FĽNiT"p-J5,-zёӻ"7:+YOJO0'4={뷙oUV̡^Äuc]/Xn0SsTj_ 3uB8Y;530T f SΛص}(:iu({jc¾:#*Ue[u] gʺSa&I,!)I񥙽ʍ-:e1]'aN+ QS=f c}!LùomrTfa*(++Y{( @**-.R)I|[+4RKnΩyC%8Vb"*Zj]Ib0r{'yߕU^h}ť"43$dmm4Jc˲+p q2dƉjfLE?!|W]Lk'Bt$1O4f +LUh|_iU_I3 kp4I6v"/΅_J}6G"ENџ>;ryʿs%Vta=gb,0-@m^y߻%"%W+VCgXo)fG[cI˺kb%uŅH~Db{2^prEt<v"™SmY12NȡF÷\FkvyT m6\60#&S/ LAl_=JzQ\Up^=qމ$z~C4\B@]asY[DU7N &%K]ɩ:3@uĵKa@Ǧ=!r#m>-o 'fr[L쌷2 M|ߥ~Zy,]|'ą2Q:H[Q ;1Rg'JVLlRJ!Y/PjKzvkI7E`A[ o5a3ȱ;E; wɲنwQixGxu g&IKqTxz.t\ Ys?2x)n 7NkC;fod@^+Y8_ $\٬iS]LJ \ lV1U$ի&S݉^ R 90+9SRw;{gK$AƟW[dg ~soA!#/EPi>o_1 qcol%`lbbV[&=W&~WM|䁟^L 8%xt>(j7A7A8nls8!8Fg RO^˙g9p™?,[q&:22 4A#Ÿw,Q:jk;1~C),XW\8#WT>iܨ)f'㻕LMzgڤ\Mɛ(eѰYc6:԰7wLQˋ1D4ҥ8- XK9oPȻ cSlެ7 w)"e@dz؎cQqh?5ow̵GP="y#_|@ۡU#|۝ˤ!HU&_4٨@lxj@?RٶjwgO=?endstream endobj 268 0 obj << /Filter /FlateDecode /Length 5039 >> stream x\]s7v}V7L'iCO^{e+Qv%vFE9I+j\ \4{(*,܃ ZQW=:=w@߮?G?R'cQW*ȕ~ڮOև3:QZ4uУ4„9Ucu]M~ 1zLcqaӚdhX"RI|]|gX4_ p!;b|\0A%"^ F]SA[GSmž :D#̴K啋,VqQ.ҭ6ڎ95"/* OSZWT^9({/VƼ*W)Fi!)W:mw4[.zcI S7)N''!Gh% 8&YBҌ44}C2fx!~~^_u,sQՂe5 uۤ>]hMU1w3Ǎ!j#hmEri+KZRGCdr"F"I.~( 8.Dbtgfi࡮jx60h &53u.>6Y2m?<0) *tI_G-E%$5)\ՏЊ-k.Zm_)]1K iW@=^h#Qj X97μz0waIS<<䕰~(VΫ1ZOxY2@r5﮳ h(j {'sMXNyٚ&:aõ! 6d-yeNjpwQɁ/y7 8x |[t{x<5}?x1e>*]/eQոhᱟzO #_i/9EAhϱ6OGRvo`^\%^+%T3M|w;HJLP TH^GZ 387}DUA,6! Um٦ yJX"Wڗ̹d$㺅lДIqr?ˁ"ް`>F#~C  J?PH#ok2 5!ca @~i7 \MD |.'^P*kKƈQAI{ʲ5d֒$,$|V%yZ$*|FIՖUgx%?tP$[bgknoEYWi0ۓT-=,ePE~mY@'Nyl&Qx/Y(Uv~ rY815$pq‚mwxwũL{/A&ȩ FBAp:c0 &a>+n * p6܁(ۀRF׸ϳ=G/L*; P"k/j6TaPmGNeb(iGX䀹+f[ܜNށ$1@*o$mT3"1屳Rc2i ?9JwlEIczyòO0B+hc2}ݶΖEKԜY L4Ȗ\? i&^QRgw%scDʜ1!qFKc2FImVPP}(9yNؚ4$LI_3#0)4ok>S %Br9ذ||m]A4p!BILʄX;(;aÒ${c)K,0~-D8솜ڛd#YWWlbK, S3.8̙T%(UT5}'eE|RZjOJH4F%NKܓ4r:N\,GYL+pAc d1WbF'|2;Gh:TQzסo֌=l.%.07Ê3s9h0)=X}ztʛ9R..WDPqHb"crL%K*r &0뉇"@H,eFWV_֡*rH(QèXI/M(iAHr%f?# <Qd{D8J2Ύ6*~(u_wIG,MHLH"/,ܠjbP ޴^l@+{ou$-6.Y[:$EIP**s Rjy .`'uC4 (KzpQL A:" @[}, oe[(HJW̅ĆgqcpSrjvFܖсȨ=yVNFo|xVx1m\_H/ARɓjŗ+9E ` L̝JO'3KU*NN R=vo$~KW0*(4 W@CfÈx1"dh,e^H)`'d̦0Ea[W^v(:}V&`+uQ-- WQ(%Hͦ! Hh ~/ >$d&$|Ʃ/*I 1/SIfkLZ)+{xWgDn!&Ǡ{m7'WͱoJklrVR育>RϩƈXbKnAt#oeQ !xX3ko*N;\Q?{=u:e 4.>_a8P 9GjSX=AA+%ktS7UUՆL5<ٿ$kTY,6uL(Ilj0HE&Q"- t?~XcV[= ˡ:Ȍ6O3 i&J"m&sC(sG;d~yM1?S}~h4PϖQ2;a7JOֵ@"%x1/QYyTB&¥Wo5qʆS2󄲿tu%!kz?'=Y"mM t,@z?@IqΔD>C^bU-Q$ktqin>+f|yS e;}#)^wFJyTױRT( kK=29$=*˼| oͳdv5^܆UGnm$qsnfEMlQj6T.a>Vt9c@HyuQŸ9i 8#mGoa qkEHBN>.-@VLN3T \NXIO?< V~&c yK_ӒJ7ʏBv']=x`H8$I 3 [p1R.'x ݬRc1!f9^<⟘PFCM9{K+5؂Sӑjv;/dwԿjyΊC }䎔 CR:z_2!pI2*-NbkɞnMk>iM=Y\ T*MQ.{d/v/ֳ7،d.v8mNjՄԏU.ƾx(-]es,NMCʱt8:~)v+a?ٙNjp=+=|c]l Jw]!}ͩ}WߟtS-ªyn5|m!΋h?ߜIi R28R$mU8R XjgvmOt1É > stream xmLSgǟ-ma]qfw^ At2ނD  (rKN)唗Q^%s1Dfp2Fp.0Mlf<|U4 $?0DEKHNM y4H/2Kg{vkAÂF1Sbs(i a>RZi5B@N$D VSDH0FAb!ْc2B@t(mn6˃-]A$Ir˜+쵔A(C1 Fi (;s lza^:;nbsU<~yIY5>%[0'wJ5]pY|^4*n&^+Eo1#c$Õ9 6R:r\0rݼdn耦vgKc Z7ђY,u]tcƀB9?\4V{1xZ df':?Z| TÉ$Nt6~zl@} ׶`llK߸/Xsޯ=OWNr0߮:x>S>sȨfFdک<<&\ddMŌ+]My/hRǠn=.6Tz 2; P1xb@蒗mG0YVBytGt( KQ:zuk~~UwYuCE@j+:<ힽ w֓81g%;~}ٳ4 Fv5+IYF0>W=~y'>І/Pݟ?D*~73-ôحYzB|!ÎY)37I)ܟ?f *,Eo?Q>5=U>eяvVIk2GT|QWSS%_fY!:endstream endobj 270 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 5723 >> stream xyTw2 1b%"X( IAz۽,HaX"41jbb,o5Y^h4ј;G[ &9';;3>s cЏH$ sGIķȮ le+^~JaF0d(V F!T"Il:ul s,Lz:8{:7>v^{[8kVXXLgߠLni==0/ti3{Y v4wscfrVXZ ].e}~ zxnۻ{ޞobf1Xf#3e3 ff"cLb0[mTƞ80+vƒ`V23f̘Ulf5ˬe1똷|Ɔ,`3o0<33&̛(f3 J0i &y*$i7_YWRGiUʭERʽ?paV \5eаAFs*2wHC1 >w7Bw_e##Fa8dObQcСN\[.,R UrbI81T)\R~Hsn@꽁tl^zh4gq1V/3 A ~,y Fȑ9 7ꒁN4JPtBT<.I?Ke^ɒn rZViazzkb}񊠥+֨t-鉮u1JсE;~S2(Gk߅vm2O [(wE7_"|@>pUVRm:G6J^je[yMH[EpO_Df>"l¼]gXug4b }iKKuJeeKhp-ZeLCtLl q:@x =wzZw6pFhUw]#߶cGCad,b>7ud> NU㰊w^lu;qNW{.E֪SzтVk\JYBVG̰S4e8˗9Ol8kϵ0N# eLn$W^"'E7 Y8 bC_S-i?",)EC;P<:":sy.uٰk : 8Gp$buاٻWF"a4a 89΅dHܘMH>O q)_YQI*RRcSdzK1'+jI;f갾TN\(+ˆCbQ˅Cez`rɩmXWuy#@iUFH7wWѱ]CǖrJCxvrdɓSwH=;nmo g5~>jO𵸁5R KԜ)KE;O7NH[(2k'k$qh,]#y4=TCCˠDg@6j^@+=^@coyWx\!: YEٗӱ*>P+ɉjP')HKx<*;l,IbӉ"F{IGao Rq5NaGBw<;c}.qsJwڭ3pײ7\x^A|VIz~hG朆hvJb,) ,6>ɃTkN6=`tF|zRn$*5Ql2& U78o=X &yK_ckRkR Y4r]]jqVrE%JDwҠIH"(הڏ7}` ) KagcJhW+;m'%zUVHuJ7e2Z _gfd3%I1@=V8+@CfAZVPJFɜjU pG(ZZY3vP<=uHQ߷%e%e6SJ^ߣzadpoAGة3!@qA{>;a9u32CuO_ )(|jl=@̿xA?dVH'7T8,Ⱦ/U?iNAmM?Mm^aѦ{BrP'ok+HԤɇ&NT굳o Fb*>\RV$ VϢ6pi8GfujJHM@Ja[I8,MQ@h!׋S<@&W<,3lC)p夾'@ v\bJ=&˴',Z"K$ݏy єSV٤?ߙY-,bRu]mܤFwzi|U&I]jWI/DO ÈK3}]RI$E5bGWhZNT45Q!Ӷv5G1Ү*GO"DHh2x4%cp=L)Mx\zo$CeՇZ>ivʒ:m(M]:kr p^0 WWrRbmFC(qţuN\y7(^ NlP=sw/~X(ΫOx3gŪ5`Nf)R Iv5'0.μ+?pPsk~1Mj2ݹC *#.K[-+\V/O ʪ=AI6h5Dž޿pS]`Xҽn7$)b(ep8 < >xֻv WFg],o=uygCxt&^8^^L_c@^ M|KAL][$yd8;4%_pWNfAy׳}tԳa?|%0`ׇl~ujBJR %d-(쟛Y_Zf~-/*,A8+ T(Uk>Pj% 6@zJz,UK]?DW*cOh.~`P| .Ky7%T]hsY&tu}K FYO>?/3ݽ?Ү!w"*Z&ԑq$w\>^oFo+$?׋gj2v*=7SEA 7U[[5c[CFw3Ě|Мz>a}_]YŸBt6FnȞO`FVŝxM:thTԠ7ՆQq K ,ySÿUү>逧~FAX6umƊ>>Bɳ=i[fdRA|IX\<*:cOÎ7Z%_`?3Z!ޣ$st1 ]~Q)Wn#t7JK߯l8@Hy7Җ]tp,J,!aNSoa`r_dmp3aѤɰh>1b!SbZ)Kҙ<Ȕ1 U*s%@F|$/'+zrFNEH[[φȮ), .8 .z@o<{/ڈ\:ukƛnm{Cc6]%o;.ISu6bm.L- lwZVF#B?L"$Hi@b0c0@?! "&03ϯgUB\*4Zs!lu7,l_\NL׵:2)>b:x ?218\uWmxGd4%yyy-);ף`?EMC2у PL]u7\|AEgU'f a"2# cir.󕾤]-| Oϕans^#|⢃ StT{ӅGl6]L"ƊT{*ȭ^?% Z7>*^bbE]/'X!J8%U 4b> stream xe{PTew\4z#DݻGT `6DaB. ؅eAԅ{vX@Q1X\5y/5dC}j)&6t=7Lpm}J-TlS(l3/M&o$UXU۩=C(9HRFJ%Sqc\ϮZ{q$dC qr݇7 ?혀?n :Aq).YG[wpdjn w dЈUDȫ bVyֻ&@%$=?EMJi| y7X#=c8U)+pvHdsE)\]PՍ ˆh<#Y͵TV(b+ = Ynx,SAHJJT59LPs倳UMښ58 ~x;uUV;RLMߙi/sU.PAs/<-ٖ Ζ)PѪ!'bl[C5M^BlmB(<G ^|zBLBQD%`1 5Φ g B7nlk]= !cmL\cfH?cI:[,`[|u_LMיC\sN,仴[Tx  8ĤuA֑} %W; ƷxFS 瞲lCdԘyyཱི#=pFtb:&q3,H g]1ᄍ"j-_߻/Jkz$1,S#\tsKt"3'@VD$j׼rDG\@v,&' \M1<&y@pjӶݟL^a~3R=b`m>8,^[ۋbCŻ,1o/zcL0q$Fo YE&D(al&UQQ;3Y\(⢈4;}9s_O`wK,g陻G o:&ݰFi>#$aZw9Iu1|U[y\AAH -))꿋}2endstream endobj 272 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 7822 >> stream xzta X` $jq7Mr-HrE-7ƅ:!@]I6_˷zZZH;s9{{7J \7q_A~p7 ־[C?e+B}6/rG A=xN<>5>tw:`=nBW9ٛ97@d-ȏo]maA,.ݳ,iypV\{>|7OSkwu{zjImFQfj OR q6j!5N}LO-&Pj)5ZFMSS4j%5ZE͠[KMR([eG Q)bT'5M%PTʏT??e#I#Sj@AnjaaeݿhuZ4CV_2!#{z'R}[7]ٷߔ~mGfx[ oa}pv]O3g;hƠ z;>.JD7I}!R8Ш'9 fvf`x3jyu{<V#T'i'䇶`r yR4v6|KFCkmՑÌ CVHVD8uFv!뵗`CiI8e Y,7TdͷjmPA =eq SKȍG5PN%28(A+_/8.{:Gk7C`.ҭ%#CdV>ौm-$+h$wѩ ("]IoP?ӺioG*w\G72uCQF_x(eq>`{oμ9&T?_pk^!3ʻF^,zkK?fz>?.p, 8t@=4ZK엖*k <`Qo+0ʷ tﾐ6,#tQI|悰P<&Y.3q ^>I ڕRrFC1\ v4E!+D{[_TL^a*K"Q6Rc8͉w]a =]4<BDdAz q*.[Ϩ m{ L8M4()mх.KNn<-Gƀ ^xIwdDc]KETpw)f/x .Uiʡ*ބ,:Nl50ׯ?"GKOgc|UGWʙ x<7]s$Ԡcy{ߍ~Ah̦gҙ9rD2,2ґUm4/~&k]XBj784A 4ϑnϚP,\]MT Xc[hxe9m콋 oΰx!RJM?q> RKм__h/ pfF.ݽze&Yŧv ~ Do]q^l <>d>KRdIHCi4|FsQB}VAņ,a "$8wk~Pu!Eh,1Ȭ/ZUS M MfN)%h<_k@XdKE]|XٞjD,an0a27g^Pkio 6ãNzc!NT5:-Bs$`ki6OP!mbw"aet߄q\UJ01.t$fŜFNU%/:[#qp >{IuQԉ>NI$ɅbfB')!6S$'+*!Tmz D&RU4ɏAjס #Y_= csM.dBFͧSR?'rڠZ2wrZ܊cq2%o&Vpk6 vx'a'섦hDunpVf@#t߈f^D JY4̈A"L_QɌ\EOb/W^>ϝ @3rV~ֈ8h{ _zMu(T#- 悧9N܆b迸i J>ufp_]EVaD ϶2'&@#^/l_<zrk(&Ihz6L@c9q 8PYuFԷHj_}+7E6 :#+oj;#Sfq=$;n{g){.b>ZOAԤS(T! ;4N٠0W&';jW^5Js}plӢ5I ))YYR)ԝc4h}!dߺ~|1ruю.~˕Kײ% n΃s䉎J7Γx=#xytUd}@آ#:SXR`&VJNA3gڎD59*hyj2|+(PfŤʳ}æ$۱HC6ҵ’dؤ89odM&IKRdrAkɍB0"o}ÉmZo_B1tk6ť©3y%'k2䃩r=\lf""]yNRp6AONǶ(>V;h382< :Ǒ\CMŭL".ؽssݑO[iEOg4/#j;#&u\I/6[t@4b^K3c וXb͎u:rz#I=`j٦ej!jBl}ʍ&X*}Uț41X(3bȜ$_9v&[f: Re$uȗ@j]fm^׮Q;\cTC(,>@M̅|W՞HR>Ш \RŘŅ`ztٸ(bR3 JVgU2!-[2k~"̳aCd81k,r'>(PXV]\sF e Ŀi+.:h7 hbY|_MZC1ҕ8QiHdUN{=!?жQuVppH-1 "R&žUXY(,xS>!yۤh/ytD֊)z(` BB1;[yאV`rzGLRǢwZeSyq /0E/4~)܏o4u` ꝕ r%7~Y;0b~hN^WeH>+TRZaLG_TNMRR؎jU:0y^, SM^Mispt̡--A6dNd]wʦQ {yJpՈZ(iS>ḿ`nd`>Y xALHAhEUv6 0=&W35$2Җ1h_9:gB.hFg?#/8֢@,* Dh2 ȓM'ع;uAMe[54Z]d(e uMASZ̷0"$@$I w!@b\YHB]'/^ol*O-2=V%KNA,^Z[(wvjR`/ZͰG\7c],iF==z.JnSZXEr$Sd8ȾCh%0u­$#+3-/+DݾfVMn z&ϭCzRczf!C=R!9( ~BKP 9zm t/m1?ϔ!wF}\SF䨮+MKS%S}lMP4 0@h4Ԑ&5O9Qx}y~I oⷌ+])K@iZ0o*Ul"ηʹy߄'qlIvKIEbub{I`Q(fĭ=8We%ku0jMv:jqy#&_gKLב";>؜m/]0ݔ\4y{zgI!)n>H_m߽*/8ϯ,Sw%h^ހ2 }|LJyhj~-EYʒdAC0r.>f/p=f3&\衐 R +O5X% l |(DTM?>!-!.,"9\WLSB8vkRyk쯏rT%.%(J9^ޱ5FL#p)(7'p4Ζ5'r<bI< us4q3;$x [cyOZu9 JP)Ϗ7f~uֆ{L4NEh>qIqQ K LV^&}x)YM >91읊S&sg1Y=KVe髎8@g<|!Ock%w+T `e"$ULj;dt(4,/s53OI]Q_w'KY?z G wVVbΊ 4N:j.Dh&;q{LFW N3~;xM F+DH2Vр6G~nDa7,5fZ'M!*ң4EjJ $Ih%;JJi&"%0 ymZ ]p6aGFx2WD9V; p^w,3-\Wg⎩Go$62^R yiSzKWM/Ŀq}t]4 5j D'{'.XRKv`SS~zrh2sw5eQӎoAd _ab>AF։'c1o Π^|O[o<{XpV"wB vzif_0|X/L!U EL ;-Vq˲IKѦK5$nAZnP j5;8`r(%?<'v</M%i䴬_"gQ- ញXjll eF {fMN[5 q(tUp\jEyP aŵttWy'0uLٓgB- -Jj]y6])+JQ}#AHiz8C1\$/M|TG;]R уpOd%~笔C$US\ZZPنyq-Xa?L#u:K{X@f7ta '-#hjUrU*ٌ眛7:b >$ڿ;!N:YLff(&F<+"y_'GA gD߄K/,~cGwD>Z}J fOᢵ4)< O(w$KiYd؟NeljLLv|,:9.N>?)J;Yf|v^JV֬v[.ʸ+w+,Jyu3 `5t(i6|sS&6P ]r7 k ?Nc ÅŨ׵L…Ya b|wŞ W;k-MrdƇxϠ'8v"m:߷QDEv- RdD|+7~='> stream xURmPSg!$1V){C-P,mW~ ~"V IJ(&#@  G%*&N@*cvvqiwglmtںue^fW;N}=(FG#8'K_8+[$gȩ-o YfeJC?0ǹK' k:l<{M60SBv#|N`| p:`qCoIvi3Epu존C1^Ci7_c1FA>º>;as hϋo&&"ZZ3Xt:(mTƲv1f%YHd2Vnr8ZZuOkaQg/aJ0ƏVlL S%N*;O…uPo3XB[9IJԇ_wށKӮf/N@/:i;H-g_plW?74M2xI]y>p)\q{ジe䩋k]1AO]hGk ZkǤO\2Ax&vZ*V2j 3 `[/,0l8% 3, B83p~wd/.aZk M2w"SKȴuBk6CxGEMΫ 6^A_hQ.Es8tc;dK/dރE2.|t;][Krx' x/_ ONf+$!ꋹ)d4㤘 _5_x>[$X/oJCC]?~z yH'_v{< w8vqpW(HXPKǺ*љJ\?{N]c'7['dwW;Um**{T3 ަendstream endobj 274 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1120 >> stream x5}LSg߷-X8rWňNT;"2 7C"BzEF(/h4q`\ D҄2]husC]c9y~%Z -e9mkY[sĪuuβ$M`F?k巠cxBM2(u5}iq=ΝY@]`B*lpx5F.;*vKCn2W˲{evͲ7ryv]H:zicóQ+ei!fX\ &\O#!$eTCH)'d&9$,%F"XgdNih55_iƹdnrPen(P;eSbV1@ܪ upպu]& !x#z3O58S_fB_ MUbe f_xd1Vhb)a~)mν̀2 .ы́;k, p`? xPIܹGس5}^[E On:V] IS~83(b3p.ZLx[|b3oa`uLBSb*{NSJL1%j Ƅa1rܘDC.endstream endobj 275 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 6106 >> stream xY tSUOŪ潂( }_to^eߺItIZ("aXQGp@fF29ˆ39:3'mzr7rClݵqK\fg<1k͌MVlӖeOdLm&58TJxrkE䔼—X|AŋWLfoKǏd̎OM+RJ^h3.]-N~eނԼĄgg兿>E/k3Ey ,tuVڜuy 6n.R5!q[RDrJ]3dF.]r =lDpps<řÙωwkM~qw=>H#_La<M]3iӾ~Sx13\3fvO~G3ã.4Qj.E0J@27fnɏ[+έM}Y2ʉ`&᰹ Xl+ H"iOOŌ ^YB  Չl"?Vx^.JA[GxX6[q 5}|1StxJJAq%:9睭A#"Y[/HH7C3TȉC@l9?'}ko> BGGhMїFdp(ZP[V\^B6MgY9 E".J;RVMe_f˟=fkBK ԥ?o>,G48lNS1.~>*PeQ;jT3G C'vã\ ҽ`s>K5u=i/i; B\4oNnEɇ?z.7Pʢ@M]`sMM$?\:hmQJ VG=G̵"Υ ZCY)nT-&34P±d~evUԺR}lct׃h"B qn4Uk{ʇ0([55tgіT rVc1Hh9/qAGC,qc 498B2M3zUie ,(b]os/Qp`=@4*( vl)ʳhId& |@0(ti:)K%M/Zc.\&U`#zMŠ:^Y&?̋EdS/AFP:>%:PRBžu3_?!u{(v&R>KgWE۩âaxvZgG(I}:^y]`a؎z,JՑia ~4.{.]5a}Gҫg+eTGI U[WῨq)2Vo5qL14M-l/mBe®y@52(R8 VPŜU\R*߰?F9w@qB[mRSG'@<ęг3߫,n0S=k>>oUCvp8mvk-Յ |ͶJA = \`ȃp m3;*LbeTQnZ+WQJ/w:cx%$a}WNm/ڕHI濽!촼 Xm?=}0uy}eI"ΠSBm@C.T9MPE l2 -H^~INt_DE%Q(*?>G9:*O7yR.!#\]䡳Kw`J& T04-9w28H.?}t棧01 =B4ǜ]OTUz|_h1pU;7}'31x\9Xtgw7n_cPIt=OϰQE79#arfV^-Ji2ך6h" dGr/ )`Oʂ(f3i2.q4Ń@t@V˰Ae,K)S>gr]07TFeUc*tXb wq_{Qm^ц&{Ђ_ >}_ B^>2;w4Kj5z&@Nd%z]\E'-AFbsc#-WQ5Дr K RT+`BkRGI6llHpH,Ɏg(0 D l{y,A0\#)ё2oмe%xeԀCC$K'Ri#kY%ѥtN/ rt:azRTh^U;o.uDAUWnI6\jA @k Qe;MD\uZ_WNOL˩-u;ȰkׂI}vjFzF^uaKHf͞;h5j>I\4s AjSYi4uf ϐe$;ݘppnjpt{%6%K> stream x%OKAnFTR'/)aD㦓 N-z!X%b!~GuH2<{yx@ gG?&,s+ -ϫ"9'9E?? !*cTfXb8tz%Sdo,5+]cq|*&m5݊fq=v!yA xǠ k:Ae rΈF$? `ݧZ/^Č$wTxT{ ^kWMNYujgovéTs]֕q_Ӳ\J-Rj\T-nڣA<}z1?Fendstream endobj 277 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 339 >> stream xcd`ab`ddp 44H3a!3,<_7s7Gg ~*XP_PYQ`hii`d``ZXX('gT*hdX뗗%i(gd(((%*@ݩs JKR|SRYBt^}ω33G[7]z}r[~kb}vEly~_d}{O!lYwVWG g/d4mn9.<'yx(qz3endstream endobj 278 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 3601 >> stream xWitTUE !h Su4 Fe'UIRc֜=B|FZcB-_ a*БOO>7dSR$MgZNLFL?=b gF8we)LԈMq$UJ|DDWy"%s̎Kɚ9jmRD*KXNtۊtV)-^JQ3i+3 ǫ&&EL֤l9P[_SoPԛT A-fR.jGQ%j#L-R(%IuIho #X酑Cf ȚGM:ĮG;t[c¦'0+^|tW^{O)hBޭƒ°yf5ϙҴ,.ᬵONqB҂50>WYvԉޚN5.J o0j۬*M ?zG[ S}Z՝ͫg,(Tl_\_.#髟c ?0S.B#Q(z^˱IЃBߩD#gS@w(#FL%c4Qoj6 HuO:\/wmRc9%dzn4LQ [pގ襫ScQqc, ҔRl-;^py +ߠ_]4 @!5yFл VpFm4+KϤ(/oۼ4c: &p4dL_)>cui3F&r(ٴ6<g b{}ؖyX Z}EL8y"M)Ңo?0CsElipt-<<&7Ueedqk9W|GzrΕm.vz:*GS{oGJ N* ;m"Wxŗ%_Eg dXAQ@0hE6SRhmp6̕Zƚ| 8Aكn}1e+!%+^ ]׻m^8AK2[঳e^L;ZEzkA(Vc!WiY{B+qGy32̓goICPT/X' Q{+7Pm8Q=38?E&쳥EΠenbbosS7S?T]HnW.nTfL_ |(;:dPXI`R8QnN-D8R8hٰ 򢄣+Jߓ!'<5:'k'Ox4|s\~b_ogkvt:(̏MͤyfʔF+y:rZ 侠pۼPNY'z lq#Ys\ޢ5'$׶!M*moww}@߄9:TN یHNr MBOA#>[vOfo=rG> _=ȪLIsI=&`&uOM(SIUK$8SiqCHǢcd# 藮%W(uUmW@a\ Mc02sI YnzZKd}(x2k4ɏ8|I4˄vRh} ZJMM)iÝQaШ!Z>= !'.yn15 xh<)26*^a ׳a_tڹ3.8d:P--Rc/VaY.A/z}z;4nΨ3)-*Ox@zJgkn"ן+@c!X L 0w$H:8W*aLˬPGҹ,6.dɢH14s-jh'9X(c-lѳ@r~k!p#lpЪd/حe|$b2:$b}l_PrOVE HMVCSTUa(=esŬ:I/ P{TUgv;PL4f"\6+A= '6(tJ):<4db1pE:JmOJ 1 3x!M/V*tϒ~ʕdo+|ovYn#Wh 24JBJED,5Y 8whkb>WN0]CRpUF'S^aOZ4u(Ɗ` +[%8nh> > stream x}mL[eǟK_h]٦ ޛqL,Y2!X׌K׵rvBZN^-:"B61>/=xMW?O9BDQThgW((G,A泛&E1ʯ~qB hտ*w؝ېz5.w 잶v_EŁR``hv&`VAl ^vA +<һӇJJYC \p6)ZQtw Ϛ\6D)]=6:tFh?2\ɑݦQ7s9b@#nŧ2W8/`Z&>Z RQ}.\#v7|7s#sSGA'#jw=#ojF}$-nR='bw!-nD΅o 롁> o}8n/rӌo@Vq?O8ǫCf|x=jjH ^ VOuqlI'Jr2݂<whu&IaZ?7S[endstream endobj 280 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 7504 >> stream xZ@֞E݌F]hA1슂"- ,K{Ҥ)boX,jbKL4&$&jlry?83;|eڃS&;E7DCICbтVN/27A5CǸйF ݏ2|c]$cw}d=eO&XOEmXi~K|&Yhd'uZ2d}U.Ym:^S§ϘɰYg9gO獝тq[O&˦Ppsj65ZMP#5(j-5ZGz#j5H6Q fj11ZBMRKI2j25ZNMli5ZA͠VR3){j%K QTʊ2SʌJ}H )⩞5ՋFRTj՗OYP ~Tj5H|[V I2 8M/1ˡDŽ"aӋYi3ט^gmjK9ȸ(xWB5]Tjjȕ/ fe#\˻JTǥ0ź@VIZ3lI5/$ltu(D(?w`G#Ң/<{>sKw Տ0զcs9ˑ{p0n\#8s4 f 1+ty{2~ =F?yT2q …f,0M`ox$G7H:2G̀JS,/pǏa/{9Yp8c@69-z-E ̮naS 8E[vΓik*&:W"o6ŦX=~p `{n_<~B+L&XMBVu&q ̊R[\NW0_1+®{8Vehp.Xw-@!Q\RJ {Tm/Dƒ% vx0Z @~d38֫)ɲ#u~]XIفLٔ`ݽhvK?u{rãM8C ^ "밭!^EuR;8nO8P EZ:`;Fm@ iaLmX!5$2lMn{>9bTB]8jʵ$g&`8qdCǞ[nlk̞ЮN̳ 8 Ҟn#I녆6F}u|A[K6ABg$ߏJe; i7#rz+;ZXxaӕ_ (V `oIYVtE_7L{7 Xؤ-Ok- %k4PPHyO&足Hwxi^Y`%qOg9SYWwy)249Z:ILxd7yc̷1yۺb.(!1 eH\Yl]'UhO4/z3i/G>PI`\r=='1Gle ~S|r*#dctjv;G![AKGkJ@$5dڐKMJ6CYe!B֠'8ZC)FI3 m Ut+#vwv6x.'>WT"ܡ *.!ݎw;iSl"<}u >" É#Y U;g]VETSݮvG#O84rnٗni\p=wFt%!~^Ȫ}5[xiMg:HMgΎي*}Դ4T%a+`JPB-hHv}j2_ !JKbތϚ)GB%f(R`0 eF8khPFjT_ŭ0J,To lľ?|֭a[bn=O竤ae[b[Yu a׈aC% hPN9ֱb_@{ ,XzZVHLbp,i}/Z(yw\lAc3G2]I {ɬnpAUcae^8agNCbuę1쓹Wjs{>:!gy*dD\4u!^}Tz ӷ[i=Ep K A9O61Wyt^\nţ;dJ vIX*p $%0w>)XMOɻiv`y:[c6lعl< =\.^WT_C$G$a KǏptۆ;vl䧸)I%yvvkMtuh)OUbSXS]\>r};/v+ގ,#?a*R=3#:P$3*>x}CșM{t)YJǠpPD^d%,zkǎeՕbZ ر`vīs0b@d)?6xQQ}%: uHͩϏINȈFD~kXOz VE]>n }u:bi3ԊB27eGE* 2:_"&xebJ|ŵ]IVα\!9J#4c[P &t~v|-k&ipdh(֠#^^}kPoi DNy{zW#Z눧'z[$ E'_Ce\DD-/e$ЬA>T3y*DPDJT5(>@{$'5u$_oHAЙc@%tK,K.󨐗ד[g\yOqkڄ0|zs'._jɻe҉:rS_!2g9 tk}L011>HV[V }erqc2ssjw|ePiO adlU*,CYs#rK$u02,T $)HZ0e߭%,7BƫO /6ÝP"\9m bxm_ ۓ8 ݺA @ΊuC;bX FUKihO C(5-+[w2A_O,O|Wd\%H'yGh)Bߞ 'ǫy6gfMnl??y0짇O~TO>H %5Oȉ(0]~}@Ok=8n#|C$BbR"DEzR!!gzp~k5hǵk!yfWsi"͕d3踂; :@/uJnΩ dGNv';++_:R2'_PP^PK3m9BB:`/ E'5X~D#Ukg^"m1OدzT_"x[F6p@P"" ޻7Vr/}91eXW_$=_fʆw K"ZX0»ݷЭQ&nGI7Y;Yt"ZxWt\x BYv̋NQTPSVL0ؚ}G5*QX6>!fړ:V!c߆p5WobMWK6w3}z%fE"8@憶3O-ܑ\AMyz?JOvr2:G]_r2+avNqe0++K'/ qݼbS6]V')ݝ]gk1Q9u6}?*d9QtIr,łi"mF!Ja2װ j7F,R "oxbij2CSe#5G+)+:> stream xuV{PSg1{Z[]kVַ>*>III@BHx! *U[N;Vl8_ݽ@mLrs~󱰔IŚnaDž߳NJbҎ]#ɳ+WZOS! i)Ϧ)FO!tI,*4 `?_9̅K,JV֒7xRAQ(3Pʘ[ˋ<"s|L/WWW/(,XP.ݿy?s 'g.2*,eNt`]^&9M<58p,FEo!t"_Vo^ur; ;ηEߢ wxe-3HOGQVrGct:W/ Wk@w=dt9: R=p2m+jwB7p-o#N{#=^@/>rmޖyNԽ gEDVDP'4f%yEí 7ŻC7mSD|+W9 WxHSRV(_<!'7+AoGI"1aqPoܠ$ Tuۡpshp arO{~VܨJ%unWO5m K\>{;5]Tx7euCW,w\ -uj)T5~yG'ʵ%t&Y/,##`+xGGU&杬vD%Gܶ1uB 3T^\uGCLutaȝ#?LR|l`[?ƨY/63ͪC3?tx0͌ AT+1ɢ[`岋zCDv\'ʃZw(51i #ة kv*ïN"q>GXqWބwwSJƸ XA-e^F2YVkl)FHf+E"ekLDY:7!{%$&>0[lĠrѳ#3m/j&~p]ɹ#Ә٣7"!(ux{%vfxi{(\g/g.t%`t"s@Yt&lwUMTQǔ!+TFr 6@!T]-Yx暵-`qwf4M t hF,FEo zAPbRt ;a b'#˹6թ,JBo5goT{d"64pM )|gC'{&~ah1ZM $q4n8:}}xd3叹$iAgK-w jl'[ ]с>F2XEi+?jY1J*ffo" *yC^=chL`ۻ.ed27R$%by5&q]:JPxЏxqJe"o\i qFѥ9EG_F?*[HZ5Vf3Vz_͵(l܄{ zk`}-jNuw4G!zlsq!gD:C >k?鉵8=|]p ր2nMA= MeK bp~Oa 3+ˉLd&zz4dl?I@T)Tx4\f2uZЊG,.F65ba\ ^l6m6kBR?M%*#6z4U$Z+Z[ E;Zo%a'72!y5e W:Cn5-?XlNN!=Wւ ol<nl EUgpZréK[A؝7' yN)=m=0Kb3&} > stream xkPww]H]c٬P  Xmq| b$kB@H(V\( 4TD}1jP-_\>40gν987q?.a%[s 0p։H`lu_-"7+F9h\q.K.ۤWgX&DX,X*j^s44]Gj}q@NEXWJrsݙU>O@4{k߫q_ wɻҁʍ1uyͮFc{J[@y> stream xyXSW1VUR^uoVm݊gaC !!yAqjjCQ[}j}I&{rO|OxDN:g%Wg7 1ןADٯ\2OЃztn›}^p׳KkR q/ 7uꔑǎ:+96=!&:%titf|lrt&')t(&!6Sic䌎N-J9ldhNBf|،E)ˢcC:sDɩYKE;bSX6+ehԹigd.Z8wqbv._j5I&N<奰^xyCg8l#72zqFDrbB$"UPb5FF '#ulb$C"6s<љ@I ""X+эNL'z3+D/Y7CD ⷈy^&N:;[:&IS.PTU]Ow[|%k{ !f3=C{J{Z#>}>껴V=w~>ofK?2#ma"|ҀlA}mT=$2GUl9{?t\hV#`au'<35h %i` TI{#ݜDpi dTiI,zB96RD^V!HH=CoҀHg=>" HrP_7^vkh'  0Sl~u`CNwJ뎟<ԑܔb]Nm-؜K|8MRAbЦJ>_ybގt?sE}.ao kTMs"!Ftpydȱxû[/9#Ұ+Po=XD}[ a8dh3p_~هo;jf8͜;F7Ft(``"~Ҵ\Ժto JiC*$XB?3Ϥwi  rW}SvNMz 0PB{NH^̨j3 `o,d:On#m"6/,g.#$m5ml>(l*cɞg +8v 1Mt3l+`7Ut_$zFR8ZVT_z LX_ť#i8=4dmD 95y82 ^7مt5#}uPKG 0+dLlbC|UCB[( \qNkEI\2 ƓhHe$nӎH@Ej]7L dn] }܎Ʌ#%͇c8u5,$ā@z5!=]>E] kגh x5X;` ]_ jg+o[|N-7ȀF/M  &S\gfHu~qZVr9>%ȡ-vT(*  "#A~L_#jQϵzb L,p]r8Δu/#A!){򚾰8(?Px~>HIg 䡗HuI]JiDѩyd-h8䪻o5dRNߥ\`bW~J+4q9iۋ6n^N_ѸؘXYTjAc?w{n(aQJ}dL1is18KGIB@5;6b=AKSഏ^D#$!OP*a^P/A|#Lw}VƑpR??PͲ@h!ݘ̻:>|ûy b߷Ut|lBP7MCP]ÅFWȦmߘ 3V::\ԏ ėWᇗ\;ow&6<)B*2ߛ_2A La{B)NSE6+r_ Dn_9aŃ"OJ\2SMަk h;= M#XP$4b[x(1x n\.bϒmkkoN,"+H'1ɻcD͌`| >g{|g?sTd]"%\#딷H꧛ܭSUlmЛ]E6@\ѪMl+!Ǐs&lntVJȜY6dQ>[ EN{~pf&v7%=z9wm^"j~Grg6pPoyKČfM>`78PN'>J}pEp*0hYcz煾' m+U"V(@Y.7YX")*FSlh37YSTP}%ܷsm\ߎWȯEYp,'sC t][)JOse7473hEDCwU  q¾@2}bUTV*޾ں.]FNNT66(o侗rLԲ9rP`;*$@RĨh<Ƙ@5s8[!_CT\sEiHeԃ\Ĕ|Vo)so r=\?,xmj`f>V ve*%F=elsF8/ fmp= C27˯)Fj|AqU'_4FH`bYu }Ki\PFnEQY  6B1W~[MA>n6 &s"p#ƞ k NW 3HD -A2,H=z6CNxRfknŌSPᶽ*: nf&xWlW-A pRmj{\&tPnkA.ߏ@[í4<+IMG]eJ:q>0ա<*D*ROd%%uw7% y8ݾWRQ׊QiՁm@44w%U(J)ܦ*yVoWDô<_pV_1ﵖ쵾Lu22p1y/>qkߦYyC&NgMF R 9`];-ɨ̝+ 5QW4buu6}mzJݑ-6ݙM.WKu ٯ8"<\7Π`6< ub"2 ),PIAH1"xxA`UdWAgJlIxa ^d:e6TXNje?onTG#FyTʖYKUIkS6XwF^Oݪpy8ût#w>p2JQ 2LP!hGî/v~>^uQQk2cX%ny;hz`߭GG/bW;wg9}vq}1Z:~:z~,*eSȴpWft=Ob'"h5b8 t/ᡗ]'1C5ՓcyNa_.=!~2v/;=wjz3^r3'?~dsLU~{Wo\}Њ _t~%o0׏{~[ْU+U %l>nxcә2lFJ䥩\/]uə2.D$ Xa5 FdǨnrfo+$QpTSbTc3Cv* |;eWYc/ޭ< +̕zsX̨}O;'Jۙ'W6BTV@ v4%6FuJ yvj<􇧝]j|gnvDV<Hy5rPړ|xۚ3'ۻk_| U 'uM5[x'^aK=!ݶÎ sbovq[1s7qtY TQnqEH[\(:W^,+f5|x?57Z>fdLebY!fE4eR[Y x2{}5sѐ^ yC@E p5 ^__a7WOFK#''ѦZ5P V%l*VGa"]$9i7)42^hCv(+dh=fv`/;Sz=yZK0^-bwԮpd˕jFyDW^װ0Y02h2n'=+|\$Rw[gGWendstream endobj 284 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 902 >> stream x{CMMI80`_B@JL4   {rlnsCopyright (c) 1997, 2009 American Mathematical Society (), with Reserved Font Name CMMI8.CMMI8Computer Modernpartialdifftyd@UZEx%fBq"~z0"{zip^l+x~x}Orh}Oi!|w[YDNv`紧 wtq~gvO`:BZzŭ_](b!ⶮtvtyb!zX\)qƺ}Sde[jbcq^zewyvuhzZ\c e,ltSuy}jwZWnN (#O¾Fωŋr}TxWdt@YFWvk]tȼ̞Br)q~\`v8٥߰}}e0,O_[b&4M ,(6&.]ls~c͘ETV}Xꟲ߯KE>Ee/vCp`  7 ?endstream endobj 285 0 obj << /Filter /FlateDecode /Length 162 >> stream x]O0 :!0Um 8ʀ0Ktpw'ez#8|QcYZ`ɲ(+Yy!' dv>䳾\C4-^!(ƘV?p֛3**O%ES&qMsT2Χl_-S(endstream endobj 286 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 306 >> stream xcd`ab`ddds 4H3a!ì N^>&|<<, -={ #c^qSs~AeQfzFFcnjQfrbobIFjnb ZRaQRR`_^^[_nPYZZTWvt-(-I-ROI-+(Me```4``b`bddqӂO|܏,IzuOX4+>]֎vɪ=SL+^~ os_ļ &jendstream endobj 287 0 obj << /Filter /FlateDecode /Length 2503 >> stream xnG)zyhAѤauQEI{ffwϙ+Rݢ`Μma>gx5{e }yjepx|y6KWնRϗYO 8iy2{[P/Xcƿ[~eF5xcQ\ت=iֺL=? cګrb wRyUUsιZ׼a#K$]גZI~`Rz[v&P)W]_Si)窫VT灘\6Hw&b\pOg ћ܂+@1N9kB$zh& l7wHS!BV/1Ƙd}R>O< G; AZ`<3r<Wn| C]t`i|lO+˧\%iQ=_C\rz[<%2^Iu',8S!]A5Fs( x(AF+ =\$^#"x ?@ ^ >S"#/%lunkPҔ/_V-/xMrԲKI>2Ϩs !e"3fә ,}QrnP}Bኺc@ v[̎ a("קr(NbS..@8(b?ʢL7S3DUYtTH ue%~Ұl}% ؕEcJƪ0yd@ҹkHOBd;c\1h;h]vlIk$ O Sm[ǥj)^E5P(wi%/ "d pKF}, λ=ⵃ ) Y~VAlGjYv|JK.O}Xn/Ky@~ ˩*{!(h(bO z\6ig]ʓ?&IQ)R4gw&}U(R1>t~$3IBn.A2J\N˧N1f%X1 Ȋ*c}o](n"TZut4;x:5g~V<<| < ;eb܃ _1(߭%sԣg4ģl i*LQ+A97_H/˓$y j ű4=ƛB7\0 ߞ Ƅ(Xåoe8"ΥdgW^Y%k' 8Ry+ 帾J&?&[ IGmp.]4fS2d{Lvq d m1xjgdoI֓8\yY t SD!=nBq-Prn ùs]%oqT: W dUM.he&Jrf@O-=T=lڛKIy礫ZIfL7*:W2^d11_U>J۸csIc.1#z>"PI]%YDy°$qs91%A>lÕj̗D\:A3/%+ ggC3'UrBv"%mw84^rKD ]7ZՂἆQQ`MnedǤ&ʚCVnQ R{!D7gON'3l5H=eS*dbbM^u M2ɍ0]74B:^+3&7!ŨJEƹ ĕD\|! /Qm)LVBx]\#5wJa)!NٱE]Q?67^5zH-pDH }Gd:ŭ代6ʸ(B+QyhxH_ M%&R넑DIab OJxHG%Z:Q`&-X7*ϫ;HC}jb{b|6h  5u] m!Y>dN_́ 4 tvC7[Ouk[o\!)H H;'Vm0 Ё.mPjӣI'k oibiy: ]"C{Jx2E̩%&8<1SI+hrmRH'y)i/1`f^u$n]|wY>a s0 <+"a(i@`6 ٲET>gGt}! 2v}FD'zkes4GF”8=jqJS|}?M;f_endstream endobj 288 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1001 >> stream x%}LSgBE;:9]nH\pG 􃶔 " =|l`Va3#3@3l̈de׽&[qy~ϏB!"DQThzvn6Q"!J 6a*4 vFe}]R1HC|UX#GbW5Mf]i-%ĭ[SZDm2^m \DrYT&^ͥ;6q5:kh60\ZV!WGQoj\Q5BmJJ@hZE": JB(Q.`OS,!Ik=HgͩP #&s#H5'$mgN gxڭ v۝N(| Y4Vx1Z7`Ƿrc(s)Rbeܤ?Ţ<>Xyp-g2 y"%a{S ѱAD=?szX?|fEvg0u}0q/(-,ICC%jpmTA#qIrNI_ tKg9ƃe]㡇bC{YX^>C { F>> >=NGzhS ah<͞L2 oThZ**uŐg-m⡟T6S G(#DȳL2ҊK-}A>)oj__{LjPss1Unɓ S1DI&#_nx799se"RG &W;s7θm#q 'ѪӕXuyֆ'Fo1y"g3w@)0z8=XhX#عT9 KpѱZE1 'pې96uͯY^ˮ Qanty@Bk}endstream endobj 289 0 obj << /Filter /FlateDecode /Length 4145 >> stream x[Yo~'#Fva|q+^M\2S3]=%i9@@lQW?-D/ǯ~܋;@.׋`DG> Bo]x0wtt+hhTR>h ^խi>tK5&)R^H%qu ںFV68mLw„4B + 1JX{rkV1Ֆ렻\{3wVns9GWs!b0so?)fM>o"m0Jd VuoJN]{O!.e?9 ?:98CZCR>8^v wJv g;RVoh#t75Jzӭ(}OCiڽ23a,])̩W@S6Yfw[:H3I\I^{}e/p0cB5$%ִ{xzTH,'Y.zcVz`ೃ_AB n8Nf6DЮ%/`Irс]5I :MƖfdFq~,H1F5BIeڅUZub *@NPR8TltaÁC JGU|21/S mH+_&*#z7yR}idĀH(eV| +44?> aJ& 550љJ3 P1z~E;A\((M .LR/x7@fe|YĨukܻ2XԞ_Zm._Cϩ^>a3ȎhѺ^h@~-LNA{e9J,daR,T !w};tIDUq*wS'77:ɇ8,Q%|QM9JOFo\gdFrM -ֱ6kVg JlLXa :,I>>m?Sܩ<-6m`:GH6冀W4гg焝@*쵳+( JʐZq`*'@;)4ץulӪZ3W)d{68RfX=$9~tް}c Z(a)P) *s]IO۾hu9hdL,wK+n(Uc5ОE{B Qx[ib iy|d! -j5YTKsgoʀKjji0sIJà:D~=0JJBɮ b+vZ:s`MJ7E'WyUL%C]㶚X 4E<^SOg?ARMM5Maf&;<ߢH`1>h&QvD&n9M5YHTR_&mc>@k,7=)MHLPϦ4 )j~$MX5sh7MtW0ƔD~.MM]ɇ.EoNmx%嫦\LJCiS%dB}$9JI wZ@nAXL曫2ؖevR!g(h[ vsŔ}r Plt{KJy41]S۹ cЩrR֙"ٙyӆՎC_lnt ̆wnc`LNc+, r0O s`D@Pie9.+r;䖾K4Y4O U+ҍQ_nZo SWLHZG27-qcJ*&+%T=)=%85+JcCv|13㜊ްܼ]%vbw0'n Q|=E2'jNvMtގ`w +K{rm9[e_Gu4{*B}ߔf{ hjSR$SFlDGG-'(u+MWPpG}.pK `qS~1dNkn7c& 9Ź_'53"yGTJQz8<+Bԧ*a vF3)¡#+zSJ`ws_Mץ,]w8q~]sƁ8Sjs*KKquX|KiZ_nQh L YlL'Hi֑u#{ e,Ek cyR+ 4JOhn ^`p&7͔A8tz|S~q,3~IoJs]3{娩.k\trW/5vKa8sjnn .ӘPrAō1_i8}@/ _"naToѲY#-;,ǐYL]"4"ٿ/2fYG_GM $ҠPm ɻ:L6\(8oK39)X+=_`i/w=A\K !h|@dXeLQ1ӣ٤T1r7dD`@,>?_E;x},64Rwl*,, E}8=cg 0>Ιd { X&]҇|ϙOf٩Z:cmRiO ZDb^:e>Ԏσ+GQKJ)Lj^S"6I j l V|*PY$H*- ǍgFQ?I-#@N>u`Wp/)uyw ?"I h/]IoD@0SF!傯wJ#0{FHc@-eH/+Bendstream endobj 290 0 obj << /Filter /FlateDecode /Length 7212 >> stream x][u~#&K8F@ h͌FJIϹCg6<<ܨo/A_(Wo.n{3M(soYe}3H"x_<lca!yag}T +Bߛxpjo'v?ex{9|ve:/s3u:lsvzGJEv)i Ƙݛ6jlAg/֚Cqd:kR.^wvɹ}] 9hv8ťݗ{z/DJ koOS}#- %v$KbN Q'! ؜Iaؔrb<%_hs֥t7!0pb8<~&` 흍D(Ȫr)^%|:g!on1J8W5qawu,~ԦFFO'2&#HQN<:ϼS;!L,%ThH: [v 4%+)2#*NLjfJ?7. 97\,uO;4q u% I6<)(_lBO51x0 Dhm[ E>o} sz"_Kfl0Uo*'{Y*:%8`J;& emY~"ƥV@ v(hc9" zxqE hvM EwMEFW|gsKmEA@@h;ϙSNOiqC{p@d'pXhfS;&w1'u[$8n4;^ Q`%[F E `KlS4PUg㟙wHgM1[LoyCSf9X0[I;ژFlO,d# PZxト  Opn*,!c Yz_`a_&I(GhzLvi#c{|#=~?]:?WL& ,o}2}޾c0no36tqq.As _oJ(TAGCh"w*mV>h*F\-T'P=jpK ʖaLPhf52">.CFuuE}ZEgJ^ )wP)*_sG_ Si˚D0rD3b{b Ns8\'_eyzC|[n,$¡ afԖ ٫`H8C>LgLwR".qB bYبudVfCh g·/-u&`i~Egi4t# /^J,R*䑵 ;MӇ-ΐnT=SOfy&d+{PTH[kӄIѥ%4Wǯ ȣ\#{P:8L&`n#L +NTi:GU[,lD4n*&߅{CnTB!+"oNIڰ&DG*2d?udH ؁JKjWs"P,c Ds,y$)ݥ\ X Y;ѩK@gݾe&434 0Ƭb^Vt' \U APW(%kE9ʽp1|6ˈ UF}_ 4EJ"8îZЁ"6+#qCAm0a& P,@v$YߋK: S ~<H}gzmbgSv|QgQ%,uӶADLXGx?XY$xiXČ:Dgb=ec&W܇(p=՟[&h"_4sv-AAbE8bO]SEy0cy?.>S c"4ʱ mBfVdvW``ؙ4Cَ^0Qا{e=.D{Q>7|T4\yY(q- 4:i<bC /"".xl_2a5)cfmq-sD7=PtrQKdg_n'~ GB537P6jB3 ڜ cg?-O _t]j,d$'𻃡]Ai'QEP^.e iGSjYǥxei&RBf*g[NT{}{|E< ޫwqn(hj"O) /+KmJUV9YKKX4\r#-ץK$jG5v&U"6쿕_c_}%%!{Oϸ__nk-g[9TY7{Ϟ0(ȭp0&lnD~rkErΙ(ubeY鲔Oxϵv?a{sK6fSI P0!:,b%tB#%~6@?4NTX^Cbru;g*s*:QҸxնc6J"bWNu6{kZVB+qRs tNQ]-{djɢ_'8Hz ^$l)*א/갺w]f)Bݞxn'?o2Ed~a9tFk ס4:}LǕҴb!ZMzLɬP.jvi*k_-oFڵR0n0\.;\_}w}}cHs1$wgw\b!eCh2ުgOƭ S"5f$XVdZaYKO/Z glqd*ZGQ!I.!)Jeݨ5Co!_ 8%KA v˰ocwE?[}D$ G`@ZXyT+ן^S2r1P/ؓu1ZV']J_|g#?4s9D{3>~UQoksw=}K,|qI(Pa-~/=n׭OciUf zz+;xBT6pL+Dj}johoՒ/ټou!}$=]U\b f_iMk?-TzD"6HSdԽI@x~T%i,]ʲ5%7/HØWKST*KH QDrV93M lr9 ,S@O}BsS6n Sa/g~JV,4ҘeOb9qxe~p$8KFg>h;<99Bpe!ju>uie,U ?XM V4`xYclX0ĬU@v 5~XTNŴ$Lϥd#lYGw7 WX jo}iIL"h2>ƌ ۶[n۽"Oh bK2;Tf4Ql2ezG`d#'ծfq  7BGT& \FGP|=*xJҐgsTOsZ?rdҚiހ(IH;`riO3\9cp)[pHn )AzKVa,cPZo:c xib}z> ;k003m5r@-C|srXFNԁ7O I?%);D?Y7&Pg`_ SoQ)fF;րc"I:oMV{.";7w{nTX2]XYrs kbōm?LE@ʘ0:is`v|Ⳉ0s35mF ,@tFf}\ϭV {6aOnz0&WBSG]78os*:࿘ϵ9Nfo!V_? T (J?Gs QіjΊf`]VWOkh T_3ċ-9(. yEيp`s4 _"\q+&;2uM2ᶾ|k)-I'7;wǂZJujGT{F $69i]6[MEswV֋`W`W ^Ӳ].K ^l_iY^[ݳBɛG0uA HiJD`ӟFܙi%!d#^M&?QT}c/F鷈aegvpJ:"Zmi"p6ʢr s@HӮ.KOS ncewxw\]Y]{ w:epionLqq)(vY[513=Npf$m.??]~?%ï3}G,RT(9oOvWendstream endobj 291 0 obj << /Filter /FlateDecode /Length 3347 >> stream x[[T~ y9l;&W9)j], 6v忧[9:Y2I0Zԗ/?E/+>y|8̈F(r.]譴so}Nfw[g@hTf!J/^i>tG~4ꔍvTRI z":U>"BfHae0`q߭pQ‚a"'8b u<]=\(;8, 8% {M݌>lFjg2BEBZ~lFrI(`1XE"ܕȲČOI2t1(+t,u8b4FΗ9}X fLL/+" ݆K"Z{!\wkτ "D4?csyF ")lT9ω@9cV>wN׺he~ixF?I&aiۦ*GVD"mCRU.ѣ^B.GD&"r/duAMwhȧDn9Z|-Fhݯ?ΤVaLB.j=mS.s"Բ{/l7wioEƷmFǜu'$,'c}Z;"6^uiݏ!D#xDe DmL&&&|z\=nc{9z6A<ٳ34-Ty8rTl1GD>!S"DyB9,hl˲eAE4BS%?q!@)4 E?Skb5#<gw4Y32yHD>"&vFd5LRM' "m7:ye4/ph%~mH< 6py[Ŭg4zCϼEQcϪ CUN*`ja^ì0CO[Gw߶rJ@o_WE6J6X|J|!UX`J[UaOni5,Ue!dk{ '"gaG\@*YOpde9Lbr@n6L%VŰdi,g X&2SlσP)I/=ڔ@L 6d]3 (@WWƎžp}ӻ}y>r_<=1RC&4Q}:3Sl" YU[&'DNqx JwQcJ0ƤU(5Yx;=uXK.#PNb|>sv!g7bm(]oK]'g5pS~!ϯk ?-#A~\ĴŞtu4:th\l#x]Ѱm'&=`jP`Ys_~]fvUGvbļCsD]B8;cnV_%I҃韓uCiqT~0Q>PڃP^ ?f)e %xv4n_QמYbzwUz+'Yr2v_F_[endstream endobj 292 0 obj << /Filter /FlateDecode /Length 3303 >> stream xZ[s\N^7m,*?6[^* BdV ec|=3LY$r|}\r._y ~yq#}QW'T΃{|uR,V?`2&QZ'b) p4[OX޹(F*-mPqamv13Bh ; vu ыc4K+^ƥ!n՝Uݫa4_֒n-ZG{t/ 0{}4b&|;6FUwJ4 ' :! $NW'5d!ZbG6Xs(=μ?L1!Ad0F:mmF;{:D#̠"êVm-ezԶe ?%z,i( e@ɛLZheR~!v&HR CG9&5)WBh<PzQxI4l̛H2ғћȍCȶ8a'(™FDG|>TGgQggq2› q "퓟s9bo;x֞\rbQ*ޫ1JRJ>q%VeBJOq2re("YG0Q4{&D;eD@L0Xa`{ +&} !(;_J[R$41:[؛^iƃ%`1M%3@M5Bmr-9\q*G}QM%|r@Km= 9F)[y!Dh"9S''ulsn[n0ZSB 4n'Z0#Y$1C} " dzwB4 3 <ӝLǂ:I~#PZh~eXh6HEu'-6|#罾?̀Mnk+^B5nƹ`9iSaA dqd.q^01͸\VBeY ~+֪XVft8_PȖ$0Ԩ0lRŅPH'#UɜT֣p:cYT!d 5ՓKc'^0fNJyae.FRnJ䉴6W GcmLx3>\1%ѩ hِ4sT蒉o\]Rc;yISCyv"Y-|%{i#,<5rb?!`@0qd[jgGz Z-T=]-%tVtmm#5ܘv'E3G~AhԑIQZIx%TIS7_h;A9]HQ"G@#'LoΕk(en';qnn,!gY)E ^J[~Z\T?Z^cPZoi{SZtbyhF^z:˼zNT,-nɪ̽7Վ&tȵ!-Է CD]p&-HMa'Sخd(q)\`S6r>-͎Mt 'qYJqT]g6J&.+aQ]ɏ+yPɯsW+ywhb%et$RI=$įSɯ*fvPGTJ4}~eȒE,mTWM(?kT7'<:m{DgpDt;3{M˦d-FhϨ~nbuIo2Xu83GQ&}uT>䝩5ʖqsYMOsVzu(} ;!TC(]ȵ'e6nL1(ƑWRo J\?|wʽ]^ hzO؍7d?6~=Q%O*yYs>7_o{,M3Wfw݄X=u9.*Q%*+e"ƄwůFK=A -shJ_ߧ׳ {ݮgzqDbwuoma}*]GLjf5 W(UH@L65~FWt>FiuK*I}=]D>)qB$`==_}/O+E|:SVzcKam!Q4lD_G(髯ѕʩ~/`#ՄwLl3&nLc;Jr%1_)uIJ&,dq <Rs&A"704B(W3N GFTI( sѳ&cw/lȯJu2|hhhYs.? G 2qa==|"iZHߔp'|gendstream endobj 293 0 obj << /Filter /FlateDecode /Length 5392 >> stream x\[s\~g#Xz:Ҝ~nGڍ:tmRrFP8Cn38CnU c1c?p8>}h ^5\AH}ޮZkK^lJ1u-)[h1 -" 4B +  1JX0B`حb ][);8, f!Fg3u{Ͱ,>e4J#G?a iYK F)DB% '>tFd|Š"sx~ rv4H:yьYZ18C_zqSm~Z[G!}YiͿCm6&}^6 ?VHCO^|o|^ ^uNwl_7;CjPPњ~) A6u_L'Ba뿿͓6oi.%d靵6Z1NyCmewd4` &# `xJ~G0u~(C"0Xn)).JohIl2nt2J8Ý` t,aO{[Cz\>Yڕ2m N(!nzzhzX 6'D,^*3  Դ?Vܼ>[In (-e욻-#1.ɐ&-d2ɚΧl~yMʭ#KN)~tDJ?mYOY!Sqئt"JO E-sQATaF؂b]k:Iy.R$ݯ^O(+TY`M,  (`A;g+(6jY6Ym\)v{/qc<;lwy[ CrͻڼӮaG{Wok]28Vm,A лuwx/#) U Ȩ `Zp `ыnwS~#i+Y08f%v[3=  ?)-&0|fZT#U=u_=ajeC'*hŽ.ޒxmӇ﫤2mrZj6 PZVE бq;'J,KmXp cIش9yM!㌝82nu 4[R?F+IjkV i{YľuLWg ئ5KQca`7iA["8xq|Ֆ]+WWq:'Z݄外1Ca!d V,hA'z5;= vj3c!#/jddsBR n+/h$-`YH@doѠ͓!It^+70VF!Α&XW%Tngtis}*M4Rmcv))i=P`b4x@Y@Ytb!u^, Ҝ HUԯCƒvKr):ɿ{64&xA6p}ˮ-Dܻ9% d-\p (D` my *ⴢD{ӡ?E>t1IhLVV;MwD=&Jh=YQbA&rٽcGvꅊZz٥u+M‹Ï?o;} ;#vFj5 LpaVț}ddvr4=ۓGGDa3{s6syȤje4O+ QOslSuXK鴛 +9Q"]%(-瀶HPoPyN 3"hF[\GfFVS?awqg/ f-aUA%6|NƆEoxp_$,(2/,bV'%`Vx?kB 3%OYw9K2c{ئ6ulj-̔1C~)  VOy#WX; BX4/*op]7 >6bo= ށ@$Va,ZIhb,\0DhS>J]z x?#Z$h4 d7lh7| ;. mSY"6j%Fk6ki<=>˗K>q{cɷuKPt(RK~]%J*XKWxWC>rs/z. 6]jcòKyc8eÖR喓rAT P) -GuI6PX& XOTi,JD*BӖ 3TM׉6{RXR,?$PyS12{~N%`הkiˁ?Lqw\y@QtXTJZ c [˼3d[cw74LI3^ gY&qzITس.ѕѕF6 yyI/ %kX6}$ِxpjimڲ+LM@) -"B*GisD)-UM A炥[pCPN$9ElP*|wgi5K+:qc@!|c;wAgJKK#Bݺ*gYi9O?@Mk nfFJ""ƶz}&SwP9jcڻ^-@f`m&, >S h\'94@#CSQ*)~dr vfi!,8َu+q>/ ܫMt,J}4o&Dkl#8ޜ|:O .t!G̜^ha]'Yc1*񈉦lWS 3X 6{ 0Ӧhlw8(=P6=ЏMQ# GvRFv =v? zfׇ}7 ,6c3/S@Oo02XƸ"9cgLBJ)*~Tyhg[3))\4$w=98AɩUOTZvC2i#6~a?Q[贝]h*zL赉9=JKi2t>zaK?rʿbӫ<;wI.QN>%rhS/!hY, [x 7 3G=w _boe@^$ s` --f>L@)1A;zN`ӞcRɤw@wp_RvٰF Ϫ"uYE/d "<\EH'zVEHD`gN,$ T~dRh*31mLq>g0ZP@$>53%&endstream endobj 294 0 obj << /Filter /FlateDecode /Length 3035 >> stream xZYo~g#6O!( 2XJd@j)J6vIt|{\R€UjUuWg3?_<޷lvށ_gWoKX<|vz'n3n\Ym;/tƫ_)7'u;-sY5G\J Ϳê7g\؎qu;Ms!EJ5p c4wy' 6pNΙ_Gvd^r{k {m[XZd{#7rťG杲MVk: GpM&$=7)!͇BUMIOoQCP@R,v.ۃ_= R|6s ۏ.ИR><Kէ$d޽L LerѢ52~6ʋėTG՟ڪr *u&+-r b87;xs/,!ȧ^n}=BW%f/[j 9 ' y<}F9r^rWKڠ&-9,}'9_& ԭLyxf =<m^3$`TrHIE!Sf?x(^RJz LI38/|Vi5E; VE-č2y\vLB6q>%g)]s.@p xn:   /|= C!nHv `!yU<M9I*VѵYTɁeats,j2M,uca#`bxhHi LpQeA u66 j\o"pR*GdLch\M,61'45IH΅JePIC$+yOWht@y@n~Oy\䎑L.2yɓLUL~+s 1{J e'bj{jEWۼ5 /r&5VQ"<9d1ŗ2nzVtJPF=`>%>FY{e},uc=~8n=nrS"&oD.`ոΙ@ Һ(B!br/ {b;,>p2k~('B] x\uBb$76&PA MG*9-X v(`[mxML`>ɝusP t6ͅ-L{10Ť-|Uރn? @M?_ Λh*C.Ihڸn sq=qN[mڢh))ff~~V0V(G",Ћ(_&^ 5kҀrp2Ii锫TklR}1 YJт: br#DR8+}34cP4Yᘘ  o2|#"y#l1&Hd.[,w£e$Aa&.=f^d᳐IJ=,1"3.(NΞm\w!GmI]\Aj;>3"Ͽ8r McT1XbT4׃cay.PU"6*w]S *~$=z2lGAqMRO8rS"XMpmK?4]%'mVPNq]+'ӯQƉO"۔bsLSN/mI\yt*__U3I02CU-uӶ$$`p>i7$N3.x_A{k 65E,&tWed/_gQ6ǫJ?iviCC(sͩVt.3몂u?T(5y=^IC}{^y~tTg"slI+zHIédds&6 \mGLw2uj?IhhU7U%lEUxR^rnx28O2i*{Ay[7ރ7ۜ3ӭ :.H2\c =٭22s0\!0,ًFAm4.OozMC@fgr7W<%'baz}?m^elMlLoJ^ܞJi}&Xm qa{}Sz=0L?Yߴendstream endobj 295 0 obj << /Filter /FlateDecode /Length 3977 >> stream xr-|/lyM;Jlɹd[Y8+c.W撒=a.IIUUƠq7i&z9_xuK/f7𿃟dYx5wxX飈rvtv@G,șΎVf6Gk)"8:9gr}Bn]sQ_̕T[ϕmPqnmv)3Bh2: OQhdNJ!!K)C z.{{TwQPwZAG֪w(mw&t]%M0*/t^#2 ą9:HH%ve)}Y{1Dp (1Jw^>L{ː !2iJ1h ateE !a)#b Z=08 \He{'lm#FZfw|awGz'J.]lRCABhq0D]"'q)<: %ώ?Gf b RgHtluW.&cA PtMƛr,`|GҝI.)$?JmM9w3biO|Uo 7G7/( DUO i %cql6'xg팴Mq\F0ħbF/,U/S!w07tHG ȜO|&Ъtr}N \T*oIQwR"xJ'L[:'QMEZ t $g#<3 = X}SPO貨vV3`1vL]H)֑L3Qf9k\+ ^-x%$6x5!Ύ~(t=3d/jX}JeH9΀>O>䷵4Ěn3U)Sȵy*MeIN-B< jKH]pR؁{cFUPVΤTI:<ڶ"Լy eΏ3@/.!V1c9&@r$;J^)[:Ȩ0008s|<3:Ս (4b'P[A o+L]i0lR-T#TDӧA7i4o!B_e<[j%ED\YmSØ6d s mg kd|_R>IƲ(=y^Fb~ZRc6N$%I![}\=qc$$SvU `P,j&yߘ1b]gn HGc&$83m Ȧ@ػmP_0F/ NʤVN94J{jbaūEutf`"O!G4<^VtuMFƅ8SaK4N7~=6TyWJOϝїe>{-ao7HZs V;fUmy4&kO8m5o64 ~u4 uGAv2GeZJs dߘ&h+b_u,OFGg6 ΔNB" #te %j#Ϋh5Uma۬!~IG{! M W[>r29w __@ilM;$4@q9^7PY]5ib` sH6u{u~yq̟O~GO!l?fSӘQnZs4[K=9lgDK{X%NvM8տXO[~A*F<˳Z~O3O氦lbnG\|h;͂B#'bL۵ V:`{_܃icOI>aV[ ;o2ɿu/E9`Ī)U m\eÎ]4W_]dV{YM_!3endstream endobj 296 0 obj << /Filter /FlateDecode /Length 4951 >> stream x\[sd7~7T\3~\1CY=`8&˯#٢ VG-eéXS{~} /NN$i`E0"ӳ˓<.U]4*pX!5J/v04kRk OЬS6RJ1h;X!SZ 1-Z!  %|+tP\㴊17izzD q  v!Fg?VaUe5J#x+D <Eаl%,C`cbo:F#i3xbPF}wϟ^[x`6')X#Oڮs[0ktOUz%ݜ pᏴ.qwCZWԗ>w!3a:dq[_,/]@qzWJaK[Na4Ë::ago\\ >7E#=/f?gl#{u=!`rds$?Y;n;d&$f.h~S:÷Ϛ ^aῬ7S)}]{ɳ=h]!DL5=/ػ^ w}O={]OE;'vJ,{ g#?G;LueS <`/yw4ӛp?yPWYo:ëio 6![4n?/ zL~[Dw0 :dKl DwFdz+/PU0νu|^WʟS~ݵ{ .oOټGp9J9J(Ӧ@:44VIhL NIWV_ 5HnA0JIvjCO 'h )cJg7;E{v;N/,D).kaJ`>eicTLJ% "krlaBtd#_I-cL׻5rOYJa :Oh7LH+p᫯ 2eRS7D/ZȦ"ݾ}щ5CiѬ] 7CG %D/XqT:t0/~W? U<&ʏZEnry0LNȜk3*'G>Q7*M$Z9ZIK+ČĔPwo|i3}/qKzȧh|Z,EU!.gtt!]PBF F#.m5S\FSg5پ!y|MceK) t+x89RFK=R\=H)ԅS`62kU^4V#3<qg\ @)n$閠D,}n'Wh\YS"b{1gg5K ţ 0uA+(J~}( 9*:p2 q>s$, AĽDe4Pͥݰ!},':damT0R|o@GZ@~0n2}bpYku<`@0ѓ LFum: `?n[%e L%8A-}&腛z}VD(t1e >}.ً$`3e^lG%I$UQ\sB ۅ4OEr"}0 ]ȼo~瓵9s{ ll UK00*P2St598]!2 e ۥ\s8#5T#eZA q|ϋxpRu^E6 PTU*'wWizFqW(N/+]=@fi `@ބ&J!ҶsM^hkzԨ\J8`_/h6"lj sV b.X ex^ m-<g45|A*A~d\bx˵ $A' R¾EvlIɸS[ ڕ0EJwF&>ޗlf Ԭ$xHӔyz@y&r z$0+%#=u[ED55scmjL5؍bM7M:^adҙ<^~?ߢby(Z5pϚ>3)#R-v* ߚ Sɥx!A((5Xۇg6g:A"cG,(%iL eaZVTs>a?Adё}{de7iCO}#{(zG4zLw9W51:}gcBӢaDB+wiip 1tj%tv̰Tc1xI,LNDSAlMV7ڨ¸/WVnQ"*37<`0ӺSܖP9l7}0Js}tЦTiُ߱3x99t 2FwYaCp>GLg+nykbiLCыC:;f 3ddm4 dkmx>dk÷\ؒ~4wgy:5 HJe UGMa9ک )(-vbMnc"yd4uC@ic|~<g Ô:kL+N0JFci,%mGJiT1ɒ,˞E^,7Xh9BL"txXU0sA9JeJ03 q h!@,C`IKk-6'Ɋg/mks^,F}մf'Y5 L?n#%8T@$~RE|?;E(6"7<ZHMlm<CX[]gj&*dX "4zVa_MWrc0Iv-!Aؚh&ITج`'&fAY 4e f?'C< SEt6)5/%19]aQF=NvHQKk">BlEx,qZ|&H %~DT1A$\geHȣ:D&V> +L̑q,3g)t^!x;2Y8W\U0 STkխDf\[G` Sb< mSOwbz: 'Y3>E}Zgf-2z"K3-$>#]5%CHؕ`r PO+mYfD o[:eN-ƝxqqM`Juo,_GlkMi}9hЗ ŴfDqy1E;h("#CÁB0>0އ_8¬Xfi Q>V=9F!hڞ!ZfÒ*#"v ~ǒ5*:*MbVAj)Sr^qQbbKx%605"mElY-kyOl1LnK"UJ#R6P>ws)ةL>hϕL|>3?'%&'%,w6X~@'ƴJ$903=H= 8ƢߑA~lM"ꙄaC pv2"iLgͿHӟOl_ޒ@k| %b}1FRQN]:6Lcj˛w>z ٚԢWVmz)qU ^66֝XE,,fQ/k?(,%8&@ZKM4?4kJ4NpD$JT ռN%)kd@9Ȃ#a{M|]Tdq(5ί^D;> stream x[" $p)pLj  " ܭʿ  `1JpE_ 0WA(ЌT~ D8̞q[h.D6.mTg@|?լxq[S2h5R3꧚?57=`~X9* 6칌q"''}JLxF7}gyE"aY2~W [pu(uV@mڐvt .a&@eb|8ek>4.I&F0 [%JIZ>8G_%jtFvwU/${0)\ I 2?TqO\tO$_\$=ֲ<ƧG&LI?%اaio7?WOGJc14iEXu8P8JPbV,NhZ:zqZ# c|4n14[Pggs%1na B[ꢤkN{8P@.wPbsot+a"ʵ='+&p>Ø-ʰړA )|AՓA Rn%O00&01ôz%gY;mgʈ<:f,t؝ ծ^.% zpA`LZOv2O}LiVYqx؊*SdKj^1mQUK\D-痸RK yumtFM.(ARqRl4+sʘ*q+fn6ː7u":[[v!9sC+!f^{Uңp1!#v?/LL;; v*jfZrnHBpEPq[ xN XUđw4;_C"P^N4}PnI}ư )V>-fO"< !=zd`n/,9.6(>Rb[:dJ:Pܷ /uxŁt>ԷRfMYo)PU6G? iVFtޞV7f:/@, EHZO/1E[Ln.a*aTLA/Pr92nO/,?A@ZlHO)(Keu_a_WnC) Ak?4]/rU0Ss5]B,T@Av)IلeXQ}8Ĕph_ۥ4ؔV9AD̯f^Q.[BV8žxrtd;W*O1&/y@oكn*T]WMgc9QF͠<[ä_v\/Xa#171Xҧ֍Yл:dEO+05d WdNe>%t|R*TBpE!W/B-9aVCP -nM\]MZ*kT_欔(vy͓rZce,ӵJWA ,ő^FrIaPNxa k`(-aa{Ǝ*6JD}%{SbASWcz1y൧y ˣ*?tD칈mF1+Z{v9t)ӮKN-\ ;M`qz{ " . nhDkX9 n/c,0 e|VeW Ϋ^>C'cWGDLMI0\ƚ)e3=*s{˾ØjwFQX5&JIzcի7Uʁy3Id]g:V|>}qƯ\#;eu]S` vüi("F<6* MLQ%; Kv?fGN\%o 3iD_@rQj$1[Q>\1?ټ.hw\[@ '5r6r1 ixz(@_u}e);>t4@x7)F1+jxB|Uw\ѝ[>f*iC9&%{[/mw˒-WQ*A{s\L]'vD1usr#,YuɚAaKuיR jzW̻ B}]^.h9B$*NƚM vr@HiWa;RE\c^%QK 'VTyCz+>VƂ% 22n!ZQ+mbp|ɮ_fp0}E]:ey)Au{VW>+ztr]d7^Y|zf,+;Fa0%} ;>`nn\)֎:?].s??rydAқ;w\R/;/q Zd¦&e77gʁղ<>~d,A+GnP TnW%ުEB9=F}5᨝%ֻh.-M }K0U i }=xrE~֧\MgP{/}?w7xS׏NbZKTJ<SjmzRDɾ5GsSY|:W+kSk I)o-s|lJL77}X|7hXk b^muhUռo78t'uw_?=qC}-_ԧb7 u\\zNlŏa} M؇>n9 fn-~Qm>;kɡyѻendstream endobj 298 0 obj << /Filter /FlateDecode /Length 3044 >> stream x[O$G#FCz{ .FPۇ`1nϧlw{%Zi)Ll\eWOXW9lrڃ~fSZ*<^쥮|4m奞lo*f@ d*r˜(nTJi)xq[оXNKa+ Im5p0ohT0\LsAmq ܄fst8 3aap{kHfѶwlZbyݮ{8ZnhKq8wU\񏩓 klDbZwZ) &n{Ga%bhJ?sP^j#aO{g(RΊa0,c>nMu&/2@vOK-dŘ)2V%V/29}&3ӉL>dry2)5V^LN;}ՁlI°&e& 2ENb$"y$-T7$H(lql5J 6'`Xm=2Cp:1)'!ٺGzP*8a/y7iԯ%זÉm Ȕ рKP]|`_ `h0*$% r%W"0˳2i2)3Hf@BgRaab#dِL3B&nb cI2AB3Ix-&B,%-&G $i0\qvj ;vΐધaƖU;`H= zzbqWc Z'4^zjK&hplU8EJuzI &L6!Uu6@ JC?! ƨ??ܘbby gu@D'ؼ 2k-AF%@3LW,oc8-$Z€37͸m/UA15Q TK#Y±nH(\% m)'/E-}q ǖXdXnXO+\%K!Y i1cH *5`W1fvIL<{ [N›B7' ײAAM f]W3Nِhsm"@wTuy1^!H$-cb~A&IB)$:*9)p[HxdjK+j]3ʔmOneDPY^:wM ^5I" g4/ 4'=Lc]衃 i9VzVYr5}T$qߒ[ kr=kDžsfRJOT6 ]O%?G`u [HD]/N0U;n\'ƫvFˎϏ"Qr|i#,WJfF? c=#vx[pP/03ehPu&Q>֓&\]pG䕠ץ+rϱ#t@}O! <}&FJt-nȃ_V|yݐd&0CmӖI@5}#oǮ\əƙIb3ڸˆl<хݹfg ORz=<ÊCivWs%ޓ40O\έm; Z!~vGzʋ4lE*=P@+$nBDc\:-%atہk]0[񼛍j@N⁔;MDm7y*.W%E3ɻ&y]4DYgm{^{!kG'_Ȩ;T3l Iw3n;87/9ryZ f~JKT(^SF,cz1Mu@:Dy߄C\vW{D|g^Ng 1wMQԲQtQYҲ]I\hP.`=2tpFwϨz~o%f +)tc8. A~-llT3礍IYKKu%"Kn6֠K`:3TR=$SiD风.!u]Am;$`uՐM5 "eahƃ(TsT[tAuG$qA*`r-2dƄY*~ z>&~hjw"?.9$CqXl:}"a@|܀!>dj=i[܁wF-f6g͒.X0 *>BsGqy:0u{(י$ysW4:إ#$p>H_᭠Z!# ;rt"A7 8|`T! .~%JܒAk32ڀ.%U|v%7j3mGSOSs_c7X%KmEynto"]Mendstream endobj 299 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 3964 >> stream xX TSך>1sEz ܩ'|Zmj*(>jQ,>@BB7w?e$$|D|ֶNj.۱U0Ykv]wrX oG@MD ͡?^E0!5~e.3-J*>)9ydQ?:ǛmDmWls= /b}zf`|vPtc!rR$;Y[䆘K_^6|;Y5 /= :\$tVLJkV{k;+ds3ӆ:(Sna|_&EyBtmc~8T&J ݿ6<^ў&)--hԴeY3@, 9s]U>0P)YPX[77qUʁ!`9xt[Z8P\zE:cCTrCI0P,Ns<?!_jFSX…Nt~~x^_ÑxZ_E_Sk1AV**/p:DA|9)]+Dctu_u gӗ=5@e+,E;]g<mӺeh7ƓoN_=kdqq&uфjk.{=쒝W4~ U,4d(3sw~391BǸH1.p-!}/8C } (86:NSDa<_㤍^sCkh=BJ[LG4Ӫt{!!51= `EVe Սt÷uW8$M$hA2թmeYc< ǽ7lα-)BĊHme\lr(p:#4Q 2ĉТ3uѠmt8w!+1]u-- Hkk//0*L5!ߟ񡊂 P^SQ8Ӛދ⬝Z^}r[~VJ:~jB|;qqpCA4ʞC;Yd51R'u0v3:&]*O{wPaեރh&N%9[og ?gNڻgoTD]#MB!Jc':zz,;˜I!z\f9P]Zq?ZSmsT9a A;g)vlHS|'T{v :u,4B dqttY6J@]#  g JGCٙj(v(8D2K75 4!>!g d":-1J"AjI=J ng{OQ{SRĒ.<W=m!6|ūU [R``:zh6]'!4KUC6-yD*H?%di td4)mómW:tFyOΐ eeE׃ߣ:]F쁲\Hf-O>??h wiZ5fpul <_ ;U:]dy`Ё>v9,hr6 c.,HEU#7R")$B_5P7 ±1gDOydKE; Ts@M,ڢP j?":qq6t̖VE~L?n[i_4'W;H=-@j.:b=0=YC~XYwfsM̯$Lkb~anym݇)G'\ [*W\t&LZZ/b?Eca{uiUaL'ND!ʦ?;Ѣ[ v8 $z&R%2X? iMEnw#kje5\AJFќi55wfֹWʮ?s(6Tlt~r| D^(f;r#zaRMQ)d2\Gtr:.Ki'qaP𮸆V+HhegG歟Bsϧgk R%B!*FPi61%ch[lf;0`J ^Ul7Խ*k6|vS<]Lضma΁(cz/FbǸ&ͪqQ+uLG3AB$: Zm& rl>kOx L,k]5c V^ũdyu ^u"ZN{ weVuBEt8 jsH'.$Kګ[ //qo#juD!~mⷰx%$Ƕ>qC}h =2!eG#lW%IR&'+]K1 ivyt+Z}™_!ԋ\y֕3[(n:]~1YSNTe9T||oS)*aJzba+kUe`3CU+qEz}m5WTw'\/!qñv4oH)aa2B5g d4(- 5ڦ2}HUbdr4ɕ[:1L06B`& S$@.}QR ^{F+_%~;> i!ׯ@/sduyJ!UwDa?~=tb9I$V&$Ϭ-&,#;DqV"Otkw"5HG6tg;=A)4@qhWh]=`+K>]֋s.. B(D~`u#O<}=sxn舺v٦ןO 7`%6`D#evw Q3ZjD Yh15{^1 HIIiN魫08A'g I[vGh)*ȝC{g=y}e%D 7ulV%)hcGJR\LY $KV>=̟ncP#zʋ$?&,a+B@JIҹNbqM\q8f/2[D Q3՚LNvMUZԈMUm"UK;\Mkil0endstream endobj 300 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 2998 >> stream xV PS1抠>mTu*h'b@ʾ$@ .E*u[m}ZO=s|wHf̝LΜsB K7ng7{O?-܇_VFC\^6k`? uEC!dEP@I2qysgL6%_$9*|"q\䯌qtZTϟ:5**joX"`gǨ ezHn?rqocwSUJ_!#<\T#6NL%b-@l$< /bp%KVb1XA$fY1p'B!=1p 68! H_ M6Km:ENh]REK@Q4Js3@1X[hmd +9Ȟ\⛳Cuo Ri y5 tlOLM4ܝ@RITI-2 !8B&j!BҙmUP.aC77Js Z5 q?|%NCsV&+L@*+ %|5dIvm>"a8dW[kjH4?*VAA(lKD!̓ P_M q&VK-B%JST:w=6W eUzm1%3e92̄>J=Jp:$8gF*Eq;nKd1ڜOcf9uT/H#ap1u@=PĩwCn4r%DTon{y9hYkgG  8Q3YR'aayd+,Nd#wo3Dx$d\DР%{ SY6P 賃T @ \=6$Ɍx\+}Ysi| 8;>XS"8Al1(w$h5( q 8*:92$crKR4^O)(1(%MrMوkY+2'(;J(˻q 5ywkxHmZHtBL%%*ru#1@c%;^f"]S%ăJ$c}?jkFCOӦk5A{Ko}e ~o&־(aWHwjagRTy'4 CLDֲF6b3iv41_O-sPoUxg1ǁq)gLfxE\PCuzS-fwxqtY{,fYwI.IIq|3&Z\EyZM-Pߛo~S1b+ K29IҕU^J}2)+/*jLiQHy$[!H[5?yhϝߠ dV$7lhmmoosfVOJ>9~kKkS]K{҉&O<ok)}p;.d kި"+4ȏ~4!&2]Ct!5q @]zD>tv_ZZۺ Gc`'$˪R3)@/G~WɧkwyL{ _Lw6*rR.RUUF{upﳡZ1٭90 ^Cׄ:N`Wi’浙 ^܂ ?a[|'ߊ5.t!ڴs.I^i8ݘڒK/MyLwOʼù̩Sb;gԍoiC~ v-KQ'ӧ@),~`Z}żN!o4lD |u ֓=SyUQm'iVV"isX\Ydg%{J?H͛fddwXpkr&//F'^|-j5qpDgZOl#ި~GAͺNDZ!ӕlf[v1iYѧ}rκY3`,vܹm=Xb @u|%Bhlճ7OUR\~r>Ղ wV,޺;4i_^PU.<9ucn mI2UX}%1Wi",XZޔftKBt2Z"  ֆ5U1},\܎_\*$&R7wOQJܐW^ N,@K H#6ٚ161r&;;=Aaendstream endobj 301 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 637 >> stream xQHSa߳-]B[D8G tۢm9$¨$hB&N.‚&K4ɚN\|/b+Acz7tg ᔄڣ KG{xڬ8Ť W@q$~AY475ى#,B}q\"h_HI,ْd/oG $#ť؀'hD&]Dlܚh?!K1X!;\]'=ڃ 5xH!?zYPRZ-V`Y( %lUETz6ƛgYn}E!ȼ!dGqmpx<YݳG8_ݼ;> stream xZYo7~##,ɗwH.gWגFfCrLK6Ol1z3_0R:xz2[زQtB#⵪J9ޓwńRݿ_=H֎5ܔqCYu,d^(Ur*4N8Ir8@oN8' ;Z3ƬdU'I4-)P ;(&B8C.(c\y RiLZ)MZW?KW9g '^,yS*;Qxfwyޣ7L $d8k!Pګjma%O\u:Ț0Jx"7Z8ΊuCN@sZJ `^M7,]"*G%Xʶmj5|چl?JjvFsT*5G#;:9Iy¼h R:%6\  =YO n__.ٷl;U[Qd2xޭ6A)af &M?\b٣=VQc%xȠ:ˀ.GYd:꼨TK䠰B:H=,^l췱/v|F4gK ^-ww0i1?5ZнUbC =i_1sRTM[Avu[ta|OspubOu4qQ|o><N}?]s㼸yVޏn_` G q|GΝ}x> 0y` |߉yΨ' 'sfw;s?UiKaߣ~Doč3aq)? $ݫdZeȴZXA 9n:V UHNQ4Nw>*zm%"I LIafǛkA4ĝq σeTEV[*z>58VqxR$RظZ,tfQ@y72jwW_KftCsͲJ)m΋Щv3ӳ!uZޖssTu[l9=k..:–i2\ϸυ afn jLP ^j8?9>endstream endobj 303 0 obj << /Filter /FlateDecode /Length 163 >> stream x]O0 ЅjqP(_Ct;,ֳ ":ր#MEY' ݕ`.> stream xcd`ab`ddds H3a!}ُì N^>&|<<, o-={ #c^qSs~AeQfzFFcnjQfrbobIFjnb ZRaQRR`_^^[_nPYZZTWvt-(-I-ROI-+(Me```4``b`bddq}˖? 3}< 3'uOX0?!].S;6vvuO4xOl妳ɽs.20oendstream endobj 305 0 obj << /Filter /FlateDecode /Length 2606 >> stream xr#6>Cb%' rsX.)c).icl.bd:*m4Ϙ]^|۳:xïj#J㳣wq+Y>u9gGW O HNr`u1fز":cъS\b i+Tsj &M8;cکDNcrrI:s7a'ggsέͪ\ϭ䀡$F*)^s)E׻wkeͭ3ls R]p?\{\\ߋml 1nWOx?9'W@9Ýr "naadRd Lݢb6HSҖuR$V5l.ug\5 i x\Hܻ^*G0ruͻ/3l"e]Ėe';-%IwAR8/$5 ~?\vZ9V3rUY}UV1–#yvqլ}wpt4r q;rUY}UVm A"^ '\Kҟo0K28ǫcguᝮaJ:J>6f, !Jɚ8xs~[pI4!dILº]/ߛ_Q[CpOSwG]Y -  GFyi ,\2)y;.ӶFYӜJI|"9'=@Ai%8ᄴD|T@SB< v &Qn&v;3Qzc{FiJG锼-½N"8(**Zf*gR}A uB-҂ L,aRFQݝ l=Y5zbX:ؗZI_9TKEظoɾb=Ϗ9l)~@'բ.YW N*6lU#1/{D2DiEVxgĉ 55R"Y"E 1yZkleUM7Kغkq> ""8`+0kEz$J?tX*QE8#C,Kⷪ*9I4VHmW)$l?jR?CtRWv"~R@Dd~d 9TχМ%ܥgэgzFJ͆ec_xd, Q Z0Xw)|Zt}1brDVLvuLu  T/ǩ5e9Qktke, m_FS0UY%ZdؑcM,Z`wQeƸ=;dxjcuD6=Q TNjȺ\V`h=1Qi96NXauv d|'D}锷A:]<>ݳ 1_>}ڇr6|'Rc{vDF^s~IxHJ)o; o}sw~7$+fendstream endobj 306 0 obj << /Filter /FlateDecode /Length 2282 >> stream x[[o~ ҇.#/I\-R.>8.@SHdR=眽,=*R`x29˹ ?Y,^FZ6>ٌFG-G|j[xdz(j2)!$y!9]v1ƌ?[-լ0Za Ņ拉0vBeg 'QbL{UXA?yY3fs]v9 2";D $0Nr)Ea=ql5XƔN]S*4)a~.{kEv08y10<@ĸav |\Zaɞw^Gu*<6yWR]01%wRh2)&[݆K'V( Z19w`Vs gLA>91 N niȀ*g*"}|k13ُ@2,L q꾮IWk59)Ƞ_9{9H4sl Hycݚ5̳`Oet떷?.֖wO΁{my¨K~pEpqD#綦?/NC*$yy>r5JOfu ސ8XU ;8ZݒI MWtdV5Π0( P3&Q~ p 5s-hp E0 ΀̮crӑԚ#pZ tZM]a /ȈESʓ~ BEFܣ H$w݇GAMbטKɞg씔v"|ưTt"ckQDoIc ){Z.hmC+>.4- =Ji;=PoZ+mx7t{ƄVP5 Zq!ݒ9B^ p$^海?2ѧJ=VxFdT7쑽RnX=7{Fr*G8\iK "H@oc s} qC"{kHeņ$iI ;Ұd]v"H^I" +T_5+ Eҕ&;' GO#>W8v"ה@/Ofui-U!Rc/=Ѳb|@v3n H/gR3dS: D/F VajGvžn? ?kҽ\ Trê}~hξH?I^ʤ}z.p/:ywS6AB-4$p^Yt.n*Hw\i֕t`^@ʻd\J,af?>{QPڤDI4٠[rhF+koc#=9L\}oqܡtG/K}H׫O^3w qQҠi !594>4PcXwK Q5榊ay/QA7K dy:+xp0ɕ庿5e*ՠ`mxkK?AZ([,v3y]Th*T%w.-TRX#g+ W _&m'~mΙNi6a$]XRp26WNU8Vm.%Vv"Tj7Y{/bWg3 '*'kX\N7WG +mGg??FCendstream endobj 307 0 obj << /Filter /FlateDecode /Length 10939 >> stream xKdq+zY#xJ~ƀmؖ@  _8Dޛ5]dC0A::o|FFDp?zo>{f"|_ZMraƇ~GClZc}_g/_?[ݳr}L/>ǬA{},>.<sJ[ԯ!ȵ]>aOs-ry˗PKP(B^//Q 텿yf/y qsv3#_yj֒K=YVxj7Žry(q6i,1a/Wq󑭊Xnoz9dst0qsmge{a#/SѨ6/?~vx7/ VNC^C,XE6EFlaк1͍]`e#ca0 i*ذ^L@-eHZ R6>}`AIFUc/Eφ-_*))-}h'$tWS$6T%iT7̰OVwWuַ0H5evFtQ2-I-a1!kƇ \} eʹE5e*N훦ʡ J{5=5m8jZn|́wjal\;^N=R de T-AcubsCbE|@Ixv$l8IvVu7h-zj=pBPRqN;cv騼͟pRIXJI+)3HlP+1$RR9)tQ8&iR&j!AAmg20? eWb"$i)eKë}1⒁6cV, ,.$ 3_Tƶ$TICIGld@  0Ll&V)ʪ2fU,}3>hhrٚ8)el]PtcH$6W]W|S&,ef O#jfQ2)+vS2i4b0SVF zZ=al~4%x$PƢ#` M 9˪Af5gDA'&գVLɔ&lSn*d˝z GV1[U&T@QA#p& goFL)lSLy>il-ႥM.Lmi*$XuѩnEa؂ .GI a_8xD^{ e<fv[8xgEkG((PDzФd򦒂UvW%ZpHRC Ŝ.ef1e# تxT`6R,~ފz9gÎ>tB SGC7`Dswl7a%!aG o0zdd?T`VD NQŒŒ0H:g|z}Htn Vj(+,:C^H qms/tO} LADܐ6}j<(l hy Zu?wt #7'd騞d?"V *'p-֩|O0ɔM~_w` {5z\bFc^vg͌$ʙժjtl. ]j,Me./:[eQ%5fE2 =j\Wn'}-y3bA+k v̨lkN$(TOO^dÊ+/ 6靛d@2YSpk3W ILn 7O*V4P"zUu k*0mI<3c4wz*Ml:{(%^H}[YvT~rM[шu{"IdM -I(w֠.!IY0kΜ|լN\'+34+-(֊l-<(4Z Tlg-T]5j3Vv,w %(3lB7(t[JĥaWI[`rg+$ViC ÐDk9[&jٝ4J\N8|>-+(zĕϗ!GeNy#qxVCr,tB˂> q>[!WTgC>ɀ9} oB߂ -g`\ !9S?[_[)$Ʋrmij$7s/咽3@=K-m)0R+~o7VX5ev\ /f?ʟacMܛcrٖ༲9{Kt|{3KD3o\k:~{34󆠉9Ks o ,3*N D8A"!Ah-A0 @4RHlT,B,p%CSN$cCSajpNdh*Nei;CSj YCS@p ME4 <Н__ eddBMs ܛxh8y jvPhbY󋢉26&vϸ>(8FMCJER꫅hRORۋE4hi{}a4 CT0 Cn"jم4^!IIјd8(MCipHI]MWLјį?G%+fs4 ! ptGuFٓ H/;#F;Hg]̎@{9H4kQp /4si,4pŴ-&Z,a|4H,48 Cq8gEt|DBm%2R'D(MPhȉrrE ME`s1"i(sOi8IS{HS Gc]ÆCqԤd F"@M@&h0@A^whx4?lM_M 0q%q!Zle%%X]il/ #HqtE BkؾE4]N4dfH4UN4Vc2tL|;J#`%4|JXە(MCFiI.ƫ1M 4 iH;Jc!*Q* i:Gih8O"NLGijq E(MJØr7y\Gi"#ߠ4L( 3d Gi4P.P"PܾPX=|4Q~߫cBi\)iw"D;QLJX6DiXQ-$i#l8i(pF4F(4g`< QhVId'iRd -V]ԭ!9K-szk!JQl\QmV^pz-g@MeJU܀[4YK{%Aelםqm^{n+佔KnJ%9[)ܖRRgQlښ ʩ0twqG iՓG}MC n]߼{$.koFo1PXMa7}爽aE i:xOǫ,΅ޠBz^Л4 ;ĹK0Z.F%.0IO9{ΈFXMj1 #SNoe 8{Qbop vQ\-_ 85Mj6{C>:3]{\ W-{CD7fYϺwqGGtAOձ.Jޜ}PiAFov<A76: Qq#z74 ?MEfpr}k/eq׵􈼡Yguɛ<ÃaKu- "E9Ёo)7':htQapPf74J87Ϥ4!7MC97MCF <7t\ێ0$tw]OޘboIY,fJT^Go d-E QI{u7WN8xsxx&s7k/:#&uH_ R oR*qNMl1ž4oyX<7h,0.S"{c?53>xR7v Q*NЏVp!Ao zJ ]7t\$oMEӅ m*UZ_G +`o o7]坽uV7ڝAsޮ#J_MZy*G-#*"9 U% ح[M7?M yLA!N _E8yxzgg7$븉\x\s"Z4_#OЛ[ %eGo nPs7 flS>wCEi_-^ Sb35nY $b[B_P zZnϣt9JyLxru7Q7ȇrh7w Հjx&2C#NC s4{Z NTF G[ gDic 5fe#&hD /~ŕiqk,솒)D؍$bXPH:vPnlŰ8vWsV`gis$37pʄ Ǚ,m7@-戸 c?7, iz@sS%m`q}vXq&-wa7gg!7TOwެ Gn4ƅ8rYGw^lRp!72*$ qCG'7H8rU/#7U`[o^\ %L|˛z_7ߏ d~ۃ#}yѼY/$d5[???nޞ?=?~x~QV-5?50m#앟={_r~Tl 6[g?9?]ҟҟz~G6oΏ_O{}|{ q>G oo7s n#^xeo7%ufow?k䶵OoO?fx2=GuY#/#7*=lZ:G&2}qmo: =̦E}J7ۻ f{7G쿿|sajv7۶Sm'w`5ڧq3>+)7mxֹtqsb6o8~N6Eof4=Mߟ??;`?U.}O?e۳+ϻҟ=% w +]o&?!|;_=_j?b_=U^ |+T-%K+Ǫ?Ft/X۴ꩉ_gOMϞD{rne\} 7+umxrmex}r ܎Tt'6ƣȃƓ^vpԺ  wSxl޵K|'ђ{M|l_gmnm_-jO[Vvc0}]wt޳b@f endstream endobj 308 0 obj << /Filter /FlateDecode /Length 1785 >> stream xZKoG n3Eshmi"ŒHkrfW"wEy#m13q8N>E!"{ޖ_=~ۯ/" ^{/mYmy/n00Yh)|0go(…?Fn- \s0Rl\a2_k %F(aY*HQC02K_J!Jw.gWYQ Egw-hg?(4Z rUQ2}u!"J(0>^%7&lV?]F^BY" `^b s!DB* !Ҭi|Q\\ނG yɮh`llJk$0t0>>a(՟,*UFnbϵ-sU 4 YHCtIOš={`%8J9r0jI.&A"x?"y7#§~]#>S7 o))#B+?GэST<{R7 y̒ }1K.vs;%JH0J:q-c/p6x\o)U7:#`%- E˛b2 p;ϐ< F?i)a#$lI˛ FrۡSI1H~ĜdC_i9屮(,? };;Ca^t¼cw,ظv&|~Wl:[>yK|h3 7\K0Iqccig\'6*ƝMv͵OX\v媉S6)##y%V5['ΘF%1tqF O\)+n71l5Ǭ;n\jPjͫԬyh@yn[:ŷ2{P6j?0>tjnUsuPc/u[ UUt@FN kA6R\hBKFP^"Y⤃f kF[l&mHBu77H~ ~ˢLzKVIri/XY#Kkdx^!ͣufm{&C?ž,Ch^,> stream x[Yo~'#!va$ ` M#d=,OQ&kS}TͰ8쮮ٷ"?|ϋgݭ;r?0FNY*wַQFk ([-EG;/\AisQvϔoTYΔkmPefmv83Bh*;K phE1R/B#K)C r&[sTs_gZ 2N~hx6Z>[m%^3WIif4e4jN3 …YҡuNsPJpqYgyMҨ Xs(=`4$ ", ^.mF|:D#LgdUԪVUߚK z;׶ E&c0L_"}$CV%)>A+smtړHEq.T!ƣdG/p|ӄ5;9~N Cr{$72c>ArYf1B H>Arɟg2t4צU1΁eJO~P|3B 9E6Υ=4oACP&$esD'w_>Q\Е( HZHzΣ1  :vk@$Q$r( IX;TN8+2USeƻr,07\| Ax%y"[evVªe/65BxԳ/|3T;(-Zdw.] ew@%)ڈZxbp\ܞ}/7bI#-p2i7mPw37y}۹Qd0&WB܅8Q2fP~p$v~_pU\0q5n.Q7GǓ!c&JYZd ӸF19qw HS9 J"KHheVR&D9dѭw1q(sDh3>&.,>bLK %GH#]8,XyDR@OIK`۬9!Y87ǜ!Gl Bϕ9=u+D ~O08mϋ 5٢+īxEe#q;8̲{ -kG!|$Yv.fBʋ&W*zZ.@S8VFSE`+ dbE u}I˂H PYBn=9=9 ~U0`^oGeUm )XP~d v6p#=)*F6Ip:8jgwl&Ӛu$ HБz!ǻ֊L̉ $QG tP(z^qW/ RS N;eo0kփ&:@ns d:CpZ7h! ~T0@ @&DèS M|lG9.te6耙-M Sܛ ^Q^58zrnzە9.n! (s lLmwćǜ=ee}yP^e6QWb0։jpE6Q'#D[JYMW֩ʺ]:KoȔCP͈|h}f$SpVOU@et uMzג8veR0ۆ a 8|ّL6ׅz .A{e78x,1ok*pٵU44$dt|E&\rM LUzzFYbh!fu"3 rZQ6Ӯ[X8}m eBY zH[D|J<ݿ$L?(s{s͡Ywm^Sg Kb|Xkt sfBA+^\Fm [3̀`u:g~D˾K='-kg @ [¡t!P/{ 6)/[e\?;hu7"+}1N`A.@.ŀE\-WzH\j(^5+$ߕj'Z9?1& ~`Cy[U.QG脞 I[Q"3CHI9|ް$y[nN~ژL>=ғE}7#z98>M M}w1endstream endobj 310 0 obj << /Filter /FlateDecode /Length 2490 >> stream x[Ys~gGTyXf?DQ8 T*<$K 0>=n.AUDs;|0S?.~w~}8I8<G0Fd<*'҅J;ַQ/S;h*eDcyFA5+ ڇb:Z_.:ecΔoT21VǠkCDj@1U" C +i fd:(B.Ӱ1,6]ݼ*$轂9oզY/u'FQ=N!4 SHKMH:o6m0J(UͧbB% 5tFVd%Š)8/=>ijnžqļg/8@rz3cg8cH{CpZUUm놝IxY+.{Wem+$1hh $? y]%.1ܰ Q 5; f+${ۼdm% $H}͎|nG5[BghPSfD8;v-¤C~xlK|9K(tζǏC7 X-1;6_!*ѵ_#wӅ]Cs>ݶZj_uڪ>>>j9  ;jyߴcycHPj;A?i{H|\>Tǃ<$y-Jõ|jS']\:7z b>!6Vd tRHڥ&2ΔXN#":% Yz4L)(3xhA)Ebr5h*[ 8DYu׉b'iFi ^O5OX:Ն dq2Qh!'KQY1ӹPG' pQgF8h"FE@/)'\/Bu{ی ]c MC刊`/i%j⼺6t~"XaCܑ(dmX3{@c%C8. ޛ*y=&mi OF5/)^KPMU:yS`A`|U, iAxfMZ:?&A 5Lެ;h$f vC F-hUtΚmTn\/I" SڔvYZrj EtjNfP2Hj "[OɁ NIhu%.+@02.w$%X. r}\J7ܹ$֓3|k?_I=F[!I%DX-Sg ;f7L5~.ul*b Q׬NH]U+V0HD}IU,s>BIӴ)f맰K W}ziPb%G5)3S}"aZF e%5ݡXJ=817,z?Z`agĆ=W #ly1koU/ 13f8J2ތJY|C>8aH=I{Hk{vlؔy\'夨g.{'"@r97HnB{\m".)ro5!щC" `1dK\5^1؇yk6.hh(&.) z;D^JI?!QşKRR?ϥ+5 PWa!\Qte.d핥21K[dI/5\~(S8Y`=~t4NʂѽAO7l J- nu6pYa0Rվ„䥼daۨt^s2zîGIMNg!5/|yG6C%?u2y=PtO\1}]xӻ^l`WOLp%(az{U#F(̭4dT&3 暦c̕6..z:%, B: Gk~vx[9$hf>(27'$ɗ@ɷ$ ķ-| J@\ 86c_8mSmh'C !j:XGa ۓ'@{ʮ :F-#oW؃"S?pZ,B2~1?;Yfendstream endobj 311 0 obj << /Filter /FlateDecode /Length 2058 >> stream xZYoG ~ׯJھ(дEA|ղXvr᮸;i 3HΊz3f5'={el;FoF<~:,?΀K8=|<;GWkVK=]_' 5+yLYm2'5[i]u2J)#}L<0Zz'ny#'@kgRuT˜r3͝jt€p,wTmbNV/'€%,(%[+@20;տjͪ{8Zn8Kx8wVu>us$H,7)!N] ` p7n{ųQf14 %aqꥆ9 -G?b SkgL`=!u}!o  .伐'-d͘%)5)vWIpZ+/ƳF'GЖ Ӛ"jbȇBcVkwQHĖ<`/ U y]NZOZ+L33Y0kV4yQBقvG|H(Ӈ$F*[u+8ϧRA#wizz0Ju ؗ?%|^1p^r]ȳ&Ļ!ssE2?.+oB:~KttB8m hSҫkA';='Ѓ;SU| N9i9E1<'l:#Ҽ˾BC唾\ §F12N5nWsT?^w]_~jOџb@1ƤBQa1 T}h>WL,2K&hxK֤}s\Eaeɟ »KӚ{7TؔQ6[LЗb 3op)4y^(;X%X-UXbwuEYyva_HF4wbcue'$ӮVciD(o'59'AaI9N a[o,oemf"G-a0З’q\|JVh 8ۅe$ϑ>UdĠh*b8pS҇`s e[we*\ix;DZA%ל<J>6ȼEr_['#-M0M St .K#|[xotFk4}mN3wTF괒 *HKAu:7R%$fUzyA@,%,ne$$cqxEeIt:%Щ4S)"T]?Lܪ$|U~S1tN/3\+ޣ"3azxS ˮcj˕~¤usnYdB,C0B#apI(tPB0mըjD)r%ȂѨ&dh~BAt> stream x\mo] nG\vjXt[;t50 i?8M$MHIGl0DR#xFr#O'^l.n௣_dsv)2F( 71j9:ٞ:C'9QKaÓşOuZE9VHVeln]@vFMag);#]|+FuFi‹0RðQ@5\6ûh:&y zQ9x!L^\%M0fxV_{5\ 3 ʅ[uN'`"!ٵ/d Jba Xn6Nj?=lLx1)UqBFVMTH`Eƺ[W a RR1/ kx=AM#^`g zxPD m-O[TI;'hn1;6Fg}qtV$#Ǽ O e٦}cB(&;aJ ^%W umk89Ϙ!RR`mƍ),h]t0wa\Z%y\7MiK=bL8Ni5ߌňkoi_tstRIӔM!C[\c2@3g0vN0b|Ll"%}>E 訲.^qVwL-U' ɒkwYuY"Tޔ_t>p[r݁zvpFa8%iSqiS?ͩj\Z @}q1x{g[1{x Gna_ܯOrpF|YJv&  'J)vz5ᎈ<-[.茶nCk=iWu7i+ʷ)g[ri y@7R577Wi#4Fa[FM퉴^Bd3q[ ZFFF{r.-STbɮC:6:p0,¯ 4 ^bExFBj xyHȱ2e0uHx9+Gҷm-** +`Pai;JmeXŠbuhZaH_!I Ҹ㚾~΁MQ0ͬ!WȍT 2^4z}#wKzm%}#Ke.$@.YfMtk -RV,/0hv/m5UiѸ/c- #Eڸ{5Vk6'5 b) [UoB$f F %?LO%aLn*{\QodtC0k )9R=P@x{ݚpd]w(\\7zϾn;rK~R:߿f~VJ-Mf.z6Y ;S1MNXtiZ0D󫠒ѦI{|!FT>fNO&e4I+dr|v52TtM&Il`K7KBaWY޹8}YIUF# HkVO׿Ƚ5meɊ;ET=4h4)H\pCTu3-MY?L >AE5V8`^4}g!*S8>w2̟c" սr}_}$B,Gģ[|JmNuv#.>rԉdf^+'W0<42g ggxrZ'I&TavՃ*A{-6<ɽe=m$vtjAD==gLD7;PwT:J # ??kF>n$W/,r9TT|;%%`HZaoڕbo ]aĘmTpe-k#4/W]6|J8|QvݒP;JSKt悆@Jʥ%Z*,S=پ" ԫ7 qG^V:jY7+k_ΨME>QP?ȸ&Lv)[*_TUũ徱jjVչtTKث"ɇ9X '3l%&e>b]9ٳ:Vr4k9-$w^N9L)ɡ/gI xD̼Țayߜp?Ϡ?B>B6J#X ~ WaRp/BW3-YxP^фuEݍ\(S% d?bdL|λS~$_FZW56~&Z(0ǣ'г}qfJyITI I"tvt}}Aot,uG3mIlLwG?zke <] <~dp'd%YJ+έ[kUw tP윘\d&uihV 8.^ qۍ7Gn~![? 4uG\0t=€j&XpκzH{F^Q m)e#6=սILejeWiĒvF`i5.ˍc3K0Ea2:8-,KHM;~x9L﹫!aҙ+CRGZm}L$>P&S~! VnGgJԝ+ `E}H|=<'YӅ ?@^?J:ErBrb)rFCZǍX|r2}jǍd>,I [X~s̼3bFY Y;ET/>VQ5ͯpQxmHYp),ˣ*l ѓfЯwg/xV.GjwΤSO!**@U~&Z-OD< ޣ Qa&i!ϹrdAS8^OlC,AR2A|LTrH7YsT8jƑ"ݨ/|/0xǩrxR>. NTH GIibuuUoƝa_:<)FR%&;@/],V2SzA-rDRǙE ~0rh+߶MY9lU~~z=,(gj_G&endstream endobj 313 0 obj << /Filter /FlateDecode /Length 8314 >> stream x͜kq gOy'ld1^)'ƚVF#kC{޷mivVR5l^Ū"ú>~^>{GNz<>S(,mm#};TgOʨ4Unn nmx:;_knWN^s/Njgg>/xYJ_C>^bsq]S\͍/em[ײȝs͙[VW7gF c{G1CKi\:e e]c=D6b~uSk 60z:L9*Zwݨ|=jKlTbĈzxm'b`URKv"IyɔتR((H_`6yPI%keHr]a"A_2沦%}J;Al9wY^1A6Rp(1qy WN(IJ Z$#I]bRITIŚh ڡS_6s*II%mYJJHٴտHJb-$W$C$\T[X%STVopQQ0iGA%mK*Qcj0U^ZnUI4[G2b!dP785 prp`zJ3#hInQI[[Nv&6IxM15g]$+ΰ*,~]F!(j))"YmF $H O& m|ERJH_$75.jM8 8`"pNlar!`Qk(M&6Oș " OkwDPu25u=} lV!aL܄xݞXkPAm9.<9+؛HRT]b9ѨDf˴( `bDP11 "%YhoY*ݫaUVyG5>UL^"[o{TDlUage)c'e̥2D'<m־2CTPһ"c}$;/O kIM,X8[HnEZNNf"7G=J`)ѥIi ;$+KTZvb$!:'syDiѠOU4MN!H I`(:2,A'Ts>c#=6BE&AH]6AM \= {\m̿4mH3G6jkaPSAreHmm l@ii r*/jxKB7dxn;9F{X$wu0S9@;LoUR%4EU `|k*I21 QGQKhH7?)z/QO@Iv52>8aX*5yb&TR%@RmW]Ѫu`LGSw#tŠsM(̡aG"t’JKLf+&Ehb3rS6IEH̒!6lxlWX!aRg]2DS;VhmݭzM&"GG- ҍR%LiZf "*Ar ]%&R4((EBuz@qb򥭺\ t)Q'0a.0 X%%D]H+01*K*ġdUWWQSK}M$s7IH F{3u F C!&.Q:!245vڤIЉF̞N0W]O*fI"h&HI"\37 CU#ueftԥ(-hd{"yX1F ^JT ې4 ұX >[FƢVix}aM{ϒex| iUdâ"a0ECUM0Jǵ'Ҋ%:** }DHfO 26~0Kvdf(8DY6XR̬HH#6$*>% 湪:M]L֮nI*D7 6Ik&XsDE >h@oQƚ̧Em3$Fo)# \02jgԴ QJY(%hAv@RIӄt/0H7BwḏBAJBQV />#~ ;ES{.QNɻl[U9bT%mG85:fv)CgPk$w*V0P'qRTp/jÈ r=p7? ~C ZI3#{JQ%܄X?Ue,-J"vZIj-{=Ivjk0JL]h*PiԊz gz8īZ/2]MH<݈d 8%4bEԓtRU"I6ZMY,UE:5bojڎ(Ŏ^BRpXUQNs\q+uC1ux[t?X;QD9Y;QeF>neΙWP[\YP'IIF}.#5h\ZSVI"m`E tV0;LԴ2O*&dH%06IuAj؈^LG,==EaF,HSgڡ3҃2F7ĸr7kh9q L%IQ!Z$'c`_s,Ct54!EgM!-UphS␌ErD;jElx:WktrjF"fR #/_R&9R,I.#Dy\rߩZN62P VT(t,J$ьTA%ĖNpꚑy G"`L0E\EA"G mWZUwqlO$*a2`g!@:ð6庄|֐::I~6j ɨՏ֐ZwG1kuJnT3|t%-_F-t#96 /6$Aڶhu.)rSߕ̶i@&2<7_B_Wovty5a3@"4}q]$tPKċ^_߼:|?>\$EW3w8;QN3v&(ln!4Ì]Wz^W D唆_}769*WW}-"N_=K|_=vjSljգn; zڙ+T]_y@U+/0u*Jz_;5}V#ouKgH,\@2(6#Yǣvn1X)4v,\ X^,d}m]*P_}}c㯒WhO_ }1U_)QkկpBо77lկ;vJjU*=02nH%`]Ku-vk5u6Չ2(`А@篮*4 bK%_0w*zWWW;`8V+u{`_]ZlTCN|Tbqc%f:{-7k pz9ע J~p nQQfgwhƼ7Z&R2 (Xn0kY zo57v}DݠZFREV*=)4:F\QW`WY*>ּ o5ݥ.Wn[C _1|C 'TtDwm 2ب JS=|h-+|Eu:|4pD}cCOL5lt7GSgkX;aTa fC\a0W^CV앗֌]^ܱ^7SJ{:{{ 兎^Ctz i+o z ɛ5Ъ0+YPk Tk о zD^q21ɫ^INk`HRiܕDqW#yܕ*5JlSN(M52: a?zk5SjtJJZMqQq]cʸ+QUr5 h^ɾk FY puE1}w%BSع+%61+$(qWJ3vMx]GÝBUҹk)v Sڑap׭]jvQV])8+"Վ]Sn]y]7]lؕP۱kWvŴR͎]9Ɂ]6:Z߰kHmî_ݰkr4+Up]]o5yҒu0&gyîI_v59ivMv4쭬"P7ѹ\j7]c|sWJܛ0pW wu]E)qרxCWN+_drar\kt[vʫlUnG|)5dTWNWщk 6yqCN\ ;qM'55FeF\髍qem4Ո+;5(Nq%#Pщ+j% q%o'ȕ^׷#WnY}#кv'm5l`WB}5N\ynw:q '5ނW|B\C[q [Nj_1J+n5hx+6[%'DD2IL\X< V*IkoeB$!~Ltkätx+ >YUj j3[uTDykW%oeo嵡קڻV93+4lV%;oefoiܸVK jíHte6V5Onm]nmq+ah㧓0ҡԎsN91i0x󼗃^[K>S_b~xwA ՚QWCdʧ+^w8̓{&V/BWgj^]0*9]r0;rB㳩Z8lUU n} ZXjjtnG}6 z y,jS\Ҿvc_x!:Y3ы՜svM!!/m~ ь7:+}_.#_GժaI?W];ml.g^'3J^M۪ LV$nulaYLT+*E2x G]Bh?mK~=W›!ŷ빅nW:p{ֹwPϳIQè(2NAVWu]Fqn[x*Hak!ѥ(NR75-d}7l-LC:=>ۛhjߌS}1&hݭ әaH?[侷{aLyi]^lw S G4]4 e;u1vJǞ߷V׻jyWg/wnww"Ui1xDnvnwT&f_ nFI )퇭ΔDiܳvj^0#br8Ӛ>obpZM\' SlC!V*kf4tNi lNpޛ8Ewl7'Q|w[4?{ǜwۉ_o&mp:kʧwINi{ovN>r20މ~$\_.(~<tn?~y_x|=@ǮwN}i&'zwYfO+F6b٭{΁w~;}ۺW?ZzzzM>lW9ftHq9lU&v7id rs½ހ8~-?jЈOaqLBsɦؿy;t~ݻ <~>JX&̫%r3ɬC G1#{No2jKrΝj_Gnkr7V;nIJם֐'k 3_NtB;4B:|Q S8^j$!H0ɷ|n'cT~ݵH nQsw0= 0v}lKp9nA8~+wp_!ːx;,D*V\e|s?yr}_9y)Eg?29Leq81ҋe?[4Bwj#iwی q馳hv8A>o#?JT_FW9%݌Q|ŗ:~) f/F(i‹ُFA<śQcSƲvG%5 }$9GroFnݫQv/Fzߌn·Q|_1?)W-="Mendstream endobj 314 0 obj << /Filter /FlateDecode /Length 4408 >> stream xko5?^(Mm] Sg=l7ҝ|z >n EpfVoK/΋嫫ov!oG0#j飈rytr)]譴Ko}]],^t]6{U4*|! J/jd<:ec[T'^ǠaNimNic}D ) {l# ckrCp抦렻oV%7Mb^fbtwJjsq6J#t|3D w} ~4obm0J 2J|1iOC2GA\ڂ,:WG\˵}p_t?2 BHh#ITZFŕ 4@5)G!JBtd Dg 5 %{\c*sjI* ִ _~S'"&'5(p|v:nKب\%3FI4 A ~-Z0xhLnp+b:Z ;n^:1rwخPǴP}R/8Z/J*]60[s 'dJww Bf}AS|]ME.L8C8ぉ%z`J(͹c_㯥@}ԟ8iB0 psF-QG坬(+Z~!?ݳgef)]6΋_eTg7n)N\oEb>[Er|5#*kpo躌n/஀ CW2z^p[@t!&e.^W|2.QUm:I7'<)|7d΃9ܧd=ioRv$)'$5Kø<Į ]O aZg pH%=r2ۘ9vr;x(80Lt|^'̝OSL]`HfWͦ) 0q F\ӢLM=CqO7M_y/)gzQ0\ϛD\4>irCk})0yݔISL ~*>vB{Ro&wr'}Zg.]o=' ?dHwXbӃ,9h5 쩫RF\A%J]0h %yFspSTi605M&⬖` a*Qcʸ4#"6*%aҿ*gP|;JI`97]6`9.>w'R)?[%Ԩv ,B f0svT# " =M}uI@Rzb!l1U6|mbP~c _7j9GlMGArI'F5Pi7#n(ȹiVzH>=\mrƃY]|՘ѫESk? Xd,xW=.*+G}WJ.iRr{R%[Tti3qѰQ>zD$UK+cl$Եㅥz)MGR𿶏p5VV}$5(hKeC+'9Mx+{2.JgU`qE5]a=j\ɀvb1V oq]Pɺﷄ6DU`R{ O7; o\'YԭtkW5FP sR@}۝( @fW,f3QkuzQ 7sqT3]쌠{L]YBnSn7¹hɻ3-tC *Dҽ ׶%ޒ*k`-yh^ě"n.>bfff *dؤeBŸ5ېVp>}wc!*ҝL4p]v7H.zrm./4R )D2ufZ$Q8M?i8jRP9E2ܮޞ^#*c27[YT;^px'9dF8Ơ1{Z`G1h꽛 ?h&L6,ێ]!t*^1pc]mIiP"nZ47I=ӶU $p:C$矔z?%ed*:Ǒ, $r^L(OeQP,a"I(eB@y2n*w)KQxjB2(}䶷[1W.ӕLtuc}"F&w+˓g%R=Υ^ЦM,8bT=_1u]gDbx as$>/஀|˗"a 1 %mMgb{G89 3L)I)ȧ5ckb\Ÿ!e1>!N=B&W$3EF=^x]أ! Pm\ei]2qfF7 a#z>85o3Q|ģ3s)R_Kس0$xfQd+ 頻<{~9vZsb~ )ZvlX{ªq IMAOO)}vN 7axj\30S!Po<7 =f,)%Uʈ>vF 9}mzR^ !YwB?Ī{ݤL6MҊuG9ޔR鹬e{öގh^Аd LkKjbsY`i04bkme.Uh3Bsô#{cyJdɓq;fG~lh;Oⶹa{e.ۈY3WQ" (Us72⯚޶/@Ydxw4^0kf7'\&A}G#9BlZpbF[no"c]35ֵsޤ ӕ՜vXmK{+$&yʼJ6|NߣEm2KJ:HDsIDMl˹aS6aC4GChúI~4"IyT4&Q4GCc\}XeInx4"Ic|T4r2j\a=oX(OM>˟bEb)Prˋ~ǑF#&{ǻ"v]JT:oXɯ,-ΙTw%<4C %BBQ@HLȟZIP2c> 7S$ӗN15a<ȝq|,1A`m~6+ܣ"Ug1u>]c"e4_-sÊf nXwmOzП ME{¥X~Ǵ,S~7gendstream endobj 315 0 obj << /Filter /FlateDecode /Length 3763 >> stream xn[7Gy: S/f/nbڢPKԲ]!yG#NX $s_f3ʿˣObv=~9Ygu9gx飈rv|vY3o}_uZ̏aeBAٺA-zf=W7Rn+۠L^ )3Bh :K 'sыc4K+^K)C f.{sTnZ 2~h5|}?A2J]!/ 쫤 t< W9"@\ϑ9 .EB* OhH-Q,s(=`4[ `HS‎A[[&u/ 7@hn,fUf`+[ l/-sǸH ?%&)d[vir]bc1]^x׌GBQt[)e A~6Hb`lxn`;` 9aV#AN2 J^!ED*}%bxE6*`vzviV1ຂ}AR3}TpY ~UI_(*E<,i짤SIϑs2iq-$ܔ ! ᦲ榢/B uݟb ҃򼻫؞UN^#\T𲂧Vp:zSuWu ޝ]ݲ;$] WbeEe,7w0LioJarܰDX+#KΏx( > UpSAÊŐfTlާ *<ww귬ޫ!Tyb2ꆞ̵2 &vrx2yLn b ^OXt9N)P2S5uܒMf@*ީrY|4S]a|z|1{N2Ȳ%"7@o+Ṁlr46N0ҏ8}je&fF 'i,":Gb5*ʡup50YZ%]%j'Ώ0uR|:iy7վP%&4 X8 ܋AkN5Iv(DUY1%}IvHCzjY` J+~iհ]ۄ9 4·Q8ĀlrI Ѹ&mϙvXў] .b}HP+i;+'&9#NL ֽ>aCV3C[u fN;o+H.ؘc[+VAK`za/S''zQx+fM hڼ) V&LyO\/X-5x~}7(}J'dC;vQccWB[(Vͽcw{"[уr6؀$e։dGKS ~IVm=]FEbLclR7&ˋ1$֌KnUI2ARm2/KO7+ RY۞P0ZAy=lM4TFD5%5劸Jy`To+R{CL * ;w%i%$ i;c.~۲! V/Ysأz͔t5+Ldwp"~ldI 7$mra2 ߡÿjlI+nn|5}tY~bxo3ƴg'YY=׌ VZ@0|N -"BK6;zS K-9ќ?\?~Wendstream endobj 316 0 obj << /Filter /FlateDecode /Length 2088 >> stream xZYoF~#(Hâ$wM0QЇ$0IvXcZw8CyJa {gKkDE)GL/-%_Qn`%vUlm'ۙm;jE?Æ":;"qBԿuHo#UJ딉&J4] ;#dg);# "^{odBdE`]J鼋&LШ YGXK0nFJ2EN'KE WI㌉fqM hhYLr.z4ՠo\$` tym`V"KqDׄIPD:NwڦAdЧI6h0([[Ӫt`-:Dd6qiZ8r ܼO`pg9H[\W՗%KcvsU܊6#C6=F !s\##쳂`Ja5[]j;bcQI BJikfdCXr !"<@NZHXV2W,$C8UcMIȯ:p1=mO]HO TBq\T%@R&>dAJJA12RT"#l4>U:49?+vVyBz1 Rh3@ؼHBTBYdlH,D(CԖǹMi@u5A.h%92xgQ,pl}X\1^49C ]݃kX|7.37XԔ,1A^`JzwoT8;5 >LRP3 {adS.jc`0$Ou)VĝZAn!+C<^T EyAߓ10Fw ƇC5cPzI".:iZjg\DG(ZimʧTW"09n֐iv|m`6c&%+ec9ta*N3V„%A2Tp)k0AuP}ҽu\ lohx0Awܪ}^ItF9TiT!L?b{)ve,秢& q=aV`C}%$N\W`!쭯G>MX?fm .f2dx"|>j8C[f>Ԉ}O%7^FkwuGTWrug}a֍(Qu>QÕ,ռlt U֞`+HUBAڄ6ppCe . Uxg2;W)4 LrHcE:Ɍ 6D޿3vBuG܍Svۀ !l`oEL{.{,_x X]dA~kPIƒǭf=͂ %_C ?^m:ۺwWn4ďD|H?֨7\W>)>GxԵDB|G jj!=>"vT_ck^ԞG [33dIf-ILMߥZRoNyZaXCRTM/!$QtaOmG%M6w@dc?))Mf^7wL_/q6~m?>Toendstream endobj 317 0 obj << /Filter /FlateDecode /Length 3623 >> stream x]o]ɏ`>i"6-G@#%JQC(YqhICh<;;3|= _ӫ{1>_gNfEԀirv|~?3Bkyۨ֎.fy FE٬ m.+h>4Bk uf;_( $VǠknBDj+mpژ:m" B +i 61%lPlrhcY2vp"ps$F !Fg}kB{M]>CH8ϑB`|v̓%f _76.P E/7i1NdbPF8t,v~o4fo󳅶mpIO{*5U:o@I 43%)Ji#Eh[&즮~+aoXJkճl'2 N̄ d6vPrhSIXZMu5_n^}V}?z\5a|A;MUDqNkA>ol )L5Z ]JnbWSU=2Bh0W[%XVW)1* ߰LZ[٘qcz;DŽQ m ߎuӬ]4wR/'EueuWsY3AO2G&bQշ&H\ًD /w;*bvؐ!4X`=t CvXL-] +npI EvXAh<6d68G|](K w.\|D;z&RsCeQ$iH2ek.mjCcyC Nف06y43U2Lv8䰰8F(:'tUiUn$H/; lJKӬGHBigX-ZK=aR0h˦/i=ѲsTL슸Y7NPAp;,B[H' wVA7ye)O^@.Ehs$%%w;n8w}@>64r ;,2,κ\O|N /{~E7~M٘(** -1ɪWX9KUxW_&wa3?,ʝA4b3VyHXU8+6ՍY#ʦ,_f2TdU?{E3.Դ !556EGJ{PoުQ>%0nKp$pS2~XU3\UfR| 51ccu8Lg@SӽSf@UE:_ecWomlFsW|Y`z:G42S`񊥌U _1H!o+ٍwhS[ԘTG68FeC2k6UU U%v8A_ghToUXF;[]QL3J-X]RJmTIJ @ 劑\'%; &uwz΀7uXaC#[ԥ@ˑ&ɩ%&nVf7Бd[LWt.543Imq^E*#Vֲ.k78Э:fѦwJ}ׯB0(;ie4q̨SC  Բw( 6ؽEMc pnL켂j6uSsꙂdZAA?h >0*У(%Uz|ho??HzhYfrtնO;dRbnc$t_RycWZXVy671G,vz]*8mm݉蠊r1N!m➔ހʝm§*3 *T5oi=>RN z d16x6C5إ|(Cy+|:ff )(WT7×%O,RİȖ[Y NQ(w=ެy4OaE{5hGχFF|8 3C}ò`mwR7v(/ޢGݔ ubx%V_QE}%,|E/⻫2 ݰ%M)…SB%K C\Yr@Lw!21}jY g/(`u|[_.KL%M_UNq]}?)k[eW5*kI;|vu~Nmiu]ۖ6~}m3aٽ=VE6dO^քmW[VM1໣IWendstream endobj 318 0 obj << /Filter /FlateDecode /Length 2551 >> stream xZKsR.)`;q)/ǖYÄ\I ]KIt70,tT[`/>UkE˻^j¿VV]wo/#\飊xJ[a >zpC[_ܭtGۍHhuvUCt5 HZfkA3zbwl+@ 71GPkq X=%J۽5^>t1^9L/ec%Qt9^0h<C yypvY+☹q,/xM*;t}^ &<T[\6mZ# dB4L|da3c7}jՙasGų[Q &6)3DEG& +?B_59~.䡐>x!Άⷕ6[MlNe/d(.)s,r -h.AB>rWȱG@f ݿlAY*Iۄm_>.%'}7}'qғ-m7徕W9WlA rx,.rl&xbR sDqr'-ֶ lW&^ea-˲z#-2~}a& LkL>>>UVyDjEaoRrϢDEOMc&* }!]W_vuIC9Bqfof =؄BL%d}ɿUfqF|MUS-A]_`obH 뮉6pDmm] ⶫBo䮩P;^6^H/c!hkC 13ڇ bY'h˼\Eˆe$&a_LP58X]aÊm&iLNe-c wtO;s6ݞUQA3XR_YHA"6wb538O&N؞VGƎՐC›!ONVivr)4(4 D;8rOI4uM:8 Xu G1 :(-9짳!ǡ\݁UGIRL(i\3JxnY0%(c6Y1yF B' $=ĎHŠ&`d,qG)ߑ7;Pe&cf~9u@q="e|[iXhдire>n<<+cbdmMy*F{BhGaܙKH/ N hf2]L(MrHVĭοjN%6k#*<&:z&fJ#/[mC_.B+a25Y:^(!,Lcy-zL' `Ve;Ww9Sz/#c%qqn+0ʄ`U-<*MhE= 5Q }]8#ۓҁ5'J4&|r.ya`A P[#kؤR|XX|K8oDjčI@~ vJk/s rgJ7M.e*9=~~kZw79 .9æվvu&EQD8y9y/S(ٳyNxgb$1GfےQ~ܕsJPs<>uXVn hsX y {Rh mBB(ǚ%[q5gx@Q5<|_S@9/s\^<Ȕ6, L+ЮM'0UHTeˮg<%DZũpr"إeAp%j%(JP 8^ d DHf)fo`T$v9Ѳ;mq[;Ll*BIvQes 諫DB,XݫYr<]Hpûlh<Д3 Np| `Lej9ꖘen_B2'q+\tN&ypx=f'>)ub N) NR& xO9F1YKW`PۑpţL?}3U} ΋sz ^TÃ4-> stream x}I-9rݾ~ŷ|?'വa7- /[_oyYmY6V/o&8 ._~_YOS~?嗯,K=~~OWj㻦k~ӏzl3~߭?yo>Ǭ?'_#H/M)e---o~MW \eRۏXO\_?JďG+HWM#~+9iδ>?e> y1ڏ{=^F?Zr#sכcVMq%~_x~zISҞ3(}ɓXCWd1$k=~{tU>`=k(0GDUieCkI:ŒIue(mczH2tĬCb)'f=[#v/5|+[2 BaJ]$cP*F_?Z?2DIQ a K.sk>GԆ0h]\h j5bV))TtsT;OFbԱ8~^pL[YoK#=0eV|V1_&2 ᗾV/W^ZFsr4X+Jw9ڲƦK&V1<$>lfKXG6̾Uq[An+p R[e"/|_a*<, O/b/ǥT5z.TLPcՒdRև%Ta/3]*!IP`<겐0tFC=Zˋ}c<+= hYFI*K؂_]˭ѝ%޼-5'5i ,ɨ41ԡK \Fs`[.r=k QW}$.LVrSJUќS*1EJhҥ-[єKi{`EЉՊзL6 j_܈*Q2t?le_GYGGY,FuX85F".o*\}/eWa:H2`bd;*Vg}zl&m* 0Lq!{,HkMwtB ,$ىZ @Ե:ڟ73tKLmbktOڈؼ,0JLQRkH~յ|elDф?-Ә׽֚:|xi`W g)\F>> (H(Nr be2cF.kle-ZFsko]F Oalv?) ?i5Oc+2kښv!Űk5,ڶVBF+"N푽 )$%0W&cNl=1*C[8 KXB a^ƆNŐ e54\30ԅ nb+F!6Tbe=!6BX~!8,1&Tclb̆}f6^C!vxoХE pAl0b3N,QP!̢{\3qɡ -AX#,1.;.F\sȫ\eigj.#;6P6 j b>kdaf5ސ ci6Kxzo`ch6Tˤ`h46g `Ip}r5a*_ ]nt-N5"^*~p{ ۅ\zP6v9 _ )o?560^ 7Q{c}>Lk4M0DI[O mPp c Mupӓh{u^7wHtݮ3% nbn]+<Ԡ]P-IL.QU !_]iIק[k6YBtЈaI"L{[, K$9y9v5WYӓ4~)~C~J, GV .]hv ۅp%~%KsIװ߭)<+khgS`vЅYS{%BbqM+I$MÑ%!!h ZC%.g ɕBJdݰZܥe-;et +Uz j q|5FX,Uo$p}sVszIB;aT.\ 4oX+^o%ճ,ɸuh\_ɡV`50dm qu}n0[Р)U=SYfw <ɎX,Iȕ``5lôN,֥zEj$AS#V2/p5ZZ&."NI IHȑ 쭷$j̭VDJS05Qw,g3T&1o_"@5Q]NYǭՒ8n4=qpDFaP.ܓW0b"k欙򏄩-pd n%i@uIHvےP߱%g:a[1uOP7jR1I][ /9T7xZQOTif8ݻ6"6K 8=BB4WkY@K 4=K?"@4uidhp^[҂ǎK"8iS]poK"<%<}o rrĭ>Lӵ %1^ AEi=IΑZ$7Km"!Oӈ OM#,pxҝ K^N>$YƱcI5a*fE^3#ᔚ<5ufˆydی4gI P)o$ۂ4Z!bmɱ=Q"|[ZDTa%p$KҴ3H&5YE"b!5֘%hzHk@v%]Ч]]^SR usr%HT'ZO~ }fT}Ir307wGA&DD W7FCFի^pݨmW;ފt g6aT]w^ a5T&w2n^d.@5 < Y'DA8vewzSsS-(SR 0k\VZ2b$ Z`hݝn ,ps.;$[n8! 3KgX9-?#ݓ+5%Bs/^i;AaRʔV3$)ڕVl2RO m͡&tfwXgzo2L Џsi3{݁QM~f灄W=9YKb`#u< Y`39{[y$gʔA!'B=Y֢̔ E'upQLiyȺ)Re/a Hֱq&GjʎC`]^+" CJCTUnZͻ&[_E0j)^JΛȠI&# 67?bh}\_֑!%1nʊDb:l[Չng-CDu^KKhн[:4,dpsRddp{º(0 _v^] pm5 Z bNZC뼃vZbvNVklƆ^ tC7.3S>6FIZLhI 33:Vbp2OnIĀ% % X!|="y PDCdʟ 2D S%`gKRV$!@qkrw \;9eH5y$^MhCDQD2]i* NU [5Rl|}9k ]*=+-A*(8MBP@0P5ǯqta;=c29Tn=L : ֤p7vJM{On'~D 0Ğ}a=Q-:W}GQƹK"}4''O+khH3D) 屻h=?NsIY{bv-mK6 ~LBJ:qg_%GmAɜN*-#]_9㸮EfYE]~?%įڒ&yʒ㩝NyʒS, g%S|z|*P^kҟuHu\5mt#5?h?>t]?2|j|Xř{R~TpKMSO||ʒ㩮:,9r[O=Zl o0ȱ(@I^_\Gך?Gi}Yd!_ZT9_z/ kk~~5fA,3jcU] ,XIHeRU٨p_fޒ^f CTK bI@Յ6 xr)a %v`>$.$ _y>$t輷SOJ [$> /㉝(ty?(=Yʤϒ^űpHTxKt,ZpNȈE!wA&Ip[:{yׅy/7Jz p.ypB栐>WNI5\_}|]MT+ϳsy4*   iHW 5V @s+, ]G|6md69¿_qIz|mL uHwzMҵ'MUԦu~@L~H\ԯm"ghOR͙U (L )+YNTEgd+$+Y0ťm|&B_3 yI_U+lѭ0+Y{AB877iW:|MȪ܂: vIV%9M,q "tl^Cng/Sy%ֵ̽uu vp&8T=BC*{a-Ⱥx.Y@geVլ2A@ e:Y漟iU VI,\CRU[ `tK?JB֥@`~52%yy"3EuJ%m*w?Ti^pm(<8kVnL|^'@y׆* Y#}(Bȟ3pxJ6}B,Rj[YGa%q2_\X2(vSw%\m@k $#W %pHtZ*eNDFCv^*Hgݢ>eHI+X ӹ*cᑪB֠j4EX8 pB<M:%x^WXCp_&lRہn-]Xml}LXFd}U3FAp&yCD m![W]XjÔzK2Hj(-4 #ְ[Be8hU*82]Pq,IMpZWTH`ogfM$ иLaLȼ`.c!eN)ON%fqo k.˳S`'*7[Vf-TwjH#^nI peةh ^iG I,zmm&Ϊ*@jՏh#ӅE>Jz}!k0%j^k Mh{ykr{Ɍ@xۖLUnw!a53n_ȟ#U=j5m5?Q]<.4[KU&Xr.d,b5޸pBnZ#-T2IUۙ_O"GL6"ȗII_h;x3*^Z9yXUjDט~^igHhsj--DH)t!<yhHx|P5B)UE]g4?5=EdꂈώGVUtw$'AbSj ~D5۫3kJ чU(2@r@RNJܽ[z0chU!Bɮ@} }z0Җ Kn7j,K#܄A UB}evDZՃxur5ALV0W}m ,ܕQ@Xu Uvdo`}wB,TpjYi`5HYS6-$ṮKP`Zl1)ApJuSҾԝw TŦH؏5]2厪jS隋DӞ}5T0Fц3ոdzS=Iυ J: KV`C*xIe AhZ;6oarR|ƭD#|V|^oVKBj=8Yu{p#恺L %H2V oU`&SEe^KvUXs /\%n8-[_%%IZI|Jºެʓw-m E6AҼG' #GIڡUS{Ϋ*2 WT =\TU9#j&`5yr8'a\^񑭆H Uc%}6IFӀ}ZR1g#<6l0١>2æ\`(tX;ț1=jT1,dQs:$sEQvǢ8$}~l@?}T݉x<ʮY)'=J[zxtUɒ쭩+Gq: Z @X;!I4l8tr<6sd&Uo~\<<$;C ^ Ui͟ҍH`k|9IDP5GDo~D?ɑ,I ]FWX+9֗*tqG-瀽?"ƞKJRs_a^ lGNHѧsBf !Ғaavk&O.ʬ;s9E `AM$U?>8I7l;K`l+U k}耯$E@uz y Tߊ唁uz oDrgf%F$D5ɑ:bDI |Di~/D̃6OU- +_4L* MÄS6 xPF)؈i}BO|K9OMً *>DQm*~<y;`7+-tznC%=k_dTk^/ )=շ!e_<7T4%&tUxY"t6 \\j "d!7@s.2 'ȗ\8V2 ]\i7 SL -{V/ote8x!/5NzbcID>So"BIfܟ[ psס꒢Έ_sTkv#dΧc<5zOSvHJʴCR-~J! KtkBXrSDzԎ%'u\]cAie 2ڨm4$'u^.9*FTܳ9CAj.sկ$7uRV6%*pz"A^kS:_ӣ5sr^ dueH0t(iSC*NL Y[*C11o&f?J 5'%G/s%Uy85\;pSPeIoC¡S*R;Y9PHUNg$DSZ,/Ć#weYBq l$C#0 +Dѵ66;r '"E 漶aOW2瓂zo8}YAaa (]}gK^&,շl^N `uR @5$Χ^^{?S,+$,;O>3}h'i$ e>}}rt(՛ 46^ Y׳p=M͠pk j.h:ܝ<@*9ioiHOW&Tܜn&Olqh:GaU Y}-[Ka26uKpS4?[ӂOd`[@^3t}ܔe6sKOK-HMYS"Ly) ei^B:@|~ Agm:axqh g;940 I< 5 N4 ?bÖ;'@':$1Wc?.l=ǫ[^ӄ=WMz:t$e-CGRI"H$nAE)1|-Flx}oPqK3N{I /ߜ%k5<ӧ9Q^ 9׸UҒguZ+#+ut\KuJ60`|wCwBr;t3G܎p\{iW]%%][#9BK[*Jt$Unp Mm_!F:aқ5N$O5; פY͎{ fvsp:7DtͿnƣ.TH8PC6WV9BV4_D 0w/yO0;êV :T^p2̆" ::ݛؑv#1lWx 0t+Rse 'b($PK7Wz~&,+M9(;; ?BUchkE(7Al/݇헆NA H9?bޟ*`X4@" ?"67iǯ]C`{uZpv*^ƈ ?)2fxԴ (w(͑:sQ =ȸԼđ/+X/\m jp'xytwtG,@@G03,k;[51eKC}aB=ta_j9%ӥѧ5{SGAnK)逵3ekWhVN?E(`iGv+ƽ$Qp sI=:(Vzǁx;ԆkNӚ [סPR*m~AvQ.}l@ڡ?inׂ䏬tfܟxS[t?OY|0|ђ}Ryʒ㩽Up}!C:a:BUz;9%b/?2+Sx<Օ xʒ)ԣ]zM8<"Voͥ1[6/DxdSi?kɻJSACJMC&TuTj?RӮ3֬*5Jmy>uz-A!R sqh!AD!aD]4yJxZLIXˆ%zZJ%<-DINx,D7 > ISQI%PcQ$ItE=SH2-aH+V1%k23̍DoKIޖݙc{xH@<% $OaV±}Ʒ [:[JT }=,>  K_T%su=18/¸83 BgyL^] ;q?хG©}AfPtS }NKOsS }PIf0MabVɨ@gA䂊21*]x '΋}\^#\fC qU 5𬸠&o}&TxOw>>y' BÄhͮphTט$گY.䔫5 k/P!*[_%z d@Aƿ,YM4=mG7$d0phgIuՕ7-^%`D>?u+sQ.@\Pr{p2#ZʼnF 2t4i `ztx=#%Q_Ҩ&\+H/8Kب+ $v*Sʮ0$ $i|)ջTuEAdѧX<51vS7GVkejn (_N(~W%e LDe 3! LWSWA*IK؎A08_cR02,huV*hi P+fdԦX"S6 %61dYb^nY(8*X35bF`*'OaIo*\2G4ڠ\JB Ư_q 8!uȺ$&(HVv Epv§- Q"@Q` xzβAx8Õ NY؟D,{\.ҫM7qy dy&uq%NLU6܇5 o`&R'J z8*l6JȒpm@>7lŁЄ2@1J8̟t>#K8Bޣ\ lbԼ%*bI521( x͋q8hu Q*%;؀Cd쪮Q" -g"s҄*ݘB&ǭU6M~A 6v~q~CXqVįF¹= 6W`}qo aacUŽM]7E`2 TGl.v.,vO L͡H*v-VJ*=%ؐȕR GB]"3065G春6$B(ْzC }oIAub&c&4ǂI8(]c!8:!xM]y &`^BJ5o6?ˣBDD2N mҭ2ABM"t]"^ ۄJp 9;\F<؞*Xg^jfplOt6Cnd7FL '`_PfSw zC{8$k&~PXHFyek&0& lTVsXZݨRnM%ebi4!>HC7aN,iBHi G9TqOwխ&M}W6TYPS93C.Xjs@r/dm؅>ۄQt6 %X28x.NCDY'6Å~17J|}2,kGq4dEWk`F*R ='t/ zyMal$ mX1yłV)=vĐ<:Q=:) $>*Q<@6k l@S"r~@6^<,A.)۫@ȭT/5礱~ 6OG/=ZSI(_ۜ_Pn3s|^By hPps2Z^JWEʃ~,RV#:޻ i s+zT!I& 3m¡|u*x6\3Bb+t)ЕҐE*B8[2c=nme x01R4d.PlӐ`*m=é}(,gk؀g&eQonBBM~G Qn]Jd1x "5DMGM` G]H܋ ]{5ue0Yn^h[&-]5)!tW`B&=W/^m;"idװI xݡmiV\ L!])k$ څDxm":qmU1"Kn _Y!;_אQn@)F8N4_f ;KC+.D2 nF{D%gD$0.EpT7V&C"wAlemAln+ed߭Q^]w2qi{Ys߬uQsošv}߽ʢCe( U]JuQ =.%%7lwNjC2kӗH ϧӜ=zlqk(R]O%7#*%7=|^YCk,qItzN +bjxYH5#w]MϸujWg 7Ϩ9V^jkdzCS]Cn^:m}1K̒힫fKvZ:_:Dj^u;^)l W{kYD] .Gf+&II|B9ٓf񯄭ZukW][t.-яR;+6QxCQwwpFP򯄭I;з5.FMG(]IokΨItD(Ip\>H&5fwb@h9u7oM~ O.3n/S.s7Oi1R'&ndqal!AF-̭I&w8ug[22jrZ/B9Ÿ%֭*Yr=hmjx5^߾"(2jn^15\6^|#.}=AAO PG [,mg))C%5s,DK$.x=D)aJd~(pLJS)fxJT>Ifty%X+ᠻSSSkYvsh:5sh{k$rWfuH%_΃E\ogKS&5e]&ހ)e0="bv%Bc(ImUA3PC&;/k5 TL^]C2 P5ds\`Nc_Icr3H t/l)f28`#l9eG,3m(n<#=ic$j-:x k7&x?-< ܬozf}b_Iެ(䮭zL]='0r` ^ʭ9OXϿΓS%.)1Zy8 , gOɒ4HQT\Ĥ@ %ixߴ)VSQBe6D*6sQCgeQ#1~H5tkO{uvcIdk}eܜKT1|F4\lM5\W߹YJɂ^nPzfc&u]{QmvCXcQ #qx(  +D L(`..}B,)}7$a) [^զӟ7'(Cd_6L?!wx"NA!gU%7 Yݙ"=!::q̛vRWV)>N,5{غ}w }\ B`G5 ](8sBkG?wL[ /;ϡ}Z3*Sm􍊛j̊Sa"f\Kpwxzo9 VUa$={S!Yn^əiwTFruC[ZsP/2T{\U;\YGڴ[mzGqZHrŌL_Z }y`S[2 %#4af`GldR. ̠pZS(D_B zP: ak_Oַdnld|<͙֏N0_MK]xiIaG2K3Q hZC d͡U""AwHN PLA`\Pڝ*JI28?##9E5H7 &Udz X:3[ll8`][_fLft.q,9e(?el}kÃryڌ״d2"έ$7P# !-1Nff$~VBPdXmd>5-t&w٢Uf/&\u?Qrb{2vByH1%vק5jp,i;+Tj V22઼WPɑ?OQȓ8w𕙄^ݰ:.1d#(gYz/ _IKB?b)u 7b)%Mƞɿ`F8 輊`=Dʋ 9:;P.6?5}Rm37hFz@ʑ!qgJ7D$mjvsqu^H!0RxZw)>ԂENbjF%*~-'~-ARٜM|<%ϧPxjKOl, xxhKO?Q"۱~a!Q-#ٵPeH)*# ꡬv?%c>Ox 1euOYr'OSRa^[‚dϖ#N /V;$]NYԇLS2eN#NIyHC >$᭏+ 6>|Mm<$Y~>]3=$U6!i‡dCOI!dyH=}$;M^ +Cፏ$.>t'lIQ$A*@4d(ﳛ>kfHx7!BωP1C2 .׾Hk_}$Y $ӝpGҜ d_ q<$ޏ|HISOT"LHtm!Iw-)w- W@H+}$ئ}ݧ393#Iq>GRJ!F%`G=% II>ztZN އGZّOIJN #vI}ڧ [/E}c(Nc>5H2 s 5$X)HsHx!/ lOAyytz[}p򑌗NΙ眉{H 9gl;C2_U/sqwDp{H a q @)/L~=S_hILhC2_y圆k=j!$DVY 1y!/A!-ƶυ<l锼!.;uKK!d*3u#!Bl%xnSܤo81NAS!/|Ls"p3R^Jh[='T&>$0[;ƈ+!ynD%.%o؉.;^NP ^ UDt7R'@D䌟ހ'f>ىV_F<$FL8g&C.67vC0puC_H˥_I} Tz}ix#npOx®[iZ 3]sxK ]3RFS'PuS'5~ Ư~Jw7mT O m<7m DىD!yo?@?G07x'oD䍿FstJyE0B$#Xވz`$ A}H 0@o/|y7{`:?;Q+ `B7&}۠_$80Ns!'ϙI?y=g3 sx+DοwFΕ[!Z=9y;Wr{m>Nt$iz-'OA}+hgl3@$Oy| q3`s& qO0OT2)cYvB4`cSz!ROAׇlI{)2ND& 2!qBC 0TSB&u~\<;Q L뜉N|pH'z sI}91N|`sx q䧠T|z慸|sys|z.`NOh։BA>)x!%o/$Z4PΙ/ vkG9OOt"<= /'?/<= ʯsg} O qo=:B bNI99BS i}㔤#@) <POxJܸD䔟#x! pONy;17H'&@ѩ`sVy90 aU~bnO+^!7TAIy! \NDtηNt'dvsaX~-OO b0x39y9]=%[`p au]~ OdB`D[`@ى00?u uaOua~gsB`s,r>O s0uFݠs&$o /3O A4?OD`/4?o%<,/4?17'&CZ2 A5?OܠD5^~\SQߐ\s-7V:%oȍ:h9 ]h.9/8$o͋㔼!7H'&' I>?Gp*#<@<@D`S0^`7#ܠ3FЉ??9[ O;r}NxNxTkj+o /??l :`Dyt OArj<%??S ^ܠ~3ЉB?PIC?o K!rt^ϏwfIT?$oȭ􇠽PAC/gސ!7(A'@|7 :9.AtH+SL7V1C0_5~N'LZtG'PD %N N 1@:uBesC^ PNb<') PNksstPNz;'}j7FS)X.zHp!x疸t!/J9g]:@ESsHޠnI{! NᢏOI^N1t!ynΏ7fy5*~B x㉺}!y9㍺qy Z DJ31['p.utB1ߨ׋˻9^ЂNЙЉq0J3l3]'#&}**2O|[=aOmO-y>ukOm{|?%ϧ^=z񏫜T`z!*'!kzWN>+'}h% YԖOwm.S֮i%C;NiOtjͪ罱I&PVXǭ=YQ[Q՞UP[b FݳCK(Zk>.i}qM$R:iߋ)$JRXض~w/VUªzL.thCbm@zGLU}p0ﵙܴXLrDpX-F<<ὄWM^IL{.$FQ61q iP2ݕ6p,]9ɛ4agC@MK.g,\au”)G)4ۧ*$qV `e<K}vtDYy/gC{LPZPe+F*>)#*h|% ԓJ<8:ǢJ(Gv1$ڏ]6l.Z<1l ajǺkk+4 ^q;&ս8.R"o ^Ah\m[]KN-y$܌)'a 9x ְr0>:Z9~VЉjG&ng6%@01xOŷaEIۮ*f*-+L 2663H*s0 Ļ?"K@endstream endobj 320 0 obj << /Filter /FlateDecode /Length 1982 >> stream xYio.G-q ! "-4(ٲXcnݢ;mgd $ y7pfK1Ot1xÓblvXX)=b8 Q1tbh-2b+?fD6{Q*= ^//_ݪ#UEBR idZȪ4Nj0\Ulrri΍׵8CiPQKZxRpncúyǖ(9 EB ء=j%}H)YZoS° r^)Ӛ֚ 9vﭕ$S`c!;q!xfϣ> ªqD?|^i'4 B!QhmP)SQI+8\7TYJdF™[5)SJ\4+=AHVBT=w AbPկ~>Ggx3\]FhN#`͊pIڈR$W:X: 1ʶN\Kvr#J\$c=;2:̥8*rl!=,ԢDL+P[qcen،(ZFEB)ȑ)`le%O5 FsjIt򵒪V eE@ &3IfB;iXx,FNXNrE!,Ne ZUsXJkJ q{zĦcު '6 ʎb-Db@vF%WfƬ*vEWݖD}I$']GHqdD!cǽ`-;m*$$yǽ9sS^!Aw}jY ^g-q5u2/pUvlZ6{]wxvFVTBNqvPF^:Ga=Dꓖڵ U1BBrYƾgr >v^>ڧ2gws\\inS8YÈ~p*2o!̩]Urg | 7_tW2X"$3%'$vGYkH7lTZ;zh|J5!wuu*y1F}B8+c[R~/HYJ6H |"$#Ӷe{zAH,;|HڊYh WnL7dB$E@ߛ,udn{J*}tt6~_z ?{W:O{PcDV csyd7#d%Rq ]L;~!wze1Fϳ{ LTuu}KTWugn<6}qG;s_Q^~6dLawL.̳9@Vԧ&8 [j0ܕ+- GOǃoϟendstream endobj 321 0 obj << /Filter /FlateDecode /Length 23140 >> stream xɲmIr6ϯxÛfʫj($3JU&H JD*Q$RW瞗U0$`4w}|oC?7Ͽq(9ۯ}ks6>OoX>M3N>~O:g_?{[o)3+Rgh|9Ոoco#3 k hz_ֈ1%?=?~;?ǘ5/Vԓk>gFEm|ǟbsv_~Yh\.5&y%/[ӛ·γX[h_~y>g66\8goo_0?3bQ~\O8QO8㳆 YZ>9(fY]sNKEXc0>Cy0erk&}nh ̈Z6>?('E^F(^|>%j_RZ (7}s~(Jї{-R]8u@z~wח6PjBs.E)|(u0IXYIZ^i{`&i& RS{EW1ԡ/wLlb1kջFq(MWaW̓۔Ţρ1u(5ñ?PVU~wfv0fԷ9(NI36CM>ֲج>e/@~z:R]3jMI>B1w2,c:Ʀl,X^U/~>.]/?A%R,^^ɇbdPձpON{G-,vR_8ŤtX0^:@b(]&'o߬~zc)Kֻ9?IB1&k ^v 9EYd]L)e/U%~{?wL^SuRHtJ%(d]S>8ʿP5灣J4AӧSU~)"Q~GR DI.t{ 2gâth"I%&&gHY8Y5G-\]轑wMryN;Nd{Wq5fA@GQB\'3Z(xi)Kg)d7v:[=S$x%LeQ)fNƽ 8a퓫[,P׌Y{Lx1 8o5Y[q\*:WRڸFQd$iy`%%%JKߏX0'Jlˠ^ h)2QaPz.08)IF Wz٫^?:0X4Jn ̀'Ȁoƫ7->i݄Jﮯ)ҝ_oG H3 2(A%Q <%Rvx̤$O0P,Kj&SsoJP[NO,4OzyT1 gJ^T s Q** RJ]G,)b\c+ˬSJbc,ZL*)+% W_ZFt(SfQ [.mA˭Zd Jm,j9g 4w, {{) `!%)dNLKY Zʧ)Z{4g,j{Hf0]s ˝em߲RĻi3bf7+(xmG߮Py( cH3J$mT ewa85M<6vYҬ>22~2c80" _5g J.;0oj3MWϲ(udAŝ:Lgi PgNX.ӯH?Pj”Ew/Tc |\ јjyF(\/,xp@)ghB//SS,9VO+]wi%Y8h73;c.ʵK󞂍 1*f(@z;g]ޓX+„l9<3K!-52-x* Pϐ;K\wmJ絗BS19jo5U2S'CJ/SYVxBN J˥bgW6i_tPՙs,1&U<6SJz779:𰱠z1Ygj<\CB~cEEIix!dVk?H*C gWm_ K(zb=y#BfK,ާ(RۖKRVW?Aljie@cq;$ȹ^*UkXpAÂ~35R,z12A1ujWI/lK+7I.4tkPJ>p5xiۑUS &<۶Қ+ Dtޥ\v2UR3/@Dge^>C xԹhٖȖyC%֛׵Y_6V=Sw!\$5^cQ/KRKM#L , WAFMv`=9D}DP !Ĉk &F  cZ7t&9W^/U23!ȈԺ 6j'S>|w{h1mx7_6b2nCQ3lox X![A!D!5AiakL:${G:>[l.*1&k}B^A%NKʶ YmT…Bϙ I*aR.8XzC_!Fٰq+ E9W3 \%?2 N'G | Xuv$ ($|n.\ )ʹGi~^;'|̶R.xdw+lyN|q}:ʷYz5NFnGKCS⍫-t9Hj.1R\XhX˟R2nZІ  r0k?SkMOq_4[lfk)"Z1D/eRp/+[U27."o/vQBM.)J|)pٔarEo{%:yO7X `Fz )Г]6;S 9lv'lz L>κ:cCB[Օr9On6#vSgwkCr ,nj)A63p֏MkL 2zݴFb͇[12gra7)PPJT)#&bl29,[Xo" ? u1B2L9sus)L_m9ƛqh8׾mIy˧3\y1Ğ2 4%y:F4?Vs<]ZeC$tyEl_Mld4 ыs֗nlnxKQ[+# Mꄫ\8Tp(EO L"N0&Zf[?z,(PC98pc=`"s7 `" 8> A2m7xG*ʐpE.}ܥHTׯ>{#R閃|tRlqW8m!0W+ZtɖZPՃpG))6CB`DU\7;-WgV4uΊ{WCӀ$Ji)#B]~,3evNUEcbjOtgv@`?3iKʴ@L^ =.5-K̷i+9ҤbݏDg8׊A{(v.Hy|65I9jkqi ͧ$UۘA1!-ð OVF(K_;4PYJzj 1։BȢ0&wLQx*ö2u["$fm$Ȓ׺Ј:/d9EiD]-a#[5eYnXJ0\xT[9*ƥٌz1},]dP9GJөʀ`en9݁ޟʲl%LI鲜ᰢ0Zlȑwm},X^̰}ah s+|Lʔ%Yxxʩ$iC,_3DЌi\%Yg j8*ЭZWQcW=KRG/eBRQ0aAɄ!|;ߡ Ԫg7,ѕ-a& pR(!*U3S&Y?, ÉLgYو5s0Fl~ed[ q$Yn)#:62U&HYImnSffvu[mSTSZ졘.s.dI=0,fGy|rݐb eWNQo@[ g庍ERo\vԉ$[1z,QGqo;Y3/p"w[i5āyMXκ%ל5$ 11..JVv߆BEДg\]fvM毿k`{OscE ؝,JR6 #R(2~qTg6uy RMR* ۵0 l-(Gӕ3 ;с['+r&?TZf1@Oxx-z =.qs@!p1*2Vy>Bރ9<0yB"q!RQ%^C\8(e{ESE(h vV9u[ c/0uh@ U\IGlsdPuEx29. ӅCKmλLL+-JS5H q؏Q~2,tx$m%>G?#۹@+Og^P b.KT SZĸG =,w1nt&"hbbw\o5& oBW.pD {qW3[B!ΛKeɚ#^tIK"PL珲UOWW L?Ln#@qWEJfY}%ͣ+16]Us)zb [u=5V7L2PF?VX E3 PtO]bs@QL]@eLi3>s>ċ⁂*E!}dƅ:,Mj(:snM~JafLg\•{z@N۾c+\]!yc Ekk-z?ڿdŔ B*+l htŁPzs wmbBtl])PTlH G\|Y/=ۼr,iaʅ1 =lc[x̧)&u3fJW/ )德@?ޯ(?eݔey_ڭ[h؟Q9}\By)B暗ti7oEČGPm{Ȗ YS 9_错|=f:j@ /(qJ qAW js]ᮼ G*HšHD5c"ƥ v,)P׃gP/gL}#CA7syi=/3RhUg˵YP߬LSfvGO#hȕ@Uj'gλH7bE 5}3.ۺ|5JK70R#SUH 0^;H ǟ1l9SFǮ@t=e"6&CR0ZQ|7!/e߆(݈گK?n' ?a;Pn୭(]P|?A#_)+^R&2a*~}/)/Nwݿ9@ &b6`>~L_O˧OȲ QW? '+C*&v~a3.b@Qm@P(o*JB+"1稃ǿbiz4) S'1ޡ Jg~;x)zC^"P[SI؀.諡W%sm,cD%B0_WIR\ FzOvwϻ!D$aHqI^")#I؀]" M1C<#Z&_'MPzP }j_cEB>[7X"T AcCmHX8IRjF9L˹[j1T# 0Jh.N" %bRO(}Ha2e%A@̭&N &A0fLp9HoSEBsނ-CR{"!<&࿅)S1lY8#,IЀ&53tl*HbnK"@2 @ q3 @,Yى!])/$D.Kl?hB@$^<̣7qGDt2*"(إFIѐP" ! 9)jf Nl &`\!*/lٹ$ 4lٸ')ha`г.MЀb1pTep+V6y73% ]6IbȀ"dQdҾҎ,5@"~a& T.zxK2`)ڽMqOs%b2`~%bv{IĀJt>i..`^,ۉ oSNUg04,q^C[ LNTziP.NvmV#M~VRMIvSqQ+^W6ʚBrewbT(` xH6!H6TSR)`(IvOտ%rGQOEOLJ!1꤉ǡDa;Pt?b  DjL5E咪c_ q-H1-IfV#ff%zIQ)G7N0ƃS#e$n-aqop"pJ.\ ٰ`j)2|m?Y2$0h1Τ$ޫtUIo_MI yɞ{ aܒqܵB.yՇJɤ'ǴyNc2fB. 9¼3Se^$$ϼ1\F07JY%i-00JuѰP_-.h "PfeԴMʥ:b9)\b^})GkNddjx}6qpZe]B&8IX I.6 V@zkYVE8J)~) J> Lda?L~MHvƶKľ] ݘI+XE"rQRAjj sg5څBMăa=M0X҂B\arJN͍j>Rh!i>%T'"2 t")ưL"g# MGɉB"x 8:96$Zh€hߵM`Y[yaA\J(Akx8r>CP(pt{&%)}i :[<=!27L@g/\>j''wP~R: I[2>1[.u8F HY0ҹf|RlA"^?қ(@nCݼOVB)zD+>.m5DZ[t) Bzj[ؠV@w?F)P')+eJ%YSzRLP&`n]SN)fHJ&z8Q9*%p=FM<%#8.ORDT+ǻ((XhHFd SH_i# P<4MQ 0Y&G^ $VI&^L*&x{SY%G ŹdMyLl)usAWb U^^Br"!aCbr6K.%Ы[ijc)IG&:DD gxӀ~qˈx)s"EK.T]DbжD] < 2hl FRLn0$ "ʸ;*. _gXA0C0+1\ ?yѻ.h;ZΗ\c&/ 3xywtḇb5pY}w?ʻ5f*;5Sp0hpXJggs5`o;|aw,Rl6p͎>jB2<˾gVolN|K94I@@`^-&T /2l;q[-X]5t1G1ʹ% VFr?vC;tpH<ʹGA@Уo,t`.pЧC0tZ9Y'CwZCS5:181x|i^w$uщ!`P{#%そS ucct"4@ FS7iw10rc~E [APnD%[B v`#@tPکjIKxY^&OtSR%0tt=@_2EwŰTlhsiCwE8oQZ]X&ZiIa%|oRCǁ;YnC=aNItP)jAn]Ηډ\r题:4cG(߂F+xH=v;/<ū*&^W V# *)ji8S33V})F˰}Q̸F 7A#q9NLEvkdd:`|OQWʷ|=tL*;^4 t A.p82!/fj8<P58ĠnyasF:ۉvY'dJ::=lvə%b! b31$5NP*cඥ%c=Ǩ0ePUoOuJ-9iC"&]Չ0tW4'dW ckW ܒhٶ6Pdx5 U/3Ԁ2 $@k[޳Љ9b 1^;~lk$cFMqj 9sig _ʷEs@ ޶]"`v/S,[=%貸k̀+D X {i-t ,.VG֔!SBTfvٗ'jean_0(0)mg]%\z5&R"2HeCUjl"l@^#貼P*=܀slo R}7B. ۉ@JZ6Fw(=nɲ Oa0f]t!lzˠw((o'lT4`hWeu  csJ~9"WSo0H/Fn'v;FR䮤Kwt1+B*)^ڻv;B" ^BՌ0aW~(خB8CP_}n{N6bg4KX \i9Cc5ۺ֌ʃ 3G3b9r.r務3.B`)I؏59Mro_S˿Rz[\+筫\ $ʘN$.Wq^I\2W YHI"&\ Љ$@v" ĻCs r_^ [#zrX) Ku%Zu/ߜ,wЙK+s !~.l@]g:!B^d[w6~X/|Q)ԲEd !؉Kq@`G@GLJ." Wrޕ(gH!h7)ju-rX ykæv;.qWYc-8 ۛ @JXv~)}̶tgB'xմ[D;>3e<tu^ىt{GAul #>`G[y({E/(2#ňG4=C8_7Tv(⺣NWwSs.횽*2U;{Ҹ-y?z9AT䣌 B^ ȄS\g'C!3N՟)&iJ-H P 2 7Bf.SP[AcȽٓo{8[j3+AAJ.[Z䥸vSީTn[)B9%Eec8 ˼/]G?%k;P+}@Hw/.Fl){mGϲE&_lq1Ur>Su_LnFݨ_|I!W{'1esWl Q=b2Q?})ߍbp{ew6KkgJ"J @T*49_C%Z? qCoɥ|F}}/)ʧXS@IJAIE %ub /wݶ ,wtR x.)e7=* RWc70_3eI׈Q |=7H?B KN6EыQ̿BM]'|`TгE<: cwck,dnQtx˘IoC47[<t2)oH!65+o Г' vXj%& ` 4eDo6 cch3 3df MN4ʁjCY45b,^^b\VsMaHV)x[?ASMD274N9c5ZfE{8[ݑP [yꪒus3t4BAo G8e`tn5),OCo.`+MScZ&? @6QOuC n ž9$"[]@(`P Nʽ ׁnnn5rl(X`B/V*mW{:o}Mq~NfN4y5$U>Ob$t`aje <q}vM (dǰC? :< lR/auUD )bD'Y[(ؐ?\4dҠZXA7A*nn䓙LQn?zycB²"&(á6tl"=$f4p ɣ3BMPlOۃ.y{aCix%f 1KC!7bGJqjC o9 ElBӄdxh2W&}A>PֱuͲ(uzrgO"f@ ݚ$R=~ at#I(JMgr% xuD0[fʆOk),`2bHZvZ*oev(0޼9H_Z &&)X6vW ]'I(EIp hm qYCM-2Kk2Жc /)h9td3+̎a < ۄam$/.&$!S赐"¹7^FOVC昴iIMqo ])JH<:mĘlvY؆\L֦o2 u70yomG<3os#&~jܜ]17Iv4z{pk\Q:Мy;nǍi _Prt i' Pwsλ&&tiSɆ M/ >GrhA3o:.u`6̼ 3A$lIW.f2צ73]Ս8a݈ F57nrw.]+ju\3K\9G:nI J B,xSԌR&bh$ZAT|ڝnZO89z1]j܄861]@$67Nl|')me7n=I(#TL@tT6'wxY--` 'aYX 'hcM{^'m, 4@!Sc#f"Y~ ^71S?x [QZ})KW%51D.[~!L]Qhe7¾f?6ǿA5QõsDFo 3CH0B T|Ln}M:{ }^[G85jN@{R`B'`||h#&ӭtQkIqK[ʁg{ PkHA)@ n\v%&(@UСM@&Hgz8jW3 $.u$a]P7IpK$ }j ;w'{*YDwEq DJB(rn{ g O*㣠^f#UP&GXzQ&Vk06!k7`x [ &!ra6!k ْ~ {Wl6PlDلh;⮥&utvcRrڄVcRDruhɪ0M:Q 1ܝK@61>5VS.Bu._.>73t 1.%! IkF]؈YdR7a89*Y!^NFMR\? 冀T6R?g1LCY\Tں&)Q @ mRIJ|V_2DɁ mQkجNBVh>IJM9j~ǜGA>LoBʸ_4(Y- `l{mp97m"&?(y"8Cqx !ʄf?:vr6ܴԈ Bɴnm9<2/j̺d|r䴍+. R܈ l:_z`/7XSN@;zS2Dڜrw2: &(08Ettk?<"TڃkF}[r#ڤnK6#"t66fG(= ʺ|lɋei;~]p2G*{)6O*VwmﻠVpm{Que#I.jl%ud ْ(lt;@6qYrҗEKKl2f2.b_cjAfMMM udwvslbz:Bd$斫&;݆ 0x pWE` XHb5AME ^*Gw+QN F&:aɠo'^MT*xԠ_be2:$ؠ kϫ3Hϵ|`e^EKy8X>茷<@$f ^W+u]ovC/VYҭ)m'Iʱ!h\-=e 3(xȣ &iPb()+GomNҞpG!`):FT8J,yEqHMWMQBt={8 պEqngrdHơz#]};?%eޙT ݁!ÿR%h=,y)pv!nbLsW@}.6Q7|^h p &@xWDLaݱa BWsnRs"{ n WtA7"rARw,Q1_J* ,ʠ#yݢ##^.%/!7ʁCd9\_ټ^Jxtu^NV5az4!X&I!*=K\'c%{APv9ylF%UuIvTn6s WJ, TJ:gJHLY6aw)l9 .z`eY^w.6_׃,nMSrCLlf62 @ٜBZP=֥^2ltlR嶎%fHld fΚN+a6CZkJgIeS#BR-RikUNZClr-͑ 0l2Ƒjd{Q&qW yKFˆ`NessPn*)OMF޼-Ypj-pYMgsHE(vj3Pօ ;6IqQiQzZ̔~h1[e;6wf/3쿔tֹkg[OQ#(Zjs]c5y16=U9\X EJ#6\cykOXm#.rfTcפ{AV |U+\Dd/aW"qWKdsm'n[0 w I4PPZ) -}E.cN Qe4%&(ݍv )1663\ YBL2aK-75h[sKI{qB(E?bsgAߥO}K!BGCςd2_/G( v  ;f*ߦs)!vt߆\k/>B$NcPa'}aҼeLasވ?86|bDkoz})ߍF?U Fg_ȇ4^ oUiw?YDUfs׈@EM[8^BSgE?__G]' 9߽{ȞciW񧲖է}MҔ?uoHՏȸ\ݏg>dV| ץ=)]?:r>oo_>n`=7?&gE*Kxpx,]߈x7ſqx=6zV`}NYs^^o7?}5#f96z^ WƳǟ} o'D^k'd}ϫ])$Q_k9<L˔y&RWS2"i}~J>mL;ӟ,u8w}~C V5~7~#<\Ŝ'>~P_q+> mѵx;0d:~" Lwoҗ97w{QŃ_|ot`NsQk9ZI g/,s Cw[K-gl#V$܏iisbޖZC D]B=^1oyƾg Ȇݮw{?GG<~Yݓwǐ$.sj~dSG'Fndfm wK?Sendstream endobj 322 0 obj << /Filter /FlateDecode /Length 3155 >> stream xkoKfޏI0\[i?Apˮu:[')Qrfv; ,zp&ga_r_?ϣ/?[_{drÄa"ӽUo˽F?r"†W͋\A⏇Iغ"-Z챟ϔoTY͔kmPy7UBfqv!l49K hE1R/B֥!f5՜#f%`MqÁF\k蛿ςneL&4o\%M0 ܔU_h.{՜%b 7$C~ "!!I9Yoy1DȥU,HQz`4{B$1"l ,. F<]T^Re]ĪV+ۚ`[DмUE7@.FgL[t\]^ ƳODF .W|=E 5vP^v_}bϳzUmG)|Sz6} ?NوX0`k/" M*ա4OZSUtU/#B.5 x fRd?QvnR'eи4 rUֶ4Ul/4lTuծ1_ݥj. /(6`,20FS2njQ3Ԅnݬqk9 ,*p=QpV)46ɺ֤A=ÿG!#JY|f4A{SOw]MW0(F2 N(($JdV"u4lɓtP *CQ c2 kF8e|}p( 9$o}q8gv+`q,F7hQUF  $-ӢK:TU-6f-KP JzMSDköj:!_;޲tc`5ƺYp0I1 45¶rѩ9hR+6-^" ّs)dMԖLUT*B!vnSZ.FsYaF]U [ Z mJ'Y:J@<(K212NdEX4hȝc@QhztEAf-$o"E D+#n 96iViH' ]8fetbpM%L,[_NQ:Zp;#[W%Ri8Ye7tr+/)PFf Hrq$B5w[u+kYLZ15.z}96{Us ^j%|v,7y#,*.<.nbdΚ<H{Hru}>5çPU&@rUMwNi꠬bs#+4oNSi iA2 ÅKaήMD~^xNG[;?lT[ PVӻiǻwI'/тI),}CⓥL5Qڲu6ϙLYȁG韭w:zWפd|\Pbj:/͗F8>kxrc?D}Y:ɱ[V6z0oJgz7: m/gsiLKٺffM%fϠeR-Y3ɠSJ4pEmmw+Awv.wi&,{DC*h?sɗ tLk` KOXj.A|r^ $ >ldDMޯ1q]}j]<>P+V?pwKgCz"ġ+@!O e#e <(:9X)/kQ_WS4bC6svvȓziIs1˭m+ rEg%{Ua\J-k=(In)9/GwBnu#U<&]oKպ唼 6y7W,.)I fEy? l%8b>fdٹ=Z? rN(BڴyOIz/b8$Ԍ|sCX[󤐾O,\!ύ69;ֳC.PdS"V(4\#s+<?"D|K{GQhPMiPNȦA9@VŎ#2͓ 쪤&rgA;ݏ,0:NzJjJAÂ]U) Vz$A/cUqkXbc6hLiPOi|YYvMiS5u@tw ݱMg,XiNiCDAE D+^"H}x$F);܅a[CJ7]nSSU$ƅ^]+%r@E 9쪟:aŞ'DӗEߓ'\ ˫#P'ucְm7{;]'t_ozFw|8#OҳuU~WYN_ v-!ST2WO?֒v=n#d[zD{Kqs"geC'?bW/Ȋ%d.[+d]Vŷ{?}fendstream endobj 323 0 obj << /Filter /FlateDecode /Length 2041 >> stream xZr}G#U*a5K*~8.?)R\$|}zf;g ְ}7-_z1Zf҈F(N^GPP[i:j;,vtTU4*j>muFAUKڇr4Zd]uj5+_ dRA[WݒNiUM/IicDVS=K9$)%9|C:(GNiXF]]HDrNNb^eR1:aoVnIӦQivˤ!b0FA iq m0JU Jp7md ] ʨLIzm)GR'J䟉=Ҡcm\R}U"VwE0-yjˊ /s"_ƕǕxd~^q^wɵnعkyVt)e(|фW5-m5XX5m65P]@h48-~3F2 pʒVݫ=*~{68 n=c9T(Gh7:֞&mKz]-vE-cU:,izy%f豾јBd9Z f\ ~cyRQ{-2S&tyx}zcn[lwZm5!FKKڜsKOS \Zѵ y(@q|tv^>! hO,, )]N;ɟMn,r66ॣj+P&-t 'YC,]4tĪji$I_hg ŲtՄ)dhɐA) Ne†O;-MlACK4bj0aq4iםu_ci#,\S}^ GNpgwsx͂(7*I5'}BjMgnm7 ͧ&8m?Cbʌ2EcΦOe]4SEevSmVP0]LF~y;H߇mEfFiߓ",G?ѿˢ]K-E@۽2N{ƝvEu ,Hb:+iX<90Zv`y޻/w"\U.Y@Ʌx if7BQ Zi2;endstream endobj 324 0 obj << /Filter /FlateDecode /Length 2657 >> stream xn# fdq#>Jv629p*H(Z3]3S$E"!@*]5q>a']:lr>_x$YN +gOfi+8>6^ !{H(ҖܩU ם)'`^pVB'94 (i;I;W\Q|Z#1$=+T7 )0k&| 0!DK]e_# Wf{K٣7r9`\*}(/Dv{,;R5$#xSSrɠ²h}X^` mkЁĈV nb$/{#37󐮫x¾9T~.8|*ӯDl@4^jBlR\z8_h嗼<%WWqnokWG^jN eX7b7eI`HYvG4VG7|+H>H2;Ebܨ1 !R2-7sU%ǂh^fr8o7OKP}U qO>| 3U{E7\X?*z+e:QxA3yЂDhH dheK9+3@g醩$rύ 6+2 jHQsS@ r jMw1dp'}M:L4ޖ'9-G`>[81'endstream endobj 325 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 947 >> stream x_L[e8Zqspz&fItt"\,ph neek tVK#)2tKyqF4 k{奐D(ʬ?tՃa/%䉄|1jw#=!|.v`S6<u_m4Zg [ϖUzάmUz*>tتx;[XySEIf+V-FEMk™\4qcoF,ϙzcg6 v-6N t^F5ew" :~ZDnOBLѕv'ML(x^uEHNc8 W\,\݅ ,PLIů=h"17* uʎ&eÕ1'p}P&96bMeEtm3+=7zEDqLv0.,3jѮ14׭7^]eV#w ӆy1y =&ed#qo牅;zOӮV[B=AqT"Qͤfľa1ѩ4V\ˆOLz حuN:4ddž+\Vm]Zz)ޒnʽavC{wh _xFRxC* 4KqEXi,A,1XIncv3a-hxU?tCn[4 ZCS0SgZ|pCDu1n̬)U*Ob}ܾXhaimn}Ziߎ]Z$> /W [ 1 3 1 ] /Info 3 0 R /Root 2 0 R /Size 327 /ID [] >> stream xcb&F~0 $8JP?л@6((=< M#Ϡ,ڍMgн*$RRI R%X'd@$;?˲H@Qf:&ׂMerA$w X) gyNz@$ XD VH2i DFHU)pdB[B,l3Q"߀LHm6Y@$gشI R.&/X;GHezis"` ") options(width=70) ################################################### ### code chunk number 2: the_Rmodel ################################################### model <- function(t, Y, parameters) { with (as.list(parameters),{ dy1 = -k1*Y[1] + k2*Y[2]*Y[3] dy3 = k3*Y[2]*Y[2] dy2 = -dy1 - dy3 list(c(dy1, dy2, dy3)) }) } ################################################### ### code chunk number 3: Jacobian_in_R ################################################### jac <- function (t, Y, parameters) { with (as.list(parameters),{ PD[1,1] <- -k1 PD[1,2] <- k2*Y[3] PD[1,3] <- k2*Y[2] PD[2,1] <- k1 PD[2,3] <- -PD[1,3] PD[3,2] <- k3*Y[2] PD[2,2] <- -PD[1,2] - PD[3,2] return(PD) }) } ################################################### ### code chunk number 4: Run_Rmodel ################################################### parms <- c(k1 = 0.04, k2 = 1e4, k3=3e7) Y <- c(1.0, 0.0, 0.0) times <- c(0, 0.4*10^(0:11)) PD <- matrix(nrow = 3, ncol = 3, data = 0) out <- ode(Y, times, model, parms = parms, jacfunc = jac) ################################################### ### code chunk number 5: compile_DLLmodel_F (eval = FALSE) ################################################### ## system("R CMD SHLIB mymod.f") ################################################### ### code chunk number 6: compile_DLLmodel_C (eval = FALSE) ################################################### ## system("R CMD SHLIB mymod.c") ################################################### ### code chunk number 7: compiledCode.Rnw:725-767 ################################################### caraxisfun <- function(t, y, parms) { with(as.list(c(y, parms)), { yb <- r * sin(w * t) xb <- sqrt(L * L - yb * yb) Ll <- sqrt(xl^2 + yl^2) Lr <- sqrt((xr - xb)^2 + (yr - yb)^2) dxl <- ul; dyl <- vl; dxr <- ur; dyr <- vr dul <- (L0-Ll) * xl/Ll + 2 * lam2 * (xl-xr) + lam1*xb dvl <- (L0-Ll) * yl/Ll + 2 * lam2 * (yl-yr) + lam1*yb - k * g dur <- (L0-Lr) * (xr-xb)/Lr - 2 * lam2 * (xl-xr) dvr <- (L0-Lr) * (yr-yb)/Lr - 2 * lam2 * (yl-yr) - k * g c1 <- xb * xl + yb * yl c2 <- (xl - xr)^2 + (yl - yr)^2 - L * L list(c(dxl, dyl, dxr, dyr, dul, dvl, dur, dvr, c1, c2)) }) } eps <- 0.01; M <- 10; k <- M * eps^2/2; L <- 1; L0 <- 0.5; r <- 0.1; w <- 10; g <- 1 parameter <- c(eps = eps, M = M, k = k, L = L, L0 = L0, r = r, w = w, g = g) yini <- c(xl = 0, yl = L0, xr = L, yr = L0, ul = -L0/L, vl = 0, ur = -L0/L, vr = 0, lam1 = 0, lam2 = 0) # the mass matrix Mass <- diag(nrow = 10, 1) Mass[5,5] <- Mass[6,6] <- Mass[7,7] <- Mass[8,8] <- M * eps * eps/2 Mass[9,9] <- Mass[10,10] <- 0 Mass # index of the variables: 4 of index 1, 4 of index 2, 2 of index 3 index <- c(4, 4, 2) times <- seq(0, 3, by = 0.01) out <- radau(y = yini, mass = Mass, times = times, func = caraxisfun, parms = parameter, nind = index) ################################################### ### code chunk number 8: caraxis ################################################### plot(out, which = 1:4, type = "l", lwd = 2) ################################################### ### code chunk number 9: figcaraxis ################################################### plot(out, which = 1:4, type = "l", lwd = 2) ################################################### ### code chunk number 10: compiledCode.Rnw:950-979 ################################################### ## the model, 5 state variables f1 <- function (t, y, parms) { ydot <- vector(len = 5) ydot[1] <- 0.1*y[1] -0.2*y[2] ydot[2] <- -0.3*y[1] +0.1*y[2] -0.2*y[3] ydot[3] <- -0.3*y[2] +0.1*y[3] -0.2*y[4] ydot[4] <- -0.3*y[3] +0.1*y[4] -0.2*y[5] ydot[5] <- -0.3*y[4] +0.1*y[5] return(list(ydot)) } ## the Jacobian, written in banded form bandjac <- function (t, y, parms) { jac <- matrix(nrow = 3, ncol = 5, byrow = TRUE, data = c( 0 , -0.2, -0.2, -0.2, -0.2, 0.1, 0.1, 0.1, 0.1, 0.1, -0.3, -0.3, -0.3, -0.3, 0)) return(jac) } ## initial conditions and output times yini <- 1:5 times <- 1:20 ## stiff method, user-generated banded Jacobian out <- lsode(yini, times, f1, parms = 0, jactype = "bandusr", jacfunc = bandjac, bandup = 1, banddown = 1) ################################################### ### code chunk number 11: compiledCode.Rnw:1062-1073 ################################################### ## Parameter values and initial conditions Parms <- c(0.182, 4.0, 4.0, 0.08, 0.04, 0.74, 0.05, 0.15, 0.32, 16.17, 281.48, 13.3, 16.17, 5.487, 153.8, 0.04321671, 0.4027255, 1000, 0.02, 1.0, 3.8) yini <- c( AI=21, AAM=0, AT=0, AF=0, AL=0, CLT=0, AM=0 ) ## the rate of change DLLfunc(y = yini, dllname = "deSolve", func = "derivsccl4", initfunc = "initccl4", parms = Parms, times = 1, nout = 3, outnames = c("DOSE", "MASS", "CP") ) ################################################### ### code chunk number 12: compiledCode.Rnw:1084-1100 ################################################### pars <- c(K = 1, ka = 1e6, r = 1) ## Initial conc; D is in equilibrium with A,B y <- c(A = 2, B = 3, D = 2*3/pars["K"]) ## Initial rate of change dy <- c(dA = 0, dB = 0, dD = 0) ## production increases with time prod <- matrix(nc=2,data=c(seq(0,100,by=10),seq(0.1,0.5,len=11))) DLLres(y=y,dy=dy,times=5,res="chemres", dllname="deSolve", initfunc="initparms", initforc="initforcs", parms=pars, forcings=prod, nout=2, outnames=c("CONC","Prod")) ################################################### ### code chunk number 13: compiledCode.Rnw:1268-1276 ################################################### Flux <- matrix(ncol=2,byrow=TRUE,data=c( 1, 0.654, 11, 0.167, 21, 0.060, 41, 0.070, 73,0.277, 83,0.186, 93,0.140,103, 0.255, 113, 0.231,123, 0.309,133,1.127,143,1.923, 153,1.091,163,1.001, 173, 1.691,183, 1.404,194,1.226,204,0.767, 214, 0.893,224,0.737, 234,0.772,244, 0.726,254,0.624,264,0.439, 274,0.168,284 ,0.280, 294,0.202,304, 0.193,315,0.286,325,0.599, 335, 1.889,345, 0.996,355,0.681,365,1.135)) head(Flux) ################################################### ### code chunk number 14: compiledCode.Rnw:1281-1282 ################################################### parms <- 0.01 ################################################### ### code chunk number 15: compiledCode.Rnw:1288-1290 ################################################### meanDepo <- mean(approx(Flux[,1],Flux[,2], xout=seq(1,365,by=1))$y) Yini <- c(y=meanDepo/parms) ################################################### ### code chunk number 16: compiledCode.Rnw:1306-1313 ################################################### times <- 1:365 out <- ode(y=Yini, times, func = "scocder", parms = parms, dllname = "deSolve", initforc="scocforc", forcings=Flux, initfunc = "scocpar", nout = 2, outnames = c("Mineralisation","Depo")) head(out) ################################################### ### code chunk number 17: compiledCode.Rnw:1319-1325 ################################################### fcontrol <- list(method="constant") out2 <- ode(y=Yini, times, func = "scocder", parms = parms, dllname = "deSolve", initforc="scocforc", forcings=Flux, fcontrol=fcontrol, initfunc = "scocpar", nout = 2, outnames = c("Mineralisation","Depo")) ################################################### ### code chunk number 18: scoc ################################################### par (mfrow=c(1,2)) plot(out, which = "Depo", col="red", xlab="days", ylab="mmol C/m2/ d", main="method='linear'") lines(out[,"time"], out[,"Mineralisation"], lwd=2, col="blue") legend("topleft",lwd=1:2,col=c("red","blue"), c("Flux","Mineralisation")) plot(out, which = "Depo", col="red", xlab="days", ylab="mmol C/m2/ d", main="method='constant'") lines(out2[,"time"], out2[,"Mineralisation"], lwd=2, col="blue") ################################################### ### code chunk number 19: figscoc ################################################### par (mfrow=c(1,2)) plot(out, which = "Depo", col="red", xlab="days", ylab="mmol C/m2/ d", main="method='linear'") lines(out[,"time"], out[,"Mineralisation"], lwd=2, col="blue") legend("topleft",lwd=1:2,col=c("red","blue"), c("Flux","Mineralisation")) plot(out, which = "Depo", col="red", xlab="days", ylab="mmol C/m2/ d", main="method='constant'") lines(out2[,"time"], out2[,"Mineralisation"], lwd=2, col="blue") ################################################### ### code chunk number 20: compiledCode.Rnw:1360-1392 ################################################### SPCmod <- function(t, x, parms, input) { with(as.list(c(parms, x)), { import <- input(t) dS <- import - b*S*P + g*C # substrate dP <- c*S*P - d*C*P # producer dC <- e*P*C - f*C # consumer res <- c(dS, dP, dC) list(res, signal = import) }) } ## The parameters parms <- c(b = 0.1, c = 0.1, d = 0.1, e = 0.1, f = 0.1, g = 0.0) ## vector of timesteps times <- seq(0, 100, by=0.1) ## external signal with several rectangle impulses signal <- as.data.frame(list(times = times, import = rep(0, length(times)))) signal$import <- ifelse((trunc(signal$times) %% 2 == 0), 0, 1) sigimp <- approxfun(signal$times, signal$import, rule = 2) ## Start values for steady state xstart <- c(S = 1, P = 1, C = 1) ## Solve model print (system.time( out <- ode(y = xstart,times = times, func = SPCmod, parms, input = sigimp) )) ################################################### ### code chunk number 21: lv ################################################### plot(out) ################################################### ### code chunk number 22: figlv ################################################### plot(out) ################################################### ### code chunk number 23: compiledCode.Rnw:1511-1514 ################################################### eventdata <- data.frame(var=rep("C",10),time=seq(10,100,10),value=rep(0.5,10), method=rep("multiply",10)) eventdata ################################################### ### code chunk number 24: compiledCode.Rnw:1601-1619 ################################################### derivs <- function(t, y, parms) { with(as.list(c(y, parms)), { if (t < tau) ytau <- c(1, 1) else ytau <- lagvalue(t - tau, c(1, 2)) dN <- f * N - g * N * P dP <- e * g * ytau[1] * ytau[2] - m * P list(c(dN, dP), tau=ytau[1], tau=ytau[2]) }) } yinit <- c(N = 1, P = 1) times <- seq(0, 500) parms <- c(f = 0.1, g = 0.2, e = 0.1, m = 0.1, tau = .2) yout <- dede(y = yinit, times = times, func = derivs, parms = parms) head(yout) deSolve/inst/doc/examples/0000755000175100001440000000000013131750050015224 5ustar hornikusersdeSolve/inst/doc/examples/Schelde_FNA.R0000754000175100001440000001472112352122173017414 0ustar hornikusers################################################################################ # pH model of the Scheldt estuary # # Hofmann AF, Meysman FJR, Soetaert K, Middelburg J, 2008. # # A step-by-step procedure for pH model construction in aquatic systems # # Biogeosciences 5, 227-251 # # # # STEP 2 - FNA # # Full numerical approach - pH model written as a set of # # differential algebraic equations, solved with DAE solver daspk # # Implementation: Andreas Hofmann, Karline Soetaert - NIOZ # ################################################################################ # load parameters, dissociation constants, initial conditions, # the model transport function and function TA_estimate, to estimate alkalinity # Do make sure that this file is in the working directory (or use setwd("")) source('Schelde_pars.R') ################################################################################ # DIFFERENTIAL ALGEBRAIC EQUATIONS # ################################################################################ FNAResidual <- function (tt, state, dy, parms, scenario = "B1") { with (as.list(c(state, dy, parms)), { pH <- -log10(H*1e-6) TA <- HCO3 + 2*CO3 + NH3 - H SumCO2 <- CO2 + HCO3 + CO3 SumNH4 <- NH4 + NH3 #-------------------------- # PHYSICAL PROCESSES #-------------------------- # air-water exchange ECO2 <- KL * (CO2sat - CO2) EO2 <- KL * (O2sat - O2) ENH3 <- KL * (NH3sat - NH3) # Transport TO2 <- Transport(O2, O2_up, O2_down) TNO3 <- Transport(NO3, NO3_up, NO3_down) TTA <- Transport(TA, TA_up, TA_down) TSumCO2 <- Transport(SumCO2, SumCO2_up, SumCO2_down) TSumNH4 <- Transport(SumNH4, SumNH4_up, SumNH4_down) # Wastewater treatment plant in Brussels scenario if (scenario == "A" && tt > 365) { TOM <- Transport(OM, OM_up_A, OM_down) } else TOM <- Transport(OM, OM_up , OM_down) # Spills if (scenario == "B1" && (tt > 360 && tt < 370)) { AddNH4NO3 <- SpillNH4NO3 # NH4+NO3- - tanker addition } else AddNH4NO3 <- 0 if (scenario == "C" && (tt > 360 && tt < 370)) { AddNH3 <- SpillNH3 # NH3 - tanker input: } else AddNH3 <- 0 #-------------------------- # BIOGEOCHEMICAL PROCESSES: #-------------------------- # Oxic mineralisation ROx <- rOM * OM * (O2/(O2 + ksO2)) ROxCarbon <- ROx * C_Nratio # Nitrification RNit <- rNitri * NH4 * (O2/(O2 + ksO2)) #-------------------------- # RESIDUALS OF RATE OF CHANGES #-------------------------- # 9 unknowns (dOM,dO2,dNO3,dCO2,dHCO3,dCO3,dNH4,dNH3,dH) - 9 equations # of simple state variables ROM <- - dOM + TOM - ROx RO2 <- - dO2 + TO2 + EO2 - ROxCarbon - 2*RNit RNO3 <- - dNO3 + TNO3 + RNit + AddNH4NO3 # of summed quantities RSumCO2 <- -dCO2 -dHCO3 -dCO3 + TSumCO2 + ECO2 + ROxCarbon RSumNH4 <- -dNH3 -dNH4 + TSumNH4 + ENH3 + ROx - RNit + AddNH3 + AddNH4NO3 RTA <- -dHCO3-2*dCO3-dNH3 +dH + TTA + ENH3 + ROx - 2*RNit + AddNH3 # algebraic equations: equilibrium equations EquiCO2 <- H * HCO3 - K1CO2 * CO2 EquiHCO3<- H * CO3 - K2CO2 * HCO3 EquiNH4 <- H * NH3 - KNH4 * NH4 #-------------------------- # Output variables: The pH, alkalinity and other summed quantities #-------------------------- return(list(c(ROM, RO2, RNO3, RSumCO2, RSumNH4, RTA, EquiCO2, EquiHCO3, EquiNH4), c(pH = pH, TA = TA, SumCO2 = SumCO2, SumNH4 = SumNH4))) }) } ################################################################################ # MODEL APPLICATIONS # ################################################################################ #--------------------- # alkalinity at the boundaries #--------------------- TA_up <- TA_estimate(pH_up, SumCO2_up, SumNH4_up) TA_down <- TA_estimate(pH_down, SumCO2_down, SumNH4_down) #--------------------- # initial conditions #--------------------- H_ini <- 10^-pH_ini * 1e6 H <- H_ini NH3_ini <- KNH4/(KNH4+H)*SumNH4_ini NH4_ini <- SumNH4_ini - NH3_ini CO2_ini <- H*H/(H*K1CO2 + H*H + K1CO2*K2CO2)*SumCO2_ini HCO3_ini <- H*K1CO2/(H*K1CO2 + H*H + K1CO2*K2CO2)*SumCO2_ini CO3_ini <- K1CO2*K2CO2/(H*K1CO2 + H*H + K1CO2*K2CO2)*SumCO2_ini TA_ini <- HCO3_ini + 2*CO3_ini + NH3_ini - H_ini # Initial conditions for the state variables AND their rates of change y <- c(OM = OM_ini, O2 = O2_ini, NO3 = NO3_ini, H = H_ini, NH4 = NH4_ini, NH3 = NH3_ini, CO2 = CO2_ini, HCO3 = HCO3_ini, CO3 = CO3_ini) dy <- c(dOM = 0, dO2 = 0, dNO3 = 0, dH = 0, dNH4 = 0, dNH3 = 0, dCO2 = 0, dHCO3 = 0, dCO3 = 0) #--------------------- # run the model #--------------------- times <- c(0, 350:405) outA <- daspk(y = y, times, res = FNAResidual, dy = dy, nalg = 3, parms = phPars, scenario = "A", hmax = 1) outB <- daspk(y = y, times, res = FNAResidual, dy = dy, nalg = 3, parms = phPars, scenario = "B1", hmax = 1) outC <- daspk(y = y, times, res = FNAResidual, dy = dy, nalg = 3, parms = phPars, scenario = "C", hmax = 1) #--------------------- # plot model output #--------------------- par(mfrow = c(3, 4), mar = c(1, 2, 2, 1), oma = c(3, 3, 3, 0)) Selection <- c("pH","TA","SumCO2","O2") plot(outA, mfrow = NULL, xlim = c(350,405), type = "l", xaxt = "n", which = Selection) plot(outB, mfrow = NULL, xlim = c(350,405), type = "l", xaxt = "n", which = Selection) plot(outC, mfrow = NULL, xlim = c(350,405), type = "l", xaxt = "n", which = Selection) mtext(side = 1, outer = TRUE, "time, d", line = 2, cex = 1.2) mtext(side = 2, at = 0.2, outer = TRUE, "Scenario C", line = 1.5, cex = 1.2) mtext(side = 2, at = 0.5, outer = TRUE, "Scenario B", line = 1.5, cex = 1.2) mtext(side = 2, at = 0.8, outer = TRUE, "Scenario A", line = 1.5, cex = 1.2) mtext(side = 3, at = 0.125, outer = TRUE, "pH, -", line = 1, cex = 1.2) mtext(side = 3, at = 0.375, outer = TRUE, "TA, mol/kg", line = 1, cex = 1.2) mtext(side = 3, at = 1-0.375, outer = TRUE, "CO2, mol/kg", line = 1, cex = 1.2) mtext(side = 3, at = 1-0.125, outer = TRUE, "O2, mol/kg", line = 1, cex = 1.2) deSolve/inst/doc/examples/Arenstorf.R0000754000175100001440000000641412352122173017324 0ustar hornikusers## ============================================================================= ## ## Arenstorf orbit ## Standard test problem for nonstiff solvers. ## ## closed trajectory for 3-body problem; two of mass mu and (1-mu) ## and a third body of negligible mass, moving in the same plane ## Hairer et al., 2000 ## ## compared with DOPRI.f ## ## ============================================================================= library(deSolve) #----------------------------- # the model function #----------------------------- Arenstorf <- function(t, y, parms) { D1 <- ((y[1] + mu)^2 + y[2]^2)^(3/2) D2 <- ((y[1] - (1 - mu))^2 + y[2]^2)^(3/2) dy1 <- y[3] dy2 <- y[4] dy3 <- y[1] + 2*y[4] - (1 - mu)*(y[1] + mu)/D1 - mu*(y[1] - (1 - mu))/D2 dy4 <- y[2] - 2*y[3] - (1 - mu)*y[2]/D1 - mu*y[2]/D2 list(c(dy1, dy2, dy3, dy4)) } #----------------------------- # parameters, initial values and times #----------------------------- mu <- 0.012277471 yini <- c(x = 0.994, y = 0, dx = 0, dy = -2.00158510637908252240537862224) times <- c(seq(from = 0, to = 17, by = 2), 17.0652165601579625588917206249) #----------------------------- # solve the model #----------------------------- # first for making a graph system.time({ out <- ode(times = seq(0, 50, 0.1), y = yini, func = Arenstorf, parms = NULL, method = rkMethod("ode45"), rtol = 1e-10, atol = 1e-10) }) plot(out[, c("x", "y")], type = "l", lwd = 2, main = "Arenstorf") # then for comparison with DOPRI # (smaller tol than 1e-16 result in numerical problems and very long time) out <- rk(times = times, y = yini, func = Arenstorf, parms = NULL, method = rkMethod("ode45"), rtol = 1e-16, atol = 1e-16) diagnostics(out) options(digits = 10) out[, c("time", "x", "y")] # this is what DOPRI5 generates with atol=rtol=1e-7: # X = 0.00 Y = 0.9940000000E+00 0.0000000000E+00 NSTEP = 0 # X = 2.00 Y = -0.5798781411E+00 0.6090775251E+00 NSTEP = 60 # X = 4.00 Y = -0.1983335270E+00 0.1137638086E+01 NSTEP = 73 # X = 6.00 Y = -0.4735743943E+00 0.2239068118E+00 NSTEP = 91 # X = 8.00 Y = -0.1174553350E+01 -0.2759466982E+00 NSTEP = 110 # X = 10.00 Y = -0.8398073466E+00 0.4468302268E+00 NSTEP = 122 # X = 12.00 Y = 0.1314712468E-01 -0.8385751499E+00 NSTEP = 145 # X = 14.00 Y = -0.6031129504E+00 -0.9912598031E+00 NSTEP = 159 # X = 16.00 Y = 0.2427110999E+00 -0.3899948833E+00 NSTEP = 177 # X = XEND Y = 0.9940021016E+00 0.8911185692E-05 # tol=0.10D-06 fcn= 1442 step= 240 accpt= 216 rejct= 22 # and this for atol=rtol=1e-17 # X = 0.00 Y = 0.9940000000E+00 0.0000000000E+00 NSTEP = 0 # X = 2.00 Y = -0.5798767232E+00 0.6090783555E+00 NSTEP = 5281 # X = 4.00 Y = -0.1983328832E+00 0.1137637824E+01 NSTEP = 6555 # X = 6.00 Y = -0.4735743108E+00 0.2239077929E+00 NSTEP = 8462 # X = 8.00 Y = -0.1174553507E+01 -0.2759450770E+00 NSTEP = 10272 # X = 10.00 Y = -0.8398071663E+00 0.4468314171E+00 NSTEP = 11505 # X = 12.00 Y = 0.1314377269E-01 -0.8385747019E+00 NSTEP = 13847 # X = 14.00 Y = -0.6031162761E+00 -0.9912585277E+00 NSTEP = 15126 # X = 16.00 Y = 0.2427044376E+00 -0.3899991215E+00 NSTEP = 17184 # X = XEND Y = 0.9940000000E+00 -0.1966670302E-11 # tol=0.10D-16 fcn=126836 step=21139 accpt=21137 rejct= 0 deSolve/inst/doc/examples/Schelde_DSA.R0000754000175100001440000001403112352122174017412 0ustar hornikusers################################################################################ # pH model of the Scheldt estuary # # Hofmann AF, Meysman FJR, Soetaert K, Middelburg J, 2008. # # A step-by-step procedure for pH model construction in aquatic systems # # Biogeosciences 5, 227-251 # # # # STEP 4 -DSA # # Direct substitution approach - pH model written as a set of # # ordinary differential equations, solved with ODE solver vode # # Hplus is a state variable; the model is not stiff # # Implementation: Andreas Hofmann, Karline Soetaert - NIOZ # ################################################################################ # load parameters, dissociation constants, initial conditions, # the model transport function and function TA_estimate, to estimate alkalinity # Do make sure that this file is in the working directory (or use setwd("")) source('Schelde_pars.R') ################################################################################ # ORDINARY DIFFERENTIAL EQUATIONS # ################################################################################ DSAmodel <- function (tt, state, parms, scenario = "B1") { with (as.list(c(state, parms)), { pH <- -log10(H*1e-6) TA <- TA_estimate(pH, SumCO2, SumNH4) #-------------------------- # PHYSICAL PROCESSES #-------------------------- CO2 <- H*H/(H*K1CO2 + H*H + K1CO2*K2CO2)*SumCO2 NH3 <- KNH4/(KNH4+H)*SumNH4 NH4 <- SumNH4 - NH3 # air-water exchange ECO2 <- KL * (CO2sat - CO2) EO2 <- KL * (O2sat - O2) ENH3 <- KL * (NH3sat - NH3) # Transport TO2 <- Transport(O2, O2_up, O2_down) TNO3 <- Transport(NO3, NO3_up, NO3_down) TTA <- Transport(TA, TA_up, TA_down) TSumCO2 <- Transport(SumCO2, SumCO2_up, SumCO2_down) TSumNH4 <- Transport(SumNH4, SumNH4_up, SumNH4_down) # Wastewater treatment plant in Brussels scenario if (scenario == "A" && tt > 365) { TOM <- Transport(OM, OM_up_A, OM_down) } else TOM <- Transport(OM, OM_up , OM_down) # Spills if (scenario == "B1" && (tt > 360 && tt < 370)) { AddNH4NO3 <- SpillNH4NO3 # NH4+NO3- - tanker addition } else AddNH4NO3 <- 0 if (scenario == "C" && (tt > 360 && tt < 370)) { AddNH3 <- SpillNH3 # NH3 - tanker input: } else AddNH3 <- 0 #-------------------------- # BIOGEOCHEMICAL PROCESSES: #-------------------------- # Oxic mineralisation ROx <- rOM * OM * (O2/(O2 + ksO2)) ROxCarbon <- ROx * C_Nratio # Nitrification RNit <- rNitri * NH4 * (O2/(O2 + ksO2)) #-------------------------- # RATE OF CHANGE #-------------------------- dOM <- TOM - ROx dO2 <- TO2 + EO2 - ROxCarbon - 2*RNit dNO3 <- TNO3 + RNit + AddNH4NO3 dSumCO2 <- TSumCO2 + ECO2 + ROxCarbon dSumNH4 <- TSumNH4 + ENH3 + ROx - RNit + AddNH3 + AddNH4NO3 # rate of change of pH: dTAdSumCO2 <- (H*K1CO2 + (2*K1CO2*K2CO2))/((H*K1CO2) + (K1CO2*K2CO2) + (H*H)) dTAdSumNH4 <- KNH4 / (KNH4 + H) dHCO3dH <- ((K1CO2/((H*K1CO2) + (K1CO2*K2CO2) + (H*H))) - ((H*K1CO2*((2*H)+K1CO2))/(((H*K1CO2) + (K1CO2*K2CO2) + (H*H))^2)))* SumCO2 dCO3dH <- -((K1CO2*K2CO2*((2*H)+K1CO2))/ (((H*K1CO2) + (K1CO2*K2CO2) + (H*H))^2)) * SumCO2 dNH3dH <- -(KNH4 / ((H*H)+(2*H*KNH4)+(KNH4*KNH4))) * SumNH4 dHdH <- 1 dTAdH <- dHCO3dH + 2*dCO3dH + dNH3dH - dHdH dH <- ((ROx - 2*RNit + ENH3 + AddNH3 + TTA) - ((dTAdSumCO2*dSumCO2) + (dTAdSumNH4*dSumNH4)))/dTAdH return(list(c(dOM, dO2, dNO3, dH, dSumNH4, dSumCO2), c(TA=TA, pH=pH, CO2=CO2, NH3=NH3, NH4=SumNH4-NH3))) }) } ################################################################################ # MODEL APPLICATIONS # ################################################################################ #--------------------- # alkalinity at the boundaries #--------------------- TA_up <- TA_estimate(pH_up, SumCO2_up, SumNH4_up) TA_down <- TA_estimate(pH_down, SumCO2_down, SumNH4_down) #--------------------- # the initial conditions #--------------------- H_ini <- 10^(-pH_ini)*1e6 state <- c(OM=OM_ini, O2=O2_ini, NO3=NO3_ini, H=H_ini, SumNH4=SumNH4_ini, SumCO2=SumCO2_ini) #--------------------- # run model - three scenarios #--------------------- times <- c(0, 350:405) outA <- vode(state, times, DSAmodel, phPars, scenario = "A", hmax = 1) outB <- vode(state, times, DSAmodel, phPars, scenario = "B1", hmax = 1) outC <- vode(state, times, DSAmodel, phPars, scenario = "C" , hmax = 1) #--------------------- # plot model output #--------------------- par(mfrow = c(3, 4), mar = c(1, 2, 2, 1), oma = c(3, 3, 3, 0)) Selection <- c("pH","TA","SumCO2","O2") plot(outA, mfrow = NULL, xlim = c(350,405), type = "l", xaxt = "n", which = Selection) plot(outB, mfrow = NULL, xlim = c(350,405), type = "l", xaxt = "n", which = Selection) plot(outC, mfrow = NULL, xlim = c(350,405), type = "l", xaxt = "n", which = Selection) mtext(side = 1, outer = TRUE, "time, d", line = 2, cex = 1.2) mtext(side = 2, at = 0.2, outer = TRUE, "Scenario C", line = 1.5, cex = 1.2) mtext(side = 2, at = 0.5, outer = TRUE, "Scenario B", line = 1.5, cex = 1.2) mtext(side = 2, at = 0.8, outer = TRUE, "Scenario A", line = 1.5, cex = 1.2) mtext(side = 3, at = 0.125, outer = TRUE, "pH, -", line = 1, cex = 1.2) mtext(side = 3, at = 0.375, outer = TRUE, "TA, mol/kg", line = 1, cex = 1.2) mtext(side = 3, at = 1-0.375, outer = TRUE, "CO2, mol/kg", line = 1, cex = 1.2) mtext(side = 3, at = 1-0.125, outer = TRUE, "O2, mol/kg", line = 1, cex = 1.2) deSolve/inst/doc/examples/Nand.R0000754000175100001440000002700512352122173016240 0ustar hornikusers#----------------------------------------------------------------------- # Note: This file was derived from the FORTRAN code nand.f # The file description of the original is: # " # This file is part of the Test Set for IVP solvers # http://www.dm.uniba.it/~testset/ # # NAND gate # index 0 IDE of dimension 14 # # DISCLAIMER: see # http://www.dm.uniba.it/~testset/disclaimer.php # # The most recent version of this source file can be found at # http://www.dm.uniba.it/~testset/src/problems/nand.f # # This is revision # $Id: nand.F,v 1.2 2006/10/02 10:29:14 testset Exp $ # " #----------------------------------------------------------------------- library(deSolve) #----------------------------------------------------------------------- # # The network equation describing the nand gate # C[Y] * Y' - f[Y,t] = 0 # # --------------------------------------------------------------------- Nand <- function(t, # time point t Y, # node potentials at time point t Yprime, pars) # rate of change of Y { #----------------------------------------------------------------------- # Voltage-dependent capacitance matrix C(Y) for the network equation # C(Y) * Y' - f(Y,t) = 0 #----------------------------------------------------------------------- CAP[1, 1] <- CGS CAP[1, 5] <- -CGS CAP[2, 2] <- CGD CAP[2, 5] <- -CGD CAP[3, 3] <- CBDBS(Y[3]-Y[5]) CAP[3, 5] <- -CBDBS(Y[3]-Y[5]) CAP[4, 4] <- CBDBS(Y[4]-VDD) CAP[5, 1] <- -CGS CAP[5, 2] <- -CGD CAP[5, 3] <- -CBDBS(Y[3]-Y[5]) CAP[5, 5] <- CGS+CGD-CAP[5, 3]+ CBDBS(Y[9]-Y[5])+C9 CAP[5, 9] <- -CBDBS(Y[9]-Y[5]) CAP[6, 6] <- CGS CAP[7, 7] <- CGD CAP[8, 8] <- CBDBS(Y[8]-Y[10]) CAP[8, 10] <- -CBDBS(Y[8]-Y[10]) CAP[9, 5] <- -CBDBS(Y[9]-Y[5]) CAP[9, 9] <- CBDBS(Y[9]-Y[5]) CAP[10, 8] <- -CBDBS(Y[8]-Y[10]) CAP[10, 10] <- -CAP[8, 10]+CBDBS(Y[14]-Y[10])+C9 CAP[10, 14] <- -CBDBS(Y[14]-Y[10]) CAP[11, 11] <- CGS CAP[12, 12] <- CGD CAP[13, 13] <- CBDBS(Y[13]) CAP[14, 10] <- -CBDBS(Y[14]-Y[10]) CAP[14, 14] <- CBDBS(Y[14]-Y[10]) # --------------------------------------------------------------------- # PULSE: Input signal in pulse form # --------------------------------------------------------------------- P1 <- PULSE(t, 0.0, 5.0, 5.0, 5.0, 5.0, 5.0, 20.0) V1 <- P1$VIN V1D <- P1$VIND P2 <- PULSE(t, 0.0, 5.0, 15.0, 5.0, 15.0, 5.0, 40.0) V2 <- P2$VIN V2D <- P2$VIND #----------------------------------------------------------------------- # Right-hand side f[X,t] for the network equation # C[Y] * Y' - f[Y,t] = 0 # External reference: # IDS: Drain-source current # IBS: Nonlinear current characteristic for diode between # bulk and source # IBD: Nonlinear current characteristic for diode between # bulk and drain #----------------------------------------------------------------------- F[1] <- -(Y[1]-Y[5])/RGS-IDS(1, Y[2]-Y[1], Y[5]-Y[1], Y[3]-Y[5], Y[5]-Y[2], Y[4]-VDD) F[2] <- -(Y[2]-VDD)/RGD+IDS(1, Y[2]-Y[1], Y[5]-Y[1], Y[3]-Y[5], Y[5]-Y[2], Y[4]-VDD) F[3] <- -(Y[3]-VBB)/RBS + IBS(Y[3]-Y[5]) F[4] <- -(Y[4]-VBB)/RBD + IBD(Y[4]-VDD) F[5] <- -(Y[5]-Y[1])/RGS-IBS(Y[3]-Y[5])-(Y[5]-Y[7])/RGD- IBD(Y[9]-Y[5]) F[6] <- CGS*V1D-(Y[6]-Y[10])/RGS - IDS(2, Y[7]-Y[6], V1-Y[6], Y[8]-Y[10], V1-Y[7], Y[9]-Y[5]) F[7] <- CGD*V1D-(Y[7]-Y[5])/RGD + IDS(2, Y[7]-Y[6], V1-Y[6], Y[8]-Y[10], V1-Y[7], Y[9]-Y[5]) F[8] <- -(Y[8]-VBB)/RBS + IBS(Y[8]-Y[10]) F[9] <- -(Y[9]-VBB)/RBD + IBD(Y[9]-Y[5]) F[10] <- -(Y[10]-Y[6])/RGS-IBS(Y[8]-Y[10]) - (Y[10]-Y[12])/RGD-IBD(Y[14]-Y[10]) F[11] <- CGS*V2D-Y[11]/RGS-IDS(2, Y[12]-Y[11], V2-Y[11], Y[13], V2-Y[12], Y[14]-Y[10]) F[12] <- CGD*V2D-(Y[12]-Y[10])/RGD + IDS(2, Y[12]-Y[11], V2-Y[11], Y[13], V2-Y[12], Y[14]-Y[10]) F[13] <- -(Y[13]-VBB)/RBS + IBS(Y[13]) F[14] <- -(Y[14]-VBB)/RBD + IBD(Y[14]-Y[10]) # C[Y] * Y' - f[Y,t] = 0 Delta <- colSums(t(CAP)*Yprime)-F return(list(c(Delta), pulse1 = P1$VIN, pulse2 = P2$VIN)) } # --------------------------------------------------------------------------- # # Function evaluating the drain-current due to the model of # Shichman and Hodges # # --------------------------------------------------------------------------- IDS <- function (NED, # NED Integer parameter for MOSFET-type VDS, # VDS Voltage between drain and source VGS, # VGS Voltage between gate and source VBS, # VBS Voltage between bulk and source VGD, # VGD Voltage between gate and drain VBD) # VBD Voltage between bulk and drain { if ( VDS == 0 ) return(0) if (NED== 1) { #--- Depletion-type VT0 <- -2.43 CGAMMA <- 0.2 PHI <- 1.28 BETA <- 5.35e-4 } else { # --- Enhancement-type VT0 <- 0.2 CGAMMA <- 0.035 PHI <- 1.01 BETA <- 1.748e-3 } if ( VDS > 0 ) # drain function for VDS>0 { SQRT1<-ifelse (PHI-VBS>0, sqrt(PHI-VBS), 0) VTE <- VT0 + CGAMMA * ( SQRT1 - sqrt(PHI) ) if ( VGS-VTE <= 0.0) IDS <- 0. else if ( 0.0 < VGS-VTE & VGS-VTE <= VDS ) IDS <- - BETA * (VGS - VTE)^ 2.0 * (1.0 + DELTA*VDS) else if ( 0.0 < VDS & VDS < VGS-VTE ) IDS <- - BETA * VDS * (2 *(VGS - VTE) - VDS) * (1.0 + DELTA*VDS) } else { SQRT2<-ifelse (PHI-VBD>0, sqrt(PHI-VBD), 0) VTE <- VT0 + CGAMMA * (SQRT2 - sqrt(PHI) ) if ( VGD-VTE <= 0.0) IDS <- 0.0 else if ( 0.0 < VGD-VTE & VGD-VTE <= -VDS ) IDS <- BETA * (VGD - VTE)^2.0 * (1.0 - DELTA*VDS) else if ( 0.0 < -VDS & -VDS < VGD-VTE ) IDS <- - BETA * VDS * (2 *(VGD - VTE) + VDS) *(1.0 - DELTA*VDS) } return(IDS) } # --------------------------------------------------------------------------- # # Function evaluating the current of the pn-junction between bulk and # source due to the model of Shichman and Hodges # # --------------------------------------------------------------------------- IBS <- function(VBS) # VBS Voltage between bulk and source ifelse (VBS <= 0.0, -CURIS * (exp(VBS/VTH) - 1.0), 0.0) # --------------------------------------------------------------------------- # # Function evaluating the current of the pn-junction between bulk and # drain due to the model of Shichman and Hodges # # --------------------------------------------------------------------------- IBD <- function(VBD) # VBD Voltage between bulk and drain ifelse(VBD <= 0.0, -CURIS * (exp(VBD/VTH) - 1.0), 0.0) # --------------------------------------------------------------------------- # # Evaluating input signal at time point X # # --------------------------------------------------------------------------- PULSE <- function (X, # Time-point at which input signal is evaluated LOW, # Low-level of input signal HIGH, # High-level of input signal DELAY, T1, T2, T3, PERIOD) # Parameters to specify signal structure # --------------------------------------------------------------------------- # Structure of input signal: # # ----------------------- HIGH # / \ # / \ # / \ # / \ # / \ # / \ # / \ # / \ # ------ --------- LOW # # |DELAY| T1 | T2 | T3 | # | P E R I O D | # # --------------------------------------------------------------------------- { TIME <- X %% PERIOD VIN <- LOW VIND <- 0.0 if (TIME > (DELAY+T1+T2)) { VIN <- ((HIGH-LOW)/T3)*(DELAY+T1+T2+T3-TIME) + LOW VIND <- -((HIGH-LOW)/T3) } else if (TIME > (DELAY+T1)) { VIN <- HIGH VIND <- 0.0 } else if (TIME > DELAY) { VIN <- ((HIGH-LOW)/T1)*(TIME-DELAY) + LOW VIND <- ((HIGH-LOW)/T1) } return (list(VIN = VIN, # Voltage of input signal at time point X VIND = VIND)) # Derivative of VIN at time point X } # --------------------------------------------------------------------------- # # Function evaluating the voltage-dependent capacitance between bulk and # drain gevalp. source due to the model of Shichman and Hodges # # --------------------------------------------------------------------------- CBDBS <- function(V) # Voltage between bulk and drain gevalp. source ifelse(V <= 0.0, CBD/sqrt(1.0-V/0.87), CBD*(1.0+V/(2.0*0.87))) #----------------------------------------------------------------------- # solution # computed at Cray C90, using Cray double precision: # Solving NAND gate using PSIDE # # User input: # # give relative error tolerance: 1d-16 # give absolute error tolerance: 1d-16 # # # Integration characteristics: # # number of integration steps 22083 # number of accepted steps 21506 # number of f evaluations 308562 # number of Jacobian evaluations 337 # number of LU decompositions 10532 # # CPU-time used: 451.71 sec # # y[ 1] = 0.4971088699385777d+1 # y[ 2] = 0.4999752103929311d+1 # y[ 3] = -0.2499998781491227d+1 # y[ 4] = -0.2499999999999975d+1 # y[ 5] = 0.4970837023296724d+1 # y[ 6] = -0.2091214032073855d+0 # y[ 7] = 0.4970593243278363d+1 # y[ 8] = -0.2500077409198803d+1 # y[ 9] = -0.2499998781491227d+1 # y[ 10] = -0.2090289583878100d+0 # y[ 11] = -0.2399999999966269d-3 # y[ 12] = -0.2091214032073855d+0 # y[ 13] = -0.2499999999999991d+1 # y[ 14] = -0.2500077409198803d+1 #----------------------------------------------------------------------- RGS <- 4 RGD <- 4 RBS <- 10 RBD <- 10 CGS <- 0.6e-4 CGD <- 0.6e-4 CBD <- 2.4e-5 CBS <- 2.4e-5 C9 <- 0.5e-4 DELTA <- 0.2e-1 CURIS <- 1.e-14 VTH <- 25.85 VDD <- 5. VBB <- -2.5 #----------------------------------------------------------------------- # initialising VBB <- -2.5 Y <- c(5, 5, VBB, VBB, 5, 3.62385, 5, VBB, VBB, 3.62385, 0, 3.62385, VBB, VBB) Yprime <- rep(0, 14) #----------------------------------------------------------------------- # memory allocation CAP <- matrix(nrow = 14, ncol = 14, 0) F <- vector("double", 14) times <- seq(0, 80, by = 1) # time: from 0 to 80 hours, steps of 1 hour # integrate the model: low tolerances to restrict integration time out <- daspk(y = Y, dy = NULL, times, res = Nand, parms = 0, rtol = 1e-6, atol = 1e-6) # plot output par(mfrow = c(4, 4), mar = c(4, 2, 3, 2)) for(i in 2:15) plot(out[, 1], out[, i], type = "l", ylab = "", main = paste("y[", i-1, "]"), xlab = "time") # reference solution ref<-c(4.971088699385777, 4.999752103929311, -2.499998781491227, -2.499999999999975, 4.970837023296724, -0.2091214032073855, 4.970593243278363, -2.500077409198803, -2.499998781491227, -0.2090289583878100, -0.2399999999966269e-3, -0.2091214032073855, -2.499999999999991, -2.500077409198803) t(rbind(daspk = out [nrow(out), 2:15] , reference = ref, delt = out [nrow(out), 2:15] - ref) ) deSolve/inst/doc/examples/examples_paper.R0000754000175100001440000002273112352122173020366 0ustar hornikuserslibrary(deSolve) #=============================================================================== # R-examples from SECTION 3 # section 3.1 - the basic lotka-volterra predator-prey model. #=============================================================================== ## 1) model function LVmod0D <- function(Time, State, Pars) { with(as.list(c(State, Pars)), { IngestC <- rI * P * C GrowthP <- rG * P * (1 - P/K) MortC <- rM * C dP <- GrowthP - IngestC dC <- IngestC * AE - MortC return(list(c(dP, dC))) }) } ## 2) parameters, start values, times, simulation pars <- c(rI = 0.2, # /day, rate of ingestion rG = 1.0, # /day, growth rate of prey rM = 0.2 , # /day, mortality rate of consumer AE = 0.5, # -, assimilation efficiency K = 10) # mmol/m3, carrying capacity yini <- c(P = 1, C = 2) times <- seq(0, 200, by = 1) nrun <- 1 # set 10 for benchmark print(system.time( for (i in 1:nrun) out <- lsoda(func = LVmod0D, y = yini, parms = pars, times = times) )/nrun) print(system.time( for (i in 1:nrun) out <- lsode(func = LVmod0D, y = yini, parms = pars, times = times) )/nrun) print(system.time( for (i in 1:nrun) out <- vode(func = LVmod0D, y = yini, parms = pars, times = times) )/nrun) print(system.time( for (i in 1:nrun) out <- daspk(func = LVmod0D, y = yini, parms = pars, times = times) )/nrun) print(system.time( for (i in 1:nrun) out <- lsodes(func = LVmod0D, y = yini, parms = pars, times = times) )/nrun) matplot(out[,"time"], out[,2:3], type = "l", xlab = "time", ylab = "Conc", main = "Lotka-Volterra", lwd = 2) legend("topright", c("prey", "predator"), col =1:2, lty = 1:2) #=============================================================================== # section 3.2 - predator-prey model with stopping criterium. #=============================================================================== rootfun <- function(Time, State, Pars) { dstate <- unlist(LVmod0D(Time, State, Pars)) root <- sum(abs(dstate)) - 1e-4 } print(system.time( for (i in 1:nrun) out <- lsodar(func = LVmod0D, y = yini, parms = pars, times = times, rootfun = rootfun) )/nrun) matplot(out[,"time"],out[,2:3], type = "l", xlab = "time", ylab = "Conc", main = "Lotka-Volterra with root", lwd = 2) #=============================================================================== # section 3.3 - predator-prey model in 1-D. #=============================================================================== LVmod1D <- function (time, state, parms, N, Da, dx) { with (as.list(parms), { P <- state[1:N] C <- state[-(1:N)] ## Dispersive fluxes; zero-gradient boundaries FluxP <- -Da * diff(c(P[1], P, P[N]))/dx FluxC <- -Da * diff(c(C[1], C, C[N]))/dx ## Biology: Lotka-Volterra dynamics IngestC <- rI * P * C GrowthP <- rG * P * (1- P/K) MortC <- rM * C ## Rate of change = -Flux gradient + Biology dP <- -diff(FluxP)/dx + GrowthP - IngestC dC <- -diff(FluxC)/dx + IngestC * AE - MortC return(list(c(dP, dC))) }) } R <- 20 # total length of surface, m N <- 1000 # number of boxes dx <- R/N # size of box in x-direction Da <- 0.05 # m2/d, dispersion coefficient yini <- rep(0, 2*N) yini[500:501] <- yini[1500:1501] <- 10 times <-seq(0, 200, by = 1) # output wanted at these time intervals # based on lsode print(system.time( for (i in 1:nrun) out <- ode.1D(y = yini, times = times, func = LVmod1D, parms = pars, nspec = 2, N = N, dx = dx, Da = Da) )/nrun) print(system.time( for (i in 1:nrun) out <- ode.1D(y = yini, times = times, func = LVmod1D, parms = pars, nspec = 2, N = N, dx = dx, Da = Da, method = "vode") )/nrun) print(system.time( for (i in 1:nrun) out <- ode.1D(y = yini, times = times, func = LVmod1D, parms = pars, nspec = 2, N = N, dx = dx, Da = Da, method = "lsoda") )/nrun) print(system.time( for (i in 1:nrun) out <- ode.1D(y = yini, times = times, func = LVmod1D, parms = pars, nspec = 2, N = N, dx = dx, Da = Da, method = "lsodes") )/nrun) image(out, which = 1, grid = seq(0, R, length=N), xlab = "Time, days", ylab = "Distance, m", main = "Prey density") # more elaborate way: #P <- out[,2:(N + 1)] #filled.contour(x = times, z = P, y = seq(0, R, length=N), # color = topo.colors, # xlab = "Time, days", ylab= "Distance, m", # main = "Prey density") #=============================================================================== # section 3.4 - predator-prey model in 2-D. #=============================================================================== LVmod2D <- function (time, state, parms, N, Da, dx, dy) { P <- matrix(nr = N, nc = N, state[1:NN]) C <- matrix(nr = N, nc = N, state[-(1:NN)]) with (as.list(parms), { dP <- rG*P *(1 - P/K) - rI*P*C dC <- rI*P*C*AE - rM*C zero <- numeric(N) ## Fluxes in x-direction; zero fluxes near boundaries FluxP <- rbind(zero, -Da*(P[-1,] - P[-N,])/dx, zero) FluxC <- rbind(zero, -Da*(C[-1,] - C[-N,])/dx, zero) dP <- dP - (FluxP[-1,] - FluxP[-(N+1),])/dx dC <- dC - (FluxC[-1,] - FluxC[-(N+1),])/dx ## Fluxes in y-direction FluxP <- cbind(zero, -Da*(P[,-1] - P[,-N])/dy, zero) FluxC <- cbind(zero, -Da*(C[,-1] - C[,-N])/dy, zero) dP <- dP - (FluxP[,-1] - FluxP[,-(N+1)])/dy dC <- dC - (FluxC[,-1] - FluxC[,-(N+1)])/dy return(list(c(as.vector(dP), as.vector(dC)))) }) } R <- 20 # total length of surface, m N <- 50 # number of boxes dx <- R/N # size of box in x-direction dy <- R/N # size of box in y-direction Da <- 0.05 # m2/d, dispersion coefficient NN <- N*N yini <- rep(0, 2*N*N) cc <- c((NN/2):(NN/2+1)+N/2, (NN/2):(NN/2+1)-N/2) yini[cc] <- yini[NN+cc] <- 10 times <- seq(0, 200, by = 1) # output wanted at these time intervals print(system.time( for (i in 1:nrun) out <- ode.2D(y = yini, times = times, func = LVmod2D, parms = pars, ynames = FALSE, dimens = c(N, N), N = N, dx = dx, dy = dy, Da = Da, lrw = 440000) )/nrun) Col<- colorRampPalette(c("#00007F", "blue", "#007FFF", "cyan", "#7FFF7F", "yellow", "#FF7F00", "red", "#7F0000")) # topo.colors #pdf("Fig3.pdf", width=7, height=8) par(mfrow=c(2,2)) par(oma=c(0,0,2,0)) xx <- seq(0, R, dx) yy <- seq(0, R, dy) image(x = xx, y = yy, z = matrix(nr = N, nc = N, out[1,-1]), zlim = c(0,10), col = Col(100), main = "initial", xlab = "x", ylab = "y") image(x = xx, y = yy, z = matrix(nr = N, nc = N, out[21,-1]), zlim = c(0,10), col = Col(100), main = "20 days", xlab = "x", ylab = "y") image(x = xx, y = yy, z = matrix(nr = N, nc = N, out[31,-1]), zlim = c(0,10), col = Col(100), main = "30 days", xlab = "x", ylab = "y") image(x = xx, y = yy, z = matrix(nr = N, nc = N, out[41,-1]), zlim = c(0,10), col = Col(100), main = "40 days", xlab = "x", ylab = "y") mtext(side = 3, outer = TRUE, cex = 1.25, "Lotka-Volterra Prey concentration on 2-D grid") #filled.contour(matrix(nr=N,nc=N,out[20,-1]), color.palette=topo.colors,main="2-D grid") #dev.off() #pdf("Fig3legend.pdf", width=5, height=14) #opar <- par(las=1, mar=c(4,4,1,1), cex=3.5) #image(matrix(nr=1,nc=100,seq(0,10,length=100)), # x=c(0,1), y=seq(0,10,length=100), zlim=c(0,10), # col=Col(100),main="",xlab="",ylab="", # axes = FALSE) #abline(h=0:10) #mtext("Prey concentration", side=2, line=2.1, las=0, cex=3.5) #axis(2) #par(opar) #dev.off() ## DAE example Res_DAE <- function (t, y, yprime, pars, K) { with (as.list(c(y, yprime, pars)), { ## residuals of lumped rates of changes res1 <- -dD - dA + prod res2 <- -dB + dA - r*B ## and the equilibrium equation eq <- K*D - A*B return(list(c(res1, res2, eq), CONC = A + B + D)) }) } times <- seq(0, 100, by = 2) pars <- c(r = 1, prod = 0.1) K <- 1 ## Initial conc; D is in equilibrium with A,B yini <- c(A = 2, B = 3, D = 2*3/K) ## Initial rate of change dyini <- c(dA = 0, dB = 0, dD = 0) ## DAE model solved with daspk DAE <- daspk(y = yini, dy = dyini, times = times, res = Res_DAE, parms = pars, atol = 1e-10, rtol = 1e-10, K = 1) plot(DAE, main = c(paste("[",colnames(DAE)[2:4],"]"),"total conc"), xlab = "time", lwd = 2, ylab = "conc", type = "l") mtext(outer=TRUE, side=3, "DAE chemical model",cex=1.25) #=============================================================================== # section 4 - Model implementation in a compiled language # # This example needs an installed toolset for compiling source code # see the "R Installation and Administration" manual #=============================================================================== #if (is.loaded("initmod")) # dyn.unload(paste("LVmod0D",.Platform$dynlib.ext,sep="")) #system("R CMD SHLIB LVmod0D.f") #system("R CMD SHLIB LVmod0D.c") # #dyn.load(paste("LVmod0D", .Platform$dynlib.ext, sep = "")) # #pars <- c(rI = 0.2, rG = 1.0, rM = 0.2, AE = 0.5, K = 10) #yini <- c(P = 1, C = 2) #times <- seq(0, 200, by = 1) # #print(system.time( # out <- ode(func = "derivs", y = yini, parms = pars, times = times, # dllname = "LVmod0D", initfunc = "initparms", nout = 1, # outnames = c("total")) #)) # #dyn.unload(paste("LVmod0D", .Platform$dynlib.ext, sep = "")) deSolve/inst/doc/examples/Schelde_FKA.R0000754000175100001440000001551312352122173017411 0ustar hornikusers################################################################################ # pH model of the Scheldt estuary # # Hofmann AF, Meysman FJR, Soetaert K, Middelburg J, 2008. # # A step-by-step procedure for pH model construction in aquatic systems # # Biogeosciences 5, 227-251 # # # # STEP 1 - FKA # # Full kinetic approach - pH model written as a set of stiff # # ordinary differential equations, solved with ODE solver vode # # Implementation: Andreas Hofmann, Karline Soetaert - NIOZ # ################################################################################ # load parameters, dissociation constants, initial conditions, # the model transport function and function TA_estimate, to estimate alkalinity # Do make sure that this file is in the working directory (or use setwd("")) source('Schelde_pars.R') ################################################################################ # MODEL EQUATIONS # ################################################################################ FKAmodel <- function (tt, state, parms, scenario="B1") { with (as.list(c(state, parms)), { #-------------------------- # PHYSICAL PROCESSES #-------------------------- # air-water exchange ECO2 <- KL * (CO2sat - CO2) EO2 <- KL * (O2sat - O2) ENH3 <- KL * (NH3sat - NH3) # Transport TO2 <- Transport(O2, O2_up, O2_down) TNO3 <- Transport(NO3, NO3_up, NO3_down) TH <- Transport(H, H_up, H_down) TCO2 <- Transport(CO2, CO2_up, CO2_down) THCO3 <- Transport(HCO3, HCO3_up, HCO3_down) TCO3 <- Transport(CO3, CO3_up, CO3_down) TNH3 <- Transport(NH3, NH3_up, NH3_down) TNH4 <- Transport(NH4, NH4_up, NH4_down) # Wastewater treatment plant in Brussels scenario if (scenario == "A" && tt > 365) { TOM <- Transport(OM, OM_up_A, OM_down) } else TOM <- Transport(OM, OM_up , OM_down) # Spills if (scenario == "B1" && (tt > 360 && tt < 370)) { AddNH4NO3 <- SpillNH4NO3 # NH4+NO3- - tanker addition } else AddNH4NO3 <- 0 if (scenario == "C" && (tt > 360 && tt < 370)) { AddNH3 <- SpillNH3 # NH3 - tanker input } else AddNH3 <- 0 #-------------------------- # BIOGEOCHEMICAL PROCESSES: #-------------------------- # Oxic mineralisation ROx <- rOM * OM * (O2/(O2 + ksO2)) ROxCarbon <- ROx * C_Nratio # Nitrification RNit <- rNitri * NH4 * (O2/(O2 + ksO2)) # "equilibrium reactions": k1 arbitrarily high RCO2 <- k1*CO2 - k1/K1CO2* H * HCO3 RHCO3 <- k1*HCO3 - k1/K2CO2* H * CO3 RNH4 <- k1*NH4 - k1/KNH4 * H * NH3 #-------------------------- # RATE OF CHANGE #-------------------------- dOM <- TOM - ROx dO2 <- TO2 + EO2 - ROxCarbon - 2*RNit dNO3 <- TNO3 + RNit + AddNH4NO3 dCO2 <- TCO2 + ECO2 + ROxCarbon - RCO2 dHCO3 <- THCO3 + RCO2 - RHCO3 dCO3 <- TCO3 + RHCO3 dNH3 <- TNH3 + ENH3 + ROx + RNH4 + AddNH3 dNH4 <- TNH4 - RNit - RNH4 + AddNH4NO3 dH <- TH + 2*RNit + RCO2 + RHCO3 + RNH4 #-------------------------- # Output variables: The pH, alkalinity and other summed quantities #-------------------------- pH <- -log10(H*1e-6) TA <- HCO3 + 2*CO3 + NH3 - H SumCO2 <- CO2 + HCO3 + CO3 SumNH4 <- NH4 + NH3 return(list(c(dOM, dO2, dNO3, dH, dNH4, dNH3, dCO2, dHCO3, dCO3), c(pH=pH, TA=TA, SumCO2=SumCO2, SumNH4=SumNH4))) }) } ################################################################################ # MODEL APPLICATIONS # ################################################################################ #--------------------- # Extra Boundary conditions #--------------------- # The speciation of DIC and sum(ammonium), calculated consistently with pH_up H_up <- 10^-pH_up * 1e6 # umol/kg solution H <- H_up NH3_up <- KNH4/(KNH4+H)*SumNH4_up NH4_up <- SumNH4_up - NH3_up CO2_up <- H*H/(H*K1CO2 + H*H + K1CO2*K2CO2)*SumCO2_up HCO3_up <- H*K1CO2/(H*K1CO2 + H*H + K1CO2*K2CO2)*SumCO2_up CO3_up <- K1CO2*K2CO2/(H*K1CO2 + H*H + K1CO2*K2CO2)*SumCO2_up # calculated consistently with pH_down: H_down <- 10^-pH_down * 1e6 # umol/kg solution H <- H_down NH3_down <- KNH4/(KNH4+H)*SumNH4_down NH4_down <- SumNH4_down - NH3_down CO2_down <- H*H/(H*K1CO2 + H*H + K1CO2*K2CO2)*SumCO2_down HCO3_down <- H*K1CO2/(H*K1CO2 + H*H + K1CO2*K2CO2)*SumCO2_down CO3_down <- K1CO2*K2CO2/(H*K1CO2 + H*H + K1CO2*K2CO2)*SumCO2_down #--------------------- # initial conditions #--------------------- H_ini <- 10^-pH_ini * 1e6 H <- H_ini NH3_ini <- KNH4/(KNH4+H)*SumNH4_ini NH4_ini <- SumNH4_ini - NH3_ini CO2_ini <- H*H/(H*K1CO2 + H*H + K1CO2*K2CO2)*SumCO2_ini HCO3_ini <- H*K1CO2/(H*K1CO2 + H*H + K1CO2*K2CO2)*SumCO2_ini CO3_ini <- K1CO2*K2CO2/(H*K1CO2 + H*H + K1CO2*K2CO2)*SumCO2_ini state <- c(OM=OM_ini, O2=O2_ini, NO3=NO3_ini, H=H_ini, NH4=NH4_ini, NH3=NH3_ini, CO2=CO2_ini, HCO3=HCO3_ini, CO3=CO3_ini) #--------------------- # run model #--------------------- times <- c(0, 350:405) outA <- vode(state, times, FKAmodel, phPars, scenario = "A" , hmax = 1) outB <- vode(state, times, FKAmodel, phPars, scenario = "B1", hmax = 1) outC <- vode(state, times, FKAmodel, phPars, scenario = "C" , hmax = 1) #--------------------- # plot model output #--------------------- par(mfrow = c(3, 4), mar = c(1, 2, 2, 1), oma = c(3, 3, 3, 0)) Selection <- c("pH","TA","SumCO2","O2") plot(outA, mfrow = NULL, xlim = c(350,405), type = "l", xaxt = "n", which = Selection) plot(outB, mfrow = NULL, xlim = c(350,405), type = "l", xaxt = "n", which = Selection) plot(outC, mfrow = NULL, xlim = c(350,405), type = "l", xaxt = "n", which = Selection) mtext(side = 1, outer = TRUE, "time, d", line = 2, cex = 1.2) mtext(side = 2, at = 0.2, outer = TRUE, "Scenario C", line = 1.5, cex = 1.2) mtext(side = 2, at = 0.5, outer = TRUE, "Scenario B", line = 1.5, cex = 1.2) mtext(side = 2, at = 0.8, outer = TRUE, "Scenario A", line = 1.5, cex = 1.2) mtext(side = 3, at = 0.125, outer = TRUE, "pH, -", line = 1, cex = 1.2) mtext(side = 3, at = 0.375, outer = TRUE, "TA, mol/kg", line = 1, cex = 1.2) mtext(side = 3, at = 1-0.375, outer = TRUE, "CO2, mol/kg", line = 1, cex = 1.2) mtext(side = 3, at = 1-0.125, outer = TRUE, "O2, mol/kg", line = 1, cex = 1.2) deSolve/inst/doc/examples/Daphnia_event.R0000754000175100001440000001077512352122173020133 0ustar hornikusers## ============================================================================= ## ## The Daphnia model from Soetaert and Herman, 2009. ## a practical guide to ecological modelling, ## using R as a simulation platform. Springer. ## chapter 6 ## ## implemented with 2 types of EVENTS: ## transfer to new culture medium ## moulting of the animals ## ## ============================================================================= library(deSolve) #----------------------# # the model equations: # #----------------------# model <- function(t, state, parameters) { with(as.list(state), { # unpack the state variables ## ingestion, size-dependent and food limited WeightFactor <- (IngestWeight - INDWEIGHT)/(IngestWeight - neonateWeight) MaxIngestion <- maxIngest * WeightFactor # /day Ingestion <- MaxIngestion * INDWEIGHT * FOOD / (FOOD + ksFood) Respiration <- respirationRate * INDWEIGHT # gC/day Growth <- Ingestion * assimilEff - Respiration ## Fraction of assimilate allocated to reproduction if (Growth <= 0 | INDWEIGHT < reproductiveWeight) Reproduction <- 0 else { # Fraction of growth allocated to reproduction. WeightRatio <- reproductiveWeight/INDWEIGHT Reproduction <- maxReproduction * (1 - WeightRatio^2) } ## rate of change dINDWEIGHT <- (1 -Reproduction) * Growth dEGGWEIGHT <- Reproduction * Growth dFOOD <- -Ingestion * numberIndividuals ## the output, packed as a list list(c(dINDWEIGHT, dEGGWEIGHT, dFOOD), # the rate of change c(Ingestion = Ingestion, # the ordinary output variables Respiration = Respiration, Reproduction = Reproduction)) }) } # end of model #---------------------------------------------------# # Moulting weight loss and transfer to new culture # #---------------------------------------------------# Eventfunc <- function (t, state, parms) { with(as.list(state), { # unpack the state variables if (t %in% MoultTime) { # Moulting... ## Relationship moulting loss and length refLoss <- 0.24 #gC cLoss <- 3.1 #- ## Weight lost during molts depends allometrically on the organism length INDLength <- (INDWEIGHT /3.0)^(1/2.6) WeightLoss <- refLoss * INDLength^cLoss INDWEIGHT <- INDWEIGHT - WeightLoss EGGWEIGHT <- 0. } if (t %in% TransTime) # New medium... FOOD <- foodInMedium return(c(INDWEIGHT, EGGWEIGHT, FOOD)) }) } #-----------------------# # the model parameters: # #-----------------------# neonateWeight <- 1.1 #gC reproductiveWeight <- 7.5 #gC maximumWeight <- 60.0 #gC ksFood <- 85.0 #gC/l IngestWeight <-132.0 #gC maxIngest <- 1.05 #/day assimilEff <- 0.8 #- maxReproduction <- 0.8 #- respirationRate <- 0.25 #/day ## Dilution parameters ! transferTime <- 2 # Days foodInMedium <- 509 # gC/l instarDuration <- 3.0 # days numberIndividuals <- 32 # - #-------------------------# # the initial conditions: # #-------------------------# state <- c( INDWEIGHT = neonateWeight, # gC EGGWEIGHT = 0, # gC ! Total egg mass in a stage FOOD = foodInMedium # gC ) #----------------------# # RUNNING the model: # #----------------------# TimeEnd <- 40 # duration of simulation, days times <- seq(0, TimeEnd, 0.1) # output array ## when events are happening... MoultTime <- seq(from = instarDuration, to = TimeEnd, by = instarDuration) TransTime <- seq(from = transferTime, to = TimeEnd, by = transferTime) EventTime <- sort(unique(c(MoultTime, TransTime))) out <- ode(times = times, func = model, parms = NULL, y = state, events = list(func = Eventfunc, time = EventTime)) par(mfrow = c(2, 2), oma = c(0, 0, 3, 0)) # set number of plots (mfrow) and margin size (oma) par(mar = c(5.1, 4.1, 4.1, 2.1)) plot (out, which = c("FOOD", "INDWEIGHT", "EGGWEIGHT", "Ingestion"), type = "l", xlab = "time, days", ylab = c("gC/m3", "gC", "gC", "gC/day")) #main = "Food" , #plot (out, which = , type = "l", main = "individual weight" , xlab = "time, days", ylab=) #plot (out, which = , type = "l", main = "egg weight" , xlab = "time, days", ylab=) #plot (out, which = , type = "l", main = "Ingestion" , xlab = "time, days", ylab=) mtext(outer = TRUE, side = 3, "DAPHNIA model", cex = 1.5) deSolve/inst/doc/examples/Pollution.R0000754000175100001440000001764212352122173017353 0ustar hornikusers################################################################################ # This is a stiff system of 20 non-linear Ordinary Differential Equations. # It describes a chemical reaction part of the air pollution model developed at # The Dutch National Institute of Public Health and Environmental Protection (RIVM), # and consists of 25 reaction and 20 reacting compounds. # The reaction rates vary from e-3 to e+12, making the model extremely stiff ################################################################################ # # A FORTRAN implementation (and reference output) can be found at # http://pitagora.dm.uniba.it//~testset # F. Mazzia and F. Iavernaro. Test Set for Initial Value Problem Solvers. # Department of Mathematics, University of Bari, August 2003. # Available at http://www.dm.uniba.it/~testset. # The model is described in Verwer (1994) # J.G. Verwer, 1994. Gauss-Seidel iteration for stiff ODEs from chemical kinetics. # SIAM J. Sci. Comput., 15(5):1243-1259. # 20 chemical species are described: NO2, NO, O3P, O3, HO2, OH, # HCHO, CO, ALD, MEO2, C2O3, CO2, PAN, CH3O, HNO3, O1D, SO2, SO4, NO3, N2O5 # The model describes the following reactions: # r1: NO2 -> NO + O3P # r2: NO + O3 -> NO2 # r3: HO2+NO -> NO2 # r4: HCHO -> 2 HO2 + CO # r5: HCHO -> CO # r6: HCHO + OH -> HO2+CO # r7: ALD + OH -> C2O3 # r8: ALD -> MEO2+HO2+C) # r9: C2O3 + NO -> NO2 + MEO2 + CO2 # r10: C2O3 + NO2 -> PAN # r11: PAN -> C2O3 + NO2 # r12: MEO2 + NO -> CH3O + NO2 # r13: CH3O -> HCHO + HO2 # r14: NO2+OH -> HNO3 # r15: O3P -> O3 # r16: O3 -> O1D # r17: O3 -> O3P # r18: O1D -> 2 OH # r19: O1D -> O3P # r20: SO2 + Oh -> SO4 + HO2 # r21: NO3 -> NO # r22: NO3 -> NO2 + O3P # r23: NO2 + O3 -> NO3 # r24: NO3 + NO2 -> N2O5 # r25: N2O5 -> NO3 + NO2 #======================= # the model definition #======================= Pollution <- function (t, y, pars) { r <- vector(length = 25) dy <- vector(length = length(y)) r[ 1] <- k1 * y[ 1] r[ 2] <- k2 * y[ 2]*y[4] r[ 3] <- k3 * y[ 5]*y[2] r[ 4] <- k4 * y[ 7] r[ 5] <- k5 * y[ 7] r[ 6] <- k6 * y[ 7]*y[6] r[ 7] <- k7 * y[ 9] r[ 8] <- k8 * y[ 9]*y[6] r[ 9] <- k9 * y[11]*y[2] r[10] <- k10 * y[11]*y[1] r[11] <- k11 * y[13] r[12] <- k12 * y[10]*y[2] r[13] <- k13 * y[14] r[14] <- k14 * y[ 1]*y[6] r[15] <- k15 * y[ 3] r[16] <- k16 * y[ 4] r[17] <- k17 * y[ 4] r[18] <- k18 * y[16] r[19] <- k19 * y[16] r[20] <- k20 * y[17]*y[6] r[21] <- k21 * y[19] r[22] <- k22 * y[19] r[23] <- k23 * y[ 1]*y[4] r[24] <- k24 * y[19]*y[1] r[25] <- k25 * y[20] dy[1] <- dy[1] - r[1]-r[10]-r[14]-r[23]-r[24]+r[2]+r[3]+ r[9]+r[11]+r[12]+r[22]+r[25] dy[2] <- dy[2] - r[2]-r[3]-r[9]-r[12]+r[1]+r[21] dy[3] <- dy[3] - r[15]+r[1]+r[17]+r[19]+r[22] dy[4] <- dy[4] - r[2]-r[16]-r[17]-r[23]+r[15] dy[5] <- dy[5] - r[3]+r[4]+r[4]+r[6]+r[7]+r[13]+r[20] dy[6] <- dy[6] - r[6]-r[8]-r[14]-r[20]+r[3]+r[18]+r[18] dy[7] <- dy[7] - r[4]-r[5]-r[6]+r[13] dy[8] <- dy[8] + r[4]+r[5]+r[6]+r[7] dy[9] <- dy[9] - r[7]-r[8] dy[10] <- dy[10] - r[12]+r[7]+r[9] dy[11] <- dy[11] - r[9]-r[10]+r[8]+r[11] dy[12] <- dy[12] + r[9] dy[13] <- dy[13] - r[11]+r[10] dy[14] <- dy[14] - r[13]+r[12] dy[15] <- dy[15] + r[14] dy[16] <- dy[16] - r[18]-r[19]+r[16] dy[17] <- dy[17] - r[20] dy[18] <- dy[18] + r[20] dy[19] <- dy[19] - r[21]-r[22]-r[24]+r[23]+r[25] dy[20] <- dy[20] - r[25]+r[24] return(list(c(dy = dy), rate = r)) } #============================= # parameters, state variables #============================= # Parameters: rate coefficients k1 <- 0.35 k2 <- 0.266e2 k3 <- 0.123e5 k4 <- 0.86e-3 k5 <- 0.82e-3 k6 <- 0.15e5 k7 <- 0.13e-3 k8 <- 0.24e5 k9 <- 0.165e5 k10 <- 0.9e4 k11 <- 0.22e-1 k12 <- 0.12e5 k13 <- 0.188e1 k14 <- 0.163e5 k15 <- 0.48e7 k16 <- 0.35e-3 k17 <- 0.175e-1 k18 <- 0.1e9 k19 <- 0.444e12 k20 <- 0.124e4 k21 <- 0.21e1 k22 <- 0.578e1 k23 <- 0.474e-1 k24 <- 0.178e4 k25 <- 0.312e1 # State variable initial condition y <- rep(0, 20) y[2] <- 0.2 y[4] <- 0.04 y[7] <- 0.1 y[8] <- 0.3 y[9] <- 0.01 y[17] <- 0.007 # The species names: spnames <- c("NO2", "NO", "O3P", "O3", "HO2", "OH", "HCHO", "CO", "ALD", "MEO2", "C2O3", "CO2", "PAN", "CH3O", "HNO3", "O1D", "SO2", "SO4", "NO3", "N2O5") names (y) <- spnames #============================= # application 1. #============================= times <- seq(0, 10, 0.1) # run with default tolerances, short period of time out <- vode(y, times, Pollution, parms = NULL) # increasing tolerance out2 <- vode(y, times, Pollution, parms = NULL, atol = 1e-10, rtol = 1e-10) # run for longer period Times <- seq (0, 2000, 10) out3 <- vode(y, Times, Pollution, parms = NULL, atol = 1e-10, rtol = 1e-10) # plotting output; omit the first row to avoud zero in logarithmic plots mf <-par(mfrow = c(2, 2)) plot (times[-1], out[-1, 6], type = "l", log = "y", ylab = "log", main = colnames(out)[6]) lines(times[-1], out2[-1, 6], lty = 2, col = "red") legend("topright", c("tol = 1e-8", "tol = 1e-10"), col = c("black", "red"), lty = 1) plot(times[-1], out2[-1, 8], type = "l", main = colnames(out)[8]) plot(Times[-1], out3[-1, 6], type = "l", log = "y", ylab = "log", main = colnames(out)[6]) plot(Times[-1], out3[-1, 8], type = "l", main = colnames(out)[8]) mtext(side = 3, outer = TRUE, line = -1.5, cex = 1.5, "Pollution problem") par (mfrow = mf) #============================= # application 2 #============================= # Testing vode, lsode, lsoda, lsodes and daspk for precision and speed: # reference output at t = 60 (from http://www.dm.uniba.it/~testset) ytrue <- c(0.5646255480022769e-1, 0.1342484130422339, 0.4139734331099427e-8, 0.5523140207484359e-2, 0.2018977262302196e-6, 0.1464541863493966e-6, 0.7784249118997964e-1, 0.3245075353396018, 0.7494013383880406e-2, 0.1622293157301561e-7, 0.1135863833257075e-7, 0.2230505975721359e-2, 0.2087162882798630e-3, 0.1396921016840158e-4, 0.8964884856898295e-2, 0.4352846369330103e-17, 0.6899219696263405e-2, 0.1007803037365946e-3, 0.1772146513969984e-5, 0.5682943292316392e-4) # generate output at t = 60, and compare it with reference output # using the highest precision that does not provoke an error TT <- c(0, 60) s1<-system.time( Test1 <- vode(y, TT, Pollution, parms = NULL, atol = 1e-17, rtol = 1e-16, verbose = TRUE) )["elapsed"] s2<-system.time( Test2 <- lsode(y, TT, Pollution, parms = NULL, atol = 1e-17, rtol = 1e-16, verbose = TRUE) )["elapsed"] s3<-system.time( Test3 <- lsoda(y, TT, Pollution, parms = NULL, atol = 1e-14, rtol = 1e-17, verbose = TRUE) )["elapsed"] s4<-system.time( Test4 <- lsodes(y, TT, Pollution, parms = NULL, atol = 1e-17, rtol = 1e-16, verbose = TRUE) )["elapsed"] s5<-system.time( Test5 <- daspk(y, TT, Pollution, parms = NULL, atol = 1e-10, rtol = 1e-17, verbose = TRUE) )["elapsed"] print( cbind(vode = (Test1[2, 2:21] - ytrue), lsode = (Test2[2, 2:21] - ytrue), lsoda = (Test3[2, 2:21] - ytrue), lsodes= (Test4[2, 2:21] - ytrue), daspk = (Test5[2, 2:21] - ytrue)) ) DF <- data.frame( method = c("vode", "lsode", "lsoda", "lsodes", "daspk"), "maximal deviation" = c(max(abs(Test1[2, 2:21] - ytrue)), max(abs(Test2[2, 2:21] - ytrue)), max(abs(Test3[2, 2:21] - ytrue)), max(abs(Test4[2, 2:21] - ytrue)), max(abs(Test5[2, 2:21] - ytrue))), "timing" = c(s1, s2, s3, s4, s5) ) print(DF) deSolve/inst/doc/examples/ballode.R0000754000175100001440000000260312352122173016757 0ustar hornikusers## ============================================================================= ## A bouncing ball; ode with event location ## ============================================================================= require(deSolve) #----------------------------- # the model function #----------------------------- ballode<- function(t, y, parms) { dy1 <- y[2] dy2 <- -9.8 list(c(dy1, dy2)) } #----------------------------- # the root and event function #----------------------------- # event triggered when the ball hits the ground (height = 0) root <- function(t, y, parms) y[1] # bouncing event <- function(t, y, parms) { y[1] <- 0 y[2] <- -0.9 * y[2] return(y) } #----------------------------- # initial values and times #----------------------------- yini <- c(height = 0, v = 20) times <- seq(0, 40, 0.01) #----------------------------- # solve the model #----------------------------- out <- lsodar(times = times, y = yini, func = ballode, parms = NULL, events = list(func = event, root = TRUE), rootfun = root) out2 <- radau(times = times, y = yini, func = ballode, parms = NULL, events = list(func = event, root = TRUE), rootfun = root) # , verbose=TRUE attributes(out)$troot attributes(out2)$troot #----------------------------- # display, plot results #----------------------------- plot(out, which = "height", type = "l", lwd = 2, main = "bouncing ball", ylab = "height") deSolve/inst/doc/examples/Schelde_OSA.R0000754000175100001440000001372012352122173017430 0ustar hornikusers################################################################################ # pH model of the Scheldt estuary # # Hofmann AF, Meysman FJR, Soetaert K, Middelburg J, 2008. # # A step-by-step procedure for pH model construction in aquatic systems # # Biogeosciences 5, 227-251 # # # # STEP 3 -OSA # # Operator splitter approach - pH model written as a set of # # ordinary differential equations, solved with ODE solver vode # # Each time step the pH is solved at equilibrium, using uniroot # # Implementation: Andreas Hofmann, Karline Soetaert - NIOZ # ################################################################################ # load parameters, dissociation constants, initial conditions, # the model transport function and function TA_estimate, to estimate alkalinity # Do make sure that this file is in the working directory (or use setwd("")) source('Schelde_pars.R') ################################################################################ # UTILITIES # ################################################################################ # Function that estimates discrepancy between estimated and true total alkalinity # Root of this function = solution of equilibrium pH pHfunction <- function(pH, DIC, TA, SumNH4) return(TA-TA_estimate(pH, DIC, SumNH4)) ################################################################################ # ORDINARY DIFFERENTIAL EQUATIONS # ################################################################################ OSAmodel <- function (tt, state, parms, scenario="B1") { with (as.list(c(state, parms)), { pH <- uniroot (pHfunction, interval = c(6, 10), tol=1e-20, DIC=SumCO2, TA=TA, SumNH4=SumNH4)$root #-------------------------- # PHYSICAL PROCESSES #-------------------------- H <- 10^(-pH) * 1e6 CO2 <- H*H/(H*K1CO2 + H*H + K1CO2*K2CO2)*SumCO2 NH3 <- KNH4/(KNH4+H)*SumNH4 NH4 <- SumNH4 - NH3 # air-water exchange ECO2 <- KL * (CO2sat - CO2) EO2 <- KL * (O2sat - O2) ENH3 <- KL * (NH3sat - NH3) # Transport TO2 <- Transport(O2, O2_up, O2_down) TNO3 <- Transport(NO3, NO3_up, NO3_down) TTA <- Transport(TA, TA_up, TA_down) TSumCO2 <- Transport(SumCO2, SumCO2_up, SumCO2_down) TSumNH4 <- Transport(SumNH4, SumNH4_up, SumNH4_down) # Wastewater treatment plant in Brussels scenario if (scenario == "A" && tt > 365) { TOM <- Transport(OM, OM_up_A, OM_down) } else TOM <- Transport(OM, OM_up , OM_down) # Spills if (scenario == "B1" && (tt > 360 && tt < 370)) { AddNH4NO3 <- SpillNH4NO3 # NH4+NO3- - tanker addition } else AddNH4NO3 <- 0 if (scenario == "C" && (tt > 360 && tt < 370)) { AddNH3 <- SpillNH3 # NH3 - tanker input } else AddNH3 <- 0 #-------------------------- # BIOGEOCHEMICAL PROCESSES: #-------------------------- # Oxic mineralisation ROx <- rOM * OM * (O2/(O2 + ksO2)) ROxCarbon <- ROx * C_Nratio # Nitrification RNit <- rNitri * NH4 * (O2/(O2 + ksO2)) #-------------------------- # RATE OF CHANGE #-------------------------- dOM <- TOM - ROx dO2 <- TO2 + EO2 - ROxCarbon - 2*RNit dNO3 <- TNO3 + RNit + AddNH4NO3 dSumCO2 <- TSumCO2 + ECO2 + ROxCarbon dSumNH4 <- TSumNH4 + ENH3 + ROx - RNit + AddNH3 + AddNH4NO3 dTA <- TTA + ENH3 + ROx-2*RNit + AddNH3 return(list(c(dOM, dO2, dNO3, dTA, dSumNH4, dSumCO2), c(pH=pH, CO2=CO2, NH3=NH3, NH4=SumNH4-NH3))) }) } ################################################################################ # MODEL APPLICATIONS # ################################################################################ #--------------------- # Akalinity at boundaries #--------------------- TA_down<- TA_estimate(pH_down, SumCO2_down, SumNH4_down) TA_up <- TA_estimate(pH_up , SumCO2_up , SumNH4_up) #--------------------- # initial conditions #--------------------- TA_ini <- TA_estimate(pH_ini , SumCO2_ini , SumNH4_ini) state <- c(OM=OM_ini, O2=O2_ini, NO3=NO3_ini, TA=TA_ini, SumNH4=SumNH4_ini, SumCO2=SumCO2_ini) #--------------------- # run model #--------------------- times <- c(0, 350:405) outA <- vode(state, times, OSAmodel, phPars, scenario = "A" , hmax = 1) outB <- vode(state, times, OSAmodel, phPars, scenario = "B1", hmax = 1) outC <- vode(state, times, OSAmodel, phPars, scenario = "C" , hmax = 1) #--------------------- # plot model output #--------------------- par(mfrow = c(3, 4), mar = c(1, 2, 2, 1), oma = c(3, 3, 3, 0)) Selection <- c("pH","TA","SumCO2","O2") plot(outA, mfrow = NULL, xlim = c(350,405), type = "l", xaxt = "n", which = Selection) plot(outB, mfrow = NULL, xlim = c(350,405), type = "l", xaxt = "n", which = Selection) plot(outC, mfrow = NULL, xlim = c(350,405), type = "l", xaxt = "n", which = Selection) mtext(side = 1, outer = TRUE, "time, d", line = 2, cex = 1.2) mtext(side = 2, at = 0.2, outer = TRUE, "Scenario C", line = 1.5, cex = 1.2) mtext(side = 2, at = 0.5, outer = TRUE, "Scenario B", line = 1.5, cex = 1.2) mtext(side = 2, at = 0.8, outer = TRUE, "Scenario A", line = 1.5, cex = 1.2) mtext(side = 3, at = 0.125, outer = TRUE, "pH, -", line = 1, cex = 1.2) mtext(side = 3, at = 0.375, outer = TRUE, "TA, mol/kg", line = 1, cex = 1.2) mtext(side = 3, at = 1-0.375, outer = TRUE, "CO2, mol/kg", line = 1, cex = 1.2) mtext(side = 3, at = 1-0.125, outer = TRUE, "O2, mol/kg", line = 1, cex = 1.2) deSolve/inst/doc/examples/Schelde_pars.R0000754000175100001440000001350612352122174017756 0ustar hornikusers################################################################################ # pH model of the Scheldt estuary # # Hofmann AF, Meysman FJR, Soetaert K, Middelburg J, 2008. # # A step-by-step procedure for pH model construction in aquatic systems # # Biogeosciences # # # # MODEL PARAMETERS, INITIAL CONDITIONS, COMMON MODEL ROUTINES # # Implementation: Andreas Hofmann, Karline Soetaert - NIOZ # ################################################################################ require(deSolve) ################################################################################ # Global Physical parameters ## ################################################################################ Q <- 8640000 # m3/d discharge V <- 108798000 # m3 volume Eprime <- 13824000 # m3/d averaged bulk-dispersion coefficient, 160 m3/s) ################################################################################ # boundary conditions ################################################################################ # upper boundary OM_up <- 50 # umol/kg-soln NO3_up <- 350 # umol/kg-soln O2_up <- 70 # umol/kg-soln pH_up <- 7.6 SumNH4_up <- 80 # umol/kg-soln SumCO2_up <- 7100 # umol/kg-soln # lower boundary - pH and alkalinity are consistent OM_down <- 25 # umol/kg-soln NO3_down <- 260 # umol/kg-soln O2_down <- 240 # umol/kg-soln pH_down <- 7.92 SumNH4_down <- 7 # umol/kg-soln SumCO2_down <- 4400 # umol/kg-soln ################################################################################ # initial conditions: as derived from steady state run; pH and alkinity consistent ################################################################################ OM_ini <- 31.9688 # umol/kg-soln NO3_ini <- 340.235 # umol/kg-soln O2_ini <- 157.922 # umol/kg-soln pH_ini <- 7.7 # SumNH4_ini <- 35.8406 # umol/kg-soln SumCO2_ini <- 6017.28 # umol/kg-soln ################################################################################ # MODEL PARAMETERS # ################################################################################ phPars <- c( KL = 0.28 , # 1/d proportionality factor for air-water exchange rOM = 0.1 , # 1/d first-order oxic mineralisation rate of organic matter rNitri = 0.26 , # 1/d first order nitrification rate (with resp. to Ammonium) ksO2 = 20.0 , # umol-O2/kg-soln monod half-saturation constant Oxygen (ox min & nit) k1 = 1e3 , # 1/d "instantaneous" rate for forward equilibrium reactions C_Nratio = 8 , # mol C/mol N C:N ratio oforganic matter rDenit = 0.2 , # 1/d first order mineralisation due to denit rate (w.r.t. OM) ksNO3 = 45 , # umol-NO3/kg monod half-saturation constant nitrate denitrification ksO2inhib = 22 , # umol-02/kg monod inhibition term oxygen # saturated concentrations - calculated for T=12 and S=5 # CO2sat = 19 , # umol/kg-soln O2sat = 325 , # umol/kg-soln NH3sat = 0.0001 , # umol/kg-soln ################################################################################ ## DIFFERENT SCENARIOS: # @ A decreased waste load due to a sewage treatement plant in Brussels # @ B1 a 10000 ton fertilizer (NH4+/NO3-) ship sinks: different modelling approach (extra NH4NO3 addition) # @ C a 10000 ton NH3 ship sinks: modelling approach 1 (extra NH3 addition) ################################################################################ # Scenario A: Brussels wastewater treatment plant scenario reduces upstream conc of OM # OM_up_A = 25 , # umol/kg-soln # Scenario B1: Ammonium-Nitrate (fertilizer) tank ship scenario: # # model it as extra NH4+ and NO3 - addition of 10000 tpms# SpillNH4NO3 = ((10000 * 1000000)/(18 + 62)) * # Total substance in mol over 10 days 1000000 / (V * 1000) / 10, # Conc in umol/kg per day # Scenario C: NH3 (Ammonia) tank ship scenario (10000 tons NH3 input) # SpillNH3 = ((10000 * 1000000) / 17) * # Total substance in mol/10 days 1000000 / (V * 1000) / 10 # Conc in umol/kg per day ) ################################################################################ # Dissociation constants ################################################################################ require(seacarb) # Temperature, salinity settings Temp <- 12 # dg C Sal <- 5 # K1CO2 <- K1(S = Sal, T = Temp, P = 0)*1e6 # umol/kg-soln K2CO2 <- K2(S = Sal, T = Temp, P = 0)*1e6 # umol/kg-soln KNH4 <- Kn(S = Sal, T = Temp, P = 0)*1e6 # umol/kg-soln KW <- Kw(S = Sal, T = Temp, P = 0)*1e12 # (mol/kg-soln)^2 ################################################################################ # COMMON MODEL FUNCTIONS # ################################################################################ # Advective-dispersive transport Transport <- function (y, y.up, y.down) { # Q: discharge, m3/d; Eprime: bulk dispersion coefficient, V: Volume Input <- Q * c(y.up, y) - Eprime * diff(c(y.up, y, y.down)) dy <- -diff(Input)/V return(dy) } # Estimate alkalinity based on pH, sum CO2, sum NH4 TA_estimate <- function(pH, DIC, SumNH4) { H <- 10^(-pH)*1e6 HCO3 <- H*K1CO2/(H*K1CO2 + H*H + K1CO2*K2CO2)*DIC CO3 <- K1CO2*K2CO2/(H*K1CO2 + H*H + K1CO2*K2CO2)*DIC NH3 <- KNH4/(KNH4+H)*SumNH4 return(as.double(HCO3 + 2*CO3 + NH3 - H)) # Total alkalinity } deSolve/inst/doc/mymod.f0000754000175100001440000000221212352122166014706 0ustar hornikusersc file mymodf.f subroutine initmod(odeparms) external odeparms double precision parms(3) common /myparms/parms call odeparms(3, parms) return end subroutine derivs (neq, t, y, ydot, yout, ip) double precision t, y, ydot, k1, k2, k3 integer neq, ip(*) dimension y(3), ydot(3), yout(*) common /myparms/k1,k2,k3 if(ip(1) < 1) call rexit("nout should be at least 1") ydot(1) = -k1*y(1) + k2*y(2)*y(3) ydot(3) = k3*y(2)*y(2) ydot(2) = -ydot(1) - ydot(3) yout(1) = y(1) + y(2) + y(3) return end subroutine jac (neq, t, y, ml, mu, pd, nrowpd, yout, ip) integer neq, ml, mu, nrowpd, ip double precision y(*), pd(nrowpd,*), yout(*), t, k1, k2, k3 common /myparms/k1, k2, k3 pd(1,1) = -k1 pd(2,1) = k1 pd(3,1) = 0.0 pd(1,2) = k2*y(3) pd(2,2) = -k2*y(3) - 2*k3*y(2) pd(3,2) = 2*k3*y(2) pd(1,3) = k2*y(2) pd(2,3) = -k2*y(2) pd(3,3) = 0.0 return end c end of file mymodf.f deSolve/inst/doc/dynload/0000755000175100001440000000000013132171175015046 5ustar hornikusersdeSolve/inst/doc/dynload/Aquaphy.f0000754000175100001440000001122612352122173016626 0ustar hornikusers c the Aquaphy algal model c -------- Aquaphy.f -> Aquaphy.dll ------ c compile in R with: system("g77 -shared -o Aquaphy Aquaphy") c or with system("R CMD SHLIB Aquaphy") c======================================================================= c======================================================================= c Model initialisation c======================================================================= c======================================================================= c======================================================================= c Initialise parameter common block c======================================================================= subroutine initaquaphy(odeparms) external odeparms double precision pars(19) common /myparms/pars call odeparms(19, pars) return end c======================================================================= c Algal dynamics c======================================================================= subroutine aquaphy (neq, t, y, ydot,out,IP) implicit none integer neq, ip(*) double precision t, y(*), ydot(*), out(*) c parameters double precision maxPhotoSynt,rMortPHY,alpha,pExudation, & & maxProteinSynt,ksDIN,minpLMW,maxpLMW,minQuotum, & & maxStorage,respirationRate,pResp,catabolismRate, & & dilutionRate,rNCProtein,inputDIN,rChlN,parMean, & & dayLength common /myparms/ maxPhotoSynt,rMortPHY,alpha,pExudation, & & maxProteinSynt,ksDIN,minpLMW,maxpLMW,minQuotum, & & maxStorage,respirationRate,pResp,catabolismRate, & & dilutionRate,rNCProtein,inputDIN,rChlN,parMean, & & dayLength c variables double precision :: & & DIN,PROTEIN,RESERVE,LMW,dLMW,dRESERVE,dPROTEIN,dDIN,PAR, & & PhytoC,PhytoN,NCratio,Chlorophyll,TotalN,ChlCratio,PartLMW, & & hourofday, Limfac,PhotoSynthesis,Exudation,MonodQuotum, & & ProteinSynthesis,Storage,Respiration,Catabolism c ------------------------------------------------------------------------ if(ip(1) < 6) call rexit("nout should at least be 6") DIN = y(1) PROTEIN = y(2) RESERVE = y(3) LMW = y(4) c PAR, on-off function depending on the hour within a day hourofday = mod(t,24.d0) if (hourofday < dayLength) THEN PAR = parMean else PAR = 0.d0 endif c the output variables PhytoC = PROTEIN + RESERVE + LMW ! all components contain carbon PhytoN = PROTEIN * rNCProtein ! only proteins contain nitrogen NCratio = PhytoN / PhytoC Chlorophyll = PhytoN * rChlN TotalN = PhytoN + DIN ChlCratio = Chlorophyll / PhytoC c the rates, in mmol/hr PartLMW = LMW / PhytoC Limfac = min(1.d0,(maxpLMW -PartLMW)/(maxpLMW-minpLMW)) Limfac = max(0.d0,Limfac) PhotoSynthesis = maxPhotoSynt*Limfac * & & (1.d0-exp(alpha*PAR/maxPhotoSynt)) * PROTEIN Exudation = pExudation * PhotoSynthesis MonodQuotum = max(0.d0,LMW / PROTEIN - minQuotum) ProteinSynthesis= maxProteinSynt*MonodQuotum & & * DIN / (DIN+ksDIN) * PROTEIN Storage = maxStorage *MonodQuotum * PROTEIN Respiration = respirationRate * LMW & & + pResp * ProteinSynthesis Catabolism = catabolismRate * RESERVE c the rates of change of state variables; includes dilution effects (last term) dLMW = PhotoSynthesis + Catabolism & & - Exudation - Storage - Respiration - ProteinSynthesis & & - dilutionRate * LMW dRESERVE = Storage - Catabolism - dilutionRate * RESERVE dPROTEIN = ProteinSynthesis - dilutionRate * PROTEIN dDIN = -ProteinSynthesis * rNCProtein & & - dilutionRate * (DIN - inputDIN) c the vector with rate of changes ydot(1) = dDIN ydot(2) = dPROTEIN ydot(3) = dRESERVE ydot(4) = dLMW c the ordinary variables out(1) = PAR out(2) = TotalN out(3) = PhotoSynthesis out(4) = NCratio out(5) = ChlCratio out(6) = Chlorophyll return end subroutine Aquaphy deSolve/inst/doc/dynload/zvodedll.f0000754000175100001440000000167712352122173017052 0ustar hornikusers C The program below uses ZVODE to solve the following system of 2 ODEs: C dz/dt = i*z; dw/dt = -i*w*w*z,z(0) = 1; w(0) = 1/2.1, t = 0 to 2*pi. C Solution: w = 1/(z + 1.1), z = exp(it). As z traces the unit circle, C w traces a circle of radius 10/2.1 with center at 11/2.1. SUBROUTINE FEX (NEQ, T, Y, YDOT, RPAR, IPAR) INTEGER NEQ, IPAR(*) DOUBLE COMPLEX Y(NEQ), YDOT(NEQ), RPAR(*), CMP DOUBLE PRECISION T character(len=100) msg c the imaginary unit i CMP = DCMPLX(0.0D0,1.0D0) YDOT(1) = CMP*Y(1) YDOT(2) = -CMP*Y(2)*Y(2)*Y(1) RETURN END SUBROUTINE JEX (NEQ, T, Y, ML, MU, PD, NRPD, RPAR, IPAR) INTEGER NEQ, ML, MU, NRPD, IPAR(*) DOUBLE COMPLEX Y(NEQ), PD(NRPD,NEQ), RPAR(*), CMP DOUBLE PRECISION T c the imaginary unit i CMP = DCMPLX(0.0D0,1.0D0) PD(2,3) = -2.0D0*CMP*Y(1)*Y(2) PD(2,1) = -CMP*Y(2)*Y(2) PD(1,1) = CMP RETURN END deSolve/inst/doc/dynload/satres.R0000754000175100001440000002145312352122173016476 0ustar hornikusers##--------------------------------------------------------------------------- ## A Physiologically Based Pharmacokinetic (PBPK) model ## before trying this code, the C or FORTRAN program has to be compiled ## this can be done in R: ## system("R CMD SHLIB satres.f") ## or: ## system("R CMD SHLIB satresC.c") ## do make sure that this file is in the working directory... ## (if not, use setwd() ) ##--------------------------------------------------------------------------- ## We want to be able to run three kinds of dosing regimens with the same ## model: ## - single gavage ## - repeated gavage ## - dietary library(deSolve) wh <- menu(c("C version", "FORTRAN version"), graphics = TRUE, title = "Which language version?") if (wh == 0) stop("User cancelled", cal. = FALSE) DLLname <- switch(wh, "satresC", "satres") FullDLLname <- paste(DLLname, .Platform$dynlib.ext, sep = "") if (!file.exists(FullDLLname)) stop(paste("You need to create", FullDLLname, "using 'R CMD SHLIB", DLLname, "'"), call. = FALSE) dyn.load(FullDLLname) if(length(grep("intakes", search())) == 0) attach("intakes.RData") ## Dose is the Dose in mg/kg ## Doseint is NA for single dose, interval ## between doses in hours for repeated dosing, -1 to use the intake data ## MaxTime is the largest requested output time, and is calculated ## internally. ## Other parms as in satres.c defParms <- c(Vc = 0.0027, Vt = 0.0545, kd = 0.00059/0.0027, ka = 0.537, Tm = 860.9, KT = 0.0015, kfil = 0.6830/0.0027, Vfil = 0.01, free = 0.02, BW = 0.025, Dose = NA, Doseint = NA, Qd = NA, Qfil = NA, MaxTime = NA, TDose = NA) ## initparms is called as, for example ## P <- initparms(list(Dose = 60, Doseint = 24, Vc = 0.0030)) ## Gives a parameter list that the model can use, for 60 mg/kg ## every 24 hours dosing, setting Vc to 0.003 L initparms <- function(newParms = NULL) { Parms <- defParms if (!is.null(newParms)) { ldots <- as.list(newParms) if (!all(names(ldots) %in% names(defParms))) stop("illegal parameter name") Parms[names(ldots)] <- unlist(ldots) } lParms <- as.list(Parms) Parms["Qd"] <- with(lParms, kd * Vc) Parms["Qfil"] <- with(lParms, kfil*Vc) Parms["TDose"] <- Parms["Dose"] * Parms["BW"] Parms } ## newParms is a list with parameter names initforcs <- function(Parms) { if (is.na(Parms["Doseint"])) RepDose <- matrix(c(0, Parms["MaxTime"], 0, 0), ncol = 2) else if (Parms["Doseint"] > 0) { Parms["TDose"] <- Parms["TDose"]/(5/3600) dosetimes <- seq(0, Parms["MaxTime"] - 5/3600, by = Parms["Doseint"]) dosesoff <- dosetimes + 5/3600 RepDose <- cbind(sort(c(dosetimes, dosesoff)), rep(c(Parms["TDose"], 0), length(dosetimes))) } else if (Parms["Doseint"] < 0) { maxdays <- ceiling(Parms["MaxTime"]/24) dosetimes <- as.vector(outer(intakes[, "hours"], 24*(0:maxdays), "+")) doserates <- rep(intakes[, "Rfood.femaleB6C3F1"], (maxdays + 1)) * Parms["TDose"] RepDose <- cbind(dosetimes, doserates) } RepDose } ## initState returns the initialized state vector. initstate <- function(Parms){ if (is.na(Parms["Doseint"])) structure(c(rep(0, 3), Parms["TDose"], 0, 0), names = c("Ccentral", "Csecond", "Cfiltrate", "Agut", "Elim", "AUC")) else structure(rep(0, 6), names = c("Ccentral", "Csecond", "Cfiltrate", "Agut", "Elim", "AUC")) } ## pfoasat runs the model. On input, ## - Times is a vector of time values ## at which model results are desired. ## - newParms is a list like the input ## to initparms, above. ## - method is a string giving the solution method to use ## see the documentation for deSolve::ode for details ## there. the elipsis (...) is for additional arguments ## to the odesolver (see ode and the individual methods ## for details). ## The return value is a matrix of values. Column 1 is the ## time vector, Columns 2 - 5 are the concentrations in ## compartments 1 - 4 (just before dosing, in the case of repeated ## dosing). ## ## Example: to match the 7 and 17 day 20 mg/kg repeated dosing ## using lsode: ## out <- pfoasat(24 * c(0, 7, 17), newParms = list(Dose = 20, Doseint = 24)) ## when finished, you can unload the dll with ## dyn.unload("satres") pfoasat <- function(Times, newParms, method = "lsode", ...){ if ("MaxTime" %in% names(newParms)) newParms["MaxTime"] <- max(Times) else newParms <- c(newParms, MaxTime = max(Times)) Parmsout <- initparms(newParms) Forcings <- initforcs(Parmsout) y <- initstate(Parmsout) ode(y, Times, "derivs", parms = Parmsout, method = method, dllname = DLLname, initfunc = "initmod", forcings = Forcings, initforc = "initforc", fcontrol = list(method = "constant"), nout = 1, outnames = "Total", ...) } ## ------------------------------------------------------------------- ## Simulate a range of doses, both be repeated gavage and an equivalent ## dose via the diet. Plot the time course for 1 and 500 mg/kg/day, ## and the total dose-response. Doses <- c(1, 2, 5, 10, 20, 50, 100, 200, 500, 1000) nperhour <- 6 ## for smooth plotting ndays <- 30 ## follow for ndays outs <- vector("list", length = 2*length(Doses)) dim(outs) <- c(length(Doses), 2) rownames(outs) <- as.character(Doses) for (i in seq(along = Doses)) { outs[[i, 1]] <- list(Dose = Doses[i], out = as.data.frame(pfoasat(seq(0, 24*ndays, by = 1/nperhour), newParms = list(Dose = Doses[i], Doseint = 24), hmax = 0.001)) ) outs[[i, 2]] <- list(Dose = Doses[i], out = as.data.frame(pfoasat(seq(0, 24*ndays, by = 1/nperhour), newParms = list(Dose = Doses[i], Doseint = -1), hmax = 0.4)) ) } ## Plot 1 and 500 mg/kg/day doses, to see the contrast par(mfrow = c(1, 2), las = 1, bty = "l", mar = c(5, 4, 0, 1)) ## ------------------------ Central compartment ylim = c(0, 500) plot(Ccentral ~ I(time/24), data = outs[["1", 1]]$out, type = "l", ylim = ylim, xlab = "Days in Study", ylab = "Conc. PFOA in Central Cmpt.", sub = "A: 1 mg/kg/day") lines(Ccentral ~ I(time/24), data = outs[["1", 2]]$out, lty = "44") legend("right",legend = c("Daily gavage", "Feed"), lty = c("solid", "44"), bty = "n") plot(Ccentral ~ I(time/24), data = outs[["500", 1]]$out, type = "l", ylim = ylim, xlab = "Days in Study", ylab = "Conc. PFOA in Central Cmpt.", sub = "B: 500 mg/kg/day") lines(Ccentral ~ I(time/24), data = outs[["500", 2]]$out, lty = "44") ## Force a pause after this figure tmp <- readline(prompt = "press to continue ... ") ## now, the curve relating external dose to internal dose-metric. ## Function to extract the dose-metric ## z is a dataframe like the ones we've made here ## We compute the average daily peak concentration in ## the central compartment and the daily average AUC in the ## central compartment. dosemetric <- function(z) { ## drop the first time (0) z <- z[-1,] ## split the data on day: day <- ceiling(z$time/24) dailypeaks <- tapply(z$Ccentral, day, function(x) max(x)) dailyaucs <- tapply(z$AUC, day, function(x) (x[length(x)] - x[1]))/24 c(avgpeak = mean(dailypeaks), avgauc = mean(dailyaucs)) } ## Create a matrix to hold the doses DoseMets <- matrix(nrow = length(Doses), ncol = 4, dimnames = list(rownames(outs), c("gavage.peak", "gavage.auc", "diet.peak", "diet.auc"))) for (dose in rownames(outs)) { DoseMets[dose, c("gavage.peak", "gavage.auc")] <- dosemetric(outs[[dose, 1]]$out) DoseMets[dose, c("diet.peak", "diet.auc")] <- dosemetric(outs[[dose, 2]]$out) } DoseMets <- as.data.frame(cbind(Doses, DoseMets)) par(mfrow = c(1, 1), bty = "l", las = 1, mar = c(4, 4, 0, 0)) plot(gavage.peak ~ Doses, DoseMets, ylim = range(DoseMets[, 2:5]), xlab = "Administered Dose (mg/kg/day)", ylab = "Dose Metric", log = "xy", pch = 1) zz <- spline(log(DoseMets$Doses), log(DoseMets$gavage.peak)) lines(exp(zz[[1]]), exp(zz[[2]])) points(gavage.auc ~ Doses, DoseMets, pch = 20) zz <- spline(log(DoseMets$Doses), log(DoseMets$gavage.auc)) lines(exp(zz[[1]]), exp(zz[[2]]), lty = "33") points(diet.peak ~ Doses, DoseMets, pch = 1, col = "blue") zz <- spline(log(DoseMets$Doses), log(DoseMets$diet.peak)) lines(exp(zz[[1]]), exp(zz[[2]]), col = "blue") points(diet.auc ~ Doses, DoseMets, pch = 20, col = "blue") zz <- spline(log(DoseMets$Doses), log(DoseMets$diet.auc)) lines(exp(zz[[1]]), exp(zz[[2]]), lty = "33", col = "blue") legend("topleft", legend = c("gavage peak", "gavage AUC", "diet peak", "diet auc"), pch = c(1, 20, 1, 20), lty = c("solid", "33", "solid", "33"), col = c("black", "black", "blue", "blue"), bty = "n") ## unload the DLL dyn.unload(FullDLLname) deSolve/inst/doc/dynload/satres.f0000754000175100001440000000310112352122173016510 0ustar hornikusersC file satres.f C Initializer for parameter common block subroutine initmod(odeparms) external odeparms double precision parms(16) common /myparms/parms call odeparms(16, parms) return end C Initializer for forcing common block subroutine initforc(odeforcs) external odeforcs double precision forcs(1) common /myforcs/forcs call odeforcs(1, forcs) return end C Compartments are: C y(1) central compartment C y(2) second compartment C y(3) filtrate compartment C y(4) 'Gut' C y(5) Total eliminated C y(6) AUC central compartment C Derivatives and one output variable subroutine derivs(neq, t, y, ydot, out, ip) integer neq, IP(*) double precision t, y(neq), ydot(neq), out(*) double precision Vc, Vt, kd, ka, Tm, KT, Kfil, Vfil, free, BW, $ Dose, DoseInt, Qd, Qfil, MaxTime, TDose, TDoseRt common /myparms/Vc, Vt, kd, ka, Tm, KT, Kfil, Vfil, free, BW, $ Dose, DoseInt, Qd, Qfil, MaxTime, TDose common /myforcs/TDoseRt if (ip(1) < 1) call rexit("nout should be at least 1") ydot(1) = (ka * y(4) - Qd * free * y(1) + Qd * y(2) - $ Qfil * y(1) * free) / Vc + Tm * y(3) / (KT + y(3)) ydot(2) = (free * Qd * y(1) - Qd * y(2)) / Vt ydot(3) = (Vc * kfil * y(1) * free - Vc * Tm * y(3) / (KT + y(3))- $ Vc * kfil * y(3)) / Vfil ydot(4) = -ka * y(4) + TDoseRt ydot(5) = Vc * kfil * y(3) ydot(6) = y(1) out(1) = y(1) * Vc + y(2) * Vt + y(3) * Vfil + y(4) + y(5) return end deSolve/inst/doc/dynload/odefor2.f0000754000175100001440000000225112352122173016554 0ustar hornikusersc -------- odefor2.f -> odefor2.dll ------ c compile in R with: system("g77 -shared -o odefor2.dll odefor2.f") c or with system("R CMD SHLIB odefor2.f") c fortran source without initialiser c Rate of change and 3 output variables subroutine derivsfor2 (neq, t, y, ydot,out,IP) integer neq, IP(*) double precision t, y(neq), ydot(neq), out(*), k1, k2, k3 k1 = 0.04 k2 = 1e4 k3 = 3e7 if(IP(1) < 1) call rexit("nout should be at least 1") ydot(1) = -k1*y(1) + k2*y(2)*y(3) ydot(3) = k3*y(2)*y(2) ydot(2) = -ydot(1) - ydot(3) out(1)=y(1)+y(2)+y(3) out(2)=y(1)*2 out(3)=k3 return end c The jacobian matrix subroutine jacfor2 (neq, t, y, ml, mu, pd, nrowpd,RP,IP) integer neq, ml, mu, nrowpd ,IP(*) double precision y(*), pd(nrowpd,*), t, RP(*), k1, k2, k3 k1 = 0.04 k2 = 1e4 k3 = 3e7 pd(1,1) = -k1 pd(2,1) = k1 pd(3,1) = 0.0 pd(1,2) = k2*y(3) pd(2,2) = -k2*y(3) - 2*k3*y(2) pd(3,2) = 2*k3*y(2) pd(1,3) = k2*y(2) pd(2,3) = -k2*y(2) pd(3,3) = 0.0 return end deSolve/inst/doc/dynload/ex_Aquaphy.c0000754000175100001440000001536612352122173017330 0ustar hornikusers/* file ex_aquaphy.c The Aquaphy algal model -------- ex_Aquaphy.c -> ex_Aquaphy.dll ------ compile in R with: system("gcc -shared -o Aquaphy Aquaphy") or with system("R CMD SHLIB ex_Aquaphy") */ #include static double parms[19]; #define maxPhotoSynt parms[0] #define rMortPHY parms[1] #define alpha parms[2] #define pExudation parms[3] #define maxProteinSynt parms[4] #define ksDIN parms[5] #define minpLMW parms[6] #define maxpLMW parms[7] #define minQuotum parms[8] #define maxStorage parms[9] #define respirationRate parms[10] #define pResp parms[11] #define catabolismRate parms[12] #define dilutionRate parms[13] #define rNCProtein parms[14] #define inputDIN parms[15] #define rChlN parms[16] #define parMean parms[17] #define dayLength parms[18] static double forcs[1]; #define Light forcs[0] #define DIN y[0] #define PROTEIN y[1] #define RESERVE y[2] #define LMW y[3] #define dDIN ydot[0] #define dPROTEIN ydot[1] #define dRESERVE ydot[2] #define dLMW ydot[3] #define PAR out[0] #define TotalN out[1] #define PhotoSynthesis out[2] #define NCratio out[3] #define ChlCratio out[4] #define Chlorophyll out[5] /*======================================================================= c======================================================================= c Model initialisation c======================================================================= c======================================================================= c======================================================================= c Initialise parameter common block c======================================================================= */ void iniaqua(void (* odeparms)(int *, double *)) { int N=19; odeparms(&N, parms); } /* c======================================================================= c Initialise forcing function common block c======================================================================= */ void initaqforc(void (* odeforc)(int *, double *)) { int N=1; odeforc(&N, forcs); } /* c======================================================================= c Algal dynamics - light an on-off function c======================================================================= */ void aquaphy (int *neq, double *t, double *y, double *ydot, double *out, int *ip) { double PhytoC,PhytoN,PartLMW,Limfac,Exudation,MonodQuotum,hourofday, ProteinSynthesis,Storage,Respiration,Catabolism; if(ip[0] < 6) error("nout should at least be 6"); /* PAR, on-off function depending on the hour within a day*/ hourofday = fmod(*t,24.0); if (hourofday < dayLength) PAR = parMean; else PAR = 0.0; /* the output variables - all components contain carbon only proteins contain nitrogen */ PhytoC = PROTEIN + RESERVE + LMW; PhytoN = PROTEIN * rNCProtein; NCratio = PhytoN / PhytoC; Chlorophyll = PhytoN * rChlN; TotalN = PhytoN + DIN; ChlCratio = Chlorophyll / PhytoC; /* the rates, in mmol/hr */ PartLMW = LMW / PhytoC; Limfac = fmin(1.0,(maxpLMW -PartLMW)/(maxpLMW-minpLMW)); Limfac = fmax(0.0,Limfac); PhotoSynthesis = maxPhotoSynt*Limfac * (1.0-exp(alpha*PAR/maxPhotoSynt)) * PROTEIN; Exudation = pExudation * PhotoSynthesis; MonodQuotum = fmax(0.0,LMW / PROTEIN - minQuotum); ProteinSynthesis= maxProteinSynt*MonodQuotum * DIN / (DIN+ksDIN) * PROTEIN; Storage = maxStorage *MonodQuotum * PROTEIN; Respiration = respirationRate * LMW + pResp * ProteinSynthesis; Catabolism = catabolismRate * RESERVE; /* the rates of change of state variables; includes dilution effects (last term) */ dLMW = PhotoSynthesis + Catabolism - Exudation - Storage - Respiration - ProteinSynthesis - dilutionRate * LMW; dRESERVE = Storage - Catabolism - dilutionRate * RESERVE; dPROTEIN = ProteinSynthesis - dilutionRate * PROTEIN; dDIN = -ProteinSynthesis * rNCProtein - dilutionRate * (DIN - inputDIN); } /* Algal dynamics with forcings c======================================================================= */ void aquaphyforc (int *neq, double *t, double *y, double *ydot, double *out, int *ip) { double PhytoC,PhytoN,PartLMW,Limfac,Exudation,MonodQuotum, ProteinSynthesis,Storage,Respiration,Catabolism; if(ip[0] < 6) error("nout should at least be 6"); PAR = Light; /* the output variables - all components contain carbon only proteins contain nitrogen */ PhytoC = PROTEIN + RESERVE + LMW; PhytoN = PROTEIN * rNCProtein; NCratio = PhytoN / PhytoC; Chlorophyll = PhytoN * rChlN; TotalN = PhytoN + DIN; ChlCratio = Chlorophyll / PhytoC; /* the rates, in mmol/hr */ PartLMW = LMW / PhytoC; Limfac = fmin(1.0,(maxpLMW -PartLMW)/(maxpLMW-minpLMW)); Limfac = fmax(0.0,Limfac); PhotoSynthesis = maxPhotoSynt*Limfac * (1.0-exp(alpha*PAR/maxPhotoSynt)) * PROTEIN; Exudation = pExudation * PhotoSynthesis; MonodQuotum = fmax(0.0,LMW / PROTEIN - minQuotum); ProteinSynthesis= maxProteinSynt*MonodQuotum * DIN / (DIN+ksDIN) * PROTEIN; Storage = maxStorage *MonodQuotum * PROTEIN; Respiration = respirationRate * LMW + pResp * ProteinSynthesis; Catabolism = catabolismRate * RESERVE; /* the rates of change of state variables; includes dilution effects (last term) */ dLMW = PhotoSynthesis + Catabolism - Exudation - Storage - Respiration - ProteinSynthesis - dilutionRate * LMW; dRESERVE = Storage - Catabolism - dilutionRate * RESERVE; dPROTEIN = ProteinSynthesis - dilutionRate * PROTEIN; dDIN = -ProteinSynthesis * rNCProtein - dilutionRate * (DIN - inputDIN); } deSolve/inst/doc/dynload/ex_Aquaphy.f0000754000175100001440000002136212352122173017324 0ustar hornikusers c the Aquaphy algal model c -------- Aquaphy.f -> Aquaphy.dll ------ c compile in R with: system("g77 -shared -o Aquaphy Aquaphy") c or with system("R CMD SHLIB Aquaphy") c======================================================================= c======================================================================= c Model initialisation c======================================================================= c======================================================================= c======================================================================= c Initialise parameter common block c======================================================================= subroutine iniaqua(odeparms) external odeparms double precision pars(19) common /myparms/pars call odeparms(19, pars) return end c======================================================================= c Initialise forcing function common block c======================================================================= subroutine initaqforc(odeforc) external odeparms double precision forcs(1) common /myforcs/forcs call odeforc(1, forcs) return end c======================================================================= c Algal dynamics - light an on-off function c======================================================================= subroutine aquaphy (neq, t, y, ydot,out,IP) implicit none integer neq, ip(*) double precision t, y(*), ydot(*), out(*) c parameters double precision maxPhotoSynt,rMortPHY,alpha,pExudation, & & maxProteinSynt,ksDIN,minpLMW,maxpLMW,minQuotum, & & maxStorage,respirationRate,pResp,catabolismRate, & & dilutionRate,rNCProtein,inputDIN,rChlN,parMean, & & dayLength common /myparms/ maxPhotoSynt,rMortPHY,alpha,pExudation, & & maxProteinSynt,ksDIN,minpLMW,maxpLMW,minQuotum, & & maxStorage,respirationRate,pResp,catabolismRate, & & dilutionRate,rNCProtein,inputDIN,rChlN,parMean, & & dayLength c variables double precision :: & & DIN,PROTEIN,RESERVE,LMW,dLMW,dRESERVE,dPROTEIN,dDIN,PAR, & & PhytoC,PhytoN,NCratio,Chlorophyll,TotalN,ChlCratio,PartLMW, & & hourofday, Limfac,PhotoSynthesis,Exudation,MonodQuotum, & & ProteinSynthesis,Storage,Respiration,Catabolism c ------------------------------------------------------------------------ if(ip(1) < 6) call rexit("nout should at least be 6") DIN = y(1) PROTEIN = y(2) RESERVE = y(3) LMW = y(4) c PAR, on-off function depending on the hour within a day hourofday = mod(t,24.d0) if (hourofday < dayLength) THEN PAR = parMean else PAR = 0.d0 endif c the output variables - all components contain carbon c only proteins contain nitrogen PhytoC = PROTEIN + RESERVE + LMW PhytoN = PROTEIN * rNCProtein NCratio = PhytoN / PhytoC Chlorophyll = PhytoN * rChlN TotalN = PhytoN + DIN ChlCratio = Chlorophyll / PhytoC c the rates, in mmol/hr PartLMW = LMW / PhytoC Limfac = min(1.d0,(maxpLMW -PartLMW)/(maxpLMW-minpLMW)) Limfac = max(0.d0,Limfac) PhotoSynthesis = maxPhotoSynt*Limfac * & & (1.d0-exp(alpha*PAR/maxPhotoSynt)) * PROTEIN Exudation = pExudation * PhotoSynthesis MonodQuotum = max(0.d0,LMW / PROTEIN - minQuotum) ProteinSynthesis= maxProteinSynt*MonodQuotum & & * DIN / (DIN+ksDIN) * PROTEIN Storage = maxStorage *MonodQuotum * PROTEIN Respiration = respirationRate * LMW & & + pResp * ProteinSynthesis Catabolism = catabolismRate * RESERVE c the rates of change of state variables; includes dilution effects (last term) dLMW = PhotoSynthesis + Catabolism & & - Exudation - Storage - Respiration - ProteinSynthesis & & - dilutionRate * LMW dRESERVE = Storage - Catabolism - dilutionRate * RESERVE dPROTEIN = ProteinSynthesis - dilutionRate * PROTEIN dDIN = -ProteinSynthesis * rNCProtein & & - dilutionRate * (DIN - inputDIN) c the vector with rate of changes ydot(1) = dDIN ydot(2) = dPROTEIN ydot(3) = dRESERVE ydot(4) = dLMW c the ordinary variables out(1) = PAR out(2) = TotalN out(3) = PhotoSynthesis out(4) = NCratio out(5) = ChlCratio out(6) = Chlorophyll return end subroutine Aquaphy c======================================================================= c Algal dynamics c======================================================================= subroutine aquaphyforc (neq, t, y, ydot,out,IP) implicit none integer neq, ip(*) double precision t, y(*), ydot(*), out(*) c parameters double precision maxPhotoSynt,rMortPHY,alpha,pExudation, & & maxProteinSynt,ksDIN,minpLMW,maxpLMW,minQuotum, & & maxStorage,respirationRate,pResp,catabolismRate, & & dilutionRate,rNCProtein,inputDIN,rChlN,parMean, & & dayLength common /myparms/ maxPhotoSynt,rMortPHY,alpha,pExudation, & & maxProteinSynt,ksDIN,minpLMW,maxpLMW,minQuotum, & & maxStorage,respirationRate,pResp,catabolismRate, & & dilutionRate,rNCProtein,inputDIN,rChlN,parMean, & & dayLength c PAR is a forcing function here... double precision PAR common /myforcs/PAR c variables double precision :: & & DIN,PROTEIN,RESERVE,LMW,dLMW,dRESERVE,dPROTEIN,dDIN, & & PhytoC,PhytoN,NCratio,Chlorophyll,TotalN,ChlCratio,PartLMW, & & Limfac,PhotoSynthesis,Exudation,MonodQuotum, & & ProteinSynthesis,Storage,Respiration,Catabolism c ------------------------------------------------------------------------ if(ip(1) < 6) call rexit("nout should at least be 6") DIN = y(1) PROTEIN = y(2) RESERVE = y(3) LMW = y(4) c the output variables PhytoC = PROTEIN + RESERVE + LMW ! all components contain carbon PhytoN = PROTEIN * rNCProtein ! only proteins contain nitrogen NCratio = PhytoN / PhytoC Chlorophyll = PhytoN * rChlN TotalN = PhytoN + DIN ChlCratio = Chlorophyll / PhytoC c the rates, in mmol/hr PartLMW = LMW / PhytoC Limfac = min(1.d0,(maxpLMW -PartLMW)/(maxpLMW-minpLMW)) Limfac = max(0.d0,Limfac) PhotoSynthesis = maxPhotoSynt*Limfac * & & (1.d0-exp(alpha*PAR/maxPhotoSynt)) * PROTEIN Exudation = pExudation * PhotoSynthesis MonodQuotum = max(0.d0,LMW / PROTEIN - minQuotum) ProteinSynthesis= maxProteinSynt*MonodQuotum & & * DIN / (DIN+ksDIN) * PROTEIN Storage = maxStorage *MonodQuotum * PROTEIN Respiration = respirationRate * LMW & & + pResp * ProteinSynthesis Catabolism = catabolismRate * RESERVE c the rates of change of state variables; includes dilution effects (last term) dLMW = PhotoSynthesis + Catabolism & & - Exudation - Storage - Respiration - ProteinSynthesis & & - dilutionRate * LMW dRESERVE = Storage - Catabolism - dilutionRate * RESERVE dPROTEIN = ProteinSynthesis - dilutionRate * PROTEIN dDIN = -ProteinSynthesis * rNCProtein & & - dilutionRate * (DIN - inputDIN) c the vector with rate of changes ydot(1) = dDIN ydot(2) = dPROTEIN ydot(3) = dRESERVE ydot(4) = dLMW c the ordinary variables out(1) = PAR out(2) = TotalN out(3) = PhotoSynthesis out(4) = NCratio out(5) = ChlCratio out(6) = Chlorophyll return end subroutine aquaphyforc deSolve/inst/doc/dynload/Forcing_lv.R0000754000175100001440000001001712352122173017257 0ustar hornikusers############################################################################### # Implements the lv test model, as given in Forcing_lv.c # A model in C-code and comprising a forcing function # before trying this code, c program has to be compiled # this can be done in R: # system("R CMD SHLIB Forcing_lv.c") # do make sure that these files are in the working directory... # (if not, use setwd() ) ############################################################################### library(deSolve) dyn.load(paste("Forcing_lv", .Platform$dynlib.ext, sep = "")) #=============================================================================== # The R-code #=============================================================================== SPCmod <- function(t, x, parms) { with(as.list(c(parms, x)), { import <- sigimp(t) dS <- import - b*S*P + g*C # substrate dP <- c*S*P - d*C*P # producer dC <- e*P*C - f*C # consumer res <- c(dS, dP, dC) list(res,signal=import) }) } ## define states, time steps and parameters init <- c(S = 1, P = 1, C = 1) # initial conditions times <- seq(0, 100, by=0.1) # output times parms <- c(b = 0.1, c = 0.1, d = 0.1, e = 0.1, f = 0.1, g = 0.0) ## external input signal with rectangle impulse signal <- as.data.frame(list(times = times, import = rep(0, length(times)))) signal$import[signal$times >= 10 & signal$times <= 11] <- 0.2 signal$import <- ifelse((trunc(signal$times) %% 2 == 0), 0, 1) ftime <- seq(0, 900, 0.1) sigimp <- approxfun(signal$times, signal$import, rule = 2) Sigimp <- approx(signal$times, signal$import, xout=ftime ,rule = 2)$y forcings <- cbind(ftime, Sigimp) ## Start values for steady state xstart <- y <- c(S = 1, P = 1, C = 1) ## solve R version of the model print(system.time( Out <- ode(xstart, times, SPCmod, parms)) ) ## ============================================================================= ## solve C version of the model ## ============================================================================= print(system.time( out <- ode(y = y, times, func = "derivsc", parms = parms, dllname = "Forcing_lv", initforc="forcc", forcings = forcings, initfunc = "parmsc", nout = 2, outnames = c("Sum", "signal")) )) ## Plotting plot(out, which = c("S","P","C"), type = "l") plot(out[,"P"], out[,"C"], type = "l", xlab = "producer", ylab = "consumer") #points(Out$P,Out$C) tail(out) ## ============================================================================= ## now including an event - as a data.frame ## ============================================================================= eventdata <- data.frame(var = rep("C", 10), time = seq(10, 100, 10), value = rep(0.5, 10), method = rep("multiply", 10)) eventdata ## solve C version of the model print(system.time( out2 <- ode(y = y, times, func = "derivsc", parms = parms, dllname = "Forcing_lv", initforc="forcc", forcings = forcings, initfunc = "parmsc", nout = 2, outnames = c("Sum", "signal"), events=list(data=eventdata)) )) ## Plotting plot(out2, which = c("S", "P", "C"), type = "l") plot(out2[,"P"], out2[,"C"], type = "l", xlab = "producer", ylab = "consumer") ## ============================================================================= ## an event as a function ## ============================================================================= ## solve C version of the model print(system.time( out3 <- ode(y = y, times, func = "derivsc", parms = parms, dllname = "Forcing_lv", initforc="forcc", forcings = forcings, initfunc = "parmsc", nout = 2, outnames = c("Sum", "signal"), events = list(func = "event", time = seq(10, 90, 10))) )) dyn.unload(paste("Forcing_lv", .Platform$dynlib.ext, sep = "")) plot(out3, which = c("S", "P", "C"), type = "l") plot(out3[,"P"], out3[,"C"], type = "l", xlab = "producer", ylab = "consumer") points(out2[,"P"],out2[,"C"]) deSolve/inst/doc/dynload/AquaphyForcing.f0000754000175100001440000001177312352122173020145 0ustar hornikusers c the Aquaphy algal model with forcing function light intensity c -------- Aquaphy2.f -> Aquaphy2.dll ------ c compile in R with: system("g77 -shared -o Aquaphy Aquaphy") c or with system("R CMD SHLIB AquaphyForcing") c======================================================================= c======================================================================= c Model initialisation c======================================================================= c======================================================================= c======================================================================= c Initialise parameter common block c======================================================================= subroutine initaqparms(odeparms) external odeparms double precision pars(16) common /myparms/pars call odeparms(16, pars) return end subroutine initaqforc(odeforc) external odeparms double precision forcs(2) common /myforcs/forcs call odeforc(2, forcs) return end c======================================================================= c In this "event", state variable 1 is increased with 1. DOES NOT WORK... c======================================================================= subroutine eventfun(n, t, y) integer n double precision t, y(n) y(1) = y(1) + 1 end subroutine c======================================================================= c Algal dynamics c======================================================================= subroutine aquaphy2 (neq, t, y, ydot,out,IP) implicit none integer neq, ip(*) double precision t, y(*), ydot(*), out(*) c parameters double precision maxPhotoSynt,rMortPHY,alpha,pExudation, & & maxProteinSynt,ksDIN,minpLMW,maxpLMW,minQuotum, & & maxStorage,respirationRate,pResp,catabolismRate, & & rNCProtein,inputDIN,rChlN common /myparms/ maxPhotoSynt,rMortPHY,alpha,pExudation, & & maxProteinSynt,ksDIN,minpLMW,maxpLMW,minQuotum, & & maxStorage,respirationRate,pResp,catabolismRate, & & rNCProtein,inputDIN,rChlN double precision PAR, dilutionRate common /myforcs/PAR, dilutionRate c variables double precision :: & & DIN,PROTEIN,RESERVE,LMW,dLMW,dRESERVE,dPROTEIN,dDIN, & & PhytoC,PhytoN,NCratio,Chlorophyll,TotalN,ChlCratio,PartLMW, & & hourofday, Limfac,PhotoSynthesis,Exudation,MonodQuotum, & & ProteinSynthesis,Storage,Respiration,Catabolism c ------------------------------------------------------------------------ if(ip(1) < 6) call rexit("nout should at least be 6") DIN = y(1) PROTEIN = y(2) RESERVE = y(3) LMW = y(4) c the output variables PhytoC = PROTEIN + RESERVE + LMW ! all components contain carbon PhytoN = PROTEIN * rNCProtein ! only proteins contain nitrogen NCratio = PhytoN / PhytoC Chlorophyll = PhytoN * rChlN TotalN = PhytoN + DIN ChlCratio = Chlorophyll / PhytoC c the rates, in mmol/hr PartLMW = LMW / PhytoC Limfac = min(1.d0,(maxpLMW -PartLMW)/(maxpLMW-minpLMW)) Limfac = max(0.d0,Limfac) PhotoSynthesis = maxPhotoSynt*Limfac * & & (1.d0-exp(alpha*PAR/maxPhotoSynt)) * PROTEIN Exudation = pExudation * PhotoSynthesis MonodQuotum = max(0.d0,LMW / PROTEIN - minQuotum) ProteinSynthesis= maxProteinSynt*MonodQuotum & & * DIN / (DIN+ksDIN) * PROTEIN Storage = maxStorage *MonodQuotum * PROTEIN Respiration = respirationRate * LMW & & + pResp * ProteinSynthesis Catabolism = catabolismRate * RESERVE c the rates of change of state variables; includes dilution effects (last term) dLMW = PhotoSynthesis + Catabolism & & - Exudation - Storage - Respiration - ProteinSynthesis & & - dilutionRate * LMW dRESERVE = Storage - Catabolism - dilutionRate * RESERVE dPROTEIN = ProteinSynthesis - dilutionRate * PROTEIN dDIN = -ProteinSynthesis * rNCProtein & & - dilutionRate * (DIN - inputDIN) c the vector with rate of changes ydot(1) = dDIN ydot(2) = dPROTEIN ydot(3) = dRESERVE ydot(4) = dLMW c the ordinary variables out(1) = PAR out(2) = TotalN out(3) = PhotoSynthesis out(4) = NCratio out(5) = ChlCratio out(6) = Chlorophyll return end subroutine Aquaphy2 deSolve/inst/doc/dynload/lsodarfor.f0000754000175100001440000000336412352122173017215 0ustar hornikusersc---------------------------------------------------------------- c---------------------------------------------------------------- c--- The root model example of lsodar c---------------------------------------------------------------- c---------------------------------------------------------------- c -------- lsodarfor.f -> lsodarfor.dll ------ c compile in R with: system("g77 -shared -o lsodarfor.dll lsodarfor.f") c or with system("R CMD SHLIB lsodarfor.f") c---------------------------------------------------------------- c Initialiser for parameter common block c---------------------------------------------------------------- subroutine lsodarfor(odeparms) external odeparms integer, parameter :: N = 3 double precision parms(N) common /myparms/parms call odeparms(N, parms) return end c---------------------------------------------------------------- c rate of change and 1 output variable c---------------------------------------------------------------- subroutine modfor(neq, t, y, ydot,out,IP) integer neq, IP(*) double precision t, y(neq), ydot(neq), out(*), aa, bb, cc common /myparms/aa,bb,cc if(IP(1) < 1) call rexit("nout should be at least 1") ydot(1) = aa*y(1) + bb*y(2)*y(3) ydot(3) = cc*y(2)*y(2) ydot(2) = -ydot(1) - ydot(3) out(1)=y(1)+y(2)+y(3) return end c---------------------------------------------------------------- c The root function c---------------------------------------------------------------- subroutine myroot(neq, t, y, ng, gout) integer :: neq, ng double precision :: t, y(neq), gout(ng) gout(1) = y(1) - 1.e-4 gout(2) = y(3) - 1e-2 return end deSolve/inst/doc/dynload/CCL4model.f0000754000175100001440000001124512352122173016725 0ustar hornikusers c the CCl4 inhalation model c based on the demo in odesolve c -------- ccl4model.f -> ccl4model.dll ------ c compile in R with: system("g77 -shared -o ccl4model.dll ccl4model.f") c or with system("R CMD SHLIB ccl4model.f") c======================================================================= c======================================================================= c Model initialisation c======================================================================= c======================================================================= c======================================================================= c Initialise primary parameter common block c======================================================================= subroutine initccl4(odeparms) external odeparms integer N c parameters are divided into primary and derived parameters double precision pars(21), derivedpars(15) common /myparms/pars,derivedpars N = 21 call odeparms(N, pars) call derived() return end c======================================================================= c In this "event", state variable 1 is increased with 1. DOES NOT WORK... c======================================================================= subroutine eventfun(n, t, y) integer n double precision t, y(7) y(1) = y(1) + 1 end subroutine c======================================================================= c Calculate derived parameters from primary parameters c======================================================================= subroutine derived implicit none double precision BW,QP,QC,VFC,VLC,VMC,QFC,QLC,QMC,PLA,PFA, & & PMA,PTA,PB,MW,VMAX,KM,CONC,KL,RATS,VCHC, & & VCH,VM,VT,VF,VL,PM,PT,PF,PL,AI0,VTC,QM,QT,QF,QL common /myparms/ BW,QP,QC,VFC,VLC,VMC,QFC,QLC,QMC,PLA,PFA, & & PMA,PTA,PB,MW,VMAX,KM,CONC,KL,RATS,VCHC, & VCH,VM,VT,VF,VL,PM,PT,PF,PL,AI0,VTC,QM,QT,QF,QL c Fraction viscera (kg/(kg BW)) VTC = 0.91 - (VLC+VFC+VMC) c Net chamber volume VCH = VCHC - RATS*BW VM = VMC*BW VT = VTC*BW VF = VFC*BW VL = VLC*BW c Initial amt. in chamber (mg) AI0 = CONC*VCH*MW/24450. PL = PLA/PB PF = PFA/PB PT = PTA/PB PM = PMA/PB QF = QFC*QC QL = QLC*QC QM = QMC*QC QT = QC - (QF+QL+QM) return end subroutine derived c======================================================================= c The dynamic model c======================================================================= subroutine derivsccl4 (neq, t, y, ydot,out,IP) implicit none integer neq, IP(*), i double precision t, y(neq), ydot(neq), out(*) double precision BW,QP,QC,VFC,VLC,VMC,QFC,QLC,QMC,PLA,PFA, & & PMA,PTA,PB,MW,VMAX,KM,CONC,KL,RATS,VCHC, & & V(5), P(4),AI0,VTC,Q(4) c here we lump parameters Vx, Qx and Px into vectors common /myparms/ BW,QP,QC,VFC,VLC,VMC,QFC,QLC,QMC,PLA,PFA, & & PMA,PTA,PB,MW,VMAX,KM,CONC,KL,RATS,VCHC, & & V, P, AI0,VTC, Q double precision tconc(5), vconc(5), dose, mass, cp, ca, cx, RAM c check if provision has been made for at least 3 output variables if (IP(1) < 3) call rexit("nout should be at least 3") c y = AI, AAM, AT, AF, AL CLT, AM c where clt = the area under the concentration-time curve in the liver c AM = total amount metabolised c concentrations do i =1,5 tconc(i) = y(i)/v(i) enddo c vconc(1) is conc in mixed venous blood vconc(1) = 0.d0 do i = 2,5 vconc(i) = tconc(i)/P(i-1) vconc(1) = vconc(1) + vconc(i)*Q(i-1)/QC enddo c CA is conc in arterial blood CA = (QC * Vconc(1) + QP * tconc(1))/ (QC + QP/PB) c Exhaled chemical CX = CA/PB c metabolisation rate RAM = VMAX*Vconc(5)/(KM + Vconc(5)) c the rate of change ydot(1) = RATS*QP*(CX - tconc(1)) - KL*y(1) do i = 2,5 ydot(i) = Q(i-1)*(CA-vconc(i)) enddo ydot(5) = ydot(5) - RAM ydot(6) = tconc(5) ydot(7) = RAM c the mass balance (MASS=AAM+AT+AF+AL+AM), should be constant DOSE = AI0 - y(1) MASS = (y(2)+y(3)+y(4)+y(5)+y(7))*RATS CP = tconc(1)*24450.0/MW out(1) = DOSE out(2) = MASS out(3) = CP return end deSolve/inst/doc/dynload/zvodedll.R0000754000175100001440000000455012352122173017017 0ustar hornikusers## ============================================================================= ## Implements the test model, as given in the dvode code. ## before trying this code, the FORTRAN program has to be compiled ## this can be done in R: ## system("R CMD SHLIB zvodedll.f") ## do make sure that these files are in the working directory... ## (if not, use setwd() ) ## ============================================================================= ## the example in "zvode.f", ## ## df/dt = 1i*f ## dg/dt = -1i*g*g*f ## ## Initial values are ## g(0) = 1/2.1 and ## z(0) = 1 (same as above) ## ## The analytical solution is ## f(t) = exp(1i*t) (same as above) ## g(t) = 1/(f(t) + 1.1) library(deSolve) ## ----------------------------------------------------------------------------- ## implementation in R ## ----------------------------------------------------------------------------- ZODE2 <- function(Time, State, Pars) { with(as.list(State), { df <- 1i * f dg <- -1i*g*g*f return(list(c(df, dg))) }) } pars <- NULL yini <- c(f = 1+0i, g = 1/2.1+0i) times <- seq(0, 2*pi, length = 100) print(system.time( out <- zvode(func = ZODE2, y = yini, parms = NULL, times = times, atol = 1e-10, rtol = 1e-10) )) analytical <- cbind(f = exp(1i*times), g = 1/(exp(1i*times)+1.1)) #compare numerical solution and the two analytical ones: tail(cbind(out[, 2], analytical[, 1])) #---------------------- # the Jacobian: #---------------------- jac <- function (t, Y, parameters) { PD[2, 2] = -2.0*1i*Y[1]*Y[2] PD[2, 1] = -1i*Y[2]*Y[2] PD[1, 2] = 0. PD[1, 1] = 1i return(PD) } print(system.time( out2 <- zvode(func = ZODE2, jacfunc = jac, y = yini, parms = NULL, times = times, atol = 1e-10, rtol = 1e-10) )) tail(cbind(out2[, 2], analytical[, 1])) ## ----------------------------------------------------------------------------- ## implementation in FORTRAN ## ----------------------------------------------------------------------------- # compiled within R with: system("R CMD SHLIB zvodedll.f") dyn.load(paste("zvodedll", .Platform$dynlib.ext, sep = "")) print("FORTRAN DLL passed to zvode") print(system.time( outF <- zvode(func = "fex", jacfunc = "jex", y = yini, parms = NULL, times = times, atol = 1e-10, rtol = 1e-10, dllname = "zvodedll", initfunc = NULL) )) tail(cbind(outF[, 2], analytical[, 1])) deSolve/inst/doc/dynload/Forcing_lv.c0000754000175100001440000000166412352122173017310 0ustar hornikusers/* compile within R with system("R CMD SHLIB Forcing_lv.c") */ #include static double parms[6]; static double forc[1]; /* A trick to keep up with the parameters and forcings */ #define b parms[0] #define c parms[1] #define d parms[2] #define e parms[3] #define f parms[4] #define g parms[5] #define import forc[0] /* initializers*/ void parmsc(void (* odeparms)(int *, double *)) { int N=6; odeparms(&N, parms); } void forcc(void (* odeforcs)(int *, double *)) { int N=1; odeforcs(&N, forc); } /* derivative function */ void derivsc(int *neq, double *t, double *y, double *ydot, double *yout, int *ip) { if (ip[0] <2) error("nout should be at least 2"); ydot[0] = import - b*y[0]*y[1] + g*y[2]; ydot[1] = c*y[0]*y[1] - d*y[2]*y[1]; ydot[2] = e*y[1]*y[2] - f*y[2]; yout[0] = y[0]+y[1]+y[2]; yout[1] = import; } void event(int *n, double *t, double *y) { y[2] = y[2]*0.5; } deSolve/inst/doc/dynload/daspkfor.f0000754000175100001440000000502312352122173017025 0ustar hornikusersc---------------------------------------------------------------- c---------------------------------------------------------------- c--- The chemical model example of daspk c---------------------------------------------------------------- c---------------------------------------------------------------- c -------- daspkdll.f -> daspkdll.dll ------ c compile in R with: system("g77 -shared -o daspkfor.dll daspkfor.f") c or with system("R CMD SHLIB daspkfor.f") c---------------------------------------------------------------- c Initialiser for parameter common block c---------------------------------------------------------------- subroutine daspkfor(daspkparms) external daspkparms integer, parameter :: N = 4 double precision parms(N) common /myparms/parms call daspkparms(N, parms) return end c---------------------------------------------------------------- c residual of rate of change and 1 output variable c---------------------------------------------------------------- subroutine resfor (t, y, ydot, cj, delta, ires, out, ipar) integer :: ires, ipar(*) integer, parameter :: neq = 3 double precision :: t, y(neq), ydot(neq), delta(neq), out(*) double precision :: K, ka, r, prod, ra, rb common /myparms/K,ka,r,prod if(IPar(1) < 1) call rexit("nout should be at least 1") ra = ka* y(3) ! forward rate rb = ka/K *y(1) * y(2) ! backward rate ! residuals of rates of changes delta(3) = -ydot(3) - ra + rb + prod delta(1) = -ydot(1) + ra - rb delta(2) = -ydot(2) + ra - rb - r*y(2) out(1) = y(1) + y(2) + y(3) return end c---------------------------------------------------------------- c The jacobian matrix c---------------------------------------------------------------- subroutine resjacfor (t, y, dy, pd, cj, out, ipar) integer, parameter :: neq = 3 integer :: ipar(*) double precision :: K, ka, r, prod double precision :: pd(neq,neq),y(neq),dy(neq),out(*) common /myparms/K,ka,r,prod ! residuals of rates of changes !res1 = -dD - ka*D + ka/K *A*B + prod PD(1,1) = ka/K *y(2) PD(1,2) = ka/K *y(1) PD(1,3) = -ka -cj !res2 = -dA + ka*D - ka/K *A*B PD(2,1) = -ka/K *y(2) -cj PD(2,2) = -ka/K *y(2) PD(2,3) = ka !res3 = -dB + ka*D - ka/K *A*B - r*B PD(3,1) = -ka/K *y(2) PD(3,2) = -ka/K *y(2) -r -cj PD(3,3) = ka return end deSolve/inst/doc/dynload/daspkdll.R0000754000175100001440000000634612352122173016777 0ustar hornikusers#--------------------------------------------------------------------------- # The chemical model example of daspk, implemented as a DLL # before trying this code, the FORTRAN program has to be compiled # this can be done in R: # system("R CMD SHLIB daspkfor.f") # do make sure that this file is in the working directory... # (if not, use setwd() ) #--------------------------------------------------------------------------- # Dissociation constant K <- 1 # parameters pars <- c(K = K , ka = 1e6, # forward rate r = 1 , prod = 0.1) #--------------------------------------------------------- # Chemical problem formulation as R-function # Note: here it is written as the residuals of the rates of changes # This differs from the example in the daspk help file #--------------------------------------------------------- Chemres_ODE <- function (t, y, dy, pars){ with (as.list(c(y, dy, pars)), { ra <- ka * D # forward rate rb <- ka/K * A * B # backward rate # residuals of rates of changes res1 <- -dD - ra + rb + prod res2 <- -dA + ra - rb res3 <- -dB + ra - rb - r*B return(list(res = c(res1, res2, res3), CONC = A + B + D)) }) } Chemjac_ODE <- function (t, y, dy, pars, cj) { with (as.list(c(y, dy, pars)), { # residuals of rates of changes #res1 = -dD - ka*D + ka/K *A*B + prod PD[1, 1] <- ka/K * B PD[1, 2] <- ka/K * A PD[1, 3] <- -ka - cj #res2 = -dA + ka*D - ka/K * A*B PD[2, 1] <- -ka/K * B - cj PD[2, 2] <- -ka/K * A PD[2, 3] <- ka #res3 = -dB + ka*D - ka/K * A*B - r*B PD[3, 1] <- -ka/K * B PD[3, 2] <- -ka/K * A -r -cj PD[3, 3] <- ka return(PD) }) } times <- seq(0, 100, by = 2) # Initial conc and rate of change; D is in equilibrium with A,B y <- c(A = 2, B = 3, D = 2*3/K) dy <- c(dA = 0, dB = 0, dD = 0) PD <- matrix(nr = 3, nc = 3, 0) # ODE model solved with daspk - using res print("ODE solved with daspk - using res, no jac, in R") print(system.time( ODE_R <- daspk(y = y, dy = dy, times = times, res = Chemres_ODE, parms = pars, atol = 1e-10, rtol = 1e-10) )) print("ODE solved with daspk - using res, jacres, in R") print(system.time( ODE_R2 <- daspk(y = y, dy = dy, times = times, res = Chemres_ODE, jacres = Chemjac_ODE, jactype = "fullusr", parms = pars, atol = 1e-10, rtol = 1e-10) )) # plotting output plot(ODE_R, ODE_R2, xlab = "time", ylab = "conc", type = c("l", "p"), pch = c(NA, 1)) legend("bottomright", lty = c(1, NA), pch = c(NA, 1), col = c("black", "red"), legend = c("ODE", "ODE+JAC")) # same, now using DLL dyn.load(paste("daspkfor", .Platform$dynlib.ext, sep = "")) print("ODE solved with daspk - using res, no jac, DLL") print(system.time( ODE_dll <- daspk(y = y, dy = dy, times = times, res = "resfor", dllname = "daspkfor", parms = pars, atol = 1e-10, rtol = 1e-10, nout = 1) )) print("ODE solved with daspk - using res, jacres, DLL") print(system.time( ODE_dll2<- daspk(y = y, dy = dy, times = times, res = "resfor", jacres = "resjacfor", dllname = "daspkfor", parms = pars, atol = 1e-10, rtol = 1e-10, nout = 1) )) max(abs(ODE_R-ODE_dll)) max(abs(ODE_R2-ODE_dll2)) deSolve/inst/doc/dynload/odedll.R0000754000175100001440000002307012352122173016435 0ustar hornikusers############################################################################### # Implements the test model, as given in the vode code. # Demonstrates several ways to write models, and estimates the time required # user system elapsed # before trying this code, the FORTRAN, and C programs have to be compiled # this can be done in R: # system("R CMD SHLIB odec.c") # system("R CMD SHLIB odefor.f") # system("R CMD SHLIB odefor2.f") # do make sure that these files are in the working directory... # (if not, use setwd() ) ############################################################################### # model settings # parameters k1 <- 0.04 k2 <- 1e4 k3 <- 3e7 parms <- c(k1 = k1, k2 = k2, k3 = k3) # parameters Y <- c(1.0, 0.0, 0.0) # initial conditions times <- c(0, 0.4*10^(0:11) ) # output times RTOL <- 1.e-4 # tolerances, lower for second var ATOL <- c(1.e-8, 1.e-14, 1.e-6) MF <- 21 # stiff, full Jacobian, specified as function require(deSolve) #------------------------------------------------------------ # test model fully implemented in R, parameters passed #------------------------------------------------------------ #----------------------# # the model equations: # #----------------------# model<-function(t, Y, parameters){ with (as.list(parameters), { dy1 <- -k1*Y[1] + k2*Y[2]*Y[3] dy3 <- k3*Y[2]*Y[2] dy2 <- -dy1 - dy3 list(c(dy1, dy2, dy3)) # the output, packed as a list }) } #----------------------# # the Jacobian: # #----------------------# jac <- function (t, Y, parameters) { with (as.list(parameters), { PD[1, 1] <- -k1 PD[1, 2] <- k2*Y[3] PD[1, 3] <- k2*Y[2] PD[2, 1] <- k1 PD[2, 3] <- -PD[1, 3] PD[3, 2] <- k3*Y[2] PD[2, 2] <- -PD[1, 2] - PD[3, 2] return(PD) }) } PD <- matrix(nrow = 3, ncol = 3, data = 0) print("all in R - vode") print(system.time( for (i in 1:10) out <- vode(Y, times, model, parms = parms, rtol = RTOL, atol = ATOL, mf = MF, jacfunc = jac, verbose = FALSE, ynames = FALSE ) )/10) print("all in R - lsoda") print(system.time( for (i in 1:10) out <- lsoda(Y, times, model, parms = parms, rtol = RTOL, atol = ATOL, jac = "fullusr", jacfunc = jac, verbose = FALSE, ynames = FALSE ) )/10) print("all in R - lsode") print(system.time( for (i in 1:10) out <- lsode(Y, times, model, parms = parms, rtol = RTOL, atol = ATOL, jac = "fullusr", jacfunc = jac, verbose = FALSE, ynames = FALSE ) )/10) #------------------------------------------------------------ # test model fully implemented in R, NO parameters passed #------------------------------------------------------------ #----------------------# # the model equations: # #----------------------# model <- function(t, Y, parameters) { dy1 <- -k1*Y[1] + k2*Y[2]*Y[3] dy3 <- k3*Y[2]*Y[2] dy2 <- -dy1 - dy3 list(c(dy1, dy2, dy3)) } #----------------------# # the Jacobian: # #----------------------# jac <- function (t, Y, parameters) { PD[1, 1] <- -k1 PD[1, 2] <- k2*Y[3] PD[1, 3] <- k2*Y[2] PD[2, 1] <- k1 PD[2, 3] <- -PD[1, 3] PD[3, 2] <- k3*Y[2] PD[2, 2] <- -PD[1, 2] - PD[3, 2] return(PD) } PD <- matrix(nrow = 3, ncol = 3, data = 0) print("all in R, no pars passed - vode") print(system.time( for (i in 1:10) out <- vode(Y, times, model, parms = parms, rtol = RTOL, atol = ATOL, mf = MF, jacfunc = jac, verbose = FALSE, ynames = FALSE ) )/10) print("all in R, no pars passed - lsoda") print(system.time( for (i in 1:10) out <- lsoda(Y, times, model, parms = parms, rtol = RTOL, atol = ATOL, jac = "fullusr", jacfunc = jac, verbose = FALSE, ynames = FALSE ) )/10) print("all in R, no pars passed - lsode") print(system.time( for (i in 1:10) out <- lsode(Y, times, model, parms = parms, rtol = RTOL, atol = ATOL, jac = "fullusr", jacfunc = jac, verbose = FALSE, ynames = FALSE ) )/10) #------------------------------------------------------------ # DLL TEST 1. Fortran code in odefor.f; DLL passed to vode #------------------------------------------------------------ # compiled within R with: system("R CMD SHLIB odefor.f") dyn.load(paste("odefor", .Platform$dynlib.ext, sep = "")) print("Fortran dll passed to vode") print(system.time( for(i in 1:100) outF <- vode(Y, times, "derivsfor", parms = parms, rtol = RTOL, atol = ATOL, mf = MF, jacfunc = "jacfor", dllname = "odefor", verbose = FALSE, ynames = FALSE, nout = 3, rpar = runif(5)) )/100) #------------------------------------------------------------ # and now lsoda #------------------------------------------------------------ print("Fortran dll passed to lsoda") print(system.time( for(i in 1:100) outL <- lsoda(Y, times, "derivsfor", parms = parms, rtol = RTOL, atol = ATOL, mf = MF, jacfunc = "jacfor", dllname = "odefor", verbose = FALSE, ynames = FALSE, nout = 3) )/100) #------------------------------------------------------------ # and now lsode #------------------------------------------------------------ print("Fortran dll passed to lsode") print(system.time( for(i in 1:100) outL <- lsode(Y, times, "derivsfor", parms = parms, rtol = RTOL, atol = ATOL, mf = MF, jacfunc = "jacfor", dllname = "odefor", verbose = FALSE, ynames = FALSE, nout = 3) )/100) #------------------------------------------------------------ # DLL TEST 2. C code in odec.c; DLL passed to vode #------------------------------------------------------------ # compiled within R with: system("R CMD SHLIB odec.c") #system("R CMD SHLIB odec.c") dyn.load(paste("odec", .Platform$dynlib.ext, sep = "")) print("C dll passed to vode") print(system.time( for(i in 1:100) outC <- vode(Y, times, "derivsc", parms = parms, rtol = RTOL, atol = ATOL, mf = MF, jacfunc = "jacc", dllname = "odec", verbose = FALSE, ynames = FALSE, nout = 3) )/100) #------------------------------------------------------------ # DLL TEST 3. Fortran code in odefor.f; DLL passed to R-functions func and jac #------------------------------------------------------------ dyn.load(paste("odefor", .Platform$dynlib.ext, sep = "")) #----------------------# # DEFINING the model: # #----------------------# # rate of change function, now a dll moddll <- function (t, Y, parameters) { FF <-.Fortran("derivsfor", PACKAGE = "odefor", as.integer(3), as.double(t), as.double(Y), Ydot = as.double(rep(0., 3)), Out = as.double(rep(0., 3)), as.integer(3)) return(list(c(dy = FF$Ydot), c(out = FF$Out))) } # the Jacobian, a dll jacdll <- function (t, Y, parameters) { .Fortran("jacfor", PACKAGE = "odefor", as.integer(3), as.double(t), as.double(Y), as.integer(1), as.integer(1), PD = matrix(nr = 3, nc = 3, as.double(0)), as.integer(3), as.double(1:3), as.integer(1))$PD } #----------------------# # RUNNING the model: # #----------------------# print("Fortran dll passed to R-functions, including initialiser") print(system.time( for (i in 1:10) outDLL <- lsode(Y, times, moddll, parms = parms, dllname = "odefor", initfunc = "odefor", rtol = RTOL, atol = ATOL, mf = MF, jacfunc = jacdll, verbose = FALSE, ynames = FALSE ) )/10) #------------------------------------------------------------ # DLL TEST 4. C code in odefor.c; DLL passed to R-functions func and jac #------------------------------------------------------------ dyn.load(paste("odec", .Platform$dynlib.ext, sep = "")) #----------------------# # DEFINING the model: # #----------------------# # rate of change function, now a dll moddll <- function (t, Y, parameters) { FF <-.C("derivsc", PACKAGE = "odec", as.integer(3), as.double(t), as.double(Y), Ydot = as.double(rep(0., 3)), Out = as.double(rep(0., 3)), as.integer(3)) return(list(c(dy = FF$Ydot), c(out = FF$Out))) } # the Jacobian, a dll jacdll <- function (t, Y, parameters) { .C("jacc", PACKAGE = "odec", as.integer(3), as.double(t), as.double(Y), as.integer(1), as.integer(1), PD = matrix(nr = 3, nc = 3, as.double(0)), as.integer(3), as.double(1:3), as.integer(1))$PD } #----------------------# # RUNNING the model: # #----------------------# print("C dll passed to R-functions, including initialiser") print(system.time( for (i in 1:10) outDLLC <- vode(Y, times, moddll, parms = parms, dllname = "odec", rtol = RTOL, atol = ATOL, mf = MF, jacfunc = jacdll, verbose = FALSE, ynames = FALSE ) )/10) #------------------------------------------------------------ # DLL TEST 5. Fortran code in vodefor2.f; DLL passed to R-functions func and jac # NO initialiser #------------------------------------------------------------ dyn.load(paste("odefor2", .Platform$dynlib.ext, sep = "")) #----------------------# # DEFINING the model: # #----------------------# # rate of change function, now a dll moddll <- function (t, Y, parameters) { FF <-.Fortran("derivsfor2", PACKAGE = "odefor2", as.integer(3), as.double(t), as.double(Y), Ydot = as.double(rep(0., 3)), Out = as.double(rep(0., 3)), as.integer(3)) return(list(c(dy = FF$Ydot), c(out = FF$Out))) } # the Jacobian, a dll jacdll <- function (t, Y, parameters) { .Fortran("jacfor2", PACKAGE = "odefor2", as.integer(3), as.double(t), as.double(Y), as.integer(1), as.integer(1), PD = matrix(nr = 3, nc = 3, as.double(0)), as.integer(3), as.double(1:3), as.integer(1))$PD } print("Fortran dll passed to R-functions, NO initialiser") print(system.time( for (i in 1:10) outDLL <- vode(Y, times, moddll, parms = parms, rtol = RTOL, atol = ATOL, mf = MF, jacfunc = jacdll, verbose = FALSE, ynames = FALSE ) )/10) deSolve/inst/doc/dynload/ex_CCL4model.c0000754000175100001440000000775012352122173017424 0ustar hornikusers/* c the CCl4 inhalation model -------- ex_ccl4model.c -> ex_ccl4model.dll ------ compile in R with: system("gcc -shared -o ex_ccl4model.dll ex_ccl4model.c") or with system("R CMD SHLIB ex_ccl4model.c") */ #include static double parms[21]; #define BW parms[0] #define QP parms[1] #define QC parms[2] #define VFC parms[3] #define VLC parms[4] #define VMC parms[5] #define QFC parms[6] #define QLC parms[7] #define QMC parms[8] #define PLA parms[9] #define PFA parms[10] #define PMA parms[11] #define PTA parms[12] #define PB parms[13] #define MW parms[14] #define VMAX parms[15] #define KM parms[16] #define CONC parms[17] #define KL parms[18] #define RATS parms[19] #define VCHC parms[20] double V[5], P[4], AI0, VTC, Q[4]; #define DOSE out[0] #define MASS out[1] #define CP out[2] /* c======================================================================= c======================================================================= c Model initialisation c======================================================================= c======================================================================= c======================================================================= 2c Initialise primary parameter common block c======================================================================= */ void initccl4(void (* odeparms)(int *, double *)) { void derived(); int N=21; odeparms(&N, parms); derived(); } /*======================================================================= In this "event", state variable 1 is increased with 1. DOES NOT WORK... ======================================================================= */ void eventfun(int *n, double *t, double *y) { y[0] = y[0] + 1; } /*======================================================================= c Calculate derived parameters from primary parameters c======================================================================= */ void derived () { // Fraction viscera (kg/(kg BW)) VTC = 0.91 - (VLC+VFC+VMC); // Net chamber volume V[0] = VCHC - RATS*BW; V[1] = VMC*BW; V[2] = VTC*BW; V[3] = VFC*BW; V[4] = VLC*BW; // Initial amt. in chamber (mg) AI0 = CONC*V[0]*MW/24450.; P[0] = PMA/PB; P[1] = PTA/PB; P[2] = PFA/PB; P[3] = PLA/PB; Q[2] = QFC*QC; Q[3] = QLC*QC; Q[0] = QMC*QC; Q[1] = QC - (Q[0]+Q[3]+Q[2]); } /*======================================================================= c The dynamic model c======================================================================= */ void derivsccl4 (int *neq, double *t, double *y, double *ydot, double *out, int *ip) { double vconc[5], tconc[5], CA, CX, RAM; int i; if (ip[0] < 3) error("nout should be at least 3"); /*c y = AI, AAM, AT, AF, AL CLT, AM where clt = the area under the concentration-time curve in the liver AM = total amount metabolised concentrations */ for (i =0; i<5; i++) { tconc[i] = y[i]/V[i]; } /* vconc(1) is conc in mixed venous blood */ vconc[0] = 0.0; for (i = 1; i<5; i++){ vconc[i] = tconc[i]/P[i-1]; vconc[0] = vconc[0] + vconc[i]*Q[i-1]/QC ; } /* CA is conc in arterial blood */ CA = (QC * vconc[0] + QP * tconc[0])/ (QC + QP/PB); /* Exhaled chemical */ CX = CA/PB; /* metabolisation rate */ RAM = VMAX*vconc[4]/(KM + vconc[4]); /* the rate of change */ ydot[0] = RATS*QP*(CX - tconc[0]) - KL*y[0]; for ( i = 1; i<5; i++) ydot[i] = Q[i-1]*(CA-vconc[i]); ydot[4] = ydot[4] - RAM; ydot[5] = tconc[4]; ydot[6] = RAM; /* the mass balance (MASS=AAM+AT+AF+AL+AM), should be constant */ DOSE = AI0 - y[0]; MASS = (y[1]+y[2]+y[3]+y[4]+y[6])*RATS; CP = tconc[0]*24450.0/MW; } deSolve/inst/doc/dynload/odec.c0000754000175100001440000000234212352122173016124 0ustar hornikusers/* compile within R with system("R CMD SHLIB odec.c") */ /* Example adapted from lsoda documentation */ #include /* gives F77_CALL through R_ext/RS.h */ static double parms[3]; /* A trick to keep up with the parameters */ #define k1 parms[0] #define k2 parms[1] #define k3 parms[2] /* initializer: same name as the dll (without extension) */ void odec(void (* odeparms)(int *, double *)) { int N=3; odeparms(&N, parms); } /* Derivatives */ void derivsc(int *neq, double *t, double *y, double *ydot, double *yout, int*ip) { if (ip[0] <3) error("nout should be at least 3"); ydot[0] = -k1*y[0] + k2*y[1]*y[2]; ydot[2] = k3 * y[1]*y[1]; ydot[1] = -ydot[0]-ydot[2]; yout[0] = y[0]+y[1]+y[2]; yout[1] = y[0]*2; yout[2] = k3; } /* Jacobian */ void jacc(int *neq, double *t, double *y, int *ml, int *mu, double *pd, int *nrowpd, double *yout, int*ip) { pd[0] = -k1; pd[1] = k1; pd[2] = 0.0; pd[(*nrowpd)] = k2*y[2]; pd[(*nrowpd) + 1] = -k2*y[2] - 2*k3*y[1]; pd[(*nrowpd) + 2] = 2*k3*y[1]; pd[(*nrowpd)*2] = k2*y[1]; pd[2*(*nrowpd) + 1] = -k2 * y[1]; pd[2*(*nrowpd) + 2] = 0.0; } /* End of example */ deSolve/inst/doc/dynload/lsodardll.R0000754000175100001440000000265312352122173017156 0ustar hornikusers#--------------------------------------------------------------------------- # The first example of lsodar, implemented as a FORTRAN DLL # before trying this code, the fortran program has to be compiled # this can be done in R: # system("R CMD SHLIB lsodarfor.f") # do make sure that this file is in the working directory... # (if not, use setwd() ) #--------------------------------------------------------------------------- Fun <- function (t, y, parms) { with (as.list(parms),{ ydot <- vector(len = 3) ydot[1] <- aa * y[1] + bb * y[2] * y[3] ydot[3] <- cc * y[2] * y[2] ydot[2] <- -ydot[1] - ydot[3] return(list(ydot, ytot = sum(y))) }) } rootFun <- function (t, y, parms) { yroot <- vector(len=2) yroot[1] <- y[1] - 1.e-4 yroot[2] <- y[3] - 1e-2 return(yroot) } y <- c(1, 0, 0) times <- c(0, 0.4*10^(0:7)) parms <- c(aa = -.04, bb = 1.e4, cc= 3.e7) #using the R-function out <- lsodar(y = y, times = times, fun = Fun, rootfun = rootFun, rtol = 1e-4, atol = c(1e-6, 1e-10, 1e-6), parms = parms) dyn.load(paste("lsodarfor", .Platform$dynlib.ext, sep = "")) out2 <- lsodar(y = y, times = times, fun = "modfor", rootfun = "myroot", dllname = "lsodarfor", rtol = 1e-4, atol = c(1e-6, 1e-10, 1e-6), parms = parms, nroot = 2, nout = 1) print(paste("root is found for eqn", which(attributes(out2)$iroot==1))) print(out[nrow(out2),]) print (max(abs(out[,1:4]-out2[,1:4])))deSolve/inst/doc/dynload/intakes.RData0000754000175100001440000000501412352122173017420 0ustar hornikusersPiT by/z EQ7` Jd A@EZ$t)Qgok/ 'Es1|73 C&ҏ*J_ m5i_gpx Ԕ4CVKtJڽtl/d,PٲSjǐ7H:KtH~ 0c(VQq6} ۏEi6GG(RQ8VoзS) }BwP;('('('*'va@6OH?}Pu}P?>V•*aKAfA=ss>7l7يI'wRA"5H]>9i4FG@ M#fQHsr -r,r 9i-ȞAm-j;vQۣffv@SwsWz;N<.*$x e;0Ol 4j ް~)w"M Iɑ&;(FVXcEnz3'ցbVr(?GOF&ix'pfCm=bĢXO@<{I!Ee$\޵GXnMB#Wݴ(of6ؽ&QYy$|yyM*V@.4 p^*t3@:x`}"DT4+0.6%^Ś$|yӔodU6k=R9j%c)㡣߼;nđ  tŦV E\GµխD7oYrZ;~`mDݯm//y<+AfWv]0"ށ."ab/:&Sghߝ =Fݡ Zk ?a?˳qOonJI<%bQ%h<2GYs`A۝U$\CLԥǙgTf:U^SqtqT0y7:gݦeo tv:0R7p/ͮKuGk;jXc`M>4ygPCOR3˂(ac\1GJvx]=^BNW)ƙ ~!>h<usC&U]>FȘ>i]=_uXu^Vg!:5uq dYkI/ .^zBΛVACҮow9V~b.y`h%?O!"Z&dRԅ o@dJ^VjDo7SkZTe;oz]qCENM9Ǭ')pFʋzV m}DCY9TP\FjUTXO`z&:;m!T>?wSΦ9?khPOEB;Qg 7>ٙw{iis{D7D;~SZЫ\r9-GvJSZj>meo?J<:{=JLȺx7c"vښ{ ÇXC|>d‡,2C&|2C|HJ>C|bPjC |b>A A C)|C)|‡<>$|C2|C|H!>DÇh>0>a+| v]>1|8‡>:p>GC=|ÇZP C!|!|!|C|Ȅ?a|Xz||k>xއ‡<‡>=Y 䞬a |H)!>|>TÇ* 5>TÇZP jC5|C5|ÇC'> xC*|>,>xO{>‡< C%|Ç>Çzp>C|8 ‡:P C%|(%ADA C|C6\g܇ X ?#Z-[ tIWX9mnqdmp@;tOW_ t=t/Bs+j!V򝑽s*EJuuu] 6m–[Kڇڧ/deSolve/inst/doc/dynload/radaudae.f0000754000175100001440000000465612352122173016775 0ustar hornikusersc---------------------------------------------------------------- c---------------------------------------------------------------- c--- The car axis problem of radau c---------------------------------------------------------------- c---------------------------------------------------------------- c -------- radaudae.f -> radaudae.dll ------ c compile in R with: system("g77 -shared -o radaudae.dll radaudae.f") c or with system("R CMD SHLIB radaudae.f") c---------------------------------------------------------------- c Initialiser for parameter common block c---------------------------------------------------------------- subroutine initcaraxis(daeparms) external daeparms integer, parameter :: N = 8 double precision parms(N) common /myparms/parms call daeparms(N, parms) return end c---------------------------------------------------------------- c rate of change c---------------------------------------------------------------- subroutine caraxis(neq, t, y, ydot, out, ip) implicit none integer neq, IP(*) double precision t, y(neq), ydot(neq), out(*) double precision eps, M, k, L, L0, r, w, g common /myparms/ eps, M, k, L, L0, r, w, g double precision xl, yl, xr, yr, ul, vl, ur, vr, lam1, lam2 double precision yb, xb, Ll, Lr, dxl, dyl, dxr, dyr double precision dul, dvl, dur, dvr, c1, c2 c expand state variables xl = y(1) yl = y(2) xr = y(3) yr = y(4) ul = y(5) vl = y(6) ur = y(7) vr = y(8) lam1 = y(9) lam2 = y(10) yb = r * sin(w * t) xb = sqrt(L * L - yb * yb) Ll = sqrt(xl**2 + yl**2) Lr = sqrt((xr - xb)**2 + (yr - yb)**2) dxl = ul dyl = vl dxr = ur dyr = vr dul = (L0-Ll) * xl/Ll + 2 * lam2 * (xl-xr) + lam1*xb dvl = (L0-Ll) * yl/Ll + 2 * lam2 * (yl-yr) + lam1*yb - k*g dur = (L0-Lr) * (xr-xb)/Lr - 2 * lam2 * (xl-xr) dvr = (L0-Lr) * (yr-yb)/Lr - 2 * lam2 * (yl-yr) - k*g c1 = xb * xl + yb * yl c2 = (xl - xr)**2 + (yl - yr)**2 - L * L c function values in ydot ydot(1) = dxl ydot(2) = dyl ydot(3) = dxr ydot(4) = dyr ydot(5) = dul ydot(6) = dvl ydot(7) = dur ydot(8) = dvr ydot(9) = c1 ydot(10) = c2 return end deSolve/inst/doc/dynload/ex_CCL4model.f0000754000175100001440000001123612352122173017421 0ustar hornikusers c the CCl4 inhalation model c based on the demo in odesolve c -------- ccl4model.f -> ccl4model.dll ------ c compile in R with: system("g77 -shared -o ccl4model.dll ccl4model.f") c or with system("R CMD SHLIB ccl4model.f") c======================================================================= c======================================================================= c Model initialisation c======================================================================= c======================================================================= c======================================================================= c Initialise primary parameter common block c======================================================================= subroutine initccl4(odeparms) external odeparms integer N c parameters are divided into primary and derived parameters double precision pars(21), derivedpars(15) common /myparms/pars,derivedpars N = 21 call odeparms(N, pars) call derived() return end c======================================================================= c In this "event", state variable 1 is increased with 1. DOES NOT WORK... c======================================================================= subroutine eventfun(n, t, y) integer n double precision t, y(n) y(1) = y(1) + 1 end subroutine c======================================================================= c Calculate derived parameters from primary parameters c======================================================================= subroutine derived implicit none double precision BW,QP,QC,VFC,VLC,VMC,QFC,QLC,QMC,PLA,PFA, & & PMA,PTA,PB,MW,VMAX,KM,CONC,KL,RATS,VCHC, & & VCH,VM,VT,VF,VL,PM,PT,PF,PL,AI0,VTC,QM,QT,QF,QL common /myparms/ BW,QP,QC,VFC,VLC,VMC,QFC,QLC,QMC,PLA,PFA, & & PMA,PTA,PB,MW,VMAX,KM,CONC,KL,RATS,VCHC, & VCH,VM,VT,VF,VL,PM,PT,PF,PL,AI0,VTC,QM,QT,QF,QL c Fraction viscera (kg/(kg BW)) VTC = 0.91 - (VLC+VFC+VMC) c Net chamber volume VCH = VCHC - RATS*BW VM = VMC*BW VT = VTC*BW VF = VFC*BW VL = VLC*BW c Initial amt. in chamber (mg) AI0 = CONC*VCH*MW/24450. PL = PLA/PB PF = PFA/PB PT = PTA/PB PM = PMA/PB QF = QFC*QC QL = QLC*QC QM = QMC*QC QT = QC - (QF+QL+QM) return end subroutine derived c======================================================================= c The dynamic model c======================================================================= subroutine derivsccl4 (neq, t, y, ydot,out,IP) implicit none integer neq, IP(*), i double precision t, y(neq), ydot(neq), out(*) double precision BW,QP,QC,VFC,VLC,VMC,QFC,QLC,QMC,PLA,PFA, & & PMA,PTA,PB,MW,VMAX,KM,CONC,KL,RATS,VCHC, & & V(5), P(4),AI0,VTC,Q(4) c here we lump parameters Vx, Qx and Px into vectors common /myparms/ BW,QP,QC,VFC,VLC,VMC,QFC,QLC,QMC,PLA,PFA, & & PMA,PTA,PB,MW,VMAX,KM,CONC,KL,RATS,VCHC, & & V, P, AI0,VTC, Q double precision tconc(5), vconc(5), dose, mass, cp, ca, cx, RAM c check if provision has been made for at least 3 output variables if (IP(1) < 3) call rexit("nout should be at least 3") c y = AI, AAM, AT, AF, AL CLT, AM c where clt = the area under the concentration-time curve in the liver c AM = total amount metabolised c concentrations do i =1,5 tconc(i) = y(i)/v(i) enddo c vconc(1) is conc in mixed venous blood vconc(1) = 0.d0 do i = 2,5 vconc(i) = tconc(i)/P(i-1) vconc(1) = vconc(1) + vconc(i)*Q(i-1)/QC enddo c CA is conc in arterial blood CA = (QC * Vconc(1) + QP * tconc(1))/ (QC + QP/PB) c Exhaled chemical CX = CA/PB c metabolisation rate RAM = VMAX*Vconc(5)/(KM + Vconc(5)) c the rate of change ydot(1) = RATS*QP*(CX - tconc(1)) - KL*y(1) do i = 2,5 ydot(i) = Q(i-1)*(CA-vconc(i)) enddo ydot(5) = ydot(5) - RAM ydot(6) = tconc(5) ydot(7) = RAM c the mass balance (MASS=AAM+AT+AF+AL+AM), should be constant DOSE = AI0 - y(1) MASS = (y(2)+y(3)+y(4)+y(5)+y(7))*RATS CP = tconc(1)*24450.0/MW out(1) = DOSE out(2) = MASS out(3) = CP return end deSolve/inst/doc/dynload/ex_SCOC.f0000754000175100001440000000203512352122173016437 0ustar hornikusersc -------- scoc.f -> scoc.dll ------ c compile in R with: system("g77 -shared -o scoc.dll SCOC.f") c or with system("R CMD SHLIB scoc.f") c Initialiser for parameter common block subroutine scocpar(odeparms) external odeparms integer N double precision parms(1) common /myparms/parms N = 1 call odeparms(N, parms) return end c Initialiser for forcing common block subroutine scocforc(odeforcs) external odeforcs integer N double precision forcs(1) common /myforcs/forcs N = 1 call odeforcs(N, forcs) return end c Rate of change and output variables subroutine scocder (neq, t, y, ydot,out,IP) integer neq, IP(*) double precision t, y(neq), ydot(neq), out(*), k, depo common /myparms/k common /myforcs/depo if(IP(1) < 2) call rexit("nout should be at least 2") ydot(1) = -k*y(1) + depo out(1)= k*y(1) out(2)= depo return end deSolve/inst/doc/dynload/satresC.c0000754000175100001440000000612112352122173016615 0ustar hornikusers#include static double parms[16]; static double forc[1]; #define Vc parms[0] /* Volume of central compartment (L) */ #define Vt parms[1] /* Volume of second compartment (L) */ #define kd parms[2] /* 1st order rate constant central <-> second */ /* cmpt (1/hr) */ #define ka parms[3] /* absorption 1st order rate constant (1/hr) */ #define Tm parms[4] /* 0 order resorption rate in the limit of */ /* increasing filtrate PFOA concentrations */ /* (mg/L/hr) */ #define KT parms[5] /* Filtrate cmpt concentration at which */ /* resorption rate is half maximal */ /* (mg/L) */ #define kfil parms[6] /* 1st order rate constant central -> filtrate */ /* cmpartment (1/hour) */ #define Vfil parms[7] /* Volume of filtrate compartment (L) */ #define free parms[8] /* Free fraction PFOA in central compartment (-) */ #define BW parms[9] /* bodyweight (kg) */ #define Dose parms[10] /* dose (mg/kg/day) */ #define Doseint parms[11] /* interval between doses (hours) */ #define Qd parms[12] /* Clearance (kd * Vc) central <-> 2nd cmpt (L/hr) */ #define Qfil parms[13] /* rate of flow to filtrate compartment */ #define MaxTime parms[14] /* Duration of simulation */ #define TDose parms[15] /* actual dose (dose * BW) (mg/day) */ #define TDoseRt forc[0] /* initializer */ void initmod(void (* odeparms)(int *, double *)) { int N = 16; odeparms(&N, parms); } void initforc(void (* odeforcs)(int *, double *)) { int N = 1; odeforcs(&N, forc); } /* Compartments are: Cn for the central compartment Tc for the second comparment Fc for the filtrate compartment Gt for the gut Elim for total eliminated AUC for AUC in the central compartment */ #define Cn y[0] #define Tc y[1] #define Fc y[2] #define Gt y[3] #define Elim y[4] #define AUC y[5] #define Cn_dot ydot[0] #define Tc_dot ydot[1] #define Fc_dot ydot[2] #define Gt_dot ydot[3] #define Elim_dot ydot[4] #define AUC_dot ydot[5] #define MassBal yout[0] /* Derivatives and one output variable */ void derivs (int *neq, double *t, double *y, double *ydot, double *yout, int *ip) { if (ip[0] < 1) error("nout should be at least 1"); Cn_dot = (ka * Gt - Qd * free * Cn + Qd * Tc) / Vc - kfil * Cn * free + Tm * Fc/(KT + Fc); Tc_dot = (Qd * free * Cn - Qd * Tc) / Vt; Fc_dot = (Vc * kfil * Cn * free - Vc * Tm * Fc/(KT + Fc) - Vc * kfil * Fc) / Vfil; Gt_dot = -ka * Gt + TDoseRt; Elim_dot = Vc * kfil * Fc; AUC_dot = Cn; /* Total amount in all compartments, for mass balance */ MassBal = Cn * Vc + Tc * Vt + Fc * Vfil + Gt + Elim; } deSolve/inst/doc/dynload/ChemicalDAE.f0000754000175100001440000000402612352122173017235 0ustar hornikusersc---------------------------------------------------------------- c The chemical model example of daspk but with the c production rate a forcing function rather than c a parameter... c---------------------------------------------------------------- c -------- ChemicalDAE.f -> ChemicalDAE.dll ------ c compile in R with: system("g77 -shared -o ChemicalDAE.dll ChemicalDAE.f") c or with system("R CMD SHLIB ChemicalDAE.f") c---------------------------------------------------------------- c Initialiser for parameter common block c---------------------------------------------------------------- subroutine initparms(daspkparms) external daspkparms double precision parms(3) common /myparms/parms call daspkparms(3, parms) return end c---------------------------------------------------------------- c Initialiser for forcing common block c---------------------------------------------------------------- subroutine initforcs(daspkforcs) external daspkforcs double precision forcs(1) common /myforcs/forcs call daspkforcs(1, forcs) return end c---------------------------------------------------------------- c residual of rate of change and 1 output variable c---------------------------------------------------------------- subroutine chemres (t, y, ydot, cj, delta, ires, out, ipar) integer :: ires, ipar(*) integer, parameter :: neq = 3 double precision :: t, y(neq), ydot(neq), delta(neq), out(*) double precision :: K, ka, r, prod, ra, rb common / myparms / K, ka, r common / myforcs / prod if(IPar(1) < 2) call rexit("nout should be at least 2") ra = ka* y(3) ! forward rate rb = ka/K *y(1) * y(2) ! backward rate ! residuals of rates of changes delta(3) = -ydot(3) - ra + rb + prod delta(1) = -ydot(1) + ra - rb delta(2) = -ydot(2) + ra - rb - r*y(2) out(1) = y(1) + y(2) + y(3) out(2) = prod return end deSolve/inst/doc/dynload/AquaphyEvent.R0000754000175100001440000000560012352122173017603 0ustar hornikusers#--------------------------------------------------------------------------- # A phytoplankton model with uncoupled carbon and nitrogen assimilation # as a function of light and Dissolved Inorganic Nitrogen (DIN) concentration # # The example demonstrates how to use forcing functions in compiled code # # before trying this code, the FORTRAN program has to be compiled # this can be done in R: # system("R CMD SHLIB AquaphyForcing.f") # do make sure that this file is in the working directory... # (if not, use setwd() ) #--------------------------------------------------------------------------- library(deSolve) ##============================================================================== ## Running the aquaphy model with light and dilution as forcing functions... ##============================================================================== parameters <- c(maxPhotoSynt = 0.125, # mol C/mol C/hr rMortPHY = 0.001, # /hr alpha = -0.125/150, # uEinst/m2/s/hr pExudation = 0.0, # - maxProteinSynt = 0.136, # mol C/mol C/hr ksDIN = 1.0, # mmol N/m3 minpLMW = 0.05, # mol C/mol C maxpLMW = 0.15, # mol C/mol C minQuotum = 0.075, # mol C/mol C maxStorage = 0.23, # /h respirationRate= 0.0001, # /h pResp = 0.4, # - catabolismRate = 0.06, # /h dilutionRate = 0.01, # /h rNCProtein = 0.2, # mol N/mol C inputDIN = 10.0, # mmol N/m3 rChlN = 1, # g Chl/mol N parMean = 250., # umol Phot/m2/s dayLength = 24. # hours - 24 hrs light ) ## ======================= ## The initial conditions ## ======================= times <- seq(10, 24*20, 1) state <- c(DIN = 6.0, # mmol N/m3 PROTEIN = 20.0, # mmol C/m3 RESERVE = 5.0, # mmol C/m3 LMW = 1.0) # mmol C/m3 ## ================== ## The events ## ================== tevent <- seq(0,24*20, by=24) le <- length(tevent) eventdat <- data.frame(var="DIN",time = tevent, value=6, method="replace") ## ================== ## Running the model ## ================== out <- aquaphy(times, state, parameters, events=list(data=eventdat)) ## ====================== ## Plotting model output ## ====================== par(oma = c(0, 0, 3, 0)) plot(out, which=c("PAR","Chlorophyll","DIN","NCratio"), xlab = "time, hours", ylab = c("uEinst/m2/s","ug/l","mmolN/m3","molN/molC"), type="l", lwd=2) mtext(outer = TRUE, side = 3, "AQUAPHY", cex = 1.5) ## ===================== ## Summary model output ## ===================== t(summary(out)) deSolve/inst/doc/dynload/radaudaedll.R0000754000175100001440000000545612405043651017446 0ustar hornikusers## ============================================================================= ## Example 3: DAE ## Car axis problem, index 3 DAE, 8 differential, 2 algebraic equations ## from ## F. Mazzia and C. Magherini. Test Set for Initial Value Problem Solvers, ## release 2.4. Department ## of Mathematics, University of Bari and INdAM, Research Unit of Bari, ## February 2008. ## Available at http://www.dm.uniba.it/~testset. ## ============================================================================= ## Problem is written as M*y = f(t,y,p). library(deSolve) ## ----------------------------------------------------------------------------- ## Implemented in R-code ## ----------------------------------------------------------------------------- ## caraxisfun implements the right-hand side: caraxisfun <- function(t, y, parms) { with(as.list(c(y, parms)), { yb <- r * sin(w * t) xb <- sqrt(L * L - yb * yb) Ll <- sqrt(xl^2 + yl^2) Lr <- sqrt((xr - xb)^2 + (yr - yb)^2) dxl <- ul; dyl <- vl; dxr <- ur; dyr <- vr dul <- (L0-Ll) * xl/Ll + 2 * lam2 * (xl-xr) + lam1*xb dvl <- (L0-Ll) * yl/Ll + 2 * lam2 * (yl-yr) + lam1*yb - k * g dur <- (L0-Lr) * (xr-xb)/Lr - 2 * lam2 * (xl-xr) dvr <- (L0-Lr) * (yr-yb)/Lr - 2 * lam2 * (yl-yr) - k * g c1 <- xb * xl + yb * yl c2 <- (xl - xr)^2 + (yl - yr)^2 - L * L list(c(dxl, dyl, dxr, dyr, dul, dvl, dur, dvr, c1, c2)) }) } eps <- 0.01; M <- 10; k <- M * eps^2/2; L <- 1; L0 <- 0.5; r <- 0.1; w <- 10; g <- 1 parameter <- c(eps = eps, M = M, k = k, L = L, L0 = L0, r = r, w = w, g = g) yini <- c(xl = 0, yl = L0, xr = L, yr = L0, ul = -L0/L, vl = 0, ur = -L0/L, vr = 0, lam1 = 0, lam2 = 0) # the mass matrix Mass <- diag(nrow = 10, 1) Mass[5,5] <- Mass[6,6] <- Mass[7,7] <- Mass[8,8] <- M * eps * eps/2 Mass[9,9] <- Mass[10,10] <- 0 Mass # index of the variables: 4 of index 1, 4 of index 2, 2 of index 3 index <- c(4, 4, 2) times <- seq(0, 3, by = 0.01) out <- radau(y = yini, mass = Mass, times = times, func = caraxisfun, parms = parameter, nind = index) plot(out, which = 1:4, type = "l", lwd = 2) ## ----------------------------------------------------------------------------- ## Implemented in FORTRAN ## ----------------------------------------------------------------------------- # compiling... # system("R CMD SHLIB radaudae.f") dyn.load(paste("radaudae", .Platform$dynlib.ext, sep = "")) outDLL <- daspk(y = yini, mass = Mass, times = times, func = "caraxis", initfunc = "initcaraxis", parms = parameter, dllname = "radaudae", nind = index) dyn.unload(paste("radaudae", .Platform$dynlib.ext, sep = "")) deSolve/inst/doc/dynload/AquaphyForcing.R0000754000175100001440000000703012352122173020110 0ustar hornikusers#--------------------------------------------------------------------------- # A phytoplankton model with uncoupled carbon and nitrogen assimilation # as a function of light and Dissolved Inorganic Nitrogen (DIN) concentration # # The example demonstrates how to use forcing functions in compiled code # # before trying this code, the FORTRAN program has to be compiled # this can be done in R: # system("R CMD SHLIB AquaphyForcing.f") # do make sure that this file is in the working directory... # (if not, use setwd() ) #--------------------------------------------------------------------------- library(deSolve) ##============================================================================== ## Running the aquaphy model with light and dilution as forcing functions... ##============================================================================== parameters <- c(maxPhotoSynt = 0.125, # mol C/mol C/hr rMortPHY = 0.001, # /hr alpha = -0.125/150, # uEinst/m2/s/hr pExudation = 0.0, # - maxProteinSynt = 0.136, # mol C/mol C/hr ksDIN = 1.0, # mmol N/m3 minpLMW = 0.05, # mol C/mol C maxpLMW = 0.15, # mol C/mol C minQuotum = 0.075, # mol C/mol C maxStorage = 0.23, # /h respirationRate= 0.0001, # /h pResp = 0.4, # - catabolismRate = 0.06, # /h rNCProtein = 0.2, # mol N/mol C inputDIN = 10.0, # mmol N/m3 rChlN = 1) # g Chl/mol N # This is how to compile it; #system("R CMD SHLIB AquaphyForcing.f") dyn.load(paste("AquaphyForcing", .Platform$dynlib.ext, sep = "")) ## ======================= ## The initial conditions ## ======================= times <- seq(10, 24*20, 1) state <- c(DIN = 6.0, # mmol N/m3 PROTEIN = 20.0, # mmol C/m3 RESERVE = 5.0, # mmol C/m3 LMW = 1.0) # mmol C/m3 ## ----------------------------- ## Create the forcing functions ## ----------------------------- ftime <- seq(0, 500, by = 0.5) parval <- pmax(0, 250 + 350*sin(ftime*2*pi/24)+(runif(length(ftime))-0.5)*250) Par <- matrix(nc = 2, c(ftime, parval)) plot(Par, type = "l") Dilu <- matrix(nc = 2, c(0, 1000, 0.01, 0.01)) Forc <- list(Par = Par, Dilu = Dilu) ## ================== ## Running the model ## ================== names(state) <- c("DIN", "PROTEIN", "RESERVE", "LMW") outnames <- c("PAR", "TotalN", "PhotoSynthesis", "NCratio", "ChlCratio", "Chlorophyll") out <- ode(state, times, dllname = "AquaphyForcing", func = "aquaphy2", initfunc = "initaqparms", initforc = "initaqforc", forcings = Forc, parms = parameters, nout = 6, outnames = outnames) out2 <- ode(state, times, dllname = "AquaphyForcing", func = "aquaphy2", initfunc = "initaqparms", initforc = "initaqforc", forcings = Forc, method = "euler", parms = parameters, nout = 6, outnames = outnames) ## ====================== ## Plotting model output ## ====================== par(oma = c(0, 0, 3, 0)) plot(out, which=c("PAR","Chlorophyll","DIN","NCratio"), xlab = "time, hours", ylab = c("uEinst/m2/s","ug/l","mmolN/m3","molN/molC"), type="l",lwd=2) mtext(outer = TRUE, side = 3, "AQUAPHY", cex = 1.5) ## ===================== ## Summary model output ## ===================== t(summary(out)) deSolve/inst/doc/dynload/ex_SCOC.c0000754000175100001440000000145412352122173016440 0ustar hornikusers/* -------- scoc.f -> scoc.dll ------ c compile in R with: system("g77 -shared -o scoc.dll SCOC.f") c or with system("R CMD SHLIB scoc.f") c Initialiser for parameter commons */ #include static double parms[1]; #define k parms[0] static double forcs[1]; #define depo forcs[0] void scocpar(void (* odeparms)(int *, double *)) { int N=1; odeparms(&N, parms); } /* Initialiser for forcing commons */ void scocforc(void (* odeforcs)(int *, double *)) { int N=1; odeforcs(&N, forcs); } /* Derivatives and output variable */ void scocder (int *neq, double *t, double *y, double *ydot, double *out, int *ip) { if (ip[0] <2) error("nout should be at least 2"); ydot[0] = -k*y[0] + depo; out[0]= k*y[0]; out[1]= depo; } deSolve/inst/doc/dynload/odeband.R0000754000175100001440000000461112352122173016566 0ustar hornikuserslibrary(deSolve) ## ======================================================================= ## Example 1 of help file of lsode: ## Various ways to solve the same model. ## ======================================================================= ## the model, 5 state variables f1 <- function (t, y, parms) { ydot <- vector(len = 5) ydot[1] <- 0.1*y[1] -0.2*y[2] ydot[2] <- -0.3*y[1] +0.1*y[2] -0.2*y[3] ydot[3] <- -0.3*y[2] +0.1*y[3] -0.2*y[4] ydot[4] <- -0.3*y[3] +0.1*y[4] -0.2*y[5] ydot[5] <- -0.3*y[4] +0.1*y[5] return(list(ydot)) } ## the Jacobian, written as a full matrix fulljac <- function (t, y, parms) { jac <- matrix(nrow = 5, ncol = 5, byrow = TRUE, data = c(0.1, -0.2, 0 , 0 , 0 , -0.3, 0.1, -0.2, 0 , 0 , 0 , -0.3, 0.1, -0.2, 0 , 0 , 0 , -0.3, 0.1, -0.2, 0 , 0 , 0 , -0.3, 0.1)) return(jac) } ## the Jacobian, written in banded form bandjac <- function (t, y, parms) { jac <- matrix(nrow = 3, ncol = 5, byrow = TRUE, data = c( 0 , -0.2, -0.2, -0.2, -0.2, 0.1, 0.1, 0.1, 0.1, 0.1, -0.3, -0.3, -0.3, -0.3, 0)) return(jac) } ## initial conditions and output times yini <- 1:5 times <- 1:20 ## default: stiff method, internally generated, full Jacobian out <- lsode(yini, times, f1, parms = 0, jactype = "fullint") ## stiff method, user-generated full Jacobian out2 <- lsode(yini, times, f1, parms = 0, jactype = "fullusr", jacfunc = fulljac) ## stiff method, internally-generated banded Jacobian ## one nonzero band above (up) and below(down) the diagonal print(system.time( out3 <- lsode(yini, times, f1, parms = 0, jactype = "bandint", bandup = 1, banddown = 1) )) ## stiff method, user-generated banded Jacobian print(system.time( out4 <- lsode(yini, times, f1, parms = 0, jactype = "bandusr", jacfunc = bandjac, bandup = 1, banddown = 1) )) ## and now a jacobian in a DLL. # system("R CMD SHLIB odeband.f") dyn.load(paste("odeband", .Platform$dynlib.ext, sep = "")) print(system.time( out5 <- lsode(yini, times, "derivsband", parms = 0, jactype = "bandusr", jacfunc = "jacband", bandup = 1, banddown = 1, dllname = "odeband") )) deSolve/inst/doc/dynload/odefor.f0000754000175100001440000000253112352122173016473 0ustar hornikusersc -------- odefor.f -> odefor.dll ------ c compile in R with: system("g77 -shared -o odefor.dll odefor.f") c or with system("R CMD SHLIB odefor.f") c Initialiser for parameter common block subroutine odefor(odeparms) external odeparms integer N double precision parms(3) common /myparms/parms N = 3 call odeparms(N, parms) return end c Rate of change and 3 output variables subroutine derivsfor (neq, t, y, ydot,out,IP) integer neq, IP(*) double precision t, y(neq), ydot(neq), out(*), k1, k2, k3 common /myparms/k1,k2,k3 if(IP(1) < 3) call rexit("nout should be at least 3") ydot(1) = -k1*y(1) + k2*y(2)*y(3) ydot(3) = k3*y(2)*y(2) ydot(2) = -ydot(1) - ydot(3) out(1)= y(1)+y(2)+y(3) out(2)= y(1)*2 out(3)= IP(1) return end c The jacobian matrix subroutine jacfor (neq, t, y, ml, mu, pd, nrowpd,RP,IP) integer neq, ml, mu, nrowpd ,IP(*) double precision y(*), pd(nrowpd,*), t, RP(*), k1, k2, k3 common /myparms/k1,k2,k3 pd(1,1) = -k1 pd(2,1) = k1 pd(3,1) = 0.0 pd(1,2) = k2*y(3) pd(2,2) = -k2*y(3) - 2*k3*y(2) pd(3,2) = 2*k3*y(2) pd(1,3) = k2*y(2) pd(2,3) = -k2*y(2) pd(3,3) = 0.0 return end deSolve/inst/doc/dynload/SCOC.f0000754000175100001440000000203512352122173015743 0ustar hornikusersc -------- scoc.f -> scoc.dll ------ c compile in R with: system("g77 -shared -o scoc.dll SCOC.f") c or with system("R CMD SHLIB scoc.f") c Initialiser for parameter common block subroutine scocpar(odeparms) external odeparms integer N double precision parms(1) common /myparms/parms N = 1 call odeparms(N, parms) return end c Initialiser for forcing common block subroutine scocforc(odeforcs) external odeforcs integer N double precision forcs(1) common /myforcs/forcs N = 1 call odeforcs(N, forcs) return end c Rate of change and output variables subroutine scocder (neq, t, y, ydot,out,IP) integer neq, IP(*) double precision t, y(neq), ydot(neq), out(*), k, depo common /myparms/k common /myforcs/depo if(IP(1) < 2) call rexit("nout should be at least 2") ydot(1) = -k*y(1) + depo out(1)= k*y(1) out(2)= depo return end deSolve/inst/doc/dynload/odeband.f0000754000175100001440000000237612352122173016620 0ustar hornikusersc ========================================================================== c Example 1 of help file of lsode: c a simple function with banded jacobian - upper and lower band = 1 c note that number of rows of PD = nupper + 2*nlower + 1 c ========================================================================== c Rate of change subroutine derivsband (neq, t, y, ydot,out,IP) integer neq, IP(*) DOUBLE PRECISION T, Y(5), YDOT(5), out(*) ydot(1) = 0.1*y(1) -0.2*y(2) ydot(2) = -0.3*y(1) +0.1*y(2) -0.2*y(3) ydot(3) = -0.3*y(2) +0.1*y(3) -0.2*y(4) ydot(4) = -0.3*y(3) +0.1*y(4) -0.2*y(5) ydot(5) = -0.3*y(4) +0.1*y(5) RETURN END c The jacobian matrix subroutine jacband (neq, t, y, ml, mu, pd, nrowpd,RP,IP) INTEGER NEQ, ML, MU, nrowpd, ip(*) DOUBLE PRECISION T, Y(5), PD(nrowpd,5), rp(*) PD(:,:) = 0.D0 PD(1,1) = 0.D0 PD(1,2) = -.02D0 PD(1,3) = -.02D0 PD(1,4) = -.02D0 PD(1,5) = -.02D0 PD(2,:) = 0.1D0 PD(3,1) = -0.3D0 PD(3,2) = -0.3D0 PD(3,3) = -0.3D0 PD(3,4) = -0.3D0 PD(3,5) = 0.D0 RETURN END deSolve/inst/doc/mymod.c0000754000175100001440000000200112352122166014677 0ustar hornikusers/* file mymod.c */ #include static double parms[3]; #define k1 parms[0] #define k2 parms[1] #define k3 parms[2] /* initializer */ void initmod(void (* odeparms)(int *, double *)) { int N=3; odeparms(&N, parms); } /* Derivatives and 1 output variable */ void derivs (int *neq, double *t, double *y, double *ydot, double *yout, int *ip) { if (ip[0] <1) error("nout should be at least 1"); ydot[0] = -k1*y[0] + k2*y[1]*y[2]; ydot[2] = k3 * y[1]*y[1]; ydot[1] = -ydot[0]-ydot[2]; yout[0] = y[0]+y[1]+y[2]; } /* The Jacobian matrix */ void jac(int *neq, double *t, double *y, int *ml, int *mu, double *pd, int *nrowpd, double *yout, int *ip) { pd[0] = -k1; pd[1] = k1; pd[2] = 0.0; pd[(*nrowpd)] = k2*y[2]; pd[(*nrowpd) + 1] = -k2*y[2] - 2*k3*y[1]; pd[(*nrowpd) + 2] = 2*k3*y[1]; pd[(*nrowpd)*2] = k2*y[1]; pd[2*(*nrowpd) + 1] = -k2 * y[1]; pd[2*(*nrowpd) + 2] = 0.0; } /* END file mymod.c */ deSolve/inst/doc/source/0000755000175100001440000000000013131750050014706 5ustar hornikusersdeSolve/inst/doc/source/ddaspkcomments.txt.gz0000754000175100001440000004454112352122173021117 0ustar hornikusersKddaspkcomments.txt}[s &ql4Y /ߍ̆c=o?g է\5_M/1/FW/?ξ\^i ?-_`U4*֫&3Go!^N=]nL>k@}Zy +QrbPTr'&-aO;N/@7}؅7Ⱦ? '·z;*UU2 vE*MaBȯ~Iw e䎑cd*rCN?ƏI> $%3-m7ڤ}  4XgR%’w#~i:4D '_uuD|K}p_!xݬh 033g>,Gx&sJ@LÜOo.G G: ьxn,z)Yс_t4JYA~g< G#3?^5C*K^ =0h+p g"PawGr@;0.ϖb,Xպj#En[gj 03T wu  C5pl&;h8nYPNl*+m6Y]` ]¤46;I':McA$tӃϖY9H,RNb-l%Q `BD W5ypƂQin < uܜ~T?9޹G1^bqK} ,kDga ,poo!Ms|$WPX1iz_P尤v%KV!+;k~”ȇdYdISO}m0R:~CMb^"*@34=Y;YzdJd$xdݕ[y0/Old4&ܱ Nok2 (uʈ9[>ȇECJ$TFҍV -/d!R؉naK{R[1`Ꮴz~GeGke&gOC0u[d#GyLcp}[XUSkJkdHvMZ n#2`5.ËGTֺ 3y_GI `IP$I487` Q(E@Y)]"g نXVd$ihexYŧfD W5Y 2KJ$3ꖨfcÏ0de4q7΅G7V c-m"#m~V=9ɬtƎ#M{O`Ŭ+T&)˼ 4ndȊ8 57,׿!f}0J,iM 7jfRAoKE]Q i?0t s7ijyXV3qB+ oC֎ Ʒ6(3C+0bM2O2+(*J+_1rn&YׄG߁*nH(B?W~Y}EG%ё1 NWqH`VȎ.CdRo~zY/W4ۗ_)8eRo_bY=,,zW^:B =|=,q)^QEZXqݳV.PaVQzđT v`۰ $t%43_+EĚՊ F|nԷ,pr}q\PI"Pn8=I&P&Db2 /tc$a-q8X4c?=hn*=(Vݧ*=0UG&V5cz/dR@R 䕆., zZt9QGy=ZGol9w}A[Ȝ]]⋈|ԁ',e`ƓUHv|b.=u$uenQf;Iq!UqODCwkW@&:TqD*!,\vE'6=cs]ѕD`1w&]&e<2 "φ{(:42CIypMօO.^Tbb2]7Bt.1'%|Qc"6DX%F@m0P :𰲯+8+ǽRy*z]&M%A~ B1z=+`T} Wistdܴyrܐ#S4 ypF@0[@=xAl6ګbaV9*r~.ӉHYS8MLd_'HaF#Osv}"M䝮o$JKw`W'WLV()SKYǍO^cd7yI{8 +B.H(,Uƍ7~HoOS!▩-/kđ)^&_d0oMRd[PB88ʇQH(2Mf)QmrT T<H8k ð9U 8i9*MpFQ086s0l&4-W,JqV Fym&9ͱ s1 aFRYZ&*4T6d++oP": " ;9l;zy S28p`zd"2{$Lt%CtH(MMi軠wBG MoR5HVxo,Y gd²L|x`0e51thͯr9 Դ%8s'EupuWOs7R5T^(|tBxv:^Ll"1R>8WtgAGQ]ιȋ)#V^[XRMQ br2i׭v:vz`Щ be g'< ΨyXN#2*(FV]yULb3 f ?r'0M(\6ɑ a(Qp0ewu< Ԗ6'M'ơ N N4LLPYB@Xu/2`6P;<)Qy{>Ç*~2v&)hd?Q6A>bݓƽq2/?!:"!v(Fܗ <.a tǤ/=HHh@3y 7UҤP܍۞bl&Pu۾Ha.J*8^DSbF/M9ab^7]AfUb(bSOP"-SObryֿkeļ/=ȎM T`:vXϣK5%PF`B4 .TKPbCq/n5 sij2?Z- 2"Jl@9 B9I1ZVaK9ATo9O Z2UGSMbt3GeVSa O/p iTNdH!&'5ḒzbGߗA+lϛJ`@_yw9y8UufjmiA ⧎bF%#/>^/@?fy.ȔUs%{~:T.Vߣz.^Sp5 ڠ{F?tld&HBDgbr%SiW?.4, GqjIFoɬmbߚ1uBH%ST| Na`Uf)=Y u_cA$ >>ۮl4ӡC6-SO:g1坳)<`ƥ4fRT*Zxtr+τ)nN8='B#6ʔ:t{;P;Z|~a4Sp{EGꓱpEcH,Z7FI;FDq!yr&IEc=2YJkHp t0CDTz[3m= !)Hx_/qB[|ZQeR7&4o  gS^KoRI7줽V?FR1=N˰oק [d>e}O6*V8M|M8N= n*yY-ڔΛj("mMAKE:ΧƄ) 覀#$L(~E4U9ȯH09̬?g?zs]ٲ@1X``z@*e4 ԟ8 `b^UyQV)1 :-pzc{1"vR.2s5j农#Uւ'&]qL0ZH U7]rFP+(g>SmzU x;M 5Cs$Kӄ0Ȟ*C%9>rnE9 i FrZI:&;)XsI2h)W4XmdSۮ9{ŭ$2mHLSGy$KA9 vJCQB*Z ]a՚kܝ'j_૥rxmny)KOn~v;Aa~Vgܿ !J7F`yh¶v͡&ާ2jUf֍&LI?4* Gkö=c (B!eZT2PRv1/e;tfѩ=[Z@Mt"u@"<|YC` | 0zڗAD9ZF}?-v{U-GjW]f>WI܀\/F9?F@+l*&# ܘoR~Ɖ7۷hj8V3@(nouInUվP ޤI^9#2~")&>@Sl/%Sr|rnkkZNs˩OOzEMQ]`CnR]ȟlnA+l0nw,4Qd|k0َs0eT"(:2$Pvd1 zm͇+Љh4=Ģ{/{S4 xuqٺn~!T[F mS7t]MsV) N{i~z*|8_!+TG鬃47c o_60,~K$kqoM ȡֲ&ar]y|cA)|? 'Ddh-fJ#C/둹)# @a-/:$D 9{R"_.c>Z|t.Q+iSzƲ:\߽u9|еp|'uJ<_KEH%LR3&ஶ)4 ӯMލD'Z T L@nd]n@PmCORIs1[㓌te].+XP2m'v9:_"_bZ_&!(~#" 3M1c?MF#߆Ua.Y%c ,{D*JK- V;!29%N6M}ߝ(~[%L;4>h7]RH`-c60uqj_*' _Al5KT3}簫0u̢L{eW4rثXS!0v9t_K]mm)PaMGZYa\}8˪R6H}F‘ Pm`[9IAE=l\R#~Q1Yof_qИ& ivsP}^$%O=nT;,Tg 9m$Ήj}g4ҔW؏pHZձvIUzRkT=P*?oĖcl8 B@<~<{W7^3L^եE>W Gwcg&c} *mk<֒K"6MMꐛE_^eϩ_Z:5DgoT(mO;}v6#G=g0ghϧœ_vCF JX'gdcAev}Tp \Əu2_!^/a3^JǶ3W.˚c/ZzJ5 Òl|$?!!9II0!ZФP=POn@Ҵ7h++S9l+'z'CJ?B_n.ihmq\_L$;oѾoC@[m9qο񾤰(]3hzuxU^[=n}w׵οSug'yCx;p3P|d^̽`dGk2uVmhǹoT𪼻 u*HYS((+nd]aQHLV H+oUK䢨O "H\׷kw xU4Fzpkn-Yl”'7tFMdKDV6nVLV,ŭʰߛ.Nu'w)t`%ʻغԘŽ%wze4R"s{AACh m߸njC iA ]={i;Ph N?o8IkiU:JT5]RM/Raz]@i.U%Tr w^RցGQ9&loB[y*.DXDJrUmY"Ư; EMe],:Hj~= Nn2};MMoi[aot?Tnݺ5Өo7\.C. ٸӋNKL&[ ?ţٻ M x"~l@ ?dR7턎;G>pk=(^3lN`gF6ZRHSf{J$d6R/Įk]@RΥ -=yhAے-5Oliܨ. aMu]G/C۴ƵD]1r8r3a>}' ??{V,>Oc FFͰfyZFGiflV 1'`rP}vdE'k5<zd.mkYmv)L)I V~!U7k<r$YD_-^kvЧ&NP I-pip^a|"|[dBq]D(OKjB~[J+aE])gF3ǥ2֤\l"8*gyy5@Q$ ̳;TTHpܼ!m4,Q3 wɚHD`e&p7̇:l0O%k"KEE}tR Kmc( BE/&wͫya&T~{h@e_a;qV{A} YH|)˘]gn^B{[R:G]XЏW>\?ٸC2N;Xf%6)bhqu'ވFyi{1Qb{dqL|z_/RKN2$0X]R0кL D)nնBTFcQMaR٩)jܦ~y!\38Cl(Ø9 J[FIIUts 92u)…āǺ>pfFIŋ+BXuI@JK d ٧AL8ɦ=Zl7BF蕠kώQͬ(=>/^{ b]+; 'ZӹֱEX58@#8.q6h-_B06Zrv &eʄ;Z=c!Ķ՞# Vx>1?b%?8诊k?hyI6xr' R l*Bm%"nu@+_k=a&JۂONGc-B\wUp$0oSo6qb#˗ȅI\MI m'ֹ3V֮6PĚCM{EBն ;<7p௶ @k<R9m~?'{ Fx5 ƓabPZ6ڕJwz&fպTWHm&{LKe! ʂݻ t:(I EA-G &Hj债l%A64ehmTvnМm5Z_.1 *OZQdlVJ74A^`Դ5x:܂,߅n74$n1lhSA/7zpjt{X꽍,]_Z)rP%[N}tQndP}Khݤz4+7c*`mJua>-(&Mn<[RjF=PiME[zY tefIgmOsq./ ;Rv1*J%"L*b t9f1Ä6էܾu)o:[u}yav6| MfeLV5mC{O<˽wx컳 X+nn'u> xzyzB# <0d6s2_𐦓<9V[t,oUch'hQs4Qn[ϓ8g}2nS#T:aK4?,jP3=ݬ$ΜANƒj}LiAM<}5)ԴWnl"/_4vMdgOnO(%,H&=h5)sQ}!,x9KI8S8?]X |aw_pv5{kdgϺ+Z8*eG$ /koWZcgΗ-s~jRgghW M*I'55lfnkVۯ0tuރñ}]L&w w%^v%'4P^↺Y6&E'94.8RJtNg(`*n>cu7`!u%]~C+ 7cB|Jeb0ϰr^($3EίTEԊ{*Ko5eumt~BJхƁ[g&9ÄMnj^%l&+kmV kjf*G?;]1cP~]4gȝo߮3i*'&iWuGJ }*hvU^sqeNuByE1w# &lGuKy7/zUvꉶ{S>Ef|úa[~&$@IzB${নH"UHΠ//t 㤅{CyƢ@Q`4TA,BDB ǜ"%ˉ}$Lu!oOGuHhS/j/jc:V tE\i'TK, D' "3Vvڃ YGmSb`/%]*4fL0պE]j /Uϼ,ɍ{NliV~/ЯbghS}0 IrWVZl)ED:T=3rL5e(0ZM@Vw}˴`p;"9PO3sE6/ML0vWk^ wazRxWnɖjQ(vۮo|<ҰLyHݷ~XO[p4me3(4i*_%Dᒥ%l}N *ʸ%kJ45G)moh7JnYz-MUϦQuBc_ԑ<8rH9:Gvy.q_vl0I*@ i gcu\ْF#8+aEw*+s*KŰUY1U+QDT[^:m O* &Ḓ С)Lk?Q=[xFڑlm?z5xQɚaO;YdkJBrn1LɯjvK\{;bAӰVSMFEBYGL$)ݶD`Yjʂ ^2i8 d^t~ne+-]dX`Eq\*lRku^o),nD-r9/`d}W|S\[ N5빪4s{]\D{Hzoo˯ t&V  ZZ1y>٠Lž IK D~NDcx֍m @W6P}̩OT~?!t.>>u*p3|s&`vwncߵą|:~w&D$!ym=aӓ d CSFl~=[vVqyI@ӮB~3uqImk.󛴼3}yDݱ* jQE*ƶv0"@ލc{3$NtxѨy9C÷\Î^%~ί? Ndnʖ%C?꼹Ν|% 3zҨJ77"V[  E4]_^4(2o+ deSolve/inst/doc/source/opkdmain.f.gz0000754000175100001440000065140012352122173017311 0ustar hornikusersKopkdmain.f\MwHW& 6; bpoKh#8̯OUwK-!d޻:9K9 >d0|#0߿b/ƪmʏV\#,؟I7?lq83/hj a0yp3w~4jr;ncnAV?=/ܫj:??08cP腧Gwӻ=xž6*Q,&" r~F {)ؕo%RrPDklG㛷#{I DE 9$MD NF/@&VE*~Zj0}`,(v Vuu7?@jNnݲm_uB ~sf]a?N wfwk]g4-Ŧ@#kp/>G>t8 ?3 h<[<Cܖ'u?Col\o Tl$-@$):{B^JY^XhK}=FX)Px^VwH$z1fҌHD;y0}Vc. hSZOP$hZzWA _“F`܎BhZĂ{ObS|-Lt;^<ď8"(W` NLW[M4ʋy")^CZFѓ>ǚƙDDzxg$cRq:oу5Ų>@Hh]0)іKSBjv㧚Jii8?7kI$_>BS4ޫfcSM M7!E 1[ޖPwn뇼ԇ}+Eǧ vI~) Eh4`v;ߋhyI2|Y%rjOC;Bc) {H~zu` T_y~Z9w fNSAۛwu?w.~:")/ >PUi.?jDXW hSpL77dO9̒j5u͟Z;>>TR9`NklF5/a&RHH}B  aplJѕe&KT]k%/#Aw,~Lfe_Xv*?CJtTS3cFȨ8:segיHv\֏B $"KJ~AT ʳWϻ<'qG>ҺmpijKU:gEy7GQrR Q-j^(8v<`v1Ү ; ѧ(g_Ѡ[V7 r Gc OnQADlZvq,k`Q @:n$dO.$QQ7 ePC[riׄ7G1^ZQԞ|:H S]X[$ cL 76fӽ)JIl~s >}3́)5oH}& )/^ͻtm|~;|[;8b7T >J"Z((74Y!*pQ[/:yR Z_:urp&N,0ȀqO3f/s&OR PL,9 UX$5G19L\@OqNfXpЙ&r&vnQD"_1Xt;Z_Sۓ[ П#P؈j=yl@ }N JJf v2ܾ1e:zHr E zWIcrj4p! >%tqE/e #Xf DBA`V/WOby6wjf2HJt3̺)K (K}qi1t#gG1@jdGb;a-5CbZmd0!A ~92( yYj絷8:(n>>uK G/LSc1Zei H|J.Pjg![ZF[׀`3ڟiBeXpj97?^q5Csɫֿ|}SJkD.G@+g)j2}yo Ǐ#ǴqԖ==L )<@Alg=yV˜^%cqRA;e\L!ʐ4bZh ڇ SfƩILC 8vr2F*:w^@C{ItޜT=Y*+EVERL J!(*,%,; D'%]&[J#8=RǍ?W*" V k,d˩[[?s"R9jh|4,Ox,u"noۇS |9 [2m| ιUi\Ẓ J^xajХvƻ[1թ-(YvY&/0y-YCc,0Ry\W^{+Fd*I9h}ka໸y D&7T`Pݮ눌 ſrgs ǤTPnJc#Jd3׈2xҩ\z?lDg<ɑN{_.>}i9(eaS6d 6Sdv&5RAvfuOBmIw2^9YwRǙľd+-O(-oiʔ6^AAeaz̖ty/N(Pw);e+X8 I `-pLp*Imm0؛Pq jJ>k GZB`fLTrJYW38e4 JT)ڄKȂ++B2>ah `CZ!etޫ=JQBW,ބyd2ojW]$(2Z&9Z?)E(-dGLYCƀsp_z3vq _p"EtJ.,9pMrZfSd[Z#Z5{ʻ2)y«[m&J n`'lpEWtĀ@f l%*,Q) 5R-HBE):Z%皀 rg%~(߬s(y1g;'mƼ~۪W-6\W9ICJr-X4 N,g[mSRq% '}] ˇAO>@E9~t-%(LLV,Spx-:T&ϤOi⎬.UVx$f:l({R&q:1܊ KgX֢+G~d9YntjR{>T]e WU((@T>1%l#hNj֦OiXpTgFZAjLe9+' 89w1 ¢?_[^4J0'0]Lj)DcX6#lpClfUh-{xA?]KKv10+9بݭ*"Hdm1zA!0E)Tfv@ a9}5TfzKjg#@tAn4ev$T dz!sʷOiz.fP!^+#˘Dt{()6(6Hy#ez%> ̟eZd.UȲW*t3VVΑiCV] JΥY9#A>TJ5h7]ypZ:9;CʈD=0nhW?p'.YՌq+=:$;siܑen0Fl>cZo;˫4|=LGakͺr~Э"O('5p\xtӶ52hff !()ʐK}35+?(٫h-ƫ H @b(SMfNKiyɇ=c_0,{@v&ioQx`*BfK ׿6&%|wAAd=o=-r ޢ 8w:=L?ăO%CBt*:2cÁ`MBq8gPEaxҕ %jΗ:yGzmG饪CWwh8؁7_cWXJnM9Н}q.ܮײ[v~u׾:Vk6sf] nv.%Pnv% \6;ʞ\Q%Kv9jiYOuv-:vq\%r˖st$Хk7[=_N5_jk}Qlu^Kt{/ua]\wٺ%:nEu5P]L؋ctЗ)x۽d؋zm$e;^p: p;r3d/9;hn@ /fۀb+;!]'zj6&cZ[aȮ>W5ʲ4f_/ʤGCA,,%wV,VTIi%ڻ(N`JN%A/e ʮS3_<]LoȸwdF*7 [¡} okBRz7*!N >O6=W%< v^]..sY U(]{|1SUj%`k`? g@#WD]_ѫ/s]݆\K5댬f0=aB(# p.r6c>9o1vtyIng/{F 1I B1r9ԝ@V&H|f E8Ge _k>3v7;:4tZcawHNҝj^ra)# C@PUc*z(ʻ@9|cKWH1[TXph@&ޟ ~"3lV4*ȝ?F@̳$P3̰c"vbl ^ obBL(pU|˧c1T*15NP/#)%:- eO?II 14.S3 wBxu2MyIlǨFb8q*?܇jƦOVn:o'VمEr053':z7 (rLT#;cƦsO8-P|!_tX.)gH;-@{F P?Ͽ^DX(\9(+i_4K!G.Tzt!Xј.;x#I ا>Ixhs\ !?vE`^hJGtlCgA:Υȱk`D}ew 3+ TWσ+X2=V9Fzkλ1Z^7A~r,9u@B#3DsVrNكS0ʅz"g#.![LeSy`♔!ֈ#`EycbAby-;[}l҉aRy4Xч΢6WE&n㧱]}ߝL`GtKn`:SH%sJc &Lsr1YrR˴J1"h { MPNҪg8 vyii]ao7 8H'+,'TVWVcf^)5 g7e%i-WԹҴߨ&\J=v."Ww?%'t]h2*RWD5,v:'mCVZٷ1qyHvsNeG|tOa;X:3 )JJwE#ˁ C R{}9G ԔT]!zQ] %sOU= }ƧdQ2V xV*U TeeiO_2D!H EmSuRH[='AOx~oZf 8}[UݒRuL)"` `G!"[K}cj7 d>*ijg 1^.5HJ8L!4ܰlSr yy%"Z3r^Ilz[%=' =% 5Y1>V%j>~1~u)cfhf)*`cDEEhON Nd CZpEs5ibPo0Y 4=DϽ2,_L¸?,!Vxm@$k`8⋏d$4~UٺiSa;?*~7U՘UVUjo>.Hո2%`V*%QP3ʵKC᎓H勨i~ۅKZB'IGgnV6DfGfcC΢zAʠ&;nn|yOzQ l?"26cBM}|džؿA@1ҙ7%^fwTQ&|CE"! 2R3[E%E\R^^JW u떓? J) ́5Tu%O-o,peNWIUNi/ؗ'Rp^E])[ Clwazd:#[k,"MS'd[N5W*b}-AƖ{RtqpDYU/ à mt. na ) 9Z%VvnC%!%X J(V=WXgVkk\'lz~@]]Rc^v+ -D2<81aC;fxT8#\/cs_GM 4dY149_UIC+yLz#i+*>ʕlQl9jGǕ}a pQ`0EV[13Þ9sw'HTwSp*G49_g/aeg"zٰWg3Apq[XRՌ9;g U!!Vh >|\WmtTJ_8VWV"AUJL|nYA3Ӌ_UKXL$M7[O0C Lzv~a~z=sWJlkhOҝ^ $m+Ȏ7E\`&8c!)oҖZpGG4K~xD3KHWV*v,}l7E95T M$Je@c,'biUEw" Mq@ 6AyN5& `*DfpkJ'TI8Ÿ|B $YL\[fhp!|4,J!~H}\Y֓Jd2<٨p35駳ReTq/LlX?"I~6Ύ'썦KQԡfEc>BLJCT!2=^]B꼆ԵŤLP{U>)J*VNJ Z-wi,±:X렦*4Д.Վs5h4$"_V8O7|7r#IB'"Eyn-.RKTt4}NumVIfZq$R3p[Ee.wk9LtEeWt^s'Ie&!TQ ^sN7"H;ojQ=P*:I%Q x,jLaLP"@ذDysg]|05\zmDVayƹ'luiܬY"CHGp谐P܌.j;$>|U_9 :>Xv3L{f[0TЉ4CWW@lg<峢!02Ц¬KeI +1> @DiN_~M=驦'k)G - Ky~*|I%(U%oMEL$l%#J&|C^iiEO쯀iiU*UXIN&2E|qD4B4G u "J8\](+h=J! 9r+@6Yi1YaS(]ăN%M@%%o\"iJq5 d  ,FdcyUrMC[NP"5;"Y:kF ZƠbj D:H"Un<JAٕozeu(X nnrt9tvp7eNn8""YT[9nī,j%͵4n(bEBր {p6Vm)/*H֑\sqV[@tv%Vf}(3Ԁ򚛇?FORVH}Wp 9ί&p>}Ubal]9*B EMJ>ptlC%T20Y@8;8"!f˱$N`!J,>bz#c-bUD$E: e3V, "j<*\Y|1΋#GE?c"9f?uK< lXF*έY^C٘ :IkyV߁zdHa#>Ҥ(gUcgj0 040(͊*6{_D5|>5VV%UZŲ]ߛB/o%"wHсbJWדeLJXMFǜj%U7 X +-бi01˝Wm ;*_/4t=PgHIUsefN ӦVNpEzULT@3Ԕv,et[a(Ϧ^wTNUHaˊX X$LDKi3#X 8CpSr`f|wIaw >5zr$dsȻcM&yjA4`{24854]$ SrFj{Q8ȨPH/EP oblݗ%OJT:ҜXyFĠp އ< BcG>ofkm9عdrtΩMGޭ&?hZjâfz,Y"1<(Wb+wjx'BWEuEaюfuSD: 6 1xѦJK7Yx|Tj9f9S{_,bߓ|J0GߪVwUz[m6L,F+}pu5cխq\,1vL0%@-3pU2}Y," NﹺD!*Wy>\&(2]Ϋ66z^gQOL`^ ޑ'鉟ڬ%\mkE싊u8^ݦE: v*~zSsKfj nI>.Dj 4%tuxS@t junʊf E,-2u2aڲOk7n@!.sFqXaݜ I+Xp4'mYc>KN!fj )հA 舀.m*sMwX$#}[1dZ ZgX FX6qg1K5rd6}F S8hyVVQ_ "0C qe% jiES iG8WX]m(٧U}{3jĶTG1N*m~nDWC,zJCOG<8ctʆ!1!.gMa,t[.F3Oo5 tc&y8G:nH`OL!g. j³O $Yx&i]&"Hty5L.왤`=?h#Q-_].Ɵ#?ȆB::ô쪤r:*m?'Sqy ν o[^1hD-̚DR|+`cGA`x𛛌D/ZG^x6&5Ę筩HL(phLX\{/ L k"=x׍?~E 7й?#$# Vqdyp%EvTT4\*sϕm2R<B,?#{CԲ)&8VYbV],R++@F)_r) OEVaQ׋kݩFQ9ӛ/A0bP9n1Ffzx/YSy򍛺8+*k֢YWhx~iEG~ݷx1^wg!|8?*mH2t-}Le5Y38z%\f[ƪ|Mp\;"_V,׆SO33S(vv|֯b肀C$hVVc(>ngzڅ`t}jOбXknɔU|} ғp_`hu}zz߷j=/P *p52n;Nn=IĶ<>X:T@lUZ hӋdIO ь]%se33-tUҪt鞬FGRxhwuL͉(S$ȓqn\V-b*̙a@xyze%W Og8wLIC9{0";Tf:)J.r $+#ƷHz {lcõ^n#5Ւ,cƐ+7 җgfA&jd<]X j^߆TN rj.J!j&KWWȒ2" xU2&rlw_+=% 3C @(W;)RSXUXikX+;)@Wk"!s|\RE4z^^Te%F )@kiH.wIQFs buāsU MQCeWD:yյY&; ߯j^13kCJg A<}%>67 y[C6?e~QaJ<6tHl 3Ch[#G+H9u%Y{θ"0Δjni0a@Cr3$Z<LO% 5֪{5Pʧf[rYl!fB;*7qbQMa! -No벱1-fPIlIlOء) ; FE0 ,-TCôѰC{jOW_S(Le2I8wj-4##)oxWVn̼8`hkmw)@|wdW\+1,=C#ȸlHhEE "O_=ئTE'SPh㧅+PMGU>Jp'!焏6#wUȄR8j`KM{u!؂ŖxX(Z/2Z%H+i(q<>`GY Qx)&TY5"ѕ?F,DWPpDjv`f"S= ]r)s^Q>ĜcB # O[!I9??^%ƚ$%ζLD r)l=0.}b}frԚꂀV"pDܥT5Q>n,ya^D-.vQuE*1QZIFj[,zOIVC?ٚ+݅yhtyNRoUƺ#,$m1 tb+~&a^4,ԭmøOD1C.)g6.,1 ltE|yNB&/,JBPfGDI??p1`+l_qP_/x[3}~Z|ң /!S{;{Eڣ2Wt Ehs(MJ<{[.u% aEBNV[BVUSy .8MUM2Q4JHxoӐL9GZzoT{:JG $9=)$(K^"w6^Z8%~uz  芎u+Y`S3 Հ\lsFJ͐.'}ϯH:v|sOwpE%yMx4ݽbmd_Z|7 UE8Q0<، 0mLlBde7&ߔ0xN!Ԭx-uEaYV\Gnjh2tsNuxn6X6~1ӈv=W;="!$1ϷkUpl -[&luټPVqEP`YeR|o"caS"n VbTU;Gcި`8h2z w{/ sC疺N#[X,,$48񣤋T-pr9:it) r~pڇW"^)Z~@!ؠ o{%z~=i9|A_:J*nKMDrZ (Prn*z%# Go?eQyBA "3::OF[kAvaLbe^bfX0 Mb$ұ("[9?'Bv8/;50n.fvݕAM*RTwqiB6RS FθZ1폿-QhHqxOw*{YwE1 bAV%UwUԲYQҡi U"ZavYFSVe@Ko. 8amr&itC~?U~I@fLyJ$o?C"Ծ/_~ Lh9v KC/>t3hLbG\-z i@b}  WD: TeMqc  #dIo0% o%H8 ML)y)vlzA`UzےiT9@K[Z!y~" Ig}AR@[{?/r)ΐ`bY٩,)*:e>Kާ4t_力'%(C;/gkIzLMtӂR7,}O7q7K?>l6e>4W-y2oz8BI(`Թ DH*! _?޲N*Nx פ?fkЧglVE_4iȟzgG}n3Pk9ڮ@n6icVtxl _1B%Iv&yz6,\oIq Y-[xg9?WpDjW݉a꘺w-OMPq2 bTo<-_XIUc̢L;Ur'm) 놧B 8qBk^Ӏ Am*4ij#LAQϕ(le|ln)*[/yٗ8ۗϙFvV9QrBXng@A < G#HKx;hЎM[ iLT_bS$2Jd{>` ΍'{yfw~1 `W."=vm)sYMCْOpĩdx9;~L2%O{(>v`a`}%J D/n Jtޟ&GPEW1hj ~ɗHzvh#sG|a O\U(mCX],1=螵 <;[E1~c6f 4b^#8mM(9/XPZh#u-W1_{7&B[1+7I`oB;N(, D,"fw( 2iMh|J{6, #~Rj5CEcR"@Px+s[󯷊F2Ms)Quߠʗ$,XF]5YFWlU;*BJAROC4ѯ DF縜ggezܽW zy-͚̆{ʤ|ӳwz;8 7"X C?=Oﳝft* ‹DU/^ 5<5Z^6;&+OGDlk;g.eA_qpóprr=Q{ zr= jUL`# VpWCe5M}:ԍsΏA|O5ϯ Syi'1%B_;o`8I:DB=1Y|/_g 1i$XNkpt4$7$3H W!!uy{E# ^9 _ HHvqXazlJxi>SD"R}Pw(Mñ4C& }KD2d"-J5ۥjp3Zi'kdW8R2s*b~dmV}ó.ޢ=~EQDMTj W2~Tx+7o5h ( i~}E7nxe2%)H+N3}g۪7ꫯ[c+zx(9Qe&Q9ѯ<пnƎQNAQX“g0(E_ #.OJčm+w+68'zrrHQ r1Uw#<5WV5FGo:U|_뷲mԒ/m }=Ȣ1(3tBu[=Ta HTF-%v _t)Q0PLԍHfBYSƔ;녲ؽkȧ%hÆruP ׻)̤`a_&w@I^3l9 ObRL׀NY:ZȿיNN>[0~֮G J{m`/(?>rw?.k.Z(li(`$f=8몤?u`Q YOȒs !.r DYLRgI|pr /X΅3R>yP Ȓ O4aHɑԮ ,}1Y! -ʪ^H<% (gU}^󅏍 0FIc{ ٞט(tݘVMWeUyz1p[:^ y[֩&‰PhF_S]1 >q &۪mneonnC}N#i4bEE$s `_fU1&0mB9$FғY$~P#\PgsW̾WG9%Mvƒ=e~jp`?|I/3palrHnSs rVPr,ojr6ծjjbv/Fv pZ%ީ -HkiVBeǸB7D}#Q>hg;Mt rڧ+KV6<ƜtiXdt+{7)X:_d#Axh@xѮhxLG rBλ(> w@QaC"#* 92s9]mveB$,=)rg5Kave7сf,{VEWN-yq]0@c¢tʝA,̃gO mvݕS&k (u }:Kyb*vyN=գ4OǶWmT k{ǵ 綽[nSm:-U7I؊M4uF&(*ɳ/ҥ1U@>UT j*Xh@[bFZg6HV9WL2іjLbH^ "JV8(`liU߬szXVu7~Y_~R +XWi/BuNk]ыaFXBt%8E#<2 CsSP)B#8 rG4պ'˽ 6)\(TR6~շ/yvg7I,LK5E|L" ez;cvumRM+&txs#׋hZ0RdA>X`ʮGvL)>^wAs cvYh9Pø[O!΢* >>pkiuEЀW9UL6-ܨR6nj0i^E"u!ZzGNE!b?ZuN'z=MzT&r.p 8k AAiRNdz6_MsEY,HվY@M'#0.sae6_Cyj`5{FFuDBǻ 7hb&>; ZC?}N 'OjxS7}*55-lP=X:V(݀= + lȂ}r}#Lf%6R1r )q>'a^P(Dї ^p=֛IHpiso8c8d~~]@tx2<[IjͯE/LcW~=rkun$¯pW? rF8Hs@Qm~aEYx#/+WDXU HଞH:ڼsdOqvi"kbGNJ7)+@Og2/7Yo!(숗:5cd^IA:uF1n8 j,,G5)m[gE\[µUOni8dM$D!:o)%o9q6^d޴*1u ?} t׆`YM%pmjUlV2g2gߦ`>NBg.c?:sLCe8%ƹ "$S]ξ/tM}qJ,h 9?hӥq>ήu)`Xc1b(%?MKy\WF!Ypa @p2 YfwXZ)0|Ї&eNG/&䰴bjM_9<WLY S/7^W=*QJb؂ePŰiPֈ|"u>BQV\KEa쵱pZZKb*jPpRhC`!V![Q NObTM+IcrgǧF@ϜT4 Nlیүנ+|{*A[j=郷Nh?M'/ &,h{FĐQ1¯qWI .2F{z1Bd)wf4tطF sZsFƪ z }%6=+t9ke.]-Ϯ e>"vPh*O|¤x $2s_D)Df+BHrwr/=5ӈh`  ^7/g:KAOz5D9YkjdN(TXf>0d*cD`Q:$6b9Ve%B2y--p-seX}gX>$S/xȟ{gDoc/o-kSkvt(Uյmt\3Q|1_@׏??zve tkǷElZfGB;VhCyʟTӮno< ();bEZsݰxSu*^ѲR.ޛOv=KOe:{OvGcQ]'9\%;<*PM2mDR4_HPw-n!;OVskM/SD`<{DWёF_o22k\jeΝoZ' NMpbq'/L)_zij0]|yфmUZU&,0' C_3zL\[Fc4,8ʤtኆY&by{;]b',ε 9WK[btqpDpMNVYKV7ǃb}T%a"Sht #[OSudS )Dٶ+ S8I vCÒ9biv͕҅X긺'tնsZAbssJW$5Amk'xY)?,F;'< z?eCͥnhI!hY}Cân˿ vXzQ> tj$<ߵsM=NNF5np䦺{Q3BXQa'fsVcco ߓn^Zq*嚣gEeud4mk-[1qe}mGkVbwepBqk6vjR VVEkwңN=`#ݻ+zn-=rVLv2z\oŧQ/Grl^wٍ Rv0>n3pzV^D= P9l Y3e*w.τ4aglvFkڥ@ڍnh_;T^CUhF*w=ku&whmwv6:;-fWwn[k5v{hbrr^7n'g\59MjqG'gQfWcjnZ(;x’T4vnWQ4wv_v^\rЄhVRv Zj٭9&<9;vvy! kwSʵ[Qm7/d_mե* wUg#jw]]l]CuyWevw:X19+ʓӦ=ةrgop괶u鯝N[VnJsCK^T9vdoьsAqvX>zZNgwn^9iuܦVfr)oc2K٢٣.mMm6{ G{mDWvU):;EuvFs:nsvUQy:&W69{T No H+$ɤ9cVp!rDXjFje5#V1=͗u%8Y0Ao [عpR?5#BȹvXuj*Քbra|܄E9#QEhn!"ЪX:5&6i8p/qkhz\K_S7guOie]MwAވFXlfKkHn'5kPF..*OB&I(6- :Cz< }g`qbL ޟN7pF!OW@1N\KVlBkf{ Eb`Y(JƎ3 /Y*b-l[I`/ Fؿ^SWw"X\mn8\5|HTBK]g!n7L_+u5.eQF]vx4?![( RGsaԹa Nr PQ!vdI0*+qK("}˱ jv'b~.c]b :1KiFy7a-4 9Z Q ^ Ka~ti0 ⋔Q< TTx}Іm8veӸE+7%U8N(*xb@,t C+|'\tu1t$ SYY}z7\$N۱cLZw a5ʾ/C\} Gh2a~?[(P2߸UcKKxf[}pHy|G2.wOwZeuD m9:G3;$,;X!lŵS',NP谋CpP%4#Zu  bhnztw&N"َ} iQzKm!~rw KX0hHL"̱obW,Y7gi>މc"Nb)Isr&·M?x6g\/coTȉ4X,0f&Z&a@tV!ca0"nYhC)3!Bo6fvht}D6~0<-f<)q1PBز jױtyȺzF |nۘR$ AIh5T*஬u86E@n TJwHfE`#AJǎ`yJVtQs P?]46:pCC5T2{"<`J犎z<C(pN8pt MX'|.-@Vu뷶,6(st7ETqkUP昏si3ʛ(a' EprMgWe\ԝ"wX Xqji<&rv=As! ɿ2p=\ڮq ^>:`śⓒpZ}&$xlK(cߚ3z_rhܟڅB63dlƹgt McVBvx\ ^( C_?+U\EO>ա`؃TyHjK*`Rx" S| #, "NzZp.Fi-3~%6~_ .Љ*PlRz apc. vĀL#USfс]4_+5J9?Xޭeh|KA `xY_$P~”Bڭg&7oq]hV-^|P[W#JpVZJ *:N &ڐi+6uglO5^A<]aĪ5ƆmO DQ !$Dc29IhU`٘-<~՟~9ݖ59fym5_TmEH~day7^ %ū dz Xjl>h rj$E%cRTFT@L( ŮlkA5qPK5n\HL"q-iD`xa(MArwnj"Lu?"i*9I<,HDiR@za6ެ6>u=Y8Ȫڐ}\r6ڕT2 ;j 0H`)IMp$*q_TЧ JR"+*UOWuŌvd%[Ɂy;1'ۣ2D$]Uj 4|VڲG8cT'4ufsi<= tKtz7)'V<(V&uƬVzo63_ISL6q*p2Yvgv0I WxO4y,bx?u=}mS';N^Mrٜ78: 0ϝ[7Kۅ *3HJ]̢N[cE1 qs_\P1T~ T(ވz'&_ip̊,) a鳡qϠ jfdg wY%eB 4)q2M|~tB+Ŗ"@~;qRr/8V?3<#gJ|*T z}l_7]Oء/qʓ; Zov'$N[﮻QD ڷel} jPK+sb4+y Z[yX7m6a7pɳ FS<]=Tl(zx/ƚw9swHTwBx~XNG]aѷI)^jQYLA*,aƙS&jXPanylx=g5* '1yx}/ʌ_JM1 8r_4PT1ҥ)rM0M0Ze6xnI]*Fu R\oꎾN 4 9LfS<9,D򷂧= ZF*f%Rx8npã)gK2۟XGWA'aSj$l疠AP]S053e<g9TImۦM 2!0w#$p\s~(pj EEC(pz_k氍+_͝Џ(PfW@f\1cg+6*'V',ħe-3.TE-޿a"iAID{xh EpkD9ߊw;\DcK\V%Տejz6+Ğ2'[r><'U ABBhFl=BmFy]){\.f?0ӎ6ld՘E VCY,=2ORHy3wWѲh R ܕHaD󐷍ħ >$vDq1#K`IgN i->!`ի4br1^T5m X\7ק*H3 8wXX#Y+~4jqD\UJ,ci2k#tqFl#oN?5xNILZDLn@rB Ԫ;re͚(m!4VбF}OikVH-z5IR\G:f\IPG)"K;1irhc]ALL 5?%R͂Ύ,̲8,BoiMѣpYڸ$$aL:{+ 5~*x=K*i >jVSflVu-z(/6]֕6;F_&;h+2Z  U\a̝ G:J#WÞ 'Ue+MQV+BDMkW+L|TϊBhi6&ǎ;'6䘘IwЪM)=pE^Ǭ\32@@E&f.GN> RK9 7UnV+i|g8;ZM =2U,=H9 y N]4#yȒH;3@4I"'jtX͞mȡds8(1FU␙H002OLRTyoprίze5gO+W=,LFL{ۢtj 3k%rx 4)(k>۷X; GN-@㡊AP uHHE>w`РDH&Dws֤QDgLKMP 2eC?x y '_rs-ݲDu9a@%3hʴOneVeZl8|]Y ~c*0coӈ`>Q g/!.3Kw\ 1I)A%'{I8^-nn9&1b*PEbv]|kNpI[_F3=Jm"[xNmnшTh KmAED}ryVzg+/R?c#ըe#pҸ?Ձ G  *t߁K;#M:jDφ2Yݻē<* dX{WwhOg<;pzNQŻpKQ=XFؔw|wB@O5i72 6$PGmFiݑBiEJjЖ0x&.~fUлYIQ̅ 45>:6otQռzA,3ޮ1 (({j_^`Ű=ߓj/lx8d9V3y<}5ѕwrwBWt S']ݖ#o"7k\3e=jjC&P1\r% oKj7H9ivM=1E wO”lbb F7)ORYe8 eNpL`:,@fG^UF_5 ߒ["3Oa}oji}*z=qjT]b`cUTjeUY@p+ndSNKp'%9S0~5jrMC-o(eNĦy28Qf:q^^v&X=y1V7KO=֞ ]v߭^7S}2^f߀+kOi#_̺itA=9]WVqj/P!9sVhT-: c[Ysvg4cl`awR=w&O.ݩwsO/nOە/Q SonUsFŢL\Fe2ziZ,*.no,鱁3}҉80xtoȫyڴuu 6泶 Mb'ީu& To\+N8 HQrv}ú c8i7-X1Eaއ [ X:ne(vLUH X@(-ATFaC؃3l*%>ŋχ2Ô #C!|h\U?}l*݌*`~s-̾?BE|eQh))3u c;`Si P:H(ZIٕhAbxŨLN烗Qńz]#sMcϣ\2&YvtU-O!lj?Bw1?>3Z6bpeeyZ-*Zi+70U n\Kc8&wG  ]Tΰt3( ' 45k^X$xUw1C8O!ZAW*'|#8 QDg"YF YQ(P!xّLu]SOV;o{b*">Ȼ WZ"!ko%[#]a94ӕ=N%kɣfUBG@xTӤ~k]ѴC9S܇΋yuN}dz3^RN!Kbo {{xp=oվQ?[U7c_D$u%an9|ghтpX.|uy䫒iHoMx_^M0\\Tpgay\ƥ?KJ=aɔf P*; Ask߰(4$>;yLQ Z(^ ,~_£wxıKVO%%[O;q ,b(=1r >X j_I ԹB:pxl ; J i+ХwVɻSqFY> >Ce {'^iMqVuD4N#ov"(83ꊘ~dUU? oʈuUġX}cVWRŊ+O9) G}Η®師"Ro\<@,9ŠugFWBgIJ9>Jʛ:&U?X>"&?cv44g%cD)3\ŸEш+_`8׎0Ttpt Jo 5C]0v_]e>3ifX.I RUYM:Xc Ka>x+cO3 lӫqt??t`_an-7(aW|ܠI4 "p4ldCXs)MyȺ7Y ǩzYƛ=Ӫ/)ϝd؊O(ad9JG8[N&8c=igi+{xq~pvQ;-wsXB3np"U V.U~ƦtqT ?&T11O #}my\ U:$itp9(Ikƶfct1-9X.U$GIFQ(˛`pTNSDLz}Y;JJ f0{&"` MAFD8,A}|eomoo(e*bC♐{ϬB9iE#TEx]xc7)o&=wb\5M2 $rᯗ$XJ!\ Qfr-1Kż >3p;&+*H@ԝH{tv2v 5}Kz.DQ5MW'S=_ܤ)2C8Y\Tv;r|*9~1NAWGW5kz.F(u]@DR_(͍ő*#ihI쐞Nh)Jû,`ʖR*&.-\ȕ6ЯnM/>*y[}rүĄUBoFoTRvur[zAOO}cF@r>}_a2b瘦nzu EUlB^J, }$>TہzX~sMŬ,!cGNN.jͲ%q1~j F؀|p!ihfb}s}D[P7gN^e{ϫ:Z\$>wl/@2+M{FRg`9Y$=:zXhΛST6>iGioX| !]* ڤ9]̗o'gM&f< Pn.>#< WaOsNCXl Q]ed5bi\JYӣߎNab_!lEmݢJ[~ۤ;c03 !ыxWy,hg M>i-g'[5#(L_[ HΪu=(mF @5mf_6nt83b|Qv?zvVj2PIIP`B퉓VCuv-Vw/:M;dYEUe̫6q, -NX( 'Bϑh$̡N pDA@?Ϙhh4h>TE@s,v8;N_o 8-sDUF4@@<"V0= T"ԟoCK3˄';G/9yGx1xwtA.}À_鏷o?oQɇ8?@c?L8㟟~0rCEɿ4)=jI\.Z>~%^WiԍRdAs?f}Я>}O~cQg <=nb%i6OE>a!$.Ӧ0 ?=[ϓ yp:B4'ĽP=' z8~Ч3g져Zۋ޿hc_|Դ>Ύ8֪o{D#z'>:8??ݤ Voj ! {l\,iW5OTb**TN'NZ䖼4szٷkgUwbR:$8RX4S$z+(D`UI  o]Hૠ_nNttۻ{Y" FP K5\#@-uº(KmF=dj*m ^z@o؃43 it۹Bs%nngP+*Zyw˨V2RU4^! FS/ie/QqB>62CAU`}ᖂ[y ْ\/ިc·2 ~yVA7NoyM[zԮgoSf♍ 2V+E3|7}UV갿_qJ'Y7YO/Գs/y16E079@\<2!_e R"]c9ٷW5:ӑEɦ~=jvd\c7%2;:[ű5R*;ױ^b 8{04O\lC3KVS7 qmS ްJpz +GD'ir Ut|a `M-P%v/Mm'$\~m4+ 7JmZ2Ҡ?By|vh%ݏRBg!Y{Ĕ&Wx٤Z5{{õH.^:P Ab<4@&q"&}2SŐ_>{u`'Yvؖ;[V|t*f/WPaR цύ<|vVZn-Pv8&5:RdP@} PAQ.vtQLI8aBU:0Bϟ7E\Α8,.?Tb  (W~}r쌸ɲcVUg/o1p@Ƣ@!ɯŭGu|^I<0-1ۻى>^`8ۏ (WG!TuvhQ-$9pNэ0\`T ˼d/>E}j5F?YF>BƚӸVbm>6oLE}q]@Y{#(ZkyZw0d>=lG{ThETRMCS#I|z~3%# "FwD|zG}FE͛X݉7MOۅ+OI :G0AtL@z^is28:I1[9ڧ8iҐOr˓2QW'%~嵧WLU H=O{QfHdD^rs8p"QBA|0C| `vPqcf(̡ Ӷlp'n+lSρ !ˡ*ЭWgLZx?Η' ?/^6nN-}}r\7R/k#F* 'G^"hb{Tl^Wx_>-;1k4d;.uNl'a3=Lffz$5TNrZ%z+ΩvCL3Nt/[B5c(cEE "tw[=z}iPc9.V8mS$}ȥ^* P x2 NRyGkysz&rDG=e hm&m?#yiH W؈¤"ɨj;yA3!l! 6n"9֕9P듛>14"EK$iAu8(5^h& $Xn3jp`嵭_.jx.^MP5nA` 3l\sˌ\6tm !]3Jꄁ5Bw?Փ&@𠷲ZlA(+m#x/n0oKN؍2SV|xg?zj1K矠gq6poO'%#/݄olr CFNUb#6ҥ^a?ɔ6YJ|$x{&o(I.w@۠6u~dpU2%n]#(_#ݧ,RMȭPxI|:)L#%H]/PKUtɲh "puw2*-S$NCֻm(_ؿ^J]8-zb(M_DU=spxe_^|i# e f]*BF3-ɚMzzDWo苋[F NSL>7r$Brb͠p=?堳'``.H I'&5-}@BMcT긞p 7^,7E!B?u);.pl^v@^*.EFdS^,g` |RMwҎ VVt*_4;ֻk8IȁZʓƋN!58P}:Z?'7jٕ>Ȉ>#*V;z7T T{H>t# y/|t߸hWm]fJ:鹻(7o;@Á`9e@ەFhی #)itaտ$ī[/O.TX rYĦ$dwxEl G!3 ɼ;F_#% 0j~p+!kks]FZޚCR!g@$Qx!r"'*;j$j܎*w[M)B]\ju{MSu:)$ѓ]VWh*,":^F+b?jmGp7\ԅ\KkiDT"?_G*yQ.Ic7Oh,0V9ͪ-v)R LC,\ ͿI~,72ާ ؂s ,=ɲn`r zp>RВHzyN`95xNEHC.%ZAz}w0קw) Nb!_TP5#evV ɡ?]TُrACJ &2ڛ^ek#8X^{ɻ LrObYƼ123ى*HGY)S'仕 +:'K72A5#b0oSIwntrZlȣn8Mij=oJZj,"U.sA;^<8|Z)\y9]S2{˚?]6Al+BI_ҔO9> `Mg&DL"K'舯eɷի#ej ίum;Dp?c?A$O)4|+O{iO~JNj[RN߄bq08K@Δ[y%)Rx1܆gs W̾W9Pvƒ=a~jp`?|Ifv4í%;[䇦w:Y0 gaM܍QMWNڦUM^ńL}<\ҕ-ltDb9[[8A HuݿC^j F! CאY4>0LIHo ̸g5M9~p7mY+u5/q]Qv]۫f jJ 6:l3rg[)иeTW|DfBpzwF1tHK:Vُ;Tvtc<1~g_e,S6 6`T`>>?Շ5=A[-C-Y0 %PW5RP+L+SCCf [9㌯':jXOzV{[/VgHi{o{#fh/ΐ S{N ut~x]"R4{dgz7zLo9m9j4ИvVz z6++-0ss[\S칃sS]ܞ;x=~c5oaxlf>2-7$Y2?0^nׇw mwWwÖs\YMLf® k$VvS3cWm'yB:x罢O#X#o"&I+.66~_}G<癅 + (Y1( JOϑ#Pr%Ȇ#?k)a5y}-߾~XF0񕰻ʃ2k)o8G+,Ae~ٷ_T?Tf^0PX=$[f;:75N'6L~?nO2`hm h;:/Fق^EjXRiCEkcY9!${}.*0ڠUET#w i#xL/FK#7eXr &@ C?r* cU|zV?A0ť2IO&ٽ^) wo{܀ufH?]HTz@rkt><⛮~O`BH6) ~2ƇҊDN3<|?(XCx&_ Pq+yi<KC-+}f@t" ImӶWT*QH[񛥩݃,`n~=܎dqt]d4Ϝ2WdehrߨSM0&"2cȉA[-tՙ qՂ%F8S9py\]0 ׷C}W؈y7]wQ9).$7ӂ ] U )3|5|4O8D(7YkAgAYơAFg ̧F9E1K]<`8 -;jo8M_澕^5%\[hhtvNcNhr8.33q: ᆃD${W+*`L_A+ٞB0¡q4p#-|efq~u~̺ 5DVTE}H\eTP$ЅSe&OƸ[a%Z9=/'JM+>ήu)dGGJȰ|;Hpwh f((Kg>0/3x8uj|!_ dHrYJGF>Ĭ8CL_y7=ގezs, p%^|b}8/ّ`E5hˎ >%MZ($nSS wU7n@tBو8G.xjz׺| Jd}>_:-l#SeR+!=εvq23cdd9+5bNw#Ÿ9jq8ܵYue"SQآSe墾1bE>U?GY$oE2Ż/CgwlZ*B%k(OIjik-Ͻ-P$ԌMKjh GCyjq UI*馕jRMpvyBjt8xOy16a5.0Εcاv{vN_O䲊DX7~EXgH)ҹeg;@\irb'nEVpkuTGU=765Z\&,Qg6 Fhpe)a&wwzyopT[ X+;??~-)?,Ztq?ۇE\cItFzݬHE'."9wESCnDRCau=/l&ك-??M& _iOL*AM ŦboJrMp2MuVhF-LGԣWjuuO<|qV}2yRqc_nZIc 6ng7.`ɹn<;8M$gx;EK.itv:{mUUkx \M4v-մNsەj)F4FAiwmT)MTZTWӲj: zmڠZ޶Vmt:;jVMm{;]f)vvP*wj:VM#GۭbӔjEhTjMWۨfoj.6l[5]xAW;TZ]j:4vVMPUifWmw-qQ;WQh5Vskvxh. )J5{h4;-6N 3 ~[vf^@wv@ul[2ejJK=Lc%ņ .n>pҫgWWGaP$"daՒȢhrC=w1XNjplܫ*Kf9PxXt鄴ͅ" dɨ5t4Vd6;D/9 -J+/s5e@Ay0Q ߎD ƕ3cԬz]XMw\4<@OP>oUp @\?&MYFrvw7*Xe_ o4bnO'B+ӮW0P,S#3yCwd>E{*F3Ne0&VoihFK;I u89jN5oqYs 265Ǻjl3c5YL2<\< "vV|@ \8:7zn<Պz{|X,3m뽀CȻW]ZRK[Ш8*?{ (0V聨*}mJNY mWz&~Ngfje}IZC-K˺4,Y?LQu R h1b*JlM k2pg!hL_+h,503͝yC<H\g䪺Ip'l/IX4n7rIl5>#aaU:6u<.ǒ-@q1&QaI"8U'tX̅Չ]VbYDy7a-4 9Y \ ^ l%?pԉcde~5u%;!vV6aF ٨)@7Ł#'&t C1*3EXE=[U)G C*/zz/ջ :mǎ<,=,2\n/Cj̩`~PPqb]M!H 8!=퓅v;gK&Rx#-5x*"`޻{a!`v#7'6@_yJаrB:!\5j <>kF Vv|C] +8MX 4nnG$~;,JnMx=?99qc:; |&8u!9}ۗX ;jgKaD F"dL㲞:pVx2g}%p9e׋*ӐE"$-3a4N'1"ˡP?aa +*KafF53Y_%wqTz{짎.e.<Ұcu n< QW/>mA+m0oiFdQUQ%dT N.S"@Eb]_fTI ޗ:Iouk`CNBb!Q\}l\VbNۅuGj!;.5DŽwt7 NwStL? !d.A7QtNT9%W.ϮC_ԝvX$-5R*;EݠƑ<e{ l]>.unf?l<ᓒYu&$xLKo5Ir |ѣ@KC.`7Vp7g3d;L&m{v4;H/2 K%W)"u|"?l耷\4rr sbԏfu1!| 'v1:ho]7.t|KU*3}X?BS3V+鑡y;}_3 eJW@{t['V<RrVWPщvZ0yUupWJvٶqbZ $֤՗G2;/L{RA!b;kŠ{#(<-hH <'ɒCcҠ%m\JE(A_:B]AB"ԼP9 -Ei #wLu Z*/4=j(4DM6eUj%=sQwA #Km)30l;,RbBdr D%@ЯTm#b1F Iԋ :HK:2 4f'ۣ2Y XWcK>eTIiga @ƈ3dL .0 P *>K$s.P]2aL5 'y,>WN(\Π3fP<@D! NKYJ" 4xDBxIwEȫS ,&{!÷d h?ޑ3$~u7(n;wyf[V8㣴s  !/~"Yz?M#L0pya B@λa M5dXWUs"WV0bN먱)gn\NpinSp$#&C٤!ǫGD=*Y:iܸߕ%~B G1i?[DWcP[9_ZGbdhڶmV0h 8ښHCGj.~* 9:0T0כ;!˕-&l;jt03e%zB[} 9-4JC>k< EbG tz.P"PXA¬09$ߴeXpAn5AW*RT38)EÊnpf^M7Yӫ5W ̈&4jCbH-h"q)5>7 vgq13tX{'Tִh|3|]Vj5bjڠXJ_*z k)y" xwWTU"]pp?V"wؤ e*Ք8\%OQC db >c [?4zPwv|o׃ ֡afd fvCrL TB!yk/C+5ˉGOb]+loZ}I32G =u eقCSb#6+QGI/Vy<˯ه O욶 'ГL2Fm$I,t?iwc#L1]SC*jg`5$v7d)[~2ed&׌'^3EP~{2^ ߊkVbb oWAvf0I<~O_:ղ2^ǙYoV7>Wek7ZzwDi^3)V}a už <n/mLhX]V6 S\#׹s ZZxQݩ1btNf 2 3 i '!'~}1_*e\F,P(-| +5QXNbRg" o7ZXkSv^vYFNTsWx 4}wi0).48b79P8ť Ud1>Es"D?k;J/"۫fp+ZLg_}|7+x,WhDm#(`{O0aK,88Re=?bqEI?H<V$La*"KސhN z'FТ S䱛7҃ ZA{AEhҖrW 5@q`Ͼi*0xѝϗ&`KMFz`xf䔕FEXm ?c8բM˕VNeVM?4%d&i9#Jz_1˚}vc:?ڑR8"LV{^v3Nc,Ҧ30?a/m6te Ay/vwˣ;.<ʞdFs C^Pd4Ps W zHsH]ӊAVs5$ȉp9ZJ1$r#_L=0Q >;Qo5I@j,crB  ct֒q2rssI!D17g!r*].cYZ*#^mf_ػߋTaON/y8{`0^-UE%{c8f׏̂Ɛ @<%Y9ӓlWkG bh9n.B(R dm4Y\?0T0zè7J^Q06_Ӫ(`d"UQǡaCpL>Y?&ux1A3ݎKx>&r1{cv˸oVƒ"!ᯘdb_tDkMŔ'eIL\_b2|"QpQ|:cdՎFFJ :j!hqa.2#9@y\!"ʲ[=$d385 iӝdYЗ{# ݜOqxB4\ͣ%)zT_Ǒ=LtzHNMCV *`}fHxYxV 5@xisc0bH4# h+xµBe) @@f%S4=Cl0 ASh/@}%{$Ү x_`{/fh~:STTa./oU7 M‹[y(y~wu10hݍ"uv.k,a0R"׹dӹI=,t1{۷b,%.}bIa^j: p]tŒOod֨hDFI #c]TF?RcA˴,7ΡŨ/ޤuqKYk-c2A:;tl#׆ƇXeւ:YPgks~8e>g.˨;*FK5OP',kd37ufb#|M0ŀ|/Nqt[*B!`fa(`:ue+إ^Jr&r!RzR\7aE33ph>#l!% KMS[H9&PK:P˜4-$y[81?; Z~tP`u;g܍T'=ɶ8Fx@̋}; b 6MU5B6u8ϬC#b]Dne%| qf9Pbhׇ^.Y!z\sTT \ a<Hf>X<;QM)-ESS)+k@얝5:تM=h-KxBeW<6i_OSNe_mt>cù:0{pXjv;;+V\ eh +" pbt|ݳb 7 (ӰPYvGWt]}jݢhUn / .dvt=\B.IxoGg֦¦nnͼrx\m-JX'♓70C\P@,T&rȧ* $bɁfELkf~-TV!cӀxFhCkƠ^݄f5ŋjY32ͨc9=ԂTJ&Jk?lyDZɗՁD>S(E{bc7[6l6UAsQ\.z9>5@sݚM5QK@28r`ΎG'Lz6G H: d2=| ZT.E0dp,C0Y͈'U*V0z<+v= `?T#`,'Fx0(Aiȓ":VQB> v091/FQ,֡5㍈̫X*K;9oHC1T&C}(МksIϫzJL ɬЂ䢩Bŧ% :b_2B|R$iO6Or.j9),WdpVUp4Y,*Pk.+ic NK >K\6 2 eȅ;n0S/#%s%W5üd+vTO* "gIi (shkzNkršElO?B< wntatO!h# ;(awMqDE3 zqƝ :͌jV2 u⹻zMSO|To:YopWHt/ aSl:egkĽG#?ev2Zn 8)U.`dTyt7Ki9=xqtt/:etdӛ4?,Tg55 DIE8uvmL\ڧiv*U"&jj Ft3ڵb5bQX.63F0147w_t4\T:rfQQpte}!a4C&ʜ"ܾOsPV-ׇd|' z⇬j?5^/:XQI](WU"߆5/8WoMbmԮjc-aUlQgd !2e_ y շ*$ \#$d7|,?C$Npp@\Mt ܸPznr'q,u"8Yi@ZpxWp7n5^ 쬸HF u(+yOc%G 6XU1H >*s}?ۢ7Vv~zQkwA!ީVGmCZQ$ٹeaBQSq CqȮzXc?@x=X2X^t~8|dz :D"jbv^)K-߮ixcw䪥q `T{R;د,Fb9+'i_QO%R/N jܱʏSVS/ۨf•kgǧo1 Uoܘ׸D`JldCEW0r9Y ”kLxC c$SSAgLkʠVe{ <&66Ɲzz^Ëoy{K I,+{yƞtLZnZ@}؉)V[`$>4;kBZSRa /E>Im>olGqp@NУb%׊<".+쉲. & x]%(%Ģ]"2x$}e%Np8Uh-:g\&C0*3(X$3: r~ "h{Nᮩ%./MUYzE!wPl?\{x2jB2@CUJ=g$rĞ<;x$g\wJ?v\\VeQa+1/5A2n D Qo&#\rL?n'cyIz/tPk0C/jR]0EIF1I?!TrfYuRłO'I + bK6cmPZ["G8TI+p@@@%TV7p A᭍etZc#E$Rr}S5P9ڽ LpF˪sC5⎄J,#'Ƨ:٤`s5q#@9/inE}Thiz_q``yu3}Qw dD//A8%ôr4--b|ί4>B#roM}=&Sakjyrjj­[$`KenY'˫/aw) ,ͼ.`h5Iܦ=p=h8]/nE=l> 8s(N Эy e3CK&FOYcU"*Itjjzvxh; QV4zW\ÉS9iEI\7Y @˙c.uFWa}eQG 5Nخlx裙GI2!: D_t R]ڄxVG"QQhӬK} [(30}$:tXߟet2ZӀѵdi\Z# NH R &ovaZL#+Q+)R]EVMjYD#vu`*x]˶EsɊr%` 1&ҷ}K*-,*$A^CtVORE:)2+aŒgcz%sfw3 4ȼh4Mz-oTg*gd]Nͼ*0=O/&"EcS<=C{%t bo5JYVtL|j4}'`x x&cUxwP۫dZOz$D.svv*nQ>|jL9^Q jH*L2zd*joog3x4lYv,h^+36n 2[`6G.>ي|8;$&Ǖ4~g(BH&*vA {keGh5MH}@h?u\ 3+.!ފq)CN~;:esd{۾EQ4[ n绋@܂1@K8Xi Cvbgslqxl< ã_埳(v@ BbHAVH,΋C?n# f J4˷@Fo#b.];$YG G=ޕqY46)VɊOcdHROmC9^wEX5=F;yEWxcwn<oHo}Wm2 O%%#:i(7Ew.՘c\E;# PFМ> 1dI?< `;\ns7ߑ8x 8VEoF&EzR f^4E%mQiP1IFaK5" obBv >ߎ@P [c1iŏĝJ"THt+UHfO)Rsfl7*HC=fsH͜'.#BCH[,fד SyWqǴLY!伞W9bه)H\#J%˱CK}mf_6ntޟ^`S;phKDȼΓP+T & ܿ~ߜrIrЍ\ )֦ږ/Deku 5SaHZ)M=:w@Ō\t9|kۯ8%P*` o?Ca/_~IljlN`e %6]SWn6izչL~YwxĞlԹ kr˳+DC Wі_^tzrݝw\X %aNlE$p輿*/W_c Yߢ 9DF{r'!tbN wE<:\X (| Shj$8EEdOAӌOgr=;Kg=$6 y}ޟ&\oas_rĆ`/>SakCBKT(ZBzPAoGnz_߾a7iL?x|Y?m*|h&mQ/?.G+U?}w@w裃qMZo13N6V/YQV*\ P:ON8J;[Ix!VK?pݴĸ"ΐ(.@D;Y\Uh3MȴT3V5 ׄJQ[z~a~pjߔdNfkFҁ<ҕkV %K]n_Mz!񭵚{JImP:B <B9 5P7?\Vʻ[Fѩ]y}9]jndg sلLT52[\`K &2L[_N+Oyy#7UMo$pA̟Gܓ$9eY',.bE0]šD>5>.kSx=! E !pfJT2AR)eGύ<|%J T̚\: KU"c)Y,IlJ跤 U\j _3 T.[wRE\~9%aGw]5tl]5 CYaz(};d h_Ur[igEzIKjdU(_\\tFoțlPї J^/:EG ;!Dt&ZmDh B+j?Xo=+A2qާz<+Yc`\ S{`/,`{}nn94%kt!;MȝpeZ.޾IYI(CQʿМ'ST1jTkN4 '3ݐ_ᜫ)9l}_Y1>~As9pnj#og6o_&c wn|gOې/YKi'1s󥻣wG펝fZ66mKA۠l*N"0c uox+^駗&~L7c;;^E&bMJJU^pteAl2Uk" ޖd̢:7xQ-)_{jg4H,I7[YþF(*]6VQ_}crt<*l9'{KWQHXjhLLcNכa$;_cεVt{Kbj*_[r 6C)FQD SD>b:aEdekڛgx$ڸB.*cprQ%nVzSQ; 3lJm]n/J0{B৶_,*&{{V`,OP{з+#fc6k<| .Z^L Y ?S?tO Sl ҮöWޖ3+'і-M(-I:5SI?Y2lӯ{ЪO@ІlWݬ+?T?[÷ܾv~,+~,T뿃&t|蚉ءYjcg{-bj݈iԺ;fs\mĥ0KhިPjWStzJ]8XFEM$3Mw&Zz2F/Ws̅~fVܷ :*y6y_5e= =r7 OY|#gG:@?0knzZYp) ݬTVC[ՒKBPqem=EA - >KŸͿA]1s=#\cZFZ%#TyOg{T RoR܈G,z<}Nj :?k8\v˄c/T>4<@WCd@ Ą8Bjs!A<^|^q7CPIdD'JDsM~㴓PVt@—ǑPX١D*S*>:\{qCޮci=_A_Fӭ2H^&Zh*eC:q?ǵ1d@J8[ OUjO]#QսjݘL\H.Sc!u<RH7M" f@4"\0ThS1ЀDP '#Dir$ԩy(QETJ0I| K6[:N {35jKuڙ]RL?+tn\3UK_+J:uh;au)4[;}yEU^ҕ hɜ*; i^'i~Յ{oVC<#rq5w= rͪ`;ty~яV/0rZHn4> o)hdWE3;>s:rP//3iQm mI/\6;ҽγg'~a[{/eGu+D/x/}j?fO4 D+}D7~tb="r>棊B? Fy-əx䅥2YM `=&MC>ʈrb>|,!xvΑwDQwΏmO9#(=9iVG懥RsCnB_r20-lUhCf>KuU/< H;N|(Ӛol eҁgb[^++IL\gs@#ԗ bݘShjg|:7#vƧE7+"V0=?[~ǧUn(_[Z7b@>c+x/ҥB>UTز9ځ|ikԮhGס= rj_TnFRm(rfHEhv5+ JW 1@H_}Ym\< 0iMį%+0g6\HzqÛ9J" Ԉbk0qJHSشE_8Sۼo}{ZF}[R[`6OѢ=lyBeHZ}>tZ>l?և3򦊷 =vTaq:S-LkU 51DZnIMq;Ȧ& }C>=tꤲWkz]zF'rxW8OvI)]PjeSթ :]6aUb?[di/6*z9G^,$sUޟO$5 r?w:=2W޶T ~X4S &䳚J?n~]kǪ2t;uw֞<"Q2E/篘G]T唂 Z+I*o/>?uwgFa~綇CѤv}LY#'8=,ם(t ܌?~t^FS_W;`:/j+VIi4S /+dytx=x)R 38+%_e;NqR;¨1{3pb^q<> wFޑG/š^&wPj'x!WUcr5ha=2gZ=ӻzx5IDC`]<gl_ ͆0ܨ儮aḏ7ʍnácDA~!!I\iwwVS( 0)]xx5ZbX WjAEmHe#'n(Fؒkk$S4q#AB8 e]& MmգKZ$dW(OWd@R3>bBIE,lhm0g*iyoFL J"/p@ ԃ ΕzzYpҜFAmi/oYO G;(пx gij.W>'-=8$ī~ey=^p~."ĩO$onh5+y$@&/;ls׉ܢin/6lժk>4=q:D)vNYz6ڡ1s]ZGnƓ/Fn]vŁdz2eCBmYju ku}].AʈLy֫ &zqBz[^]fq2mGMNv2HgE/Ϥ'2 8&qटzNvj K.MRooUS'Iq릤 &7;TfQscs;f55~皞\8yX{ǔn1v<ٍ<D]=Bǝs&b*!9 7c7U2;w+%cv Kݍ[+g7C1 15}WMɽ;/VmmfpSŞrtp8>}Zm߶l#um#|t;>"(؝a^ py(E%T@[6v@_ 6#.#/cM2J(<: g]d='-#ifF̽e"_tIbSEN ~۩8b#3kk2vW]t=M5 ̫ r6n~)QHPK;~"8VFKyZM`v igz0.-aIws&ePI+ *>$/S-\qa4BAV'#6/Qw'o)]T0 gEu4a)9Nԉ ߌWMuG%k<!%v d+_eKȋ9'4! 4~KTO/MihNLָzCOVl [f++@Z{* pltڙ{_ڼj*z)4h NY\BX̘6%%DV[9uI ]v.B@6N?9'|H8uqRT@0*5&%E KK:n9z$?l9hrA ئ+PMj!2(hT`JxxV  bxϪ_Et9B(dxp샡Ɇaua̺`6DVT%}é ʂQR/tarpWRP<<nŕhmmwom]LwB4a-a6|GZ Iy $^du}XHdpk+&"΀L,J!pAZ,t'4+/%F3A9}%2 4Dth Ba_-ldsxĝtGRo='k0vkI00plnnlƖEBxa^loyw(1KQ|]up?Ot7|_U \-0 SsϮ{ .3qpBwo7۴W%]#4\Ϫ`ڸj[ s۝8v?;j>j'".Hl;צ ?TjX,h,4zZ)d*Y+ɣҤ'@̙s{#J¬dذ d ZQ3Sև`5NoR8JMDT4ɭdCT)kc^=!B'LI?3 'd"Ĩ޵Q怛$䘹*8}9٩kXLˉ)F|)<7Fq.R=nBtjz# |Ӕn{KY6yBD3&a'MXc꨾ڑC-Z &ڿxLV|u V8OQj\jR5 vwwA_ud =kYM?n7Tz'eK k0Aqhp{U#kz8l N4 oxm{LmBhv:Q0{91Mj V+9 %U7 8ٗT~zHY5DZ]5U4o 7$lvxytjsv6Wǿݚ̆x&;|tmv3qDy-<0kqpWmޯ6[k+L=:+]NGWVW` ߕoƙTLHG .icJl;HdGLV)}_Xm%6㡍ze:]զ"j:Zlb.Vׂ֩l{SGP0](hVrjsa\֚ 6 Ƙx ݑi#@'Jreju3M?@KW"2k@<4Vۨk⤡,X4G(lmQ65Q͵{>/#4%Bk^R_k]sz SaZ:LC6kMl߶U{CӍiǞ2A_W5hNV\RvlCl7x.]'s&qi,CS4ĕN=fCu"&ï ^miXurH>OGpmwWm57BKJ+QP+۪˦sv_7?-(:G= ekhWJUF>V=Z-KhMyrqz5{?W7U_Bq -!W"~6kgNܯ˷IrtϷQq3!ηkՇREO=^ hjnB<@:03~!4n67Z*bC&aQ˨VDFv`/Np(%\5eϜzp^Mj:wmo O`=8.5#dMkSvݏ4$Ir%9s۳4yt+/ 5#S/=F6H3F1›3kC]qr4+'ЫN,L% H@tɝŸS MU2iz 犼nM7W* '3ӭWЉ,7Fi+6<wC8 F߇Jo,ѨRjL f2jS f*tZwUz6"O8Գ[dcd tmmdnBe|20R'ya% B^tcq'LON\a iiGۉo[:/7SGxCVVdw3W;zR=+rϖ&k(A8|| ^(*|KkE m!zE |z1V塚SSRܑגvOjZΆ S .GSl E>O#btCRGԃDXmm7!KP;:*yFMTr|Ql¥+xmCPh*c}9y3Ɛ,0.r*uWq Mީ^=Ra˾d+P%*=ZTV%:.?2V'ʭ~Z(h5dSe]jр_kw?˝lG ƭҧ!Y6ꕄĊa/m+QZe7]_Kq (򜋸wCznU}z^L<1y48hV3Bu<0ӶXY鍩7"ʜ^ f+;IOS JQV e60I3"&JpQoh;/d2xn tU'&ousrMvrɂgHkĞxޠLn6_Z+|[{*.⩻-/:C a(D8l;kfۆ?-Jo w7{JhwP20:%na?al,X ;jהgf>IG.Thܔz{IkyӗLrS8r񕣐XO -!bt{f\]%Ì冠-iJ7HIPk/QNAS.@E3+EW/qWmP'>Q쬉"%Kkѐ=WR>B &S«%;I\%I4tbaa r~LN$e[a3nhjhۉ"Q0B#DU&6΅G1 OUfwe\ʼnyi K g2AT?cF !,IVW$_nw:bt.s9⣁. G!Al"s`x+}y^TY`/:ݹ3Ⱦz,oN6]n .& K|h6u/6Qȏ+s2h38%ps 7gp=6ٮtd}aOe%!h-ң{Ck/g:x[o aFJ븂{hrllst5dy"!˺9i0 ܦF }X!iyfsZaD81ȇh:'2Ֆ|ī|* 硅 Qi»8p|FzR '\|>ƟAY +kKKgj`ˈLL a"s=4bby#BбxI@0W >tQٿ7%]8@oMC>Y}_a3! -h~7&WITi9ED,Hr~kL1Tӎ̡'cg6H3z=j>(u?F8 [ղ CU>uM!FȚH~"Y T'?uixbι4}jd:RS6AJrB"c>c_>fwT[nJr8X0y<p^I8㗒&w"H2RDhWw^ܫ݉{GvZ3z/SH0LjUq~B>p0 @8`L)+(3EjrSDw1J܎s y5j#KB&&\ݭzN&S2xӚenC߾ ՋW8%Rɉs˦!Ty?-} j5#wOhy !ζWiox}C^MRUl̾tQtv23$h2m^WNՁsE9C)R1!T w\M=-+w8E孱z/8Ey% njCUq= r%H3eég"=gx 1MmæM91qa/.9aAwȁ32ל[![hU͘.U 5zΰ^foV@D )ea S0 P@ !qHpu6䙹1;QFjWy'UaB`D+.\Nʫe$JSAϜGyeS!ĩLIr#(F'5 Yhf8I#*X-4),nj$I%!T'l{nNN) g^|eM8ŪP\緳JUMb$=އWnaZ˳@ q qYwwRTr!s(h+lX nj\B)&Q:P޾mj1gIѺqUkHfnb5]=wJ6 =٘ +55iMb?>m3' 7-@1( 9]Ϣvxz UY}'iUN&yrܦ4Op.;.FBj2@j$ ^nNw;3!c?="dƊkY;wȽWV:~j.חniE}_R3x_ FiKX\<׃h_ZH˝ϫs 3Yx-2K ֡.IIve; dZ!,TZ;+`A 6ɍJ}ve=Fw,?NSE쪚1"ܻ|O,AihP(6GRNmZ^!-fHY`r[Ós?81ĊȳA1$GLMTF#SWi#"(z_ Y 6a-T.BƬ+x,jBt*b{q%̰ye=j9Ř芒: g$#ܞ{?knq*MτT.n =nJҞc+Sݮ?Dx kh Eh)xzjG[v$7(g5j(^%8L MoWZcx䂔oTO%E6d&/M(<9r,0j5M˅ZV¡,Oe_ hJ᪛z!?vȻD,׼i'.G Lpgt$F&LSi,'\QW\/3lU}MGJrՇĉgfwyQ#G>DK){}u5Ji:Ʃ# #Vzo4%X#vf%_/kQau"#$r_$[4&E"A'R饓t\ӱ Pb(Hh@ܘϦ-((8"Evua9./1uyxp/7RgM&U&\/ph,V۪"q w?OϔAҭ?$ x>Pcɻ߃| 3=S5UM8BubAtsd^Pǿ$ ( ح f *Tpbpz9'T4z`,G[Y $8-W(C1ΐ'ӗ֤PcP X"@HDq5-/#w+eDGz* 9jI~Q71]0%쮇6QP? V!LA/B]OnFW3Agϝ1g5v~7bh`IN-ZsR\c ;QÚ&ٵJ6!4){\$gyY+H71͈,Dx &6\ñt$kŦRs["Il,.%Vh?-si!GTڟddՎƇF&:b8'CzLR$b!^̯&ʔR =>p9e]4ZrI 8Jg4)Sjj٫qM({YGLsE+⡩ܜHKsvH=@{@ߏJ%җyF Rfn ADsxaiK\$^ZJMU+3I%2+io17n#Xf!U ظlDdw;oA#G,K:sUzWxch..nE3}ARVSy3A0rgsIqK .ڳ]g6jFp{ku>,%S@VXy.XN^UpL݊ώdrRH(ꚍSsP`%rrl=蘾E3z|)[ s>ތǘKrbFy5?,gkx1h⃟Z4)}"G7<"j)LGCCuI iílf3 j獯u3 $qMh)"&DϕaP.&g++Ĵ3Z?% Ӹ5ȝ0`XUP5pWs2c#I4eܿJa@~Cܤ ]ƹWyȽ}y<믞i8.΋Hm3OD=!9IAb /:Ѥ>6jK-y묝6)Uidhj8/aA]5Oh֨ea>ќiO_# Íe AezW?3s^=3g{Wa ԗ$R'>ᔻsQ692Mz6,FQȎ&r* 6ilA+3n1\hh)ۧRϡ-$?G_7b%u~PHD1U@KAhIˍyғCO6'1B,(.kwܴ/`iL1_Hi|#/yu] $xJ(\0(n)նx UYo\mϚ@Zt*Q&5$c,@8P)[-m*u;˟\$iN#mpG"[9+VkG^tAxCwh}ݬ쫍.'S*d{?|ZvYRz{CO=uf#^"U9?7r': 6KibЛj~) &c6P9 ll궞1uKc|vIOvpJ'55ՎF$ɰE5:ޫbVCyBf?GT/ %obKP ƮroWK5R6R؉>̢^Gq6(?ʕ^ɮvku #۽(> oN ɜ2/(QHTSDFqw "|`zbq/aeLE괈tQM !˘hBf9*VV!@>iY&T1%pꙝiԟWJj(=LQnߩuK Ha;́ tGk:;kj5I``g׳s}Lj5y`\a/e1Vg;ns܍5Fȍp/!d/$#A'zLLoNj_ ؀)yn~z12dU;? fSS·g:+ہm$zIIƝP%Tطtq@LhZ";FQn~SBfg6*y2NU3cm>9szlo7Vr˙1H"v7}(5lNu/jhL+e>LKV!-")QS1@5]{/C4@_E) ?e:vI[WJ` o Q1^DE0Zx&$h+"^=o9 ,P嶵?QzlI]w ;$;Ftppo$v;:R /y=~jrɽǰzh"4w/D M'A[zIzn/õsA[Yp%*?Ie9y57F;£%ѥZ>[$VO$ š o eW omޠN[&ޘޏ=鹉uN8 X$l0Kv!F8 Ygp7~5DAqiq-ޑu5rQ [RH"aIn@bātR+quj)Nj^8ݬVGv:^NgVŴqSV\I<Rˉw@z3Gz}bxk>Y zg6HԚ* ƕ?;tWP$Qc3$>wy ;ۇړzxl$VKǥaK1YmR]Zg>[+>e570?0~ -qb+o%\p ?e釽lWcQpm6. xN ST7R⦴66H%{q#Acj:ph&*F U!Sv x9=;>m៏)0dLj98}6g85.#cmH .`C .1\tꬭ?v.ʼnɰ*=c 53?Rҭ;RX Ab|oУbB.UDGIiFH)M04|䷕$4}suqR o/:LJ_H|]8M4edz(v'^@L 7) x;Ryyws=PJ J"H:Lr;M]NCo\ aLh"St<6د \Fָbg"d/,l.@UպfdpW|M Jؚ֠#WE3 ,bL@HgOwj'L}.X҅pwcM{V)/8QG482L0?IʅV%w|3 nS˪;0)ݛ:_,ƃm[0pO8a Dgͭ t+JػU {@z.tl@/*"<ɕܓZ6W*{tc|o My?2J.5naҰc\oG~&Ñ055p%QA kv3,br HE+(.;w7$FvjZZ-VYyŦkW\+7Y*#l@l 88b}8aO;8W;"&:d vQe8 쓭^:B+P)#ώgRyG3HxO=!}q,Ȕ*j)SZ>׏o U|!ǝIwP!6"c'9í 2B<4˲~1j?"Db'(ZeG!C*Ic/ BmrL-L&;="(GUު"n|Sɝ@CqVkkhҢjO[Q#aAA!wԷ§==x"_RN>z⻿G"1<;,Dx͘-]O7z6D_+U/(ʰ֯{_΃c3&Vl~׈xh iF3R*ɡ@JXIO-XZ¤Fo`94+y$R~ W%6/۹igࢽY) *D11L DlFt.F:n+(P @'*!uIkQx1@]]j|*o wr"2>e!%@N:=JaZu"6"8&bv+\&T=^BpIЗ#DbĒ*)^T0G{bSd=X\BjTC )[4c#;:}%buUl@1*M $AZ1-;MAnjwP/tVE7 ^h*Ď< P9f*Cs'cG#r^TOlg7=gt^pzx_-437V1uMRlit<>DjRI~jn^o."JGn^'w.\%%W;+++{ɴ?:}v zn[p6r;?;/:vgМs12gK7D8H)|8XoorpӚ\omfM_ }fmÚ:CDwn:8r~6hdYe41g\6PI1BO(p M]nv*iC+;o4؏`cZC "c 6 h %N!" h !>?[K+$)흃7N?DOh8 M$7uScm;6)'EQkVOweq\/#J)O0S4͛Rı"_~{r܆H0 LŢ1*2mCިwfyb DCP7-Ԏkѝj9vpbV8R2#|~;AV6#'w{8VdL,,MOS'5^5F)ŵbvڮ}N[ƓR4*$^V k:_\džw- ANrlE<ޭt t$9:c}t#'^[z%jw?fp tZqZܬܶV>}:˒d OZyG,ޑ?:܎==?=ޗE4!;;n C{w3pz~=wO>~|37S]h Wu8wc}]_>P󏾡k@ThdD*rȱ;hanz³nݾ8V֩Oz;@zh`t{ǝ1]~.md0% fP QmRsF|8!fM"뺩p zRN aiz- D*0y=67vZ3wRO[dTSkԈdpݛ\zjÌSs7*泙o\7\'v\kQ봶?Kem^Ͻ+~\r< (0"H Ǭ{K֊fOmN,~Yhm쯃mzCv(V덑7֛$tf+,3hf`\5N J"4J* ЃvZ<SI >C7͚n"AimC( :!⟢Ʊ9& ⇁¿Q gX4m氎P\4!:xyVfߣ41ӦQ^|zUlq)lRHz(ӱ2m0aVl[v+~[*:Jeu߯) 9׋S'~o`Tjٕ`ӦLv_Jk0Q ݺyᕁ"PQ^K^t$ 5r",Ci 1ӄnO3Խ7D%tPp%`Ê9pYS~#MU(ؒB-jazLRwWWjsE;^  #ө7"|WmӞ!XPeT9S h "/)X^ͅ8Z63p_iީ)ѥӼؚ2=#n{]Qj*m8<뱺%W5DjT+ڧ 0R~F}AYǽ;HmLoȣAKc9蕿ޟ7T=HvM׃JSo-Ƙ<= DW~ Y}'5ז)vCd.52һ< dݎ0k6hW\?ڶ0ice3GhL$g變ivWG_F~i|+M!=ij_!qR٪x%DG̋CJ ^udiJ_<87v173.cfp?J&b%ňPB?trGz]-Fyxm[^{דJW&tL3N99حjW8Gd8j:aqȆvZYKWɛƴRpuQbuEmpor/R?Q b5Os*ve,,@_fz(;Q5_;!8fA>ѐK7!@u64ԉ)]'oirL DҩJ^g]q:_ |ͺfpAX⥒\/{8.6ﾴT{o% xwЄ/]3;4r"sl?oELm6MZz¬b #&%[eWj sbמNW`T#'k|h~d64D PO@hT}:C=Yb~~*B}nЯ̊DG^%&o澬_G&I8}o ^xMO".eA^a׻@Ý}k"ѝwr V0ǘ87VR`%g$&ʥLi*`Щ#,$0?d~e͔{ q`Z ~!v. HHib.(ow]'eK4s;`.їtǀZNg{T qo?rK$dS0Nv09>,#*19nSnrkZ8RTvh-y="U)U=:\{qC`ȦzQ5 ۜn5޹ʁ\dB dc.¾^[Y $UPa#׭Յ':6U"jv^gث։{ ėZ@ITgTd fP8jlD/lrփƳt MNm+eYtQUw&d"7z\dާ0d2įĿX GF!}{[B~L2߳`ڻS7D#tvĩ13w~2k@ +&=/eS|nxc Mysi60is7x,t$2^^,60t:X[5]γg7P mlaYhOkbQ+ي ޒ>y-6`z3rQ; x4tU@jDE,a%ҋRNNs#M9Lv͊U Nen˭:$uJJgshHU_;G]3)"OҰB%%p23q)xvK l3_|K{:10k'Y pV(7gSA+Lh/25c|bF*$ԅDc?ۏsAG  J,PHP TP0g 9[BϬ^e/|Y$T MmޝW*m*9 3_O4w{m?yf{>n<)VB `pI,Ҧ{0Hn;*T ZV/t姵zz&m IIw ێW%ƅEMV.$4WntSj*08#|ጩ02]^Ẋ\Z˃n _YQMH o7KfWXMikͺ뿻6ji¯G /8y?Yڈn쬿810rq'\ &H}K=8TPUظNnJ;!C)KR%$ވ'݅@8]ۑfziR?UtSVF5Rloă}Hb>a[;, Sb%OY^̞iZ;Wp ';->wLV:s=Z_.\0uނ6 Z =-% ἓ%ο&$ ]sj'UkwϏmO9s+=9is\P@7^1mGl~J+5q6S" =N;N|(Ӛo4 zҁoNn-*G!߹b}{v&*ʖ2' Bj:ya/i:Dx\/RЗlTLy,UFzgnl -=6ʟ DC:rKb]3If %/Jߩ}\B Z2BO} e z>hhu#qCnDdD0sFKy?k o$3iZ> E5ů]/R:D ?M]̰BMZTŋ^I3Na$W3Tl>MYk(? qfبq8^lן4=6ۛ=f{{?{dQYbdaoߣ=$6lڠsfٰ0it{dV2S}굎@ {Zm(}b__\/|Y! ϴiyz+ze< {:M9,v $S$""MJ{h[Sz^#+C/ E"8ףZOJ9]#h@Le8 F:%rv ! SqDdz$h^6Sso *wt0K(I݅dc6M# GD6Ig*:<-x5o"[KX3L~G< uLźiFtmGc#O\moV g퍍}jo+Xj}*Z>$AS7h|l36AJ<;]j{QS%M6G;U?mU2Pk<򚶧4_E19wCKWHjEZ rj ;vB AyxC iz(Ft1/y}f44'|t2↫0k,J op]ҋ{t+²<iܷW[i}{m XUoUT\bیM?mE+rF<_$>TkB:RC{[q`A|ȡ8XcVH"s2.SCV_^v#;Ou쐧O:^1UzFrxW:vI ]PjSթ*:]tUYl$?[di?w*4.-"M2WUD2N#3y?#sYmiAϯ8`:,IOc:@>6_i:61OnwM[ kCciw [*B>#gF74uӦJ䯓n,#|cR*Ug a@csX{J;=VS֔b#9RV[.sR`;Y1+^=(˯/P wjewoWy2N}~UxϾ(jY9PhT. EBvOw˰3tEO9'ݏdd܁£ڊs%?\UZ} q&!0K;˨L4R?Xq"WKl/~c^@N3)S鄡]:V>m,~) ]#\(eb>Aup;iהja˥62aJ{C^bYq+&I Iy3O{~WofZр,FQ]xuZbX W5l66} Ezd|5 aw+̽o[$p @-}/$WʲPJnkWWt`!&+mAu<2"2;=% K.V?wTm^Zܶwuʭ8Rx 9{|(Qdcr|1agd#NiFtuT,܉MP긦̌hSEq56aJ6QG,|`E`A'(ќ-ngrvG446jdGA K!?M\l9)ާ#hC.!Ʊ'U=H0)Ist0^/wN}bj{1 LxxɭMj܍&'x>LWÐ9|[>`tEOnjwm$m@uuf-T}J;՛zJXwlW+ŮeZIuzwm-VG7x27xZ:B_ !]姦? S'?ݶۮ=bdұѸ|="ժ%B>N]*^5KMvζO\Gfa8ONCrI\O*WqtHœl6Z.L~sRcO*ǯkxՑ[z$ OӉ>q:Nڶ++ٯf>}vŶ^.]סo;*_/ N?dך\mWn\/x ^vI<-?L%8;ķ!mG}"XMҼ"`lY0Tx>tLw@o\(҇Ra&z"C2eՇpp\Up9O:`vDyLRFJ4Zj9kt:žb&^J)ѭP;/F]gŏh4DV3QNB3=';3ZN?yCa}O/[_qY 1Iڴm"czaxz"(+=M X|$b1,w d/ib&f'HЩ((!AR%˝xђC'QFp` $ьxgvR7ʄwoƟ {LW XpW IfI=4WXg=dx;nO^a"l*XYCooruEΚᵱ!ODS^j$@U3Z~HҔx> w$q>=(gd|-k+9Wf:$5r[*=Z ]?S~d~-n),In5rZN"|YM[S]V:WRŢZڏMꔋ]DEBYzG?nN:oҰfL}ĄG 5jGlʿ铽K=fh~ϩE 4DVt-Av{OQPp:m?o9о~P`룴4{p1Ke a<ɛ r5 ;wܠuY7a/_% nRD;1LvnRnBEo6›! ?'W%>f ez p%AaT=3S}9QReJ;/[_٤m%EM2򃈶FUq%dg+ *]h[K{iΆqD@dhU.WJ3s*30:,u,t88Z IX*%N;%{[W)"m@UeZ j\Yp7` 'TP$hdVqa$xfD.u&0 i̴nL׫/ p` ?줺j~漊z9\ NrqބNSp*l{NMHVQWZIyȊdirm}OԵ|9U*ka63 n9]x(v$QGz+Uۤ+xt`sBE+&CVZe4zS+VDuiKRﰓXY.+*[NB8Y 8ζ]%~ YkRmn[iO2ģ;[jd˹E{aB2fR  pIXU7l6sInPVbYR۵d<|Uv\nxĸOHyM&g޻\%`i0:sBS:&kMf!M*~+*C?A|RIYNP<<nŕhYؾv|ѿK|(1ŵ䇔 ˛1_n`̾GWQMAwoS>j3^5::,j@8|cʼM1m88uun&XQj]~hm6Yhv^`@'/ ]Z_X@: maO["*1wEky⿖oK#mUؑh({[>l>{|^Ӆj`J.g7kH؈wQƬRz ]uɔM,FqOziGu/Qʝ{N*{}b NJ*xZբFB0FQA%a}ںԦU}}]5J-{87->+Jf=kͥy\fu6 {̔ۃb$C6GK~HLk7*YU?ŭ6U%%1f~0s2J] ZڣgegEop("|4 a.1s㒛-d=$ZlJ.W [z%NbqD|% pD dgR'0|T)vY#Op8No4p\V72a-8$Heg@Vuh03 &z4b _lgl/x}8XFqakhy+^!G:z;GdCgdNqGRMYаWxضeqՙ¼2#Ř>r&J:zȾ%Ir9+_ [*\S$22.|4<֓|P7KJ`|T3ݿBA:<c:k_9!~rYpwW0\c`DюKUf[53R௙Eӳ۾w#2B0}:M%W̡jJ<|5ֲ`]#qe}g zI& *auNʝ7,cd1;#NQy}!|5ENfBS$*Ac>|rAcu\ ('*Ew4۟ǪiGre.q-7TM&EƭqcgXrr-9M͔ Y\ѹ=u(+ F:80?8}uЛg,|f3@ E>w+l8 N51OTtu79f1gU3bO_O#غU5 &rU[u$UWaHH(>}8p%$Nu;U*W!Z@QGFiFZQաi?F%,GTx䦘H鰳Ū(R}|>*r>J“R Q<2bFա!w`cýhg&x♉INZE,hx,tPf[ Sp ٦("Y߹9 Tp~;6}@맷.L;pw-42|BGg%sEGSJ)PZo|z@vM$88X0%&Rv]%4{nJɼ-20liP/M^WB^jC%ps}np'*{lO (knAV绱PՒ'%cђkOHM7Yh 6-zLz_6QrHߋ܍37baٶÃt.6C7Ri{vïƆ9R<5}.jC "y5Թ0-U]]x l2`-'rWٰОRx~Tk浬[q*wEL]dxF@df͠LէR~h`dl?&# G8*GiFBÀ]G˅(wk7x`\(Ro'sU95Bۭrթ7qP}Gg:=Mww)JV!H\gNv0Wq#~Y,S9 Cz|c^JxƣUR(ysoC?q䔤ՠK/uqe"ʧA |ï~#z(_+=< :y)9ȋ+D7/ujCuudX+83oRIZۥQC\b(ƣ(1nX+SSUз62H֋, E D: y) xqjv0+bӫfW1Uu7US5.+)O<`+_`XMwImsMq4fj ~~Ċc'ïP>%+@!N} WXj~0)b֟"*[tJ}c&8!>3Ou_YW .jnU`v1J-RNc#2bPnIa: kͻ43)9] {|8 킂oFnM IXlҦV\"^VG1HT[0ײ @eąI4땻gtu/4e&jR{"|nR'__y8VsoQٿ%&]8OtMϡC>c2;jY0X,>m;t8H&5“!ҴB&+WJЏ ҉ӎᡤ'c33;=j>5y nPlH62Θ0Q-Gc_vcmQNlבl4&^мVu?(mNX]wfsMH_ 8r_a8 UlgKtxMea7wJkdűZ;LꆍFMq Y?ܒr7T7U2W[CanL`K3SsBIԜH{c7ЩR%ǗL Tg@:B;p5NLHy!]BoA̫@WV#º+ RՈ+Jb v,azz|(@(剚ð4cD: ި%IFDy$mnMq)b%@`BBeM3Tix\緳J;pMӪ-w{"X~vL{O-U/MYm`쐁d#%׃6,Oa*lZU(@|6t8;?;:G+,ҖϚݯQRۮ(ƹ0lIjVjNPL !C[媒g&ʱ" 7\],~uEGZ?V=:Wua'6ʒ~h:T}z=[g/0@I5T 'ճqS26xt7s?JaB@_H'uk7x޲.Tt2TOZ.fIjN t k{\b[ t <)'x"RN($R{+4\(bR9N2Q&sXqJtP2Ym_O&X9X]*/|~7R2k*V]M#IM2 (MlxȢYr|dPP Mj15L}Uv1~!d]nNBܢV=߶VB֧5?/joKn d歓dޒelz*?/(WΣrN"Hg+ v<6mfn˹ d?1KYScx.ԏ *ڞcy›=_?/&ͼOB$H$Y5_`ꃜvw0'9XЧ̢jeWoR_̡b_Ӵ|aBi. j?#[1/wWtTRbNE_+n$ض_̽E?՘2F\0BoY-/+7! z-ID Z:7BL$X&nlm)ɄNzMFEyu- +q4q:NjsG9}.:31ä%Lv/ϵ>gweTKU݅g3Oyx p(*JW;}u\ Qʘ}n qX$ޛc%cro\᱓lҟ<Š[hT\M0F4&cDV0Y1cR(rh<C)9P5&\n5ڴ[xJ&Xc ['GۿlhONt5 F,7A/`in( W{w Fn#_LtAc>O*+aD+vÐ֋r9`wX. 7fk]ePolm=E㤮v$3_zS`¤["MTYVV@]]UI Z6(hi_>KN<Mz߯+ ,;"&%uz vڀkKhE+"絯ǽCfe_}2ȯx4'Aq&PƒU8!(%nyhY!_ϟ4y8KBDj/<7N؟ڢFXREsTaҬ7+xK\CoE1FR_e rt軌{tiG?x3wEL:>4ByPj3AgbHR^B⿁=oOch!`}H8pM~y⩾_G~| $ 8>]GTAb_B:Mq@ ƮJ VQtC#eZ-T@J)%I_(!knm5'{ui D.C}diNӭaACjWJK4"$CJmW5<.BG#D ^<Ӡv=csAEřrR-Q wtPE'bLve!Yt닭(Uy{i1hQC"+Nd[?øV܃E/j-wӐCH]7m "+P&qC}&|Ā?/o4 !r2 ImT,vXRsQaSf5hi*]Wd6.VELSfPf*6Vp+;n/õ F`?tZ.(jJ/0V4^@y8s~\Ydz*yv>Q.c"D)ɲ+ƌd9[*G}ZęiLߩ416r$ÀE?P|ɮRl(XPoey p:y ):p/%1ϯ@'Uq^NfDV~S% KX2tXxٿ_ o'%&*r*l1i~WmΉZUp}!١cwt^.NkJqTBdy\ ԡ2UzL$kt?Rҭ;R it97Sj1H]F$l4' MwK@~ &sĪg4$mTIy$pꏒXBVbm*U~Dk |<;ÓX 2PݏDеK6k\#Q~:oDz/dUӕV|!LȽkzIWSI.e*2 w2#_>o;5 QQxs3-pXeE (gCIyr^υ0*Q%̔JsLr;[Nýb PyOM7rUW"O^R=^D%)*UF-bsg 4Y*~4qv^gP{UJsaY2͕oY =I4nnÑ(DQ;6"*N+ &eq7R Kre&јnlf)S}I#_=}o OUI6 w a׸| էH(̐{}uRtTTx́$8 v좴j~\*dߡZvJǃoޯgM`Z+ّ,F$=6E |U;U wjGdM/PdEH'i" ֮a\G|ׁ*!H{ N |~޹n#@KGObb ynԯEߣxw B[t.s1~&1<n;"Ev"*\ܺjzl<vLx] <?G5|Yӥi(B$Epyǚ7T` C_MՎ1NlVbB.3t2ۊ{@(luM'l޼63?5{3wV[~GG+HU& !uOGClVotl p"Fؼ!"հOKO5½X07Jc/15]C塳-ґ"s"hhR(NA_Do\ir^픍P=.ĝ/FHW ۹b"LE_EP|%Xg"a@^9OܾvX-[;q ֵj*%YchSj3qFJAgΧ#pF4뻂3ND t3o5^ɁV| 57}7H.36,Hn^ښ).İP Ɋ:plF3]ŜH&(R`ݯ담n`_!W"*7e\ҏK}yR);Y=y bőo^|qԑ*Q|,]ԚfK>]}Sż.-[KK~,oAxrKExi4`:BTsji.цۏEfjg< VB*[ Z/bVmEob}Uo &+IJ6'yJ'F{x}u?oBzgN:R}vwq[o7Z[۹pr;?;/ڭv˝.Nn!H\`n=;A LT R0v}|;fy-x)Mo5K2}%҂4~d@N*F9\'{daV5qhή=VZC=v%㈲B:s&-Pw[ߏ ˅}^ĥ/HU?suw@D+.U8iqC;<,A2'Uz(MjKK)wzޡ@NԒbi\ihV6`6*ae"ݗ#%䎾twrCnSr| k+;NſGNěX}:Jhأ~?'t'Ob9T ?pmu[8\iyfiZ AgOsul[u뽩s*bdկ-p$r`R}l:)}!+Vf:-1[k✰Pɥ8 ="AɪfxewoWyEF̴xįl^FxZwj8,#_(;/'cMnKs̜D<ь}PUaO=)j=c[Y?"]B6Y c?!"m8oocWȉQ]OT]4=bmM٨|ynj_z_W{n&7Aw.`3VqUt|P$pv\d~!!uo]z9ODqh`t1( VT5MSJ Fk 4Q 5Ӭ{2Xz8R M3kj|.MP" zΊ|!AN MlWXZ=>Q4?)^)M19WR},D939Uj[{|z6dTid~\Lŝ%܏5~}0:J޵ӏZg 5X)0H uS;sF|3GZ?:1ޑjZiQ!q?L㋛.VCs?KI*,*Y={^7h?8f_`s6X@S6T*u}A ГiX1zF||k M7X|N݄m%\;GU_=2 q?~张H&-`NZK-S]ſ.g~>=^[Neq(P[ >7ӝFq|>xw;tKwɽ qʟJpm&b}Mha\OΞOX1DFMn[xwZa%g]_Zֿ1;uӇ(k=C6ȮFSs}F+S%ܳ "ds$m / uj~\`C]*NHẙaNU I׃P#H_؅vUձy{ZݦR?jOA_}|u V*yg\}g  ƤՍ\AbjVgLty6ѭ;lvJ(j4,Wl QlJߴ;7FެZoi޼$aq-'VG\!Y@CWnLMM^{[x|$#I%h$ř6MH &p;l9׏܏C/%Y9hx/$TY}<GzUjǥ8I!y2L%xv+~[*:Jeu߯,N/׋S'7{Fzۼih]m#% 4, 6R tn]c bQz˶s[J`EVsqێRt1%ۅ{ɆY{lu֣7lP{Fsp$aU*6ghZBa bRDD#y;q gQfZ^hӼ^)[ +p4tR^5Fs^ !"V"@zI`u$oIy/zVkI7-y76bopvk•h+fL Ĵkv=]k_w?<ğXXp鬚*&?>t(NK b6 : \'+"Ej6;BDzۿDmou%)y/ƺ#꧶Ґ@ gMYAoVCkRU*G_VZEs7LaAeKՍj %k2,b҆mQUZܔlsJzFq[33O5mNmJ cLc%K"KFdڐFBq\m&Hih>zqymܒ;Cr=yYǴ#k{mtLSɇ߭RY_ P%5_nԘe PHSA ,1+5,cgɷ`Z韰&ø}9;F@=_7@dadb*t_'gYOfg["ؐv ؓPli_yiPMu#w4Q ݿyie9rQz#v{=\.r|'mc.gq\0fiYܥ+n QU1Ax#;ڝjFɏνU1ujS5[o=isJ7p'.LA5?|Z}_ogz7Lm}Br 99ҒK/j1=%3^K_,$UDmKbEsʹPGLU9YK˹ÀYnqDkڛgxXC?c"qr":vϽj|nՃ"1qoZ~Èٕl~羸Ƙ~̘e1DAk(xj1K@ONi~ʷJ;¢w 9+j}s[Fx@ݘF{4TIikSIM0ym \ҒyM[Scr/EFZı"-n+ԅށF*mCY.&DSnX 2מNW`T#'k|OD6tfG PO:(h=sߪ" 披Fޗ[UBF3+[wcy>kzz:OY|v*aMIx cnҥN)SOt9Z<S5U1ȃ1Ho=ƏD$Qsz-N6s;>VE rJrEž!5!Rn-׮^]eHm|;Ţ?(M ]70s*ڍ^=^=Wj? A$ji4l˫W=(w6[ℰ.-66?7~yꗟ9W [Y1ǴgهwP⋄L5 .99gUs6 wm=}DZʤn pfu7"ώsC,[dv~n2+Y1KI2gS'fIsٹg\>m"10#Q3Rj|aAlT{+7όj!>X.v+N?͞Etޝ~)zq85A%"^=/}t?^CS^g_o2<7~Ϝ=a">g Q40c8jӖ4}GiD?L&&2 neiͷCUe:[1Jb"?кWȰ? cr@H~NQ/hH*J=R {W)H_RQ==<- NAWeD*!nrYȕxysE*§+x R]bA 1BfWKƌ-;/)`u0v6ǭa^.浻q;IibX"JLPL!wY91 F&nKbkyTz # DP$D|zڔvmR:,}-^&`d%7GKNKbDrIxc$sW(/+#bҿt*IMTO5/>HgF.$k NtYkG#>ua'>\::7OWUK.ϺwQ`aEŏҧctOn<]ízbRV=i>VԞۃ4ψ:o )XruIP!{SA DO.&Y>mTsg>Pd=)?uZGw?w;MGcn]M"HV6`dÎp>:?!j)W>v &);I~DWLcFrVi(3k)I)$׽@K?f8SNH{`b KotJ#7f; ve4ZzlOSO&.֊ 2r¢3If Z/Jߩ}V!w-['`}~".0><!U5"~?cl3F2ÝK8&Y.i~|ן?Êj<.kQ=D󕓵nUSs}bB<&,^@,@w_hb:Ƨ\\l^gxb' ùd^ת]~nVK6~9J@+ zVBNY2ʗ^&ݤ+q$uDTorlK6>9f}}3o`eD곯k.RҫHe +5ǥS\L9n~@vR]bZ"("_<),;R"CQߧ0]Ù~@g+ȲtJg1mN/w:t00(I݅5_3z/>3kA8Cppc ̈́`F=Spa*>rM 8ם^T_rvmT w{;"bͪ7}!{bo+>[~lS[nW Ў6a둖AOl$5Y&)WE\zN'Wjo8YJNXN+<+^Iƣ8"ҕ\ xU0ҜL{щ/3缸* Cy oT4eM4hL ͽ(lpE4&d^/ߖ[з^omԷ">o[ &s >x~Q|}>tZ>l?ևs =v|ȡX Z/ S=ԩM[ҡnySަu쐧 :^A.=ݹ5U%@zȫ]{B*V%8ATuNo- U4u^Z2T$}xѽSA4y@ҋEd8SC]4/NGj۶õ;ѫgUSKDfQ-/z)v{4V,#b*dj(ux$TۿO,싢(̯&>-3-մcHzwܩ_OU@0pvx 9i>}{of^z `G*rkUҞ8βqƔMWfiA(y[!cy_e~K'd09/j疨7(w<>)-5$]KqwP3'x .}!=Q.<ͼ!p>JF<"V\^ini#$qI`(XCME?Εґ@6:V:Y:64} e3? :rO$qTwztg Ț0И9F.kt5RTf^]ӯSHď*ACQ30@}]L!!wr|14#&[A##_(jm+AvEVS\KJe)7Y(lw>*m~iI5O᪽Ҭ XeI7k?mj'4-bf?0;*mEő۠wnëygЭIzR3r̩{3^RY<9Pt YJhDҩ?rh3kQg+Oig3TjwhW $L+jݵiEcJ􈑈 n5 wz;!Q !$S#\O[:yx2s;ߝ [xDjHF2OMPBj8uƠds蓇O_6ڲ`iސn%5ҝ*7ۇcJ:o B81at!nt*'S{)3 'v;ddrYQ܏>6ָQq|:}[Nx$[FI!,|*g߆h=@ 2?Q XMM,+z7}\[RF ጻBGe֮FLى) +ore tr)ݺ pӎ;Q]'I`2A`vi_3F9B lz$h:9l;#WuMn,\Vw_ZF>e|Bf~2!fq8dzpủvpb:9 LYl;zDfҗ(zIZkuOէ8l6dV|9=\Zo}}gdǹ[JW&J KGNwಭrwXDWSg<4P#6fqs",j{WӦбkͪk5=VW7^4Be{Vc2E|qKV=@˦z"W7fRjC%PQ^o;zEpջ g<(v|^Sx>Ʈey5{ 83&[]v@87(37@#TRt!l9){x F{NQfs-wդcbS&sUP [?X ,yhn?tۤxbpxA61$_;1}Ģ:&W\cT\iB^30;VMXS2‰vrTڮoNM$1LԢ) \FLD*078t.p [M`-۟|p|X;\/۳Qn]IG t,Fc1;N#.L'j('ZRr8-*bBuzNa't 9,NnW"Sh0]7:] 5rcԙT%KG:4v ]mЋωSS\;nrB.^MS!s2 tڥUK'v^I7Jj )TI3/h;A.EWnL{kK!߰\ b: KlG_KQ:HvɈC+YjDeF,2\_K2"VZRR,Wjx U7p[/G˙j9wޜvG|Kl:hΓS"Y&ˋk1lN.JzbG]$يs^ OUՅ :ٰr/#& |Ϝ 3&Sh`8QϿܴ􉎴0 Jԭ/yE\w(NePsu&dg;&Oƴ[q%Z9`xd~)/gp/}_oRfJ]Ė"7;o Ѻq$p Vx :,`&29 A#yњ.fu+f6 #[G@PFфM"ó0FmXxsm5fX|]tW?D_b T +Qn3.ZqN;/~RN^NX9W1=Z?>~^{Czm"aYLuL+w{a"X𩘆/&p&vg/" I'4_}DY7u0fVSRs.$a4z`Zidkk ~d~(WqPqh6&7$$kgbZ&wH?g=<׍NжOiT>jZ ?-t W9jwAUkMh&ߔ}_Tq ej\Zl T@0`V dIq UWRch-Som#unqn Lt [\P?eÊWx]ryuР)Upv k#f'p 3j+m0?ŘLBJTkTOɾ&IrX=\=T : |f3tg(аG I@Is'޹d)F&fQUA6VV$h8L=У:+H?D"86Q'^_NNGcjUb5/O ";"'㩆(nmQnΦl 1x)=GQZNNe2y z)jBWBuqSnSNR;Y čXi"~6!|5 NQA%t"QD^=5ZEH9yݭ|rA븎wU /|nN!!7Cĵ#3P5^L;6,`wQPvR,?rE'F\׋\Oś/fxLBp!}:Inh~ԹYUMDuȯD^x*aL>=ֱ>C?,؊~׈+gX1P#5K~|]ӈN X!jb}ȃYBdƓC:v%-LaxU]Aԑ:TՑy\ Z~EJT2.P~WJK.9*;QP"՗û r;I)9""¡!`’cg4(gTЩCEf ݰ50G\T5/ڈ" ;7WL1' f<گaӹM#7Odz[EOc'aa3q^-'#=/~IKr.Hx틔g0 Im`6ƹKMcBs釱O GVy1O{xlKsMWCQ೪+)"=4jKQ,H%{s R Z˰U_=L6Wj4?K1o6 ʺXm..Y? >eP?^R8bAk{rf$yq,4_ 5_9=:[ޭhLH]ċVHWLozfթ7{&wB1V-6Jx# !q:\֏xs1OhI.JgJxTHƣUi)yo&oCqdՠPL}uuqe"ʧA |ï~#z(_+= :y)9ȋ+D7/ujCuudX+83oXSMMjz'\إ U\b)ƣ(1nPWSRUзTx&2H֋ Ej*D44+7pBqj!+GTvq*A  ktnA/ {7%\iPc\xZlD^0%(1Z > FhSowdL6]F%@xtXJ0ǽ?Ϋ5*0ŻĪ~%ؗ)۱ym1פH׊0,M9`E.^ Xjl>d4l>IZ\F$Uf:Ⴞ:`]s I1:bD@B$ȆU Nk>1 .L)X ? T2,X'Ld ~I([N$U0t:d|}]B[mEmgrt| 5uyZ+dFTL),r&]/eLj2'QoFՅ"OW# uj)#)CIOfr$ognL4+G9=t ?+Q0` 8x8<ͷO@){? ^q䧃)'Fb9UHnIw](PN(C"&)IqϘhOlw+B1)/M` ~>nŁR$MG1ŝxQH7A+_h, X̬E/\P&C~>h H :Gp zwl.JfzO!ȜfWxmw2oi: >6#wBc}Tԙ?D}\ffaxX*UԣOkH. Gݡ&\BWt?SW4pi 4%lu0 M!b655&-lkɗ[j1P{O"c> V8q>"ͪ >\ HZbOiX^ zo(衑xϖ:1+Ev`:oRvA`A^a`# /Bf&VL `,g2}*s˥3ķHV>h( %#.+BddA4w>2SJB+D!w֍/RM8Bw 5χ@ }FSי;6Fv%&WW $|Y!gY9;5>@QR |hI09E\QK"ցHR``u<SAL\p@U5EPwwpݟ*u%Ko9i*U:ihWW9BCp4_VjGۿ:}ݮ ,MOw|x`jhNN׃XBI49uqw~@g,u :uaWً-8c34*JjY.U] hMP(+ | P"uV3ir,u`ۯ"䩨Qn_NU}]X{+ (%ΡQxzл,U]Ol^rrY+4 AI\hǴ”?yIʳퟤ"?nT"M"CJ c0HW.A_=wծz\58W1x6U{8c*mUONvt{+64Mb]96QblsXqmKt2#yYmOC6 +4r`1LU^U ěC:4fYv /I?RW׀1MTv1f s0 DF/fyH&#ԏOZs9{ -ߘn&!Aܼz{@o7y.;tw16&De;:aZ&bۣ:R7/ |v״ew|C˥LUDJ͝vrƟ/'$.0RDJOs-@9!OI,l+Fh&%jJ:PB) Vt!:vncA(Aexa-6z`xbr<[O˰ʼYJg(\[qOI$J[qڭ \|.DW\ sNX{.9~NjOOag[O%}rO5J'GXZ~ݗ0-1@4:{y>rlΐtc. /l7^K&JfZP=jλb`kɛʿ#i.T%9a0 <d#JhTotN|%gz6ǏHśԜ #_}EߛOH?^.GȘd% \JJi"<g2%4wlGD@FΪ$HHԜKv<:J)7\4T!4XF3OOT^:<)_'rwo#c0Og+y4\2/Qf'6,7>'k,_NhSy$DV")IgJt%=mfy%%O-_(䒡[^|,dx H]̘/əkfg Q Ƭ|Lw7mvζ4h5$IЧ̢jeWoKf~1>-Oj qr(U.đgÆvgUe:Q1X/W\Ja1lsG+ K1$GӰqegͺH{\}SNF0._`2 p;VH|J6~SKu9Ӫ2ʘ#vWlƑq%qF$vI%}S#KCѷ9\# Kv(;ײe'3gtY2q*˼9G^p;EgĎ,XV c; .lx#N81/3ݕs=n쯁7/k*#xUzwsz?lvy/k< ۆv%C{wD l4j"HU"؃" c!O/;~䌮P5zv5φǺ ^ /VTE^._(ùa>>>=>KE x6Ox i5C룒ct~`1Ô]ʾW*@xybپf*3#_y\F1%#~ pZg7͍ى#1mu}d|pߍ8:=fDXfhCQqXBۣ"ZkMwyd!T`?Y5d$#:^hA )e`@Tȸ}([C/ mA6j 4˨r$ "2,8[sӗ[\l,A1K`PRzA!. kf*т\/XdD9g5Қ>|HCL ϽӒP WJZ'@?#HR=(4qΤ x1\ ,Iza(yE &l3?#Y=Fk W0_ WXws)!\O;y05?CEaK. U*ӫQĈyU= ޅ%ZO̯S0$( Di+M`:>u>A`G37 ;LdPIc|r0G4YՄ~5 #!TN6[ B)9ϱWԒ%R\P=%^W7t/(.zfdkEi؀a~SBΟ'ړc;`8`ܲ!T͆9V$g, t<">YrQ>1Sͽ ?7noس)Ⱥ%8IQ6=FJܦuW~*ub)Gd*ݒ(SQYIPJjU VΉ$2 < 3J8'xщǡID͜])T%-iKoP_RQGz8Y_*h!K<?4 g~q-,|jxN0鰤}V-6ǂw;[dZMwVhy܉t2+DLTծ姻sgu61x)3]Q75, \KQ$ަ^ފu6M +FȣCe|ޣS>߯~]h}Zl(JS7aɳ6J~ppȃK'a`Ny DsK)U!U`L2:;#4 Dg rw~1a 3X^n*VtYq')U`Ƃ32e_ D/Ad3-Z`M곔=Dq_Q'c75NpKM>[ ˴ *E)&vqw9NkQŘYzua%FB?aNdHq (5++o9VBNǖ8񕌯z噆 **",'BApAhU,92ʐ,Z:U{qlJQh֚j"ncrjEuW`>AI`TII 5]i.>N$xjوbU(딘>CW#L^e--A5l-ck>v??\Kਠ8&Iʴ5/Ѡxb6ߺ~0[O F3 OE8O1n8y Yo0 xH6T} !boX8{C;0 q {UT mS!wބG+brۇATbwP5,nq6;'N^C.>R`ZzLiwAKzlq9})f9QN*?¶ˮK_39u:7@'$ع `~#@/yWk4Ei7/#̢P~r&j3ftd\82S'|ŮRx=[ƚBǹ(3Z4vex.Przhנ9^Su_3ggKU=Kp*v* '#g>o> wI<ؘ3<߿8`Z_s(r*`2KϏHPBIOx31hݝ#I_;׸gvK[Lh 'Ys)Nb#D> I!-p ::mGϩŢMt"&1Ϯ>M\l,]q7l0D`V+"0[X:aNʡ[S4WiI&x\]r|;'ÓWfxa,.s˂i17μ=HPd;?%0_rW8uɥLSEF pLa%ȘH;1yF⋘Ued<̳y Kz#\7[KeO$3Ysy֥ 7] HF8h;hRѻmj٭Æ):;oT{(ʢG>an dԃ@3%7%}p,%a\:b}q"ij-b>|]9{xGѹ&ĵ 3d$a &5q3F}:XRUlXQ H%]Ƒle$gw :Jt\3KnSH*AꌙU"CYfFdzmhAB|BH-JdBٓ""=i'%,/w1R/#<~ʕ'"95r}LXxG+T UcJw4,'8|$lhY3C]Sas31b z7,UYC=7YKD5uR Ao%V3֪n9-f-~Hڢ ['yVjzFvj޴,:Cmq٤y"$ak?6ujʧ;*Cаal,b9 7P5v*;fau\1_J0Q4K1x;p^v < Zjf%sh26(bfT )QpˤÓVM-dH3Au`{Qh6Α@.JT L!/e e]7FwsbJ<ّcTkzlTC,ĩZ)A/NsC'Cl&8($$ 68|'ʰq0{ArA|OF>Й]'d{T* '#Bt$[{V͟y!s1au'c6y:4!>;F @)\H;9E5a=t%,;AKt| XP4CL D l1;wބ<6ī GoAظ @c/Y0<+=džMG&vBBq0U()Pu[EYx@(&8X x|:G׿0ÑwnwR3pNp敕Or/܌TiŌ3{tQKr/*1y▣Dyۛ^Hz kShjp-8i؃1ȑݤDr^mƌfg# ]{qwd 6J~Th"1ʉ ,x TqRquBrxFqޗB$= XGk"Śh[eV`@Pa$+ô4ئԜc㌐,ΎݓczdRK=/-!Xf<=zLjh_Ihd'A4Ý&.yp!"kMq}o:# 5@~ P]ry)_+(_KVadE=,Eg:_%^b$o\jք"ӭ쓻=ݝ\=A=[#r~_'t%9ɀzIMu]K yg]Zf!3YXmAxtK)u8o7S[͇1pHL팃xJȞXG|5I`uaj8uv|fgXWopLJL&83Ɗ'}BʥWkkkg%;_])NQk{t{tֿf'tNޥF,5r^ +ٶiݮuǔ]ۭU1}sV?Bfk4vU.[$(z$Y4MIO|ɳ|_)Ma~eP塥Ǵx;»P#CΟ0~h6Oe1C!qbv-.U ĭ y"w?ʢȬ q!$&u{?PGy?BkFHd N`gSs7TV2rVΉ7.\`0bZm28?j (\j8_&M~AO;h/"mJkb>?Ю t{^w6*rWt~^.Fb.tjq i{-Ⱥ:HݹTc*TE;^H="3e^%16(UK )7p9[tUkk;-姊ta](c=8۷kX߯D'p :"DEOp98) 輥Z2sЃ;aC=y*Y容[}Tqrvqx>"H-ت3\vq5vI>ɦ7MF3Mj8v)TQmP ,bFO~Gav_e)~adV•MV!~6X,!1~mxCՠ/ 8(9LsJRȵ5K&:}9;v_e;< wpvwa?1}yt5#f BCw'tY2 =4C&*/ <ȳpFmݥGo)%l"+$IH9#3^dBWuSyl_t'C:xQFF_ZU{.o3>OPrEʳ8uPɧy.=sz7v~s'9ّ!E€fh U@kIb#;Kp_sx1[FT7~䥣MS}֡g\Pv*'0k\d9Xǧ^r9=PA KW:By07Ň'A3sw?2״a6_ɍT6{ bP).i.md>ÿҼ~̳3Z z`oYU-b/ 9`)w#zetڅ~e%`&ק5x϶Eш0`g';p34IMUl]G'}>zqGh6_Ý]Z&%>/=d߼kWxlr[M^I^Frb ?Li0r5Zclc \ SDUwb&:!x+w\ҪzlyoèFܰ+`xk=3:0?Noh_U)4;kYQL 3 ˹`V <et$j5`IIqNI ] 8F+ćO5r&`KYG~M0.~Rg5tzV?S'7Rsun:'#@`Љ|]IL^jiuY%mht}^U}=+0yCl*6M-PKli x>>pŔSٺe ao߄%$wi<3kdAՅy`魂tl nKhR^pnwO-y'\rP`?w}D;ރqg$|>"'D9lN6F׮[s~+5VԦA}2[ݖac5GA(Ixa/%{{1ޤ?pdn.YV3\mfyꨳkY,Mmwi7X7V/GwiW\O-`?J=XdոN"55y?f*[|_6ފg oތ{(AxWd'{T[ /13rV#Uɐl 51{- mtFuݨ|nu NX 2D8HpZI2<U+/ɫlPǧV$LuO<|[[CV?-JD|[Z)N%Cz$+oyuӆɉAȩLʘ_pWI(h_ۆHJ!Drzұ<|kbWȂP.K ڶD>p< , qus6G VڕPP_NT;b.ծfuŏ1,}XCl-Fc|`>O3#L6ҀR:rbo!L+dD]|_oNZ 0Ad&iC߹aCI+p3ia g|#l9ywNSO~Ё35FTӇxHwhPL[Mn#O` Fk;~x34e/6gN;48H<#Xͻ)vɦlq&rq7g3Fs- ny=qz] $3x{6WJ(T9Wx}1g*9`e6]|f0*?{qXNxF#g+St\=%2#$'5@F_*&D홧nveO&9Qt![\(Pp0{sʏJKvnvOtt#adEؖ\hkw\]܂|j6 4 vB ^&ioҍ¹*~{iPח֟xzy?jWs8͏Z1Dh$VZ#M ^cUxdtID#{?ax7j;(k.!y!J*дYQPq/1fw#@_('ׅ UjuP 7(rm+%'#2dhPJܱ!NxDib5WHq}CPQYmIsKNcM X7ԵGgBŽ]ط\v{-~%FC_Vy9⌓!X,ȯ݋RB'Ykh htL ҷcgAOaHG?H;.!bո(jIƊّ=至ӟD@Yti@&s?C{;3_PTT0\$CF!xs@x <*jHUY݆w0zjп>hGySU0^2} u cuS&e^//t!LET vY%J%KY b sU;MLEμDrZ(%:PkW˫+ĝVVRo@ N+avM j;NuZnHCGxgĂnUiB74KUv~0MGsΥjE&r0Svn ?aY ΠSZϛο']P|{*_N,:5_v_z kHySec".TH~Y#>kBKR/fK}3Jw!ŅD`]6fЇ}u£9>.k@&(oƃVqo?lYu6(=p~P|p? %Oc8Ӟ<n#c7MRJN1oǝzlҵꞎ㏸wum*9u188ߦ $H9٦5-\)ًzY`@r+{j|JO :sHAs۳sF߅3ipi Y%:]⅋BiKCOP,hY+_9 ~yͷ< BGʜYOHP*&@H:4PWe5}OB ;}֩&})Of\llκӡZﵗ6Ê[?-BQ=D󕓵NUS@p8B0@vzV#dzO.&1>j67|6q!Ofxżv]}nU`?uIY]ɿePHUAREX'@OK7Zbϊ"]P9bRyD\zO"Sw!"\L{wyz#_/t"m%OHbHb! *#G"@D!YsI e 9ԟ%e|+;Yv-:rjфÐEa2#Y,HFKD౴o.'pxS$Z-,0G:]տNq;0 P]!Tlx3݊@CQ̈́`=ҍ9 "C 'Ĵ:SOhrgGo'ceFr[UmPrm3l3~SASWzy[mi5<}FOVmiݒ7_[y}{.ٷF,=l; mhڀ}}h7K}yU7 T[J&k{Gw0 ! i3V0C WE7xtLiqh8['9YPߩ^uA36,!Fez?%gtB ]FUN:QeJluyg[O $*zLUz1,n/`˼o_J t@;XD ?TԴn^N11_~8ne1+0|B.1󦣊>AYv? ŵX{t/1UeP!p^k6w:tiV=SaӬxR`9K;Y1+Oղ}Xo2.gJRBۦ<lϳ9{{;kΝ{'/숳-մ(C)Dej|g_Gw5.y69npf tf5}-߾~hjjPq*$U c?qԗ/oEO߷~ :ZVӯ#@bWMxg!M: yW5`o)O"HUX#wA6\Ӯ9(L^rP㱶H%?'[V 3qv_ɝ<gk ~thLušsJ2 {ˣkT"kTwQuڸ{!8uO[#s(C-cSI:wm;t(r2{r7^ j<=cE9{=$r e53~ 6&z`[s#K0d**u|392nff& )bX"Cb_#Gb%nsj(lTo4/A>]|fփxA44؝I/LrMh% 7^0|5[qKR+*-+ FLw7V8VzJd"F%Yzy 01ٰT*9L}G3#Z^ΆkX:ow Np#c"6E̅+=^ C=L0fXY@ @JNjѶr$]䩿m ||D/nYpvFEq4Aę ϼYyv֊: Ju;>s&q6yR#shۗ6ŕt:BTz#]bN+ô=a3I,NrZ9Q0-Cc6mR 2  8*|;޺]wi?{;0J~]N:uA.c$ʤpgO?r՝ָH\u$my;pLᛊʓSn?^cwfS;Y͔In&۔zwjc jHzB9RxMH ҔwD^&A?Y6^Owu`γ9Q Q7ofQaw* f7o.GXKk "r|߆+ m>rc']9^i]ؓ`}BRۨ3|i ] c ovvS9qΝc1e|ev w !&Q:$y[!BH[>.[^f5Wjva_0qO)O%ā/- >衄|åOwozjabC /]hk_c&P]܆bϯG;m4\+^Gs> =.!fd<w/[)D gͫO C//r6R.ztM J,nՕ 6 D"~yԴBe \oY ٗvݡNt ѽKn4Й0]nM>KܱU6+2b@}!j'26_AC7 DV)z4J\DXf`aIG [ 9h'N_ͼ}e~// [wZVD<ثq8J6=<-jF3Vw Wݭ!rp) g#4}m(Rqb 'v=݄@J*G9)qEYXM%GWrn?M?CHȜg(Q ]qƈ8U$`z T͍L|#BAoYCptצZB\~5COQw,I-B@u6n= OhD_E('>{fW8' nCMw8ӻ̂tqGB6E׈&2) ]JoQ8伥ĝ"rB"A$AR/ɞtam/A(PDս*He|] j Nq! .8J t K(9\Uaf\UFLCr71JV掕^ Txy VnL&wŜ +>,̄VQEfs6TD*ET 3)LNOP7גn ^7C\hҖMS UPA;#UE:N[G11u1Rh.3nZ4ZvKP0Q̓#V`ZQ[ْjV(s"Yfz:jk-M4yIz}-9;V"^=gsJ%>Nj5%6SK7|\^ߌBON@3Vl*˚1V<9T8ʝTTWrt֧a6sӈa mW6 '>89;޹,{KjB%쵺M_s >0Gr[jr>G=Tl6mP|GVG$~S{=qm5%`v$CϑJCUI$PCM[NZiPs!5׏3\vu*Aro4A[}dיsT¡VM!-%dnNktPii+A3;/?1Be-z|ѮCoNHgcBi!x|Oڥ'ID_XQːom6 x'8_[ tĺljoʳNf_=ɍvEyD뵺mhwfnvոl5Z7͞pzl7 UCjVMkv nw;]nZj:VMj7nMmvsy5]xM7mTn;Rvcloo-Ekn`llPTknvWͦUӣ)nob]L*mf歵-_MJrozfts<]T&TW:m[lVKoW MonɤҠhO,Tu~[V'u6Oxi^OUp)KB w%# .d̷_VZ>0C 羺^ދnlX!ٲ[}ؐ{av3C1QMF4L"ܫ)yg^C 2R7k!;أ֤Z"2K^sJs*DVS,@.W9 X܈ƹh8 K]9+X{[:Gu5섎]ëxN/Mp`2!ïLqT@\BxX–[,sөrnTM+xL?@b[1{HLg )Vjl0wըB,50u7ȴ3ws ߦOhnl=jFw8묐%M,s:o#f䑹>ߏb&8T(-N :W|0E$Vpf$ @+@bViSL3+I.S.\2ll'C+js$[iv 9M (ѤJT۬hsM -'VvWӗ@:ITUQh,X+sLAzI n7S +S0bWS4wϟHS}or=rf喢l|1hrvK' lSUDO]%^ _*̃ʊR)2,(ۍBuk ˊ+Q5xOŕ)d= ggg{IV# *8Cus.LfI}~<S đ Qoa SZ26]^l-쪵{c:0mYDž4miW;)}$tu❯Al%{@.>gbF/|АG5R̉ʞ17ԪsjD\_Krp10IM8߭x; , 4`Iz%{ aY0)_kY)QXr,V'M&~rӍ>,-F(4\Tq/'1WxnSG#P34&]|<ݖ6,BoR趘V_uFFe4@c7OHrhh'Q@ xQ7c3 7"z?F<< .pq 2-]ߒUAiA$9; Oi2+KOk='nhR]/@É.v!Su-u|r/k$VYW/.#YAS 4}lp1dju6(БW~z#''Z|s]Aw{\ßRF;6:0"H="J98糡 p 8HXO_=L E\ bd8B#3Ƿ; r=sߕbLf|nBX$HϒjNإ8zb"?^[vxep"Jupaʮ"^@J,16W<;_쟉)0)?>%Fٚ`}HO%t}<8-A#> W?/U eQ0[Y ſ.3m;V_*޺ `:?1p)dX~q~&)jꈏ'hO=c-9.''_y '=AjFf -%K.fށ7.c&>9,g(Xl=77ݧJ~$x*9; w19NeT@J1EV WGO\ !HIvQAXnq?)h;]#JQ%sY.ÊĆ(FOEiPiC͒Q]KJDq0+oC<"![tFa"pkPpv5&r6d?di 豾񙍉㎝e /8&a}v< {qNjKa 7{('"PC F{JQ11@ wn`f1iD5K!&Ft}Jg;li!_Ulia3Bl `BEsrq;wŔ-(ܢ0_iIr@fPhzCp4׳E,x}50t^niʹ Ÿl.)aLg'FٍtblW,萅toL8 :@m†D{VUݒohu8 *j.-s|V%{P I@ڙ~ /P&JG"ΚGQ4K2SITQ.vYqbafy-@59(O:RG>&e1x mL?l djcJ"3o sr tiWbV䂎^C_ <[LnZ̮D4שlvxiBCpt48.wYgXN H+JiYf% 07t;&Af^"vT*; ,Z 6&:^+ŭQ畝UXQ\ wb\Mʴ!؏elDnaaHgGUjC,70ZWc2\L/}K{/N瓝_Qsg<84XWDh)[5aQ3J5 .rӫTRg} v(GU$Q~sDOXyЄ {ix3xEVVZNgધ K/[R N)DDC@U6:\nSdQ(kS.٠62]6f\t][c_U̠1D~zxdnҳ) _!m#GIo1Mc,WMp¥"^):ti=҈u(FwXA/n0q@s`Wٱ՟ae!%%6~..PNѥE3[4 kmTϸ#UP&{ezxGLU}T?g24XH-Ʃ%S|"C $!/)ѮkF6<+|oXWxEXg_Z;D8tO'w0$azB4/7\O vI-9OƔ6ǖcHZ7n!Wǖ0 LԨU`r_&|`g8?m23Nt҂I'6dZG'ஔ388ëtIK1N {Œm<,ةlw:a V5-iHEgu2Dl>3qVD6pJu]lV*K)`uC#I8sj^1:PH]L ō0Ȭy!(s>-1AN_l̼F]>S*,">,1U7H/*yfh 5GEg<(yr^ 95ѪO1u=L؇=t.8LT>rBt*֎ټy jȞ%-u_vnRt4G9iT_Xs7D/adR $ D"!OsҏFB/#N[qULmkI%۴s`xa(MArwnr|2>c"SԌ4%N.WQ R4CmԩC7SB=Y8 u=+Yt @f"aG-3,?vl} dJ GЯ;F5PkOUD)їl3z9KQ ӘeAxX5(qfsr2{QM~;G\RZQJC)t`t`G%1 :(.L\x%Ulds>\)oS6mCANySZUMu\xl[2/% -֘\SL+);\,?,J4Gji8r9wIiԓcbxFȟFܕ=jCmνI9 "eY >l":T.\0MBY0/**FHbFlUPݘ Q1‚1OYg`N:)^$;kt;\+U^HbibKë 1Чc.ʵ*.MYUdopvah~c<̲ IS~&)]/9B[}vݙ%'&Vˈe |-e儁\)jG%c:g8" X#fS>S9F(В$.]n7& |$ o,"73+-֒[a^嬊-V?ӱ0c0죣@gGLP!*4&m#30c̽hIΛ# 5ТME04ť֜GċOQ2q!stDa}5V]VX$3k[v)Zk Nk֖-I~B`:>Z-f\:Ѫœ#?I8N#m^}X,ʐ_1JV/ zCjO󥎾K褨cjNQ HʩgAjDW@`>Xd8 [Zcce̿ǘhe`|=p "+ I' D, *Ye+2QYU+IsAW I|y"M}P y Po nOp.t/2`F7OOqE8i1|vYE^1-+&3 [~ IZ?: ^ \`>G${h靮$ K9p0{;lLס]U/89L̀vC'G(1 M ~^uIL44z 쾠&XhA*TY)45<w+F6x7ձjOy(ŰTNS8+X]tiu5~` ѲdJ8̥JZM}=hf)$d΂Vv9Z$k-A 2MyK)ׅqQ7 ]> .AxOߓM].wMQ'a -kx VEt*k:g5sTDuD*>]Wdk4`[bPvMv/xԮS >RQ>36,G.A*ju/qv LNΠIeaqyӉIȂ5 _[;m%4{AUW5><8 }ޕDf0_$d5;Y;mU"if&bG6AxC[d8S?2z#.=8倘sB˩EjwH܊ds@})l>oOqlcbRca)7OD8'qey}сIl<"TJBfWGV=B| \kV<fwuH4܎#tU͹#BY I-$ Jzi=.sxYM2rP+-j64Q,'_i@t"5.U|riHzAeVJRԹXR&9  D c8zhVz2]hVГ "1ˣ~Pf]LaL0^0 $H6^Arb,"I`Oum/M2I5E٪'VUAkL+O}2#<3T*[!~7i_R"uqUpqaQ㵃?nڋ (I 8r<,f`-|$w緓wuN4U(0g)0w\YgIǗir Bgg0&4֛ĽX8uX~j=F;[.]%i ڎJr.:o=zN-hI6VD%1tbV|x%1cUDy3ݲb"ͥM*7ɥ\qҚi @|-E0 (X((D! Tԇgy?wwxYŮ W+/`Pg Gsr,U rͯ){>H md>qy2|ϸ_C\ nR 0ٔך똛d/tm*$ԛ>ӏm2v%R*cn! ќf8W|ҸPxT$c!MV Gh:1FM A2z^t؄ byt8Inq<%hX Ps#DRA8w"mۄn[t$D22(70P"z ·`PMuF˪sC5䎄̧IN_%>%^ubl|M 1gnϚ RH㤹- FBp~CpΫ[L EM.w6F u'{G TaJ_jECHR=Z<\S}&|HK]_SAF즬롆֛,eW\.Bn n YӉ(yu;D΄uàbU璭' ':fA9c &b<2㢝p$_;QuaM.;^Yuca=tz;>-g_"qPk#)Z<:HAdjIlbI0]wg'/}PTa^23 WӦoF6acgjXEI21F,Uܬ'b 90 n /O)I޻1;tE%Cxg.ӁBgD wX:S9)>d|*N={ NΎqzu;Bs TE>ln%Xr(xD4c`\%Ƶ%Nz<w*ZDGOJNLBSuC8hh, ~ "@wbF^jldGɬ֥E8v;SXHNITF!lc!6L%n#B"f>n#đѶ&BFd*7,bn"mWUi?$m1GؔS,vh{'gg ;;:ׯ8oR>2m5mƏ:?3J + `{e<)eNdtLj4}Cx ,e2*?ˡ\Z ԅSy4|)qfR2P"ӞKrM[ꋴOwJg! *CՒv*g>=ݜ\dCh1gkDk '$< :"KsR3=$٭tK*d\ugٚY(mⶠv<.!p< K0E:YA6췃L9ث;o O~nv1'ۘe(e6.rLY_k:P~p2/*<)N<3{NCUet:7NUKh kHMyU9U-(tP[}ڳOy4m"yW`t$Is~rt~֮1RB6l6ϨATLv[ &f`s9ɍ[en"s-{s%v8?r¾-8#bi/&ѻ;=Fߝҿv`Ws9(hĕHn7unj;ASc. _H隴\oZjXǖ+۲v6-pҊ;z(4KGDB7a/pڏYs\"KYY/o_5B6Yrs?AZa|.Ҧnadžz|:ZG TAlzu#Wt垏CyIwA kE_ XI|x[  Kn(Uvxg\oDQIE=' `TvƖ e!o6&|pYFu]Cx F{W]^̉J-$43,1]8՟[&F9\*ݺT!=ij,VjT^U+1bi~fME6d3psbfp:*e,4A E19(=W&;<~BUmlOęh C#:8u5TC Вsp I qdފO7;&=T]l B75v͐9U 0t3*mU| r9]}]¸FfCOc1lhk4)PNQbj[s>㖻T4GzFfr.?! ]XՖ}diӫ5Dm&l\YLe;gWyj]ƻ`}R.imLj`?Ȇ+ m@_oc<)չۿ_?Sti#67!t_ %%$^Q*m_V7tfnֶ>c~x jr#_e2eq̣*Q 'u*=ͳ z"eKv.wlF C5^w1ݕglCV y?iB??8f֮]ڝ>=9٥]lʽf$G[|g.=6k! #|8fS"ZM[+y-23 qu@(ZuLv'7 R4qʕEWРT0ruKQΡp8TYQ0+09 [ L-8vs4y?Hak(4<5s#ĠUϕ(lyoFܰSjnIgwlG>ḱ܁ÁJRg >r G0%=@9}{HS[Z30`!MP5Heb奀{Iɺ,ob3QKM^qtрY{zԩgOWfB--$OP˴Zo {jo`qh*:UBbJ\nP!FzvFw;#R*Cf%[Jd`% K;Z:u=5,Rj#CCFD;y 8qW.U~nR'-lS ްJzdsPWpr<@]_fXѩ(%lc@*ٺsG}o\̝'ə(Ebe!1A@oSGQ4_~D?oc"a!ap|܇0Jm> Vmd1=nQn؋oZ,w| "x{ h;`rJ+b= 'W 3ڪxEb,?s?0˰ .F5ʨ.mSkuy- 0uRe_w%)+q _+QkB@s#u 2aM}^@$+v/k+BBB,9C䥺Eqˉ̀1R0/V}e$)8KKTJAlBEMh_歼whsFzs\3V޳2}^WG,.F?6&e+~ow(< %UwVa5N4yGDONft!|֏~EC hfRkَY-.wnRK3:9lʼ9Y5C}džҲ%k~$X-\9\{ݮ E6`t4ߎ_ZgI;qwǤ|Ec ꮛz3S!I(p0 4რuںԈ4d$ c䬡#_G!j/j!]viW4=~+QWc<ȗ끄IN8I9V$r%ޜ!<!s FWTm= $ysa @#* $]_$R^lپOtnђ peSQ,;Y,# _߭ΨJ"J`#ݨ1zZ5=ը̦1z}DG5:-5ÏվFg/=76RD0ؕ$n8>d/L*"#/_*5R#&:ي$VR^Cb|uЮC*HEGY &XcVi?ĺ1Įѕ8jOLuTn'6_WZ=,ܣt]%v6꣉uc olMz KzXj+Wrgd5ek:nCJ*[&t} 0ye{ ]7Zoպ;PKA=3^E8]KVotBe_R:Ԉʼn5n;k,S>`ќCiwf1pqe#֑rABZf^hg*hMhzDOy|C[mQv HIK1]9J+l{u=Ķ6|ZEw*<4VPMo< H7a 鶶R~B6y [<{;E*qqp,_|sv{߂@/5$hMF8 ,uRyE8IBlb>P@c_`i7/ԑ;B"Y\$$ǵg $BFtD77۝߬xx +Ѝ^nrvWĢu_brڸم>eE{_*l)١hݥی #) '~Jeԭ'./^M~yʸ_tΰ=0C]['u` S+bCbP]*ʩ-}bO#J?k <[Q-K8FNM6;z"*8ߍ Eyv,󦤛`]_m/)7˧0ڛ1s (mTuu飸Q #FܥiuߞѬ f/6HՖg`Z< ȯ.'Ays%He˻c,iO͊9 _oB[E:Ea+Kd ;bpۖdxi^g/ pSr )95ѕ}ho.O:aн˜p4>?~P85{#/΋|E}$Nc x^3l+f# x\/+غ%$1Ps?ݗ3Wʱo<70pV$)fY_@ ,>_:M@=-.?{_ZWEWU ey;-fe_%(3c_7n6䣑z_Y2p^=qCAX/ ê}l% {n1)%we:^lv,i]e%2Y{ϓÂ+uԉ6v 8>3>8F&N <:WCT }LuS?^ `Zg!Q7T}RWXMiߕ9K?˂|{H..~;%%CDH2`b".!}*<0) 0YD./iF4Cn 򝛢Pz ir4n+Ӻ"нIy+vt.i΂rr[dީuSIK4m~?ԣOo.?._,ZآlŤ RjљTTHXVF;R y[lqn{"\!?zv5Hb`:aң⾔ls# ]X&,%3NG$( Ji?K;O ,W}^-K+A:d :Mrya5F$2*c,;D;uӿup^`=FgmS$~O@_StHչxN|r](OГ݆{|*N#i([#j9^`:\C=&oW̾TSciLJAٸo9J9:Kfk+;A0?5O6_R oE3nܟ=ů5X)΂9~9 +[r7G5_9Y+T5|1{ TpQfV݌XsƱ^٨ ;q*Ϧ0;l~7ڭjt]UAM7CC*׎VqSm^6;(YԻ2IjS[ǿIQ.6-wp`ԚokA;⚍_`Xyo@4dUJfjs?5O3gJTa\cbes?< Y 4Lnju8)+IV}^epʒXZ֫D@˾΀iR劓ȡ~'t-~wh5YWt rڧ+KV$ {_틟WB`r1b+.{lV6tsGbCL!j"."rux)mٲ#&3YǼ3c8鉦~;u㇚o KBӓ2=En}?o"/eBH"Y0fHBt: ܌#KHY,Kv(.JX8^86|x/P*~$XSxV\x)Q7h oAV{J`pD٧)6Y:;"FAy'4.DD;@cg5QLtm&0٭W0^.ή09Ž2S3 nwmV팓tc<1~g,s)U6pu~mm)}|Pj g]Q9"cAԍm@lV~ErDH*hFgnZ!J |CTif*5ͯp*7_A% ї1oDaJU6dǁJ8k$CX4ܒH##ɴ7^Y)]p!f-6\V= i.)hY6_!1F  2SF;^Eћ>.ˑ=hP˼FRbAgP8pKq\=~ԄW#@U1V nlp̩蔉v1)N3w #'b0cu8Y"f83(_ Vg Mt9 V2+z}Hwȓ]L51z/fW<Yr:iDki,e`kg8MU*K FnWs+EkIi3f=[d<ø\8m5S$$䂙Tw8dMS;q仼QȪ]aKa5" 1:"wws,6:/DcT- g #6p2;ǪƏcB Κu2|S oT~9@ 5I!N'JQSi ;l|S&*nuWuZ1H N^ $TT^Xk`s_me"!QL]rVxc*M&q goʔ)" j P1c|go;l3)%5tɅ2G ;3,1| pd,_R`WERVXQ&WA6@3O&1,ůk2ZύUy3:aҤs8P۱&?[^a|N͖wJ(jM|yᚆ;;@Bk zN1 3˞_h7xKDW&|V?V+X[lMa`LhXaj8vc.^Ϥ"1LKAN4vΡT}ё y=,[Fz?lUWrĻs.T/ZfGunD3-hC{p<7@LEǶ5'v@l?nPkS]A؛,V rj+O0J=yG55 ɐr<0o'u87n|R|㬆rkM-0t!~p;B7tCM?CZ4l_/s,aBreZRF1X|Nun U %Jd-~VrPI8Se$*ˆ:@) YɚGu!S>3VA]?rhSg\pmiQa]Ϣ~2^:tWO,F7wDlrP3~S2 ]Jہj$ 9o'qExEYMQaFL`"i.f{-,0()x$ouYpz?]H>3NDl9bfqs`[ ѝ\l>X掕^$xy זcô3B*n9Ǵ!חlQ~m%֠᪤݌4QݰH 5a2L8eC 9a~T+hGv"|8bưQ4͝۹ADrhH#?:sEwЫ)oJH%Q2(ðy(B+T|&OƸ[a%Z9 6 P_H|7;Zdݦ%P ”ewZWUW93oUQX3 :.y3:YmL\TKD7}"nG@Sbo`,Δ 3a/DŞ@ßv6m~:kR̠^IL;m$+"c"DzjVhy ObvykƹŒETL( @|],4y&4a簿zi=(Q/ޘ؅fMMFݖ0J]/cIѮp h'yseh'}`;pZ{ YbUN3ϫWEg#asTmLՄ~7! .Tx>\nn/Cv$&6 ŌS<@]x*c$=#;̉rYo." 0'|o`@j Yv\KWp 'Dq>0Î1"5ZNVk.L/ݙjy; bx8;dF`GezSH`b7gs\>7sL;i2.؅×{rG-X!}}9=wv7܀P5I߂i~؂VJ ӓr.2AI”QoL`NjQfYFn!O*t56瑛@G4zu%pH$l̓&XKD}=>ndo@_T8)޼޾eՑ:)A/uRgJ-Rah0@_bM89z݂HM=u%} l4odx3gmhzBAjG˔ +Y ?y+BjyLny|~<vA5A'iP~?ofb5w7cG L~* e/oA4B !1 1G̱jXDu:P~>m CpyZ"SaY>PQGv6oFYnq7שT}nkby~ukjD(9--a](9 5t}moj&F.BroGb5az#戝b+[Ad7EѓnK*Ps4RkmlƎhw^;n9\ ^G.exE0Y(2TQAFiRa4GJUňVi ]~&ёˡ3jr]3J&m@gVEYQ=wL;A']@V!]ֺ-ĿJQuI7[0v\{fe"65M}Rq/֢st^ETF6)V韪6zWz&%@k6iE 89d.]qf 2rRNbJ{bi0߫޷Ĵ|Nt&Z8ܬ܃e! x hP,!u0m(6=w H ~:s!b@jvӽ[I|7TiFr[`ic%;`5Y:m4~خZFwn<8 53|*ޠː؁ۖᰭLA=N_ґ^ܿɳ?דsۻ!ǀҝޠې*w.j;zh.l4.6$Rǣ'N--8S;o8"%u.R}֥vНz^bG}u"F ;v./sMc͇y g`:H6: n$ #?d/">z+o-_PZ]-! ~iu˿.xUzs7xswɛU{΂1/yh5ŬXԇ .?_ ܭ.Q*5LՈ֍T z{}ە{TvP6(dnEݽ&8Xq@Ƶ!w7+tۥNT aN0­pT׊ -5SmKhouF_l5Z^o)M}il]\Dcs)߼i7=WS-ےi?9̍^g[4Zf~jٖ߻NӔ{&}4j7֦fّ߷V~~޶oy#o7Z[-۱Ԅnlmv͛n{u5Q;-_Z[Nzquڭ`+it67[6\z+no_/;qf/0p8h8i[:^Mn0W̭ʹ{z6aed{D)7$.m3D2% pXQ[퉻;b^D$RvlY3>Qܚt:^+}]DI+͹:@Zy9QM>AZ,eKs#Z`]piIf-= J01 >ëx(2D[$ؽ"QFeZG"tG>6#0tfF5x83/52w7t~_ߏ[ju#/lc8lV]U 4,>cqjpHV h`U`Q@%kS ̒ % j)!;*oQDVG0*ҳ+X&%@ \~zCuNl6`;:Z ʼСnhlyv&] J@MԊĮ;֐@=RƂY^<՗Ko"GKg6 _)`)WS*gW]Bۜ;X*f7/e@fxGJn0òygwg$ %>b3$R'=QϲC~N&F_׬ȾLűZJ{c1253[` L*9ٞJ,lPcɡ@Zt.QBMgB6=-!GCX|/1%HG,͏ ֏GM@B>漄gB$.OrYE2[*<5oJ%g7'S:]-S~"wXr{# ">o-Y練[et3eF|$LVPԥm̦:S y1źzt]+Yw~z#2(:ˆ&q@[a[+{%ҮKgHa\OUlB;'}waRgC6tw֢SiiAGb;r=yi:6+ٛL॰ i61K)M`l٢~6JDt+ (F|dw~ $X{)1G*@"6&殗 9:Vġ-(SRA]Q4|yr(J1dor๠cn!R ;?EX(G^I^Y?σNQ |&:a@q4,Q ,8gvqJUK *S ?*BD@XYv' ڒŅ&6El ^Dkd lgA4 I0d(Y{q7e]̏H???)Tt.'Yz?bPТQsH+ۓm[fCj>yx,WݑzA]Iw?rNW<B'=Kt`餺g$:x6Ybpwsl齵gO/[#C]+҃h3 c1oՈPpgEaHߏek'Q7$vkZ/pG OuBX  ̜P0"t$R^̤Q1Du%a^aEj-Bub̭ ӿL5MˬN~z80m|,؄N[yB4DWr {cK3[`sߏq>ph KzoF} #/&7+O%b~ S$]6^pZ' n%H|pvZYI}= ;(KVĎidgzS; ,Z vHt>4ཋSa!xWC툆dp< 'Z+x1ŠEZٺ5T$._QoIC%DDcdR3gGOTc2tV.Oƈ:)l!P|^ql)sLHhbRIF&a8pTyhc6JY$2ԋQ.:"q k0DtMqV-5/s$` J#~4j``2--aOW3(+&6#Z}KkT ̅7h8_%H@30#J }ʾp=]KYtmb_Ϭ642^O7]6.u*] L^Fܳ/Ͳ2tS7cW]ܹ,"Q1DMdww!8W^=-ePA1mvypv Y$j5}| 8'2P+h\ Q:Hs}]o52k^B$bB";l$Fo"!cܠY]Ac.l / FCXՆaK4vY o)X3wo mI^| [Hi*4>/?d݄Bkh9 cU?N)=8_ɶ#$bŘ1ͥP,M}p""c~H.UE+>v\E?j̏<<#uQPGlrH +Ⱦ.T'*MFq/O8}L ?_ =p cn K顋gSĆEQ?JlSP>ccT*ǎe]ǔ^#]sv|>Q\Z7 N,K*1c'Pߪ`K!; Z5vq]B{Ծ.j>vF&BEQx:w&YC@ 9',`9]QqS:>xn8<;Mn@% kc6? 0 NԨUoC-LD4(2ځώ-qBek%vZA;-%yyNTmȴO])g.Q5qlWlgbX4ekŒm D08gIZZ Kc#YلW"w REv dCG! ?iq!]<й~76<uo_ b`4r;)  =Kڳm YI~{`l::}' JWio8IZMpū9[z^Z"M,=D~JwbrY\""?9s+GtC$ϑ=MPMÛ$g#q;;6 fqN挪ҙ2o J nq#bi*A#rpQquCKHy_}$|PI*p-˺JOQykKNQZE*]Bn$zDX a"dVMV=S6;*(xF6mF8pqо:-tZzz*͠.kp_RUndD>`2ZIi`8uFy`'xO3>=~X)+t|6or. b:JK.!#}q٢}ݎ5vs&)MQջUq)M ]ۨ NZיJ+jX#œ+!>(g) T_(+x>adk/ bd&+&$t{M-NIy`MT Va`]v@oHL3WBH//F"IiFUPݘiQ1‚1fXYgj\YS¦'Hv,[U/_$VڴpOUkw2+tqԗ,͕kL'#k?Oιz%g1^dt\fSDyq1΂0\J[cVȔ爎mug%ۜFWI ݭP!a 2V܌nm$ 8|d x/bIdtʭ|.r[T2se*hgb6 ɛ0ɰso$ !|W)v ms87^Asg>fuL I{z-D<|>FoϠk:\V7ˉ=8j<֣fƅ~hd(?!U#|ٞ{J9N,CΣP~S+U0߯|v[&/쭧ebIcƇ9Pq֮t Ɣ0.9,`ju1Lh԰d5**v}w_TwEbp`Zጒdry[_d! ܌?Z7&П~ի_ӄ/<4ܬזٱ8J.uxC aIٹZo*KN== <F eYyYu,OYS͑pB`Nu@>-y(h54ZNfDd1cE_hZ8ו.z"kg.w''iO]tF* 忡1(eŨfZ + #"ȶC}%Vq"v'ɍ&Ibn+5l.Xl츥 }|b8a:cVWd?fpUW+9G-U-2e)1HuNȁ鱾ܥ+zǻ!̔|er W6nf2R̋psɑ0SԫyXzJI{qa ō$>y#0J[pPyP3c%LYq]`ox *μCߍY{R P՚1vTa72B?aOdL1C[Zy˺s FbE\MQھUOxpuc:AvZ#ҩGD9sEYrF5/ABzP "+"091FQ,SvR!C4"TM9* Ɍw]F.pF ݌}_6%H ac.GBƨ[t)Aeg*0-f1_3CUq˶{Q P+sc\2Aq [*ˇ ONX7 q!B4]_e k0%**6a^miB3s%h4qW E-}טZ*j|gI0YLuN@u3_|0AïH@4hL*FPZKϏhvu8_({( p(]st=}knHf+wEA cف.V'O>[Z%i7OYFݠ~Msr?{9DLcc9MrT V} pͬ}(:7HX0'b0ՉJ?!2C1Si[x2"+>.`$k @G+w~{r\;;#N9cL n\١glJdzfԬAIdh0(b{vSR-f1k> I-DIZ6 @S9A2ZEGI 3k9϶>QnjպȘHt$s]Mzr|; E>=1 tL!. q )tg^}ݝ%ي %$xyy*xw$_sL}"6leq)!PÿD>IM ?TR8#cj:*޺kb&u2(E#]x<:WP nXy'#1n*NEr8!*.ù(M( LF4^K (Yur蜹fܓ U@6Qԙ$tԇH\',dOurA>,|Is-y[Gٱ""=XUCɫ[L-tEH.wr6 c&zG+Ta{Ji8An>aĒJ"T)ak\Ȃ5Vkחw$oPf)kz&K$`%\⣂Y0м]ȺqP1j\V*_|k0Q|eh(93Ip$ Ab<7R aM.'o=f psTJ,Js-u2Xi[hҶfʹ3.qycЪ!(2CEwFm,N΃S(R-2\e½HԖMV'D](&Vlp75w.JSɎ|[4NG >gt񆱫d Ke+ '1ۼ3i!  aS/Rαq0&n9@M=uo;s࿠usN}JY6I\BbjOlthB|v*ω K]kgQ9BhcUSVֳOc'WA/@FcFssPC]^=L䘸ƿXqL䠗h2h%3n~怯L9NckOQCK,5ܯ'3bp-UPT 'wRl|m̮l:AӡwS'G.ȴѥ)5'IZ!;h?;=Oѹ~E1=p|6}κΖio3~qxYמWjh_I</8NAJz" CdzP{=o+m@gnWh^ZL).*kWu%kyX5=T$:+U_ݚP_}U<.ygPިS;,Y"{DA=[#r~_3>!ird#dv5*ЃOhEC=ar_wT!K,dFZ-(FvAĘ\Ihgy9R88`"e336{u_C8>_ G,Nnu86T)#ӏkGlcV[~|Iǫݵ?/N.\xolhq?/N3ˎ _<  D) tO!_+QD7f@.R3e"A\-zxgR'|YF׏VtWKC$Mi3ro;hWAb:Ī'.\Gl?˴^buC;j3Qܵiv.#8Nt11Z=3yUtpbd *6-{%*467H 6=p2 'n-٥sz 7{4LtDwg~=5 8ڃ&Te^ꕜ?োH]£˪Ņ(/:Y4^k eo4QUjݴ4y[?@W )({ɺѷ9L<@М؎ιivh}P olI`7I#› 2Geiiaj~$LOw! G6w"n c5SҲH'ٮ;Q"aZޅIJf/~=twřh׹:/σ< ?/qlҖSrI;eBvHg~y}+N&'+9uU}"(&ٹ'COR7}Oi_Qy69ғAoK 5-'Ilyqy6. ipKqxkwtgsz7V]v~sOX&2yX~'pgǧcΑC"?p!-i';>\+no`-=Vܔ}R$$Y^SKh掚2P[g<ҘliRg?n]Гg'{*1 \?~ P'WOR]b@k>fb@ ɽr ў&# S?p㘁ZϏNwis%wwvviA6r13q6}2m2/o%ڸkYFYW.2145q)VSfv QWezN;Y_YNPUTG.D2)8z3¤dAcgDF.IT>mkwOCT%etI94\W59 1L8vs4y?Hak(4<5s#ĠUϕ(lyoFܰSjnIglG>#.@B8aag&ڳetoQN;~|dd ɼp5אpFtI/l~g)9[\z/x-bʹٿdzG xg5#D<@_T`6仴Wgʢ N+):=$Xd˥N7"}5yQwtuD3T-"{_Nk |麟7UMo͉O#&ALqX NW~ujoB +X,Jq I1_c+Mkghs#Q\&8viK'CUWOV6|-rKq;:IB101R0fp^4-X.Th 6Ǽ^I~ 1߫aPQKRH]Zr8!Mv'D{rdn%z F +EB/ɅX7g{uK$܇`yMz[uEo^/X%h#|os@fNKrD 2U-%5۷`i.!J Hݬ3sz dR{w]ÁJMM]I,*juX"űKoE=OMNᐩ i ݀kbcL^* @iB DJ.R%:(ңiJ\*zDw.:F|.N<&qX0-( P _Co4[;{Ir+U 2JF;k-P*o2;K_ï%/jdTBJN;YeIZV*l^a}wq$~R+sHWᡱ b;lEcZ8v(`1p+"X$߽QMF8Tnnáx0 CIm/5$qMF8 ,rRyE81Bzlb>ϰ@Ӑc?vi6/?;BX\#ǵgH $BFtD77۝,pV@C7z=櫺 Ov]9}i#fi{_jk)١hݥی #) '~Jeԭ'&^G~yʸ_tqps>CE['u ӂ+COd!g%ĥ`JN ?Nؐkl P;SG-7KF@N;Y"*oxߍ8NEy6 Enub{ެf/{hoR;LSUZ÷HSa9BV?ډEEQS7JĤ.T9Ru3V3P.~|_T}FoʴohV~o1phCj30 f?E_WRDA;8pkTblRҁ+e[${b_0J9K}6NGey6{@"1kz,tzYz] P19vv8[F:Jg9n廿"{Ȍ _Y:'E3:(%k:TːE2X*д,R_rSv s+Y͖aKvz^ub[팕w,Lw>طR5AojJ?~0Dmq@V9CbdZby16H`ާT7uA!@uZu"TVySwEeϢ`(-_^2W+ЋoWi/`[hD% (=P@d2"}Y)4\p#/`#ɴWO|;,.oײ K8T#Bir>4j>C4Yav V/_#!pU0t=&#p3!1?X!J3sCQ+O7b9-"grt}/N]W-m;f^ "+R'I l%uOmEFԵʔy72WP zQwQ/Q*oQ({wSx(\;W-:"գ򪀅^[0dVb%/0F F@9v_ƧXA$9>0|R/n*WM,_ञzE *rBn[L#zwwtyq"V_5/eYm5٫}-nE?,C \48v\`sQVV%E|gQ^~c&se؃.dې(+EDZf$OhpK8U"X33K=gO?58rQZYsoW#IKOg; s V)SXEz1:"/OflrTW%biȃJ +/5qn+ ]TDaUDF5l7Do*17{!=(N5TOa+B+s#/nƮ eZ;K&Y\{둷YWLߥE ~}jKvܵg'Ag`pf4?ۜ/$mʻEO?SPLw6.Nh1:~)9z ;dG*5"@{pA7U ?j$ޫ˟K:p[{}Ɯ$v^#0;luHȿzu8zgf|zww=G Z1?V5yڵÄD;8w]T߫$5q`io eAYĆt=ބ*>.ZskA<> lmC_ wܰ@, 6`AC(R9оI %M r90?άLD0M>\p>M F++QЀz]Dh6Dv;bb::IxOٌGclyu;k֭EЍ SY5-pz3Ȳ;߰[m~[/G` 3:}\H@7xD# SST8r~껔#fgC,APԋ3RqntEr g;e;~ n&08aG󅡊X`pxrzY~* B>φء-DGPL ):>ӻ f }Yy-O8?g%@;uծvMHRdɗiQl>/y07zTZAoP6K4r'@|ڼ%rrI7"Bpewn'G*zAY/d2d.M|fq4"jG=h 蟫+ah%<[g1`0oo)#IS ԶAA g90[||-\o{a8*2ˊPUiwҨrCB< 3!%lm9O"V 1lA@xʼo eK$fZwĥ0dAL:p[y&B٢|a yGڎ.6'tqny9|)VkH ^f;:o2~Jn`ǜuR 3g]NBEgqBDժu\mC}1-p|n%ۈj[kG<*L:x.&flYκ"t _ gSh^IZ P](Yd6}6A~}8}ĺp?g lɡgV<""iiimƞ q7Wtʘ1ρ?K φNxr>[ }ѝـ%QFK-S@BU3dY慣!tߠ>(ayۼ*T߁ob"-3-4[YLG #١tд EF͇N4;Sf%681塍EI kBTȯXlR#9y:T\Q@@0%-X6flϊ}\F]m/[ggfD^-tZ(3>އ5;8ҡ5#3/jq SR9mk=f1ǁ&0i3MϾ[w{Gv\%@U@G/#{ٜ@F.`) p愰V\pX5# c M>Ye ? p.]d`/Ep_A#B.9[ʘ{0'uo8RtY48+JtK%/2(xN(酮WaV~]'e_cܭ8̷aP23-Rt^a-2h'l>a$_tNES$v}\!};nH:Mȷ^:y(c暥ȧM[[ͧG$v<H993v;e@_ C==?Oʜt"._n۽__N5#~E\f\,ԨpzTfZ?"Q|[P]a5%:C)XDJ)Ksg^ˀu<B4TbVZ@aM\tI|xUoy|Ĭ7U, ҩǐ!)>sDCsQ*rCay8r017e:ӎDUf㉮dXYW72< B#-~{? b"mQޭoF\pgu\ [mHYC!/k=h#2S~?euZw\Y=TB+V^ReCL 7]Vp"={ZsxVAʚԜ*HRz^zRBzªٟc4ss)PtPrؔe x#a=A@bۙE(`}# J{D]Vѱ>;u"+ L2`kU|y*Q̻vq-`M%re$4(G@IOSP.I -P<l`i%T }nG$'tNheoGeW0:XLJY(]FDJ !,%^t(9xi6v7$Ÿ@KFkUԂIj.r#ItJTP2qȄ c}ntp3ds5z qr'UˈϑˇgHW!2gvӮQJԸxP̄0+go$sf rdz!;1']sUJlWSUUm{<&Ȅal|[dXt8Ė\3q ;>PI׳H H49uzSBn Ћ N$5 @zez̢7nN锚$1.FB'[ùO=ZDr5.Ͻy=_$"34! DS#XRT[ rFFrGmNKNyf7K"p:tФSa/[,8?gy#G#J&OfZ89kGYĆ'Y $l"|Q_xy+ 8c06BncFU(M կ5Ά|o4}1#FYsvZ >Ccѕ2:;C4BH 2qJ&b,mAT/+su|Q-,]&(熵L?譊Y~ vi ncWZ!Bvp%*Uػ4Pϰi0oJ-. ll^7`?MF-o䭲m/d^ Q]E]w';Wn wdJy {@wSR$>Ii6y#IPalRq(Fh6>9N=r,,0\Όhb/R <\UzJܦڔäR#S[jr2LKp ,XX.BL:=ਜ਼+wrGA'7`FעN.oYɎO\ҧp,[C^jL\^\'7ݨޅ&x+=PNsWŸ_䷠ۭ5Тjrn.ðXG]j8n0lhj9W46:h.3UG8TIqjvPT!h=IeEAfR6Z*kU7KNRi}*)@Y- :8(blIsu{{Rګ4dBTEUdYwy}qt[1~kVD,<1v[a8yqQmCD^otQ#?FA$l[ 4Z/;c܂/6p\ZT+fftPyhZ^Xja/{xO+ vk^sOZnɭt'}r&OF({`W}e:du^i[C|ߥ >hUfR#ޱc9wzNە~r}Ȓs}1%VloP'L$}|٤ZkT|q#G E7cЃA\u06AW3`KVN^\xxn.!3넔ݰt}K<% mo (w *S~ \VUՕrae׺0!_zR():I 8g%KqdW[zNn p? +y=Qq&LhP}w4vwηBCU'5㫺~A {M ˩^ژ>>{!pArjRf`)duk7j+msRv縳WqJb -z$lT  zT;kwjh#_0WzmJLHTUm[V[\vu~(E:D'szf{~oFyPk~NQ;{{͚|s@+]\Sѐi;J7V%4zf7ڇ;M^MkjWk[Z^߮m-_mmpg&/ijݴ[Z~k5VtP}vmtK7=k{uo=OaDN,o .Ep`Ԛt:^+ y'Wq8 bZy>UIAGF =U 'bIZ~x.@g'J0 =5 ,qf@i1 P8YVc b50|GYc#:=W@-9@Kwn>=vm45$sT.f 񍃉0`'4~U1-HJud9z؁tC#^u͒V1-.̧wVmdžR[=8aA juu=t{x6ש_(B@eeREyH=.T:5]IJP0G\b]CTE CMs\e?+-Gh؁ B-uJ=n|nZX udf8s^q;,qxbC.ۧ: }a\Fp`>ї=ͥGc3us +˘cټMū5P0ada'/(gş=z{Fjf3_Cv0òbpIwFiNݒQJεDKA 5a@pi2H/9/БzfŁ8,%*`bfPj_EV@#O{gg[ с\4>xϾv{RWl2LPGXrE|$P6֩w31L;tC| |VPgG4w;2| ɒ0 j ϝ#3:≫rtj=5}sМQ[5z':pa.{ͧ}!=nހӧLaՂkei%G4Ij.B3o+? LikXn{:FH{J ܁N'Em/ w'l?2<"(RňD/$Z>98(*m'JDL!& P̙ Sب[hҩDG8 (1*ԑA8W!E3Um4V*$ h(Y՘>Y&hFۙj6ۤ?4>}:)=wZ,t=Ё*ܧM@%"PgG%o'qyVz]/we,SS9W$X u/U3Uh.攅?!BX CIþyKT)RXoYg/¤i* оrؓE0 ᥬҠVψ/K*(*ԁ,e|45-㨠\4cs~Zȝ_Nnи#3&!hNLg㠺©K1Rח)b.I,\Q6PՁ4LSÓ+bCtC`!P6C'M9<K(Йn80tPf0p@^y\s}Kp`TQaW2؟T%Ef_m:p4ƋaNl9 -gpDbל<s!)wkV"Hq*61^ F/r8ۦ!FҏFԆvSIru74"4>%oAV1$ۙ%}Sq5C(!s#7H+iFcR`n=Kg9h^``E8 2XQssL> W}fl"~LdmcJWor]+n(k#W"XʕMQ#&]2O@0D,JDB/]LB{(Wt4ZgXppS4,(N# O|Y yɊخR]qGQ@Q =BC!uOS<zpQOi_.L )T_喝NFPFݭ'wJG1C5l Ǡ?GKIğ&@iqHf y31Vj'aa\ېAQmܸl@ u:E8~ke"3`p5p% U@*ıԷ C,Ǽأ'T?qϢ NVb6D>W>ư.~,%tizŶQFmMLh"%i!Ij&^hsBpzcVs$DxHr80m1vbH5XC͚-J#Ep vbI%:U.frsmW,c5Hɻ+t\."3pOA/YD̢(z\Sӑ1!m(MOTWXM#Z^}pfKɅTbQQß%H٥3/gPvB4( kTevrJ\Xw!0w\$;.&=1wb4W;Y~QO: M,[4P8)a]kOXvę͋u?8؆uB 5,@ GC炎z H Fu;Pݗu-BQ:3Hx;0Tުf.-mE6VZ_)_H9o'1B~yqآ 6&rv'tC;!=O\Ϣnd}dVwd6 l[߆n.E-$Kji7!CZ$n5gǠrlUKODS CW GNSㄞM~?!BMbFO|ZhcIvo 7[cbxgϧ݀wKSCB@\ yC[b:~zTrW{3L *)pphϱ _yn+{s2Wg`~lcljV_J7]~ RȉV8N-4Rہ@2WA\_5B)C㻊`l %r]oE׹!X%vgkG!Ɯ֘ +Soy}[-ohwl3N`$I \hÙ͚.'3v98Ɯ7#]颵c9 %!G}Xpw$=RV}6dDw2,_#)_ i)+(D3-t :Z?Qw%'#1^Kw;;:,N'dÿU-x> K]27 D HX/#B[qULOtԙ>˘2N71&Z fjhL ,[ &25AަZr\G?̤ҤN9/Z:f%^)' =QC}]O)< 3 hjy@ӡwd&Sb8D$X5;:=cXϞ^WE_>k/1H%Աb8)^&1Q"FCG1!,,=ֳ!Nj5 0wE6$p#GCh u'z\$`72D2dך|>||2K`+W.o-)aRq?bj Gw.=J+g|#(KM0/0DS--}N<r,kjo %TQ&Gl{tUʪ~W%!j93Ytw"`8u}rϫ%-a &,&L"jy|~8Y9AD BKnBKkS!%䕣 &J d]*P}Cs2uͻV1 9/,EҹϲM6N2. Ǎ7+B5I zUww*m0!_`}®;v@^3?zȻ{~p>{q'.QAqIYo!*.a-z]V*nܖc,O EyXŽ좴@n^FyqQxګ&+L)lL;I,>gdfD a0*<(p_h]:i)N [n=flXN$,wrB1Ϥ&ԯQi4L;RHY:sヨY1ܚY xzeϗ;X|zKΡ97HnyyOx i*3"|Z}*y&W} oG۪$maat̢'|:6%X$a@htO3$Xvq[%M7ŀ;K$jd.Z~iB誕+泎h4Q27~lIܫ*oxfz#{ U҈us`S@.rH{x}2m|"pFmH,DhxM_6yjt] ra6(}}:g8\S"+$AJXQ4H o2sU٩g@Y@zY 0V'F KH.w`u(NS ¯ uSN[Kt1N}|H*z8b+D!@bšTτ}d7+R9ГYM+4um|0ckQԃjLv9!7Eٚ-!`Vv1H3>n.>H?|L{N??^5vϧ,.QFhߦg'~Q•5gikdnHP潡+џo9/&@b J:xc2ҍ`?ZBӌS&?$B7ХSgj+" ֚>d"QA&2KSƪ B€,<9 X4xxQړ7_}/jKpGS4F%kVm찰E-ZO1 T5Ҹuo3/A^cXFT`t%iiէ #9צy74OcM+P? `sʹ7y.hY46m+vz =sxKFv0esjVxdH<4J:_ ]7Eş# tSr%=+l"D8hX7AZZ{f5=i'k_qjV|,E C8vyG}Ƕ}n8ɹN;+).ȩ!gXIIGpj":]sQ`TZq)vB fV' F: :rPwOASyN*VpR`AA$B%hoM"{][)F%E,c,A{;UQsF扤s@FB0SE4BT($Yg%cAE9uA߯pu2`xKTTy7v0B7؝fGVoX.wE,^z[ki܍~}MA}ω Hhl%>tخ7ʂ}x y?%" @LUFJ4'C:orǙ~DZ) ™$(L[RKA[GMϤ@مn4ώǙK;zҠ}K# oMkft2"jEV,JN8v/,r+Ub7 {Q.p1T,jt m#ś# rĵNq6;ႸvŒ̄D@S} xoxE'9n$F=FA(K$LƞC10lE,gTPo <c[CdYqHԀ mf hkϏwPnݸw_Y q2&5ð.rGt c'!=<;#jZF)HT^`w{﯂hxZ(deR4j;@$TƼ^ϩ*^ qehu<OegAWXCmzu w&8*vV36,JhLngP2*_VrDqAQ3U#kMtA6^\Qغj 0YPV̥}=uϭ}U7k.=Yt?7:{rD$;3@>A^%>HdwHdK^ψ hϑVv95VӁ#U!f8m e9;%Bx A>瘟[b̷ҁ%*T+!dH2*`Yv9xgwQ%-J,Xœ>0q/8OyxB wrU/f9U%SQJ3 #nb[eRe%P2@q tzٔf0 )}d[QzE+hK5iԽ$ap9f`_ %,{1kk m1˘֩?r>*F A~#R_4$̒;-VҫJmPc͜S= k0ek8 ;&8 k؎qZ/)p4W͊i.}䫜hwO,HtTmn,yݽ#f9S#0L_vBȒ$bV:avĴ*yRIȜ%8gVS65Sy+:}:-fGiqUvzfA.7B>u>prM? oZg<z38!qD(qx7ɖbffƺQ xZf}wjOkL;R Vb$ٰbkd15?H'"Kk=O1t@XDrT%sW"QF A)?$8u=Y[^Ꮨc6sYUEc^|L: <'K~$'1/|.إv?Z0lexI8'ʜt.߱V;q:%k/[EEFqv\^CST"\_ +n.zJԮ#Khgp3x _;DEDO[çrk7ǓG'/_9YYNbQ?Q&UmpH$SҚ.4E`':_wM0yet/x.QgEcTa/UpN|y5n&dQ$[(u_ab͎mihTǟ$[P\^YbMyHSv`c㘥1,A,RH졃 6Dw{T+ DKB3&`"€;+ $`p/1735sR >514JVE#"T=Fd9]7pD7\Hzeq:$T+AJvJ1C \ d+r0ޣ4'9FoEt~IcUPwFO!3u>KkZ?3{0.Opx33z>O9uMn5/*XG^Ζ8cRnĕla1@| Bi.&2*Ɍ]sRC8yǍgwN] %{]d.HB_c$:&ͥ A՛7t~-;wuHѶMYr27v;'mc16f C(-tbVT3in.}p73߆_(zA!Qq_իT#$7Hu$ )O|я 6{M]RGcKjŒGq,y.Y@TYF5^ 6,;܏gZI[mըѽVdђj"]D$wsGU"A<9DFyc\I*8agdhˣeE1m!X! 25u ;R!4y%T$:?;]TtŽܤ #)l47h?0l1\; +EdB0ggj|\.E_N\.b-#6Bw rꬱ$]wC>o=aB9gXJpc=`sZ&g{;T}]nn8(tR2$P@j;% %cgXMKD<#uS"Huh(۹S=ށ1KP1<pe{0~"z'.d}ɭ> 춊7MK#ԥұ4I" |BK EEi8w(.-l™6Gijw,N< k/=hb`jH9ӔfjnxEXoh1a= EmumsȦԌp/?v~]]t7^v}nˋ zvzҥ_bQ=yg-{ʣG2*ytXrCdV Z(w\ X>&=˩Hq b|sYAaWZ ߛ)8&K,rf2ܙbN%jք"ӁQdݹ 1Q);:{w{l8cbv#뾎ȟӼE1A>J$^qyXC(O<5 $=$tP- YFc%k4ܻpSvƆCHc&-bj b $e⑋lJ#aFXİ&qϯOloo_!{s{yX'\\cz(ۓ|ѬYvi@̲Ӧ35J&vrCυ$XHtA^"J˿HbqtĝyZUCfbAe#*s$?^U*92y$7y3]?8;_=4 +qe{t|v~-.+θ,Nr' Ep/wեsq^%U)Op[\Dxr' iMߴsM zxxGd,ӱϒK%Yԧ8U.M̒\$.j*bbq\,__~ZxD>E2-awhSv'ٳC̙/>8sn*O ݵ_zqf $4$(!np31V쁻 kr!"#Ffz\9:9 p&u} |0Z Wj:V8?F6) X1&L;vF %ȝ oq|#TɾR;6jW!2{ۣۙxJ:QUW~\?o8 ''@?.5|1'M.9n~; 惖潇{p aʍQZKu4yWU8z.p}rRL4: hs3v}?ʏO5{zb! ׄf`\_,h; *58 >fftKO>weӿ\~4uiF.+j/~@CON7=8S1J~;yKMǚ{q1FY_vtOszt}ԡͷW#{Yb+m ! ʐ[KV"PW*w6wJp/y86>oaZu|ZHH7[u)B†5(zk|TQ1 l|'蝶N Acͦ퉂Dډ.j^{O*{WFK$0.s΢uJ̹fX7-]ϔ2SL.&crN~~CK?{7^HoƑHy;>=V^/Wvky^}Mǰ=y#cیqܐ`8 Yd%HH:, O2"؎jM +>H + ].ktV2R'"SQ0\L_kjՕ6^u8';Sx?`U O }˳Tax=$_8iL_w4rG/s8> `z6)"*>0Y؄y%J9gq{[* ]/T$dNWoyxO%*۫R<\ ʴ}FQK'K}^ ,WYU4 + {Q:-d To5{O$8Tl0g.$ABq:+D\0gA-ͲY"DłBje8_a&$E, `bҬpf N<1=N-)#@&/޽~jԔ¨5D2TZ +WbJ%/ϓ K sUJ}}-`輶-E7`~dʡv7JXZ?By ,5 ;ȪGc+'4&b޴dsÒ\F\rg󒭕%1Lc̄EIL'M(CR5[5Z$W[1#b,VeDsmtZc=r]&KDlqH% T uSXg-2nݞ^S K!ߥhbX=)KhXN_i%]'[:wXjƋz#)h{9r}9}vmLO oޣ 'EU,p{> O#}z==3J 3nEQ5Z0zh{]o')uyxATyf ;0r$_/G'W-p%꣹9eٕ} OPخ;de!gI1>1\l,pv_B{m_&qVcؤ]0cIA=\4^ݴ;9".L!s7CO;r$̣e;`M{!?j]<)&΀Ʀ`xk7a_ .#NehTPwc.EEêSѼ"ajQL1(ϳ5*swI~Qp cM8TᱣoVgIL^'\42X.HuV-Qn ֶ{qp{Z9Ve76=p=>.KovF;h ouKm"# vQxBtT0@7Y/] >V:)?wN7xDŽz[߸^v[J;Φ#Xݻ3}gEz E gNpU7b@6kF^^'=YWdc_9FKlz|SGVp[-sZH套J}#&^*jbhWe´IlǶ"_)~K[udG ~Vf>3 v@+/]Ey7I;6x,tV_$]{B?q!~w#Ja@NՇBAg fF/OU)Hpʼndإϱ#Ȫ#A&RXz6"m/mUUnj7N>0,Q l9%꘩Rtҧ`XHN-_dCWh@%{j5ĉEJQ]oOOnf oI1/4#YDޠ!cc'\'/^ z6t9eN˰ď F0wZ6. BϑT-9Sa/0Lѩx&%4 onƗTbpۦ@HH#RR2H2l:4eyf- |*}PO%x/pgG)wēSlg,,r̈́a>O-!8OEV,mɻg+َ%!aBr&lO4Ox֖n#x)g{[F@7s#WNuS*q(DX5 CA>8I`wvwز>D ?4'v#u/ ';MF%C 7EMF-y Fv)o$W[`E׭W$}Svw7^W^9ot&BK'J9sgjěᣂ$ŠŊזd Uӵu:<-L[h}mF)^.<\C^SA2opf+ཅnQw'_vhٷw_ud85EF&5jGƛ94K I4,:4SͤrSOkYe>LQ YӰ{a^״ʴA$pO$ !BVlY7zGuX!F 3a[3(>i": nG)i oyлY)N4p2~vvx/pbXFd8l]v+AFȨ yEUcnO0, Ֆr88>O6 Jk8bZz]`P #̎DJSÐlfcop6> Α^pc^}$t ]*`@J6nL^=^m~Ȫ@Vօޙ `H|67Gݳ/%9$ jwcwù}9wZݝ"Hn)8HQ!-3Mƶ䓎,_Kߙ~/n"?b{* kH$vuק5.xuuCwN6sjSצ/7,ۙ\q@s!w+w$v<B G4>KBgPe%l>yB5?lmZC,z"vNF l7piXΆKq)Dɵю[ TK/擋^j~aBEChApk@ǽ<]bzfG"!# G{f7aY[s5|aZMbmݑcZ19 ~@33suvqkTK|DN^2 D EZk)qp$9'r+[;KOMXUEaBd w%Q[<P f̓&ׇ>8z5}dW'E:Q%7+ I(9ns5h I1rg~Ù\8p9+ ېA_U&n%: vX(8{?;kA I+^{?xm# "+Lߒ MCD_"zH6{='[h5, 夺%1$qIm@5,6!9@H1VhOʌ$g.`#4k0 n?- aGULy=,d_ n[R%~dhGR2{Z9,ܷQEYQ0Zys&pڗ|KTA"x=Q5MPClKl'3P]P*Xh%~iM܆G&?8!q0ؗG&@<庙-LV-}*Rv؍dZN鳪[X&20._vsTS:viS&QpSXR eMdv#,H4 z0EGe~a kM(/xг%~2r>^y+r{{Q[3soЅ-"?ȝlLɧ(:i}Rnc5)K]]xI+%O}%@ٔmy?<䇽?}?6ڿ{ot l9A^K䘵II[r\Y adDQ;0S7;So{6M6ՖYD"!"eV.l +%Ta_]"Rigݕ~8t Gn| _Gp\f'Y5C0\DhMhǼD-Yƀn:G/0"ߡujD}7|/)H4`ۜ)N5C!\Bzy=ohr7_NmͣԑTU^ؼN2P%>=7 fnq;ķb> ☳Ȇs9k3xoZ/1_<5{~9%V zĈg[[V\p6$&ٔ} o)дyI.Ԛ!+J(βtjr,bF?=k3ܘHXX_K lj䢉+gkUr/+ 8a&ј# [!kПRUjEeXo u L{Mj ̹FH4P]=/0.f-๿Yކae v1_6}6p]u,Fch(ȷ}.ݦ- DX[r 4φNa띳Sl|RoWx/l%D{~[/ݲm |#7GF %}Y{4\#/`=%ɴWO|;,ZpaU +h ؋+2ǔ.3.1ZFʀf7Vs2]äQeH+1$=j^4,y#m _f楪U3Lw9f[v7A P&kMIZGPLֽaؽ:(I6jmu{ B'ۻ`%K\sH!=Y!wywꪰWe{fg^WإOvIo.K-Tuw(Ull,3)ld鯯rFXfXJ>Ʌ,neJkj?Ou 46]\uW^x^Tj/9??Cg/?\:j欀ХXqf:=[fY3tO0 \ӾU>z\̽YʻN+|͸ʿ'4P2M 7;[+E Wج8$qhhDה L[vc}$;bUHckkp)H deSolve/inst/doc/source/vodecomments.txt.gz0000754000175100001440000003716312352122173020610 0ustar hornikusersKvodecomments.txt[[wH~_Q_$pbi&Σ{W醝ɬVj׾j>_<|Zg3չ,RK/-5_>Zjw>i0U{͟ qanD镥n4`8]`1v[5k9[Oo oO ;!B}v g ibv5?7PglQ:˞EWVy{:@19 (o˛_z?˕ZL|(UO1 Udض* z$nuĹzH7a'unAG? ?Y /aW[EM;UQp;g k6I1 a&4zrP!#G-N砶IH*cwv@xJ]z.fFhkszjɭSWY k,gILZ fGؕ,l8]qmxvU'}u_]V~l@O7{21`qz*2ynuF`n,!C !@fL][ Edmuoi[[])&@Mmuea9iԯĔUR WuUOD~UOhu?*ܶWh79!0S(K#no1Isjqۛ SɘDu@}G$E!98)E.F*~ӫ;L}K&OEhyyNo2"= #ZXp:(*&'k:K}SeM kt}d4\!Iǐ, f/:i[D?~iST"eXKM@ouZ-ɠ$0'Y,؜i9:"_X@|r `ҵU|g>0Xv(J^ 'qnaQ=%3s?7õĒk/KQԷ Mյʀ=Yߞ'5COVQg80u[juRQ")5C)6 lr0,x]dM%/ #/[2W1vd.ҌlmNjMA&1LN* Gq`'dVBC_l`/d×Ô5Q )g"͡c>Cq 鞚o۴4 8dCHx_vyIE`BtHP$DZj ?%_DS-C1@< V:hYF柩`;E` 0% ) *Yr]kpA(3CD qH "P3=bAxpxW^0g߹.]!)sR\dV/% ,5_d^ѶG^ &Sw?_&pA9:YZEyofu8!~3ߑ\)RlC9i-a(>Ye\b.VD!fbB"NI,ad?ujk]x*`e^~dfl1mtb\ES֛s\#{!eApiBU#hp3_?>ǣZxfʙ,`%)҈f:T8ǩ7#k4B߳ j!J)m#W1Ŕ&7EcȄnU +@߬53Bv‹ cpq&̣\ y49HF_#3שQ:҈SD" aDby(A4UGvScʨYݖt@Q7HjyJCPs+bEvYgLV9v.Q~᯲U3f,utj:)Qn#^:o9 f-{<8u@t,5"+fе J+ @MjI cT4#o^s[tJΒ56A<"7nUYQ`"fM1(sV zUCi%$= _a=zDEÉӹw&iikƱMY;} :ӍȺAjc~;j񷧓M3oopk ZY b0h"śۇ?+P#7겑t 2 \9N@~^evju@Rvdʣ/CRڢ|Y$r` j~|qU H2xS Nՙng=W>MKG%@Ѧ7.$RTj2(U5J,^,hȸ@58|n*.BD<?bAԅqmOܶADKgYFdH9QQi0 x] jQSR)]Z D rҰFHA2kH2lA;aԠKJS>z3g`*ѬotwxP՘7DL\5*,|Q&^U비_q? fڊm23XHmO?jR-h8ytI?{'L??T)m|k)S}uz##ގ'H'5N{CDEB4kkv]:48ej C5P4_~= }^.fחk5;3{s-?-τ-&4/^6;cH ?^*ezU?6rP վqk߸ɕ=“#F [mqz8dt-Y>e鯒,v)+tV)͒H/6gx#.P=:~x9|]؃ع'o~?áqmwz2 _Rbri;ñ 㱇O#98c5 2as 9N}23@{칠@M%}rFox8m.r(@&;- Ê7iG@&A!d2[@F(fX]]"`@&7x e; tPޔθāvMP{ GLjf%\z ^+ a2 +] 2 w*ìN) !yxɘᜯx=bt߬}5DRgV7~StQl1nd1Fw\oR5y\MOZ̍LJY*ilo~A[ʳfT ZNGdp뎧ʟn@"ȫcujȺ PnZˡg*Bip>-Qu1L3%c}Vt*iSЩ-`D0 s,J fۛf"ɼ$=R6 {H-B59Sz a fE%fλ!H/!B{0MbP}sK][Ιc%VVNH@L 2)׿lfTj֔%?"'yba O@*GմZߑ.q nF, |t]DG/kʯn55՗|!R=]P΅:x-?oƻ$B68JJ?#/f+ k{I/ѷAn)nrg o7Ț;$Wˎ-.3Һ.bz W g(P6w;:e3$%9RƔZ(!!U3SkѢX߱UdMӑWC$Pk)H7[=C)֏)-=+Y=an: eF(/gY׉.`+ZnI#QRi^zibxWwmM$#AWyAVc ڒy,[-ڒ<*|qKe0ìu֚ic22####v3|3Q>?,'ӋV9ԱД|0@<ޗԂ ^ݦjmtu͒Q WՂ#0$a+ρ̚WOiu턜}hHۓgx 0:h֮D/TZr|S&#(*( c סY§5AnkRnǷ2%d2MSVZҠĆWz1܁\&fu2e!O3h ER$ī!;# 0-fLm7R;p^rAH5=db|!r*pT!ǣB y&z `a~GfÎS/ $Wf?], (ӎ)\TFw71#dE6t1M9>`A[CBռ7j$dxRݤDxah"ˢ-o2ʄ.z:ɘUF BJ8ڻ4FX|D"0njvN{ t4]3p9!CD3KEpsiv7~&e=zR7ea]GI!f;}7'J+&s8MzonY6 HǰnItCxtJa%H3V+։]褔Uƌ'&7&7ݒ г'rUDB˕gx2l@'cZmgAG?g23̝p[:;5S70#XS0?Icڭ_1=»{1itEG;.8h}8hnN:S$rbD˦qJ_$^uNAoKRK)ͻ)S.K԰Y-a{7]VܯEEtP?W뎻C_{v`QУnd4Ż A`<5i8rm`( \ώ=JJy#1l#软)8K`%2eFWopyTs5]b6醄BqSupǗ>%q&yόWtWBѮgDSq9f@uF] 2]P2Ҷד ~`̯oyi;ڎpk0͎YLEwoNe0D;3Q@BWtܪP⌰䍤Sc7/zd_)[Jز6[s>|FqIzYG˟;7dQF88\5QgNUFpLҐvFc: ¦!){`֒@SS۩AXh)S*+"9bhdٶ16/zȞ.4B7Nk.&.D$6v巊x;Y(vU$pf]Sb@T*J.&+ v̈/*QI5p@؃XK?a(s2F?mlw$HG& ۊLՕSkAlzdgҞ)rʩ)_?eBZƎI*b9) Ӕ47us C S{d[Ҋ0$v&mnR|U_uuF!ERm\3,FLuv0SZ:ycfr 8@#C& Q<P,G@TMKQ]5ĀNCHLݜY0I\ӈ(Ӈs!ؤtń{,I*06;cK7y`//kp~9qjg)K5U3IGF`aZ*RwΠbǼ<^ht>q7jFAg6BݬÔzE--PN֒52+_5BY i]y5nHo}?>i"ӳ@v9 w &s9k4>zxvm"Rd ؃>` P,1Ic6ux̸.-6;6=Xai@ʨ$K<`I?6RnjˀI܇k|g|p{k`YH r ]򅁧뙕O2rtAK+-XOG!{K\NIxR 7$NE6b9K[SjݥfRMp$_h5^%isru8 1jʩT9qNqp+z I;NCMw4>H.?P`b~]QkaHZ4aml6\}x5 ɶ&Nw!'i%8|5CҴ[.n>2ֱ=l89#(kfV}}ԔMe15PrŹ,,̛!v_ējd lV{Cv`)I f]PFNDWB,m؋n7oiY#D^SRgaWwu zo\a]Mgd9=p͈W%8Hb0DNa%LaCы\©gGAfmVk#6ԡC11,p$TҸyNHaxl,!`?dҁ5l9vȴӲs8YAiXpY@&=28q"I4S2`z,y7 ?c'_@`&= p>qCu/}) }i@yO wז#FyKJT(54#'5D88l}k\|jzK]t\IHVё rg8l`"hKZ-4aNw'_88Q9JOhy"1A@)'ceT&V9[`-J߹Z]֫j5{TM0ң9% nHRR^AsJ-ƠM߱#X`g3+%^&"i%VlGP$2,"j'?Q2yib*GS|y#eMqzDVnYTZ1P `_=&JFN(׷j!_; ?fɷEH) ܽfģ4>+[h$Q:KM'8l>aCdl B;QGw 1EV^<*1ӋJ' 7ݒ[PgmӷlJ[6y-v|8g-.J^kܔ ik%m5HB/C%wR=22s{gZ)l>vGŕ'mwlT->*8QN] |u_'[/dJV3$ lZSI#D*cGP9iph]1H`MˠWif&ia.ΌNoW6^jYG+N/C kQ̈RKp IAS(XJt/lQ_;^ _1y˿mCSˢ1qxFWTg(l$MP#%y*bk 7ǨUN8hhsRxv|{8}wOp0ã?83'8쫮[(ÎZۻ&ɠBy4+#c=NufǪ%í_,C%KeZd(N1Cݖjg>Di\蝙=`n.Onx T< |މؙa u35"E$ Kk zҀ`S5o1 B&>bȾfA(,sg]Av#rd Q ^F@X!!&=T{GIGY4pK1_=%#'J)n*-2s}%51dzTGCJեp?>Ҭ׉y e~[b)5#5 <8 7ꔍGQn71Ȕ:N9)qbUMMX +c̸}nEuG1[`t( RFm:*PfWo{gW@֡X=3voq lRΚ0ME#&DJ&\^)[E 8;> K۹\ZO[2[`a/a -Zu'+Di7YOh_GA tUQX`bdt⼺qa2mRP}L|1n¼.T OHQѯFǦ_\@3pX$ÌGR{#CͅMqXtFtC}kP4ƦFvF|Ŭpu\tZQKàV^ʘg8謡V1rP^b#P^!eiUXiˆcɜUJ{? o$tIBMo2YQ_b \GbMtTϏF#ã=̞¿ߋ*bQw> .[( /Gf1G:F8n]RhԺʟ_nlkdN?y7G |m@er6(Yqҥ1!?]{n^кϐa cΙlt~/0唰F3}:f O/N zJ45: +S|~&H+ R1_ɫĜ)?C\w"dG P1]^U\uqUl|F,8hQ ]G?%GS!1o|/l=HI{HljHk4e~ANŞ+IrJ^*nI9{R-2ih f~7{vwzʘ#Bb{8zp+9R@ʮísHU#ٻTbVMqZRg%ޓ8Es0 ("!^O?G!}rxcs z~/B `^_l.be휏tQEQuz~|<`IA`(Y -W9a,_&?ڎ|J+wXآe>i;Vg'VyBY@d1mӈE* A|wC!IGb0O<3lN=]$:jNBs>^ԇr/_ ^Z>y1&d#TA݃sǜי|6$ S3c_.7a%SnpstM.÷b`uJc{=r! c[_3~mrL5tgg y4\ҀlJL'ol@L)y JVZ<"/GZ*>sCuJؽݸ3(GRwmqOEdMH'_96=ER˜7t"d,~7MC ȔiIw]׈U=h!SJSbuVTDZ/[Zx;h}7“Y=idNIT(g{Ή[Mq!;Ѹ[-X^v\0"]ߊጓ7V|iK&unnA;eTpWiY}Xt ̵֜$?n6qn RaA^? Ml#\ rBGQk7[jIwol>z-v 'U K`lٵK=J >OTTRHgk_{RaӘ03MM\$>ՆBMmW2A.~fلOFӳ![\PPc0=ŪN ͕1r5+QT)kLU] 8gmb.e/ڔ_"W7t+יˋ0eUs)G+!&dLNWziX;)EqTǶ" ~a#Ð\yF_JKu>._6&~~`DbY)l6׮VlGn3UP:\̽"甐495۔`h> wПsHm2niMϑI1\!x%"#uHw5*5ɚ>0kx4 :xhA\ј/%CPNrNKZкL^;tJD8_F"&UtӠxe͹|tpZbBGp5i3N.J'J JKt* Q:f~io,!ѧ;xxK|߻l3trI:n_̺'D*:N0ܤ6݌9C[Yrv.fҺp2#UERoRuw"c#W`~IeN0K%A)_z ]OiGP3ȷ;TT#$M\鏽=[ve_|bn[ 4c9*;:]jPy ;:(D)J̵~aXӘA|А^ԎݐZ7aYM6:r~Li]k \$qQHA4FDœ\m ql34K00 3-"jHa'mYAI('YCdHw]!=@,=InG( q-ÉGykV $ ms',h=HRp<)3s0"y=Pԣ17"xR[: R&9;30Wn2RrUl0.\MTg4+%3ϲ+7)rҰ}K O8}V[iS*(7tڕ %0xՒWߏh4i˧U&#t0|?x+6ACH_^:XfzfWpe!].@Lu 8va;-:=|ǥ7#vl|9y 7aiԵ-iR<US'PĊ a-s3gT:'UzaԇIЎt&#6ǀcP[O}`t4-5e_X +/+}qy'3u,[R^9;65bfNP#BDsgAkܦ7l9uܺ1C黾SIn侰C_<`PBإdeSolve/inst/doc/source/opkdmaincomments.txt.gz0000754000175100001440000020154112352122173021446 0ustar hornikusersKopkdmaincomments.txt[M{Ȳϯ'#4H|d,``|2^  H$0U-3ea~tq3"nFO_> o"{%XO'o F_*$^MZ^Dabt- ODE4m|9I(o$$wVbIڈ%h*gyy_ŪZǺ+-?hBMsւ? 5?nݲm_uB ~uf]g&'!N̞OX>> 'cQ{`4,ŦM|<}Lo`:φ؟!_wHLqW^ -1sgLW.w^l,z-Qƣz ,S"DaWi-1jtNi{,|C,/7b/cy~}kw:z:'t'G1{LNxRD&D/XBE^*p{HǯUar $SD{D'\ad˶3E$Q!Şč׌9_Eq*vQ x)b/,?h7te᥾d3,D((|"ɖ. _ގP?p烧>&^O|~Wp5/x+ 8*e{ߋ쫈eC[/.L-Bi7 ]kWvpaFCy^s(pA] ^\V*B6T5ng.ď~NHy``>1")"y6MFfr?C10O>\${alS05SLFZkcO<ӫfcqiY!K%r#E a7J!OCy84S,:Һmpnhj>JS6gE?]? OB''ɠ ٢ıG( _T X)#FՂ5䣘"Ctk*'_D*3ib9r5SGGTIrtc9^NYu&!{*ABoހAdrׄXpH*܇ÕqH J`o=H#(1n#P։ך6I=503fdoHƚko wCIRZ+ Bd8H o_V!ظQ!*Q (^#:,:ERZ_ͺzur LagAL`W8Ŧ +"Y$-G19L\@OI{HR%37-T2i7 J,+qH%ARϡ58`  \R@W)'r'3EB]l(a;!gu{4B&n5^N`hR/>ȺaFu@Bʄ?̳A4{/7iϖbPnpBAbVoW^6YJ*9BARrLppSF"TQ<9(f-l#gG1 Bz>9, x( pCv[2U11v2XQ[Ȁz1`/Q@R8o=љ?BsboqQطQ-Tp8zeI?CxuV[Q/xħUb*hE Y` s7oT:OL M1y594^goϨ!X#2v#:$g'r֟?ËOy"8CLT45v/d#f, d?#kƌ*)bmWldBSVsɧZKk";q)8띸T&: _|$,@gt,U(5UѰX+JU+JTeb U DQը|g썮2 MxR}"nwUPŽ#8=T?WU*" V pU)c—S~6Dzj԰Y]5,M"F9RWrQ%Iဋ=6؍s1SUe\̓׮ *^xRajG+}}SoTnK`Sfe}zg%2sV§p+ֲߴ򃸷bll$8V\56<#'^Gv?Dn)G>ۓ|4QQ(@ljV(TPg0o͕U@8SR?R`T%Ga MQt|W-]>d}F=,&52AvfsOBmp^]9UwR>!q&Xv#Z*ӊXOOzxKXb<|yv#i-&Zg \t W81$%XTBϛi3֞ haTkiq.iRlj1F[B0ts& hdh3@VDe 1C΃x۠?eA_>gKCONiD۲ӻrDϸ4G9\<Ŕ/,= !ѭ x vAJNE2ci5+N.Duc=[r%+#ŴW%͜kSܩT8>b=, T~Rq! D#R uA'16G!2yl1 kXAX,g65ƐJZR)BSBåTr]Pfh0RY_6T/)S~NWX|פGCqh TSYZKH^hf?/R6cJSf]N5 ͸b)ёTC72QP`J=U *3U`'V*[ 0֘h|.ÐnsCZ!Pt\xTX=%*%-X3r\KQ)gDJes"h)٢ JEvt. 5*ݺfLЩX`́h`Y~ҟK,`uO>K@a1:<̢fxFdؘv]Sb%C\u,Ki#v:*YsOT04nR%UI)Mmu>2Fu1Шyˮzpe K~c4#4mpW M@g l??=.,k!4C!Crx*a) ' -PF}z h2B*~{zOkؾqzRIr u18LO8I2z1#Du, wUpq|4N *aä/dGYcbʺҿO*⁸R%F^%R !Y/-Rڌu=_u@/+H4,hԡQVW_:wg-2Z'+xblSz 㗳(rGjAx~uGywz,UӲ5XFǐTbQQٍnՊ>+t׀aY.9 C.kz*.@&|xհ/6wd0 6㲟 L71yJ薝b a7G|=72scꩆ~%p!-9ļS0ˇ(V]$2ڶNSqQm/jMsG@ a9=T% sk8$X^`MU9lD"m Pm*_].+'?Q '",Y; X>MD|aTGLٗقkH{(#Wch7#xcɊkv%>e[enUM˲WҴꪓZ{3NvqЉQ‘Ų;se0?~AgO@4͋Fg}Xlr/]5sZzL KSIeRԶ3I{o [oLR 8oL$58tA|M9ʛIEѬ($v}7 +pC70* fqsCԊqNAM};ڎK\-[JSHWj(½4%jďm *#\Ps: EW QVTL&uJϾ8nW^k٭nI:k_ZKr>49Pqڮrml;WgVPFѥtEev](@;r5P4nՖ@8PK9U˹l:~]/{5P˾(r :N%zvi׀:Ұ/CC[Իj]vzf*f.-M1Ps^́Zu^b1tF@6Or*jڝVSo8H9 w_Ksd/9;hn@ /fۀbÉ+Ԛ{Lj5M w1+gL&Owgɞ|e%yPަ!* ur`^0wWv{_BΛwe Պ we$%Pޢ }"TW:YLa|ڥz CE}<i3SKH}YjTC bb4_`tNPg~BPuSX{:vKu[*G=7a'wۍTNEdqG$eP=)]o2w߲"ksD&UM vA6mmq.NI8jiV 10rw FUH(%S_lcFdr~*ȌfFČ>3,H'gWu=AJ?Z"J_pk5.[ٕw`ݦSN>i|m͏GO]ߋQ1.-l0lTHRmẁ$kAMu&:"cdF4Gbt}\;q抻!n'˜12GplRi! SOg@r̂.XpS 춂eYc^h 8w&:qөu-d1?( vԂ-G-2 G`&ezz/DY  9͕p ][2wϾOn4aV#j5IpFC[KO&ʘ`@n|Q,(f]&K+NI[x@[̥ BձH`UijL,@XŠьTCK 7% MmsEn (lk@H+jzv44цN J'8|C]YLrk^UEP)0;T%]5rvsV1E; d3 &km\9b{ĭcS.Iea6a}i )Qq4f6%b&͡P|y #߿UIig(*#0/Yh2pB] &0x E`L$p('1jJM3̱څ+dV8F޺ᒸtgc^=_ʔaxvSPsbc"p #^xoA m|(&NFzPV$ 8).;j<,I71,q}0xqMt6,51‡76놏Y4_nNltVwLpQwF7ĶmiMkT |baYQТ?$dz{w6'EP)[ Z]Wݗ HlgJ`0+2% ?UWDS3n[iJm_f8!WQsjdQM*xےӄVۉP]'wZ1Q#I,nǚۭU'3*"_JL(TiMdk5 1d, 1^.*p,d%ݰ3rSDy#"n'z~i5p7F=Yj4`+"=ވZv Ǐ0TN3 .huJT+Xޒ6YT`NfɈ@^e9Q߉JQ[/p/)vbDrn-~y1$ 5  gK&4~avukzX2;~@*|d"jFlb×U6RH±⥸O0?©Veks58 TN6= Xlg%~b+e&Du \-mS_'Y#ɤS Gj}g]//}h dePc3 ~`4_%ЕRn8$ '/TY1DH"3$-Wf 1#&|wқ{5)j,ܭ耪 {AF;c$ W9p rS$ez2 pȻ 5W[ }"fEV=|'3u>m=l@tl(^PWcތ{떅23ʎA6N F1gwϾ^ >SnOM |KMd|<;C)~uWS譬ç(' rln㶜+˃Xc5x11- OCm F֨`@~wunUrF#:^5pG}>&c?ge`?|u^ jA`I{ DEs v'zoưo5܊ݟl}_JՔ^+KW>7c LY vSp-LU0>gbb \oZ2k *DU͔yuX/(~4jlk A9W5/b%*M4+%!͞`l;M[!Iݩc_<&hđiZbV9KKbDGtףΚ5W@q'L6@2I[0m)?uX6pgFjIivꋲEB2N'&tm |>QwXj*?!(O?i Jj+hc Ѷ'cRoPfjGE%Ʈr^R%(Q\ %YMJa]m,E%q}n7*E?RS , m@.rZPALzaE@JYp}'U%$!zT-BQLC[A[lx%W J$TaFl!րUhN?uWs8Ūzd"h8pm9WkKc ](Y0M70(쾮%ռAk_wŽzu-_WW[K1rvA,uim.\V; [l[*LO4wR5>5:"R;/["O\Π@ךZwfI*[jmuw[g[G#G)F~N[lښ! 7 l$YQQ"K;jh* kfwقrhh9a֚\ 8bC5CRGDz>2 )Z "Æ0t7⓮KWnðgJf>53 (Y-WTw;9ws8A370_{(OZO:7Qw`"yCR'foP08E\ M `TbzC <:5 +[ w8W31Doy̚VT6I4tzdMxDr2:v)oj-ǘL.Fb&N ~kB+_-dղzwO2>Vo 2:-nH-n#Ji yΑN^B$#؃Pv c!AK@0GG| ނ4dCr`Z+$1pM֐pJI%InA?"% 7oN!׃4`*H{߼ >Y ~~O7Ч.落l;'wOj͆ oh5HhAU`"\G5p񲨌\欙-9NEr*`ƋH~7D5/n )!,j:ClZfӈ~>x_'/ ]5 *܈"1YȰ \cTT-5jhkxཛྷҥhJBXZ/Ū_!G$HGOy5 xnBb]#@DѠXLb1yxVDBK\diFkalߩ~ 淚W1KI$a4Oӣy8/+ S9B9^C;Dca wZR30)ﲪ@"x. Rދ@&>LA("ڡ}KogB%3o <yk~˦苘>q+q ?fQ~RHD'K`H\4#5 J# \ZaˁAl=c7hA)px}L5|3lhMMec>.Kr\9[ɱ@1&{2udauV~2K5`E=t]=P2uϳLo'15kƣcAάK{OUG =]uh 9Vv3S VM8QV<:9 Dx`+ݙxjqH c3xS ECvY_;Xc;LLWDOַzhAW+)Z7$ 0)Xi|T[!eXv Qd N 3w]5Kb1g**=Bb^c>Gew%;@7> 4\3GQ7>4" LEvYYZ]V eC˱G=S ^X*ocο țGʻZ4:Uг4X!?"ANØx'EG-9w ud!(/ڡq["P(s" Q[}Ne.fl 9]K2\hq'@c~XYIabël617Bb$Q>\>QH~pؠɷrlVof ȡ 97r@y nդ fke9~s!ۊ':~3I''Ƃ5$At\SP\<;=:dHws'L&)N ,?yDR6<Ŧd""VDɘ|(7l*LL6_!c!A=x4dښ X d1 fA LBdm#8C\}$D&}8Td6 0hN Rғ)|nE@`PjFY!YҏUR'+7@jAT1]fpV;bbHabE(ĬuA4&hAX$a)2Hf62ևɟcDj{C 9x@gg!d&yJgR;&wH+08,\%,b`pCVȴ Z96v>vzA;j5 *vP38l&%}+2]~Ԣ ȳOξA?Ah%D1t tSWV]: .Ư+| qh ;:%O54M&5rVRxIh0%y'ȖW1Dh-ii8?bIc'9R r-s@na$C3n*6+e*?UG)89*\QĐ& _Pd/..m"<|'xG0I >u?ŞMrqE),hZs2iH)DX'IGDv az6]|5cc]\ۄpH_"Bzo.kf僞䪅M4dܥjI)qXCoY-n$kRqc]EZ/xs9n`4zu4r8r=^ 3h|dK)Gs]`$cl+1qBy?3CK۔Nf1U)(C W!(W1LQut!gǧJB;l^|>'G"h/C1w_P{;OptkA w2CS!M? vp,}6Z/u=<8k\^>]P񝱠D̖F{Wlt;u_l#IH:ˆ}׋m Bٕ$stsТ_lcj9]Ey\! Ӧ/݋PP'B>KnX$i0fWp֌:œ >J9Yz[|G`p Eխ^3?)5A% 9D=\ 5y62vAqLrg'x2V|Cor_طAeR Ԝ#EbӤ,,I:&#Q=LufqtqW@KX?rl\|_jp_0[HVOQae IM7cC%Rj-{$~8 I8p 2 pe[sY4;Joktd6f/l =mcGCnbUУOl{oS 'G^Yn ʹ]CΧSGIm/'\L#әaB̓[r\1|K˯iC"y%0TԕǺMol=nwr+2JD3^f3>W0B 2dc ,)2W%6CMv% h Ƃ&h"@R,Hua<`d(u pb9ԨGO<5>Z"J˚,Y!첣~Yj9tF򳜊H6ajrOsYK$>Q"͠ 3xm8/B 4^ m){.!&rr;4\{y8Q%l!-PFw%iѪTL k3xuKT%Cw9~|(nx^cZkXWkSU0Ìj Kip.nrGG($hxmgy|a nt.S66NMyO. kc3T31pĬ}6]P/A" + lҧo /D ]XXȍdGa?s7Na ~w(Лa'zsGm2xI XEr@=DϿ ؂(-+k1&ȠUk6aU`DxLOXƃbBPL$"h{pv돮:4%*RJ@IP¬1ftAW>9YkR1;G%L @Sp&F{3{M"\r巄Ez 0.JM'Ng6fҜI8* H..} zb|Ql_je#u. tazsT&C l}t='܌Ƙ8-TF |"8C)1vʤǡ62!$1Pɋ=>)_;ek\Іb"Ș!WCG*Ud(, q5, Uh"N;# !Se^˩nSU5Lz|rq'Y"b"Uv;06Nꔣ.jWfF"V+IaRGQ"{A6(J ;ȍm8=Ϟ;L}`!Tx|w$j+] :zk6u2m`'pj1)OT՝9 YM ;kT2|Uv.!6W#DhЛpnL*bN5;%9M"CMtNadl<$y/_>ׯKJk 7 E􌰘w8v], e˜DHB 'ԅ4 & ptuFNp\ O3'W\~m0[}zqnkoċ?. v>gg";{;{NwϽ_ Gn|Xj>a{0Pni-1uC: jZMBT+9x}\k GWN~NSˌ11:{- A3pFX = &`áܩq.%3B_Dp`/i۝cщQm) Ŗ Ӿr~$!+^׭> q%;qE^0+νFOϯ;M%tb_=E1Ƚ}[ko5f'?G??WjE]L˂FHnޭ+lk/ŷb6H\Q.񬔭*+&tAEbudۑؖN }]:yMvڽ^ z߱vHSc:ɘH i1_'>h)SXb=r3/H\c;Am΍ֆFHr ? !ծ$ޖx^[vt!D6&yz*]#ޯNg?:=8(<lEMyw'3Nj展7/'Tp{}=* 6DHV̼?ȺdPS0&MfLHzBણ60#sӿ}DzA8NbнOAAc 5Aykbh4@ G(I8NM9#9(i91Ce/&՛7Gnm驫چ=,ȫrw9" q`'e a /@}z͇H]Zr#Cv&±0lGE(;嗑p!<K7ŒKg׀9>"k۹].k,fChNyQ q erjt![3e| o.%gеAX|2}x4mj< \@Aܕ(ZØ}+wl5iaN+nߺ7EgWMQN>Ny=:H@qLd$ݣQTby |^i^=>`sO R%]nGN3qiggŇբe_=,:Zfk;aFsRe'T1)Nˉ d=_M[F3rCn;`thEc;FgmNё=cuW-3;Hw=_fP)i{})U8P,=Q⭰G偾+.] 2nrp"J]eӵst[a`9k7#FUsɹv9Inb=ę2*Њ:Y ѠN.C86E' Fv4TOfEW@ #dAËa]]*x@HTeJЃ/Z΅/>q(laE& w<\4k&T6.e ~}NvZx&9 O E'=b!La =(K]6 '- sZgJs3`Ozxzsɣ`ڞ;p׈S&'cc˹.P!nBCINAP8ΥPJcl R xs`񔅠;o0jN#hq'Ek<+ U t9 qWKun+chږT8HbF`aa; Xk\aERdiH',OWr/nYQu3$P{(Bq)pCC%sMM՗rm࿟_RȄ>F5`}eĭb  ]22DžlJS_|ڄBQuR Iyh S8Da `RC8iZfWi>_"BMusM#٬nY>^޼;R3Xn )]L*pZXHn NFJF,1 /N c Fv5ITD~烀օLA܋m|ăYDL%(Wp+!YLspwZΜRLzc,wqsuj‚7WEi2A΀<WdP9;uG$cͮ;d'JEh,\u򶘁zMX[wnף'wuc$yJy`J;rّ fH!5=&#,>0NAc/h2Ju9=)PZy! ;\j$}f=L5zNkX5^l"acA4 rwQݼ+1-"QkwƝ5n\0te訲aדUa$$3Hu.@TL>jY M3r}/Mɡ ][8(:0? .X"B,6Ó)i95;f7lE@$u/c 9_Zq+a~ YB_(݊wQ𨵓52HohInQrgY;rdc"UAl Emh \EAW{\'n?&彔F4=Kٗ* k8:c(1^fjz~t=c, WTqۯAP +V1:!Ixy2H'0np\Z*ӳQo |¾H1y9 S:8QVcE]R75[ !\V7jh갓Gk M}͏`DpTDX NB=Zo\Ff9@`@/ͷUcE},J?ܲ),FXZ 22z@`lş|[S:?>ǿB{o㹻ß;ō~s?umaǽvTJ ˿nK7}& ~䅁0v?ku[?zwd5+B6CMv]}iޡz.ZڕyO 6l6b4_kV$PHkzlp: *^+_{|qin>8["^c^j74mg Q՜aAti䚣:Lm*=J֘;@ߺCBg jڞ_/;H@PTݶ t܂)ac >wX Cy@%p#]eYsKb>P Kk*~ыDʖxEFP,NBo8Q-c PX¶VTVI%P ^srZvAL& t5ZK}ͳOG_l23A<<9;:ǧ|p&k8^[$>[[9[d ) JG GunuM|ȡg5ׯ#()ԯd=WB# mkTRF@J7fnZ4NA4eyKkC bJ9CJ'㪃{ދ֐|b skOj{=\˳acklOavt?ar ?eR @ХDj;[?[NkG?c-I:v3pFGI'tpq><9"sT|7#O*;_I=>*,zKɷ_ۮo{[6 [GS݀s7 &w]u/KYЦw+Ʌm̗[~է໻O /-j[}Eơу@4xRx5~mn.rY:P/EP9dpUɐ󰏬_?;]Ϟ96|;v_l-tD09}-;5(? ;m}u׼g$1xm=j1yj c@0n[~{ DE=S$qu_=B6-& w6zMɵco=_o!nqj1ݕ/qeж~ZYۆ^6mBϚAHe%m[vg.Goc=yoh=~ϒ&?8j;v5J&7;tL CCMδWL#}$R._.O6< d4 .nQ܊pk-[=PY@%{ +dt۵$Nko\UT|?hz~o }zA-s!Y^v2|;:aut?UiVC_N}^=o]m9lN;ݎfӍ;ݖNj i;otRmK^w]ONWA)P)l`ٰv'>*f/4`]^edڼll v0c O#_5G[;)L-)]Ɵ>S!GPaVv'Q,֐ DxMƒQx )e:<2Rcp^=ƶ[nwl:=m5VNl?o7qhVwnfota44N~ovoNm NW%Nkw]Gq:cmow"ف'ަNkw xގ l74뵁r\G*6z-@Ij9Uݱ ١vvtp8^^wvࣽ^/ v:8EΠhغ[mGKӇujMgS%N~8nݎΪEvtwzrn6n;nkm{8r`pvX>rtN`k^u4unm5vkӫI ĬgvGύCM ^`Nu7_mUAkoo~kq<㈳88;=C2ikt{6M Y_RdFʂ7EBX-7Q5EY9 c-@t! <Εa$ȚH^dtHSZQ!j`aDh`'+b@"4 ¤@]hCslKQ t@^y/! XM5:*nkJ!HKXtͼȢPicNlj[k2;`E5@*\ <bX@yP< zCTlHDkW. Dg 3b>2*= = 1̣y\H <9jc{?0&PMTfl<3o<͒u]Zԕ +t0ĝ+>Cބwi!u$ŏ:f/kULE/*O}*z=ans4b:%.$Ӝh~ZMe 12ߔPa@QC9ƀE$@/-i䧸M5Y` U2@ 1h$Z SjRNpP*CH7bn&qU$[\0TCkC./3X+\q IGDq׎ݶL簅8tJ'%4'q[aԆ1[Vy9,#xl˱iAx 쫕eiܔC]3.&i#/,53Lx΍,7`5oE;Wcus^rP=j(v@l $.ff'piYŇ*35Z-n`LaUpR7 Ż[6;x98f ӜA IƶR DJ9%_bȑv:|Ri//;a00)܉Or3'YɐXL}53.gonLd 8}1`ΤMO+ 1UV\NʹG,(BՍ3!: " @ŴŒ`q{yx[NH0챪Y gSʹٜ7p4E-@L kCc; j$:ِ먮 ҅e2 &ZI)',夨Wc)pJ (Ƅ5Bp'UHҳ &msJ4|~ngx/XwƀȬ|)>ta@ #$~e#n!hUPS .w p!gced>gWbs̩%Y wī"UP1R+FXm$6ɚ; +4CX\M3ͶvՄrcKUac|M<% V`̝mxhGQA&3Hb6x``mYzC]|qNjKfX;%yPF?&[tH  "!6q8j6uB2SG[@Bf8_.EX~BSD6J$plIP+(i&VS5_1jeet)_#І'ۻϹz'bэUT;pYí_g%87Asf+o@s=ZV3QQxelHX.BBMi,q(Cs5OH$~gE]aGji|eP?8fp; ^OؕhêYDHaD,d qȃhMbP:*ӈF)R]zPTMecKSۑo?زP&W3aʿۍ{'Bz|2B%&&d5iMt4NbId!RD20Fmάnv'YE( @1$4X* zQۆ[ qf8"0(NFo5;%QdP@o_P !x _BP}%Vp"XYfe4^(QSt0'w2*~%KN< ^a 8Z6ZF^B4h{Ujq3W1g]BŸEcd8p\8pKSeY\}qY}PqK6S̞苩aީlpkJa( KU@ ۵*/ O p4OSʙ*їh \P=)20k9WPKC#_cF-h nA#ʃjU:]sFFNMKŇ$ke!٤yA{"aJdcK YΩaٶl쐱PT61k;1a` ;(ȞclwR듂%'ؿA͝o)*PWTƘAh]%#mFj6FӲYGhjf _G XsQ!Bj38[2j]J54/8D;UfpG_!e `nS+ /'h5q$Ǥ +AqPsQwlpo,F[Wcn &bƎ4E,I$\2]MxdE5eo0D I=ZX6P Vr\Cd*Vl|jh[@?pS1 ,ekX"<7Pa뉨[ά lTh}pnT)A4,K5\XIFl!'oN?0!8fJmv*V9;~P=_uj/++D ٛeEB.`&^1v.Z2׷{K.mt^F6b&ڠ7-"q5ɯe ^.oAGS35$I8. M v; #mb!蘈KYܪMz݄ld/܇ 8+D|Uӕ~yZ #1"/Pi ep/5ݔAѬ!`pdwbIFdRZȉ^fiŒ=$F5/ JH/%,Gj\l s@|` rbp搉J0q-y_'̗a,B8p'?HE距f[t_͘X@"ΘEM3k),WScɏE Z R# hBpNJ̸w6Gj&SA3nXUCBL}>?06h $P1WwJj4(&"Y!D 0^B'!&Od>6eqy[-hrְ*dl[vˣv+o%#!$}" PDR ֡&.R` @ `lb N1o|Ȫ+A2ԋ'D^~]z("<)lAwEwuRfpOMZ钍z*ߧMFg3ql#es up Evӫ dy F$Ѳ5Id3Uka>l#00&g: } ]lح ڪm;p;wPߋ@G?P lO"[сr 4wBdbl њ K7{0ygZ[s([X(U)n)_lM] QhĘW-4EP0fڂ+Ŀ @rCY+o .TPj 0WjV 9Ádp[mH$y·q`w,%4>H$D넢L 10vstnܻe0QZP 9e,>v2>GGA)F,YF}4lBmch<[%<&B6k=h. BK]ZImA50qܫ÷ 8Fon67Q tz2Q4-9/`ȍV vll˛WX#*>|=Y.Rm:Y͆ʼn[gƛUehBoC,Xxfm9q;`ۄ(';c'/NWPrqċ:]h̰@<ϑB5ޓ7#3@ʹ=ޓQt mpJd9fyz0ⱊ Qly3%"LwqGLJG۩ZjupUmTxĬk];[71;.̹e3`]3 *zA_} ,P\ .+ *Ԉ4Mz?&N|C]}/PSA`,[ qX`pakfƲphQRKs 6GV鳇32"y H0;["3y.Ow+gi?{5\;2JM/fTVmЖ6Tӭ$p魛ٌsi ߮@gzxA%J*'c ɲ"eô~$r|aKhG]"]}XO1<Ocv`Z.Qp!$"X?c'}Fە ! _bA8j%\o+ʏ9OX&qQlþ2%lU) 4ƓŘQ"TB.͂WNҴG<uٝi޽7]DwhS6>UH_v/1ǁ'ݢr8MH6*--:)wL4x~,0f<&&2O qhu/ѵbCҪ) az]ujI?x-p.(S|i~<|KB\5}oa}=GWA{3,[$[.[WqyW XBNg 7^F6\M] KqF ?`7nhf[^uǍ~0Bl-7c'>:im09g>[Y:u7)R\MpK.#D (. lU#)-nj݁VEw B ɱ=nΘr׆+{xuypvո-?|xĴkp`iUIV-Y~ŦT&B# qNKDlMbb_:&ŶI4yiANw:Z7-K!]5H/4, m@ .nqŝV3V&> @ e4M$Y,]$(x́>>KڬʎT$EiS !L`IXEWy_yp"eTj&>ubHH  M,?DDv]J7"@My-1ݝglir;éyv˵S1V xPŜAVlAR:,_,*nCQwyHV7YU3q \ ]^ XL9ut_VX9Du 5h sXh1jñ_H[ \6srBYY"Bq,̄BVIɌQ x[%uq@>b8 q&InʗRYgpydibo{W0/ƪz긓ԱsTyAd=^4f 9◪`n-Bi#Hn,n v6;S^ĸC|*S E(#U.]QbFzL!C0Ux) SïƱ vY>&UQ<-4JoVf6U 0mI>u"[Ĵ{;hhđ@Wqt?_dr9fZ.ɕvPGE[PT'7F% LC2jI()d>YQ((tZL)dU tɋZdS*[Q(KM`Y+fdh(Þ1X|@Rφ;O\& /1ak\=QriSD($ Gʉ` Ҡ礠UHVg0o'v ?3w.Ǐ/+;{d`#uLꀦ(SbʱoT ʿweAdH C)Ң|t\s= iIAȴ S7lױYO5pPeg +¾J~7;C -> xj(dٻ ʎJ}U"b*ѯQ4ã߯^Icj =:}<h65nDzTҵI'/7Mfk PV8Ma+\2G3_n%Y\P%R]čwJg偏'Qb'Ҫ~۷~[ru+0֫_/ Zn7 ͧ"w9sh!Ř2x cڜ:*\/YdV;R_kEw B| H1ŗϕ^N}~Ǒ"Sg,?Fei)`Vu"zC4n|Ķp(S6i#N :qA"''$B%;j&W!eYtfվBeQ2w/|[5eA9CДD5&kNLr <Ǝc48ýisQ(UYVqp#9ٚj+ ã=?-3`Lo}Lo<7>1հ3b~?z~Z 2vkf(o[" Zk`'Zs =VwO-MzzzyiWv E!"1UJ>Gd3 Yv;6GA]NڨqR +sPd?ga`g ˋa_ZRYbHt>Z9R w#wg! ;JCmdJgCnnwkX%Ƃ6<_[<yv~ufϏ^v{ *!7+)D)op{{pf!D?*"1#*\4 ='iFm#tTsb=(n_) O8 m`j86NM$, {d=Wx8)γv"x"?;OLB|"KEw?x2Eԍ.['&[tIzƕAEXDޢdA3M&-ш{67WȞDxy<Ϯ9"7gb?"wN Ö^G+N w"faƑty>_,7?Ni]SbTLs c+ 6h]iU~v56C=3;#˯%v*LisInh5`M}@ՔBs/Zr}( C;eQ1\TM:dږܿbHsFQ-<'el/t\ʨdY"yi&0=>P: k,L.xWGg<+X m 7Yu3e&ʎ*~P֭XhefAËa]̓'ʗp_? fj`\䚎r`c +#3[NU%dLkDi-r ܞHLs\I&,Z"G|jo(e$k?#1VQOEo0X561 6896kM,,LuWg qD*@z15JﹱTChkBG w 2]e+휡=Rx}v%gW.6(՛O,LnV=_>n+5ƣ[(*'Dj뭗󉮆wXvmiXa$Qh"҅͂kQΉ8keݲil_+M#wf&YJ Q O6BOl N\2KQOXTǝ=Gq "'lKs/G܍0<*ݰEg\z=SBf"%H iQ }RxCwNYFFж0}F)A# vߊk&8rTC* kxekhW])mlRbM0.@yA|5T*imDtf5gn4B @J*>QXDoZ``P|,uQ 'd;@?;7pmŒD+&ZٸO(&.ĺ\iX=:w~V{nVHcI>,[-h^C=v+= Gkwnns:zOWu#3)nF] \G7.2XPn`vS&ohy}㙻,3lvxoZNKZ.<1p{oT3om:-L{0zLjfw^4 vmnfqon3hCt3]irumTf^SLOv{5wvvl7ӗfzݽ?4^kLj'vA3{n~ۅfmfx=uمno.qt=:mjƵӭof7YNqu:܌[fh?!z}y XJw ~?֐ R05!f̉`8,2!'~AF3xb&ҁҼxBgrStG  UU}J7ǻ) f2+7Yԭh+AfQLn3zo\6UA6H b}l ґpz¬!Y0Rv~Nԣ݅7&o☧s?d@j8T bDŬE/$0PѱgYw~Om;@ t3HEm5;2;/uUTuX2.F[I{T3w&)%x 8@Y-kvwڛmC˜aSh6J,$rLr&%gJ.vFQ3%'D)?rq3OԑJ+_]>P#ޓ`;AJuxZ]8$#2b¯IKr y>[*' \3蜑q3(d2wī"@ہMkr=Ï|,$<4ZJƭNoAVJ&zF}ЫsRڌZO|ge>PpodT@7~B}AAKmDHC6c[Gmo |6rZ+)S3חb=IpP$F\SME 92l(V0#ξzx)x0n7V,T3DH9c2:C`1`șQi5 VŃQִf(1ǴaCkKVp f0AŮgE'OZ}5'y cd"ڼ9DqC5\hdP7,ؕǯCL̃WzSp3N"Sű4ו4ћخ 4'2R] la& wŐTn V̻7 8g%(jl y5jO=HtWL ,Eȕ`y2M'u)B!ݼ 8)Vײ_x(jB6$R6Tz®5&@4!j*AB|eQQ$9Wl!f⽾DE6JZV?ƖԪI=ʺ! 275S?ݸg8ZTPhT6/Rkfs*mUWw6ϭܵșGAc`Tyx\ bx$П9vf^Gu_ec [Ř H7ZBUA*lz^{STw)ck4\0l<^i ϱXMJ7*' SЈgrәdb @"yH5GU8+4\R3r3TQj}R7hcE6ۡEE2, ~߻>$ avQ+JbܑM!gzb(_0wB|~|uFsHF_X[W!>AۊHKzn߭)qb7D ˔t[HKY1pQ<_Bu)a;Xe\wBٌgss3;F){ekd|C"³7ct{5k^몙Vp&w_ԯ {&ZfHoZTQ?r22`\Oc, Ij a3A"d1Rz""bg{, H_g?;)!t5-tDqvKs7!- /,ϯ?n4Ț'zkfpe^p{2^Ci,83 5. )֠;!;NpWJUVK6iɠ6zM^nuwt_x5L6[&  Rڲ% c=VZ28@!Զ"M ĆY5t,m|d:8}|JU;*yT}B yJ4\4E$8R|x8fRӺghQuMBlmۀ%Ih6a0u__EMD?TW\}kj6(4cWuQWp1Z0c7:GRq) Ls.-AY#0Pb(6>["$-&\z牿nt6|lX:q)8GY (mEDě0r4\M9"QHl`C G FA / G4OݍH!Kbk Ӱ=CetvH G;CnE.}&} ~s_O8na'!@Up'I0.^ ܅>@2UĠF9`ȾWuu1ܡ#UQp%0Ƕ(sIMa(I/B²mVRn;Yx鳍n7*#fJ+ :~ !?#X+*EV *d:axEP uf1(ʪ`#ùE"OXLb1[l3&$hƃW6"M@EZ "Bz7T8 bMUrdԧ^Dptl $ (hb$9L,K(BDp4Q[TTrl+#K7# O`E^BrMdiϟR7/Dsŭ gs]*:4׿:Ya$meJD֣̑MDjJ^LV3xBN,}5s/K&Ë]\x0ðH8$$i JF W>NdpPTDdL8d*$@bwBt#|8 1ms!~FؘwX-wˬ ؂;%aK8E_sF  H3F͑|h4EBV>ANs 44'ҋ] \ ҒΓW !< G_HPy r;5`Ř>:t%NIU9"5)0Q%,B_#,يЅ=gh9 qZgs* I']!7x ئ(si$`iPciB`DG$G#6DB:fs$[:<9Ha%O@*l%[FtF{ 1GVst%fڊwKdt(_Z qͥ-рQC s:iC.x|@\&Py-WC57K' \5`Us8[Um&%,$Fv{xPRO. I+ ҭfMn.q'#_NW8/y249ЇU у SJ((U8ePDȺUD<~J!D[yB/n@EsʱX]tJ*jD7#5"j R p"7~s@z! sINqbfiCulnKX]]9]Ng \wЫjrAbaC;ش1Sh䶁Sf _@2(ǠL!ʠ$vQt`t )R԰X[nDЊ8,kH;zZ | Lr`׈=c<&ۨ`! N Hxx7 G!Ncəh]g8=UX}\@H"z M$#$EKN놛GfIatg>t=i4&5lQ9P%J6AXg"(o+i.9_+icx9x#'Bb N Y , ía? cT2Wi^W\rؑ&**lP's0,/=S6@TŰ8{pdž9>tvŭ\ҧ^ܒl 0FOJ"hƯ_04 |?XID?9zdZn*Kё=Bfeh\Es!v8#RGor=~2;(MH684p땫i+3sPOq )W`!A2k= ùDZ"5&#I\l8FAiG;4=ruti*^2#cZ#ThNS'/y,,qk;1n׬!DD )6)^ӂ۵p[f:; b#SΠ>%rmj#!m^)-SI#( `0^Ψ>:J΢/h}[Ku* U>Sʋ|ﻝ0sojn=]n~tɽX rLz _[yC`9dmuA@cF7A(&`lBdl>E/:t1cI0Re!}'V_.:rp,!;՟lGZl,ű"?М[ɋMaBX`(7s?aүS f1g ,Hk]ͨW==/ַ1RԘS[ȣ =*3>4Z.b >K_98;8϶Vvyz:iNh.;|mUI...)1{  (:X8%cy-.CeQe/jWG/ ?rZBv^WNt>]*zN3;f|m%ɃSIy?FWwiKZ2n8IZ1GTnn̶$0gǧazmHG&0 +q4Ce+k]F3I'x^K11 E3돩K蒌]/4rd@:\0) c'&޺1@Ā {xuyp߸-?|x᝱ LWIj WB#Aȱz$3ŗ/J>ۤ歾Qm-(›n Ɏ2L@Nm^ӊ'RB܇vI=Na/5Ĺlj*\>q I'/Wa$3(tq⡍>49,NB>+Ci. A-L x2/_}ܹ=ee:+  `rGdUx!'' +$v|9파]P~ړg\; Nu/[.WR֬EEn('dHҴfUaILFR!xuVR`_(Η;Cɪ'3)/-; 5S`W#Y?)R-7e.2sX'jñ_P%yz`>71ѳNF :qLH :HɅhqkQ7nb(au[svc{{bjpMp>D: F=6,X΍;eM 0DV/[Ch3Z T'Emv蹧Ͻ5C\]$A [0k$tG] FbEa6΃[r\!Ώ\['N_c=&3 yZt쑂[7-:kT ncQ*sE7 ގnˣ^^{hskX3U,XVdgk!;*3cuK(HFwL'3[1YQ(4(t!ܜ[)?kug$)(1M|Y H`(Uh"5lcu w+ ^<_0#}p?K(%} ll}vd,qNzQpԭkD:xvbWº? ?_ٜu9~|(nx^Q쁘h;GSDVB3yGUUAlZxکJp Jh9(iA✾0)*LQM{W[\@!-M)oSa`ܝ>҇ Sg{tl bc8J(NI*<%Ef&iƪ*B,qS%s5fvxЫr*Ku>+<h^74~gdRBX Uo \䥒]DyEq7[s{_,K8#ZKEgY'Nn0R %Y O>\˝q(9¤@pYN=<lL0QtW8n-}֢6?j1Tu@rκLFc@2ó˳LKAG\Qzk͌+!1g:!>yG& $MPoD~ Zv}Vj"XG` 7U.e ȣ9rfavcLMt=@dWT"З{ tV?KT-/Y !@؅9R-r͎sJ8ɼjz-_T}Kys*xx/9p %z\WH/A)J 0{|(`YR)"p{;in}TwkPtZ2&IvwtHwj݄p9ظ4+q|"A?L A8<:9 r:r ZJy,.;gh }1GCl B'.,?ފgN0-N@(5C ,w)@B"usAh;:\?͟f?M%!VQ` c@)Xpm?t~e[z<\x7fuVp-qkQ^e:i0phh]хwk1h۝^4@-G}d&;E;8<@`;n{7⷇/?9uA+(An]I2xxEWM0d/qT~;&qڈ"9mE.Dgj##&HNZw#ӝԹUޕUL:ZXR!H_oQ(bwx\ FkHe o,S|zEZ3VeVIUNL.Ž2Rd q$\@]w|8{`cGؙ0哛9|W |wr>mfOL+!߱C;ķK-y=ުBkP i7Fn%N͸/^; Ȩ u[P0$eL3G~bUyQw9bW@uhf7{qNmʭ/FI rMb'Mv9ѿyv"q({Hq\ ktc(eB-Ѹ=;stjt\XEaAm؋5Un!LO^I׹1Պ:Wvz5;b1χljBcÑRY{_ T 9s9/7&~'$-UEXzWl`T1顦2R9^ׂlxAtǘuEQM=L˛HUHG1*a^|s-9+%)/ŃxydIZI |0@;Rp6oP㞳wjy}gNuqrQgQKxރA+7-}"e`ŶlBr `;@sZ<gO"A"Uϳl?@nEv>=Hr>_,7?Ni]SbTLs0 }ԩ[Ubq"9W$?Е+ #7K742)٧&Y~ր7if آ_Fl!5v_Lv2uvYV {“>CpFhaO>?:gW燻vgWQlѶh$jJMwٗR  ' ѼC3D 17Ug{IU%;K gI F~CFH=m-HJqJBBTJ%/]N7XH R\ŕ_d7/usAvn7[1u{]p[0`gDŰ|x`IUn#@5N;p^U&-Lߚ{4?S ox圾9<'Tzȿ2 9G-L%ǐ |0ҝ1!Q}xj$l = OR k\*/<'Z#./sU@1-;-b b&{t aqZt66=6Ic2J3 t2Q_WX`t;ߤjS / b pmq!E%CMHh!9 N@ kz̹jzK Z>X5MR ],fJdL)C#~#%pw3@B R[ Lh{r=<;5pct/d[U@˄f~μ ӘBѵM4 űK`"X-*_7CopX}@~ba~S<49 C*Lm+D|ݝf<7y9hZ㙁e@yʆT Dg+=*eX@ dmTj :kwLȃG_Xxntq݅c Bʩ8czd2^?LBb'ݞVx\F@Z9(^"+ \ieAvKDBd +-FXiE(_-)slAqt;@oTBZAB^tyq1; &T 8exb8 1}#LFn ߒ#H)cu@PNK쥿߇/ ^ﲎ+:My=nnommK$q{S|Aʤ0vu0!4!`~9m*|ց;X~ps@4`Ass\&#ĵ4H::̜ 1'5ٍ.t,4?@r\>/ CQc;ﶛV/%a@:s]yƀwz&m:7:zvpnw۞{HIŖC5>,[-Ceq+IWyػ}c>Z<h @u(r^pG |hS݌:<~<_?cooᑚ WᄯiǞn7c6?`sg)wqi9D}b=nx kmz]iAR~oMSx;A7!և:;t^Gͼm}39t[~{{0fZ}:~kuhz}64 hrRo!/sA[&vA7ӓf:^gog@hf~l;[?4^ktLj'A3{n~ۅfmfx=uمnoҌ{l?pxs7=7 =gwӢ,Naagop@{]y[O]Lwowdu:ގfFof/`M Rߨ=E~.mP9'z\rͶzjͲNzB]#n{@ޏAU8 _ rz]a.I5*#QS0X5VGrgaG{sDRL(r/MTm%&rEQW(:6kW;vݨ6X'4XhVHtM $HsEgj Q㗄Q!<ّ惵Dz0U?`!a# Pl2!pƨ+v| |M Dg<>Ygj=D06316x#s ZRrI @nsO$?X C@ ``;9WR]9Wx؍K@9gu58'X&2}TaH&-t4{تjgr@׋rE7Ff!0,u1FQ%A2RM x OVdp!YGF! H̍9Ky8DtSY mп vT )oj`*=5u I^rfI8Ǫ2O?߾+ Zߖ\G1iI/U^Zc t7ǦcNʫ!ba^`EHAh $Oƥs*mͺlj)D;r8Hھ?">\? TROpcC~b.ȘJ'%4=q;Z2㨟JxڮfiWKc' ոpF&x^qnoipeyH DCr?nJShgQ`$̃.-G4ov!&۱ʼ3/ڈq~k(4CEbexcЋQ,˱x]Z81|l72d ƒػTHDF6J}ܾ’n/ar/ },76ĥcD&րIf&ȭjqeKͥDĕh;3}N^+ :J/϶R NE*-qQkC,E _^w@$f'Ł$!5/?q+#AT7yP#yiyS{e cʬْ#$!$x3%!T 1=;FΚu8iq(Ӄ ђ#//TYxΣ2^*Uԏ .Aȵ!3,.i*;'1 k4A@m,t_Gxr-0]_(nN|p]e7g.! lr8Gmz400Wd&DSWk D9$ vNJ8Phj:%ה 74hT4v+Bqs(@"Ͷ#eh=E 0MccU*UT@nƷfkFhXsO _aK,ƓT}ЮЬIjj`g$2I,e<.w ]>C:1/%ruC9* J7;7{fd@qц t,ʐ=!(@T -mRb} ,IC`3{ |-kscuV97!%Q`ߛR? g=ns!Jq RMpBs$T]DۆPA!n MXƆWǹ8uHEYVIen4&qβjQkLK,`TFl%1Me М"LLd沫Mj R8kFUN7ngx(W`w|TE^0}50H*X(r88su<4x:ldB:#^P" nZ;4hAU( ܺJxMGKl>۔J&hT\[)[A޸fdI:ju?}cx[G?&[tH  ½8q8RmP*<-ǑI[ ._+ ք5ބ}6{ ΑR,6 ߈jVhd ճȩOͲ202ɒjw[= 1N۸bR;uvI poJkP7G9 =VhE{%' Gؓt\ ylWF]SN|pN'2RlYb* wE xP~fYE ڰ;\H^ +5@Br\`)*$$wGT[ f›y2g'u)Bzl=P`"6@'1{2_(P@)fp ;43J_( lOTK$Å+[Ŀb0j]=-(2)Tx *Q64u`\_dc( Ӡn3,Bz|J\I3uu5? &…@k@t4NbIcӑRC"FmnΖ'YE("3JJP`0 7Hm_Ojaѻź &"gR ong_bQoB;c۽(?_U6w ׉`]ޗV,~V "T6R Ÿ?\knjIC ַe R,샾Ȗ9(hͳ]a>$WE:0pbE]^Ⱥw.@/嶚A"I.`/ZuP`r,DRz8!øC@hЛW<,s >RRhܵ1,Ț,N Z;{;+*qE7S!JYw!Idƀ"`])VXcJWãϕ!r2D\K@)"F"OT%@j %)4fvL3nURln`[iQY ءKuנ'5T@;(x+k^p.W䓍5\xD -aS\ bC `h p-%EtGҐShM&Tƌ%1R|""ug{й;`{s']P4Njt7Nߞ}iruJ/o@+[baF/&7? +#Dӳauܴef5@ ws 0/ V e'nV0Ϧ_Lwt v.'wل]so}(ۯ{!2[~%7rElPh0|.HW9?SR F78M,JkSUۊ^k6[[0+.Ntv.mkΧ |#('PQq #Ԏd ?n@pH?R^pDIzߡ1oF)6QB_myl*%JM$\$ï8~ ؟y+Gaܨ~gPws g;>C1j>ZA=F@Q`p1"N0 %<:Z:"Rs'ZMLRAàWӪF^oOҢpB ΥǘsVa(5ݫ d(#V$VF82a 5R%#ʽl[!:&  W)%=|XYq<ÍQf1G GDOȧݍHyk k/ =;~{R%8wv*J/-\=>z/6i2rzA(`b%I&zΓL'mܰNlf,$SOc&03q2DQ^> q?;́X;?3PB2 MI״~$_f8c&,W{j:VSDG7 ^䟸>JI{=-86`ր8cUFD8dF:ysvWbauH-HRS8u9dr{W91w HnܰH-(QZ8O$ӐBq aԒP(.bH:ƅ)Gj PrVFb_[e.W)Pi xv;_-ojLe~9sgFê WƳIIB4>HCDC ` 8xI8/bAU0yh.7>{, l& q% s w TA?AHנz _XHF$%Mlq80|gkPpgs|_Fd:F43|ӃDP LXR!ޠ5l:8&onDTx6̐ R%? C*&(~>ͻDY2j7;sj0j:B:xv&N,5s0K&Ë^x0CH_$dieFk ׭dpRT'D(\ޓѐ&bv,#K*_>PDZu.|am=,B>Aף !`!p+%jxB.chRal#(A-HmIC @Qd0n*&\M@S7rDF 4rrາ3v6"&*p!Y#|O! =K{ h@$" Cץ,'Ϋxnl 0Os[.Sd(|H]-I""\xPgIPIC6WƇTpWn5`z64H$q%Cd6"L(wH_ sCg- b 87%k)4 AZSdKDsZ=W?mw**~%wC&9o{Vx63`& lEp~'Nt%ABn|>D 5̙KM㫄 !2>CGRO gaCW?+?]S A[&#lU٦n%&/& M\]xPROY@Hw%/QmhWvJ +a ࣄqĊY^o *&Q.% Cl \Yˌb J/S4l8D:z+OA|cCi$^yx:w $\#!S"X<#H&U2SFhCz$u Pܖhﺼ >'I¶'27~ChPJ(#ȳӣs&$߁vb FͫxErd(ʠWLA"׊$yQu ꀩٰ/l1ھnD܊,ңV$Cߧk/)9.W\bTdj A,C+ Rtd2ߒ1Nsɩ}]g<-=3C4#Xo j%H"En &TlE1##*1HkN3,[b.ѣ!z)# $i 1,tt-A ._OSvy_QS1ՎX4Y880C!TAKң66,ʸ8L \@<9WHHu T> !m ߌ t5-u▨0iַss} Z-{6(ȰL$OyKDlƯ_04 p+1`/ #vS_)hheL75F*Z0;q%/XOy&IdMDU١T/DQSU?̄OTme$P&)B]=\ktG7(DKm"%۱2dG,"PYS e;aɷt9 BX/QUDnP1D`cnbTO RO98;8϶Vvyz:)N/;|E 5K('`1EPXP&FP1a01of }+yM: ׫B;5ی̚),C{ O݋E[1yW/??=4N7cWcE&Ҵr/W*%>RtxmB[$mkfTuS5ӻaqC3?nqKXcp\0ќs\qVaN'-)?~,3ȑ-$U𘱙$j4`@6 ؉Kej}3J.ET*ξbSf UG0V$!`*Hnҹ &AM*K u:h tkN,Pc[a~[0״"J /4, m .nqV3VTAZP$˺$QbB_10q֢K,Y᣼$@F?>+Cm. 1A$- (<9>D &DM|t/2Ƙ)Ȕ3wS|*)i|z Lt)ndvC=yv˵1Vj] Qoˇ.#J6^N2$I[aMVaULFQBb+njҸ&hZxyb!adC1ښ`Q猦 h e,]iBrs"$@#ߣĞ FFe۝a[r\a݉7ty#hNpB~53Hn+%6.b\' ZlUuSsTJeGގn ͣ^^{XթA^k+25q}..+[E\.Ljuy#+wCXR{Sɣys ͨ7a%VgqL~u< b:Ep}=;*3=(@aݽ"k(V@ꇝj@bSOqgҝcA$s GI'WuK]D!Q.(2sN`dZ-zNʎQ;qԯkEz0~2ĺqH0x9~|(nx_QhGGfDg/J*WM:8SZS^efa1FAc P)MĦt|$BZzfn>&0ľOE9և#1"ޑ<"Hdž #0.O-.O7{7m0_y*b(ɰQ4ã߯^őiu5< 04.È]otTUϡxJ4ICXmQl~1sjk䡴.*-z_s#pn%$T1rL'EF|\Vs~⡴GfFꆯe&@ !Zܛha:N@aYVe`4@=,%>yxv~qy&I)%d1[28&1x!-rĒ@D> #Xbїr$Iv}nlRi zDTY, S֫0֐4fd~D>3]uMlX 瀨a BsŎUJᠪt& 0P>"_ GGgҡeeDxGt fz] 㛃ˣ߈ONo\!Pt]lpxtN;팫`ܬa:.IdR@9Nf+|2#XoV$ pKw./>?d6}vڽ^;P Y= ױoO?Nz8L砺 /5n_Pw.>V&J1\KH` 8A\;9=*Mȷ97vxt"屣W1 F&DopctIBVh[跣SJyq~jpo tv@֋Pd>] /> uݱnxқl0c*q8"/Ydс7`ZKr9?u@ _ 'G!?ggv1waeV8sªs2E1;ON9џfYY3zi4/ DJ'cBQw E.m 96T/*#\牡LqgVw B@)ˡ$QUx-Ml@GCj5s]!G26l9 7S0Ћã8w#vy~`.=p=`]I2xg70/q wL5Ml!%s:ߊO voGF M%;,1/0cwܽX'IץJڔJ$ߢ$uHdFZRh:g.S]Tnv1UU-دӏYHRn9K)2^Pz\!0hP~,aяdeSolve/inst/doc/compiledCode.Rnw0000754000175100001440000017231712405065301016503 0ustar hornikusers\documentclass[article,nojss]{jss} \DeclareGraphicsExtensions{.pdf,.eps} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Add-on packages and fonts \usepackage{amsmath} \usepackage{xspace} \usepackage{verbatim} \usepackage[english]{babel} %\usepackage{mathptmx} %\usepackage{helvet} \usepackage[T1]{fontenc} \usepackage[latin1]{inputenc} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% User specified LaTeX commands. \newcommand{\Rmodels}{\textbf{\textsf{R models}}\xspace} \newcommand{\DLLmodels}{\textbf{\textsf{DLL models}}\xspace} \title{\proglang{R} Package \pkg{deSolve}, Writing Code in Compiled Languages} \Plaintitle{R Package deSolve, Writing Code in Compiled Languages} \Keywords{differential equation solvers, compiled code, performance, \proglang{FORTRAN}, \proglang{C}} \Plainkeywords{differential equation solvers, compiled code, performance, FORTRAN, C} \author{ Karline Soetaert\\ Royal Netherlands Institute\\ of Sea Research (NIOZ)\\ Yerseke\\ The Netherlands \And Thomas Petzoldt\\ Technische Universit\"at \\ Dresden\\ Germany \And R. Woodrow Setzer\\ National Center for\\ Computational Toxicology\\ US Environmental Protection Agency } \Plainauthor{Karline Soetaert, Thomas Petzoldt, R. Woodrow Setzer} \Abstract{This document describes how to use the \pkg{deSolve} package \citep{deSolve_jss} to solve models that are written in \proglang{FORTRAN} or \proglang{C}.} %% The address of (at least) one author should be given %% in the following format: \Address{ Karline Soetaert\\ Royal Netherlands Institute of Sea Research (NIOZ)\\ 4401 NT Yerseke, Netherlands \\ E-mail: \email{karline.soetaert@nioz.nl}\\ URL: \url{http://www.nioz.nl}\\ \\ Thomas Petzoldt\\ Institut f\"ur Hydrobiologie\\ Technische Universit\"at Dresden\\ 01062 Dresden, Germany\\ E-mail: \email{thomas.petzoldt@tu-dresden.de}\\ URL: \url{http://tu-dresden.de/Members/thomas.petzoldt/}\\ \\ R. Woodrow Setzer\\ National Center for Computational Toxicology\\ US Environmental Protection Agency\\ URL: \url{http://www.epa.gov/comptox} } %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% R/Sweave specific LaTeX commands. %% need no \usepackage{Sweave} %\VignetteIndexEntry{R Package deSolve: Writing Code in Compiled Languages} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Begin of the document \begin{document} \SweaveOpts{engine=R,eps=FALSE} <>= library("deSolve") options(prompt = "R> ") options(width=70) @ \maketitle \section{Introduction} \pkg{deSolve} \citep{deSolve_jss,deSolve}, the successor of \proglang{R} package \pkg{odesolve} \citep{Setzer01} is a package to solve ordinary differential equations (ODE), differential algebraic equations (DAE) and partial differential equations (PDE). One of the prominent features of \pkg{deSolve} is that it allows specifying the differential equations either as: \begin{itemize} \item pure \proglang{R} code \citep{Rcore}, \item functions defined in lower-level languages such as \proglang{FORTRAN}, \proglang{C}, or \proglang{C++}, which are compiled into a dynamically linked library (DLL) and loaded into \proglang{R}. \end{itemize} In what follows, these implementations will be referred to as \Rmodels and \DLLmodels respectively. Whereas \Rmodels are easy to implement, they allow simple interactive development, produce highly readible code and access to \proglang{R}s high-level procedures, \DLLmodels have the benefit of increased simulation speed. Depending on the problem, there may be a gain of up to several orders of magnitude computing time when using compiled code. Here are some rules of thumb when it is worthwhile or not to switch to \DLLmodels: \begin{itemize} \item As long as one makes use only of \proglang{R}s high-level commands, the time gain will be modest. This was demonstrated in \citet{deSolve_jss}, where a formulation of two interacting populations dispersing on a 1-dimensional or a 2-dimensional grid led to a time gain of a factor two only when using \DLLmodels. \item Generally, the more statements in the model, the higher will be the gain of using compiled code. Thus, in the same paper \citep{deSolve_jss}, a very simple, 0-D, Lotka-Volterrra type of model describing only 2 state variables was solved 50 times faster when using compiled code. \item As even \Rmodels are quite performant, the time gain induced by compiled code will often not be discernible when the model is only solved once (who can grasp the difference between a run taking 0.001 or 0.05 seconds to finish). However, if the model is to be applied multiple times, e.g. because the model is to be fitted to data, or its sensitivity is to be tested, then it may be worthwhile to implement the model in a compiled language. \end{itemize} Starting from \pkg{deSolve} version 1.4, it is now also possible to use \emph{forcing functions} in compiled code. These forcing functions are automatically updated by the integrators. See last chapter. \section{A simple ODE example} Assume the following simple ODE (which is from the \code{LSODA} source code): \begin{align*} \frac{{dy_1}}{{dt}} &= - k_1 \cdot y_1 + k_2 \cdot y_2 \cdot y_3 \\ \frac{{dy_2}}{{dt}} &= k_1 \cdot y_1 - k_2 \cdot y_2 \cdot y_3 - k_3 \cdot y_2 \cdot y_2 \\ \frac{{dy_3}}{{dt}} &= k_3 \cdot y_2 \cdot y_2 \\ \end{align*} where $y_1$, $y_2$ and $y_3$ are state variables, and $k_1$, $k_2$ and $k_3$ are parameters. We first implement and run this model in pure \proglang{R}, then show how to do this in \proglang{C} and in \proglang{FORTRAN}. \subsection{ODE model implementation in R} An ODE model implemented in \textbf{pure \proglang{R}} should be defined as: \begin{verbatim} yprime = func(t, y, parms, ...) \end{verbatim} where \code{t} is the current time point in the integration, \code{y} is the current estimate of the variables in the ODE system, and \code{parms} is a vector or list containing the parameter values. The optional dots argument (\code{\dots}) can be used to pass any other arguments to the function. The return value of \code{func} should be a list, whose first element is a vector containing the derivatives of \code{y} with respect to time, and whose next elements contain output variables that are required at each point in time. The \proglang{R} implementation of the simple ODE is given below: <>= model <- function(t, Y, parameters) { with (as.list(parameters),{ dy1 = -k1*Y[1] + k2*Y[2]*Y[3] dy3 = k3*Y[2]*Y[2] dy2 = -dy1 - dy3 list(c(dy1, dy2, dy3)) }) } @ The Jacobian ($\frac{{\partial y'}}{{\partial y}}$) associated to the above example is: <>= jac <- function (t, Y, parameters) { with (as.list(parameters),{ PD[1,1] <- -k1 PD[1,2] <- k2*Y[3] PD[1,3] <- k2*Y[2] PD[2,1] <- k1 PD[2,3] <- -PD[1,3] PD[3,2] <- k3*Y[2] PD[2,2] <- -PD[1,2] - PD[3,2] return(PD) }) } @ This model can then be run as follows: <>= parms <- c(k1 = 0.04, k2 = 1e4, k3=3e7) Y <- c(1.0, 0.0, 0.0) times <- c(0, 0.4*10^(0:11)) PD <- matrix(nrow = 3, ncol = 3, data = 0) out <- ode(Y, times, model, parms = parms, jacfunc = jac) @ \subsection{ODE model implementation in C} \label{sec:Cexamp} In order to create compiled models (.DLL = dynamic link libraries on Windows or .so = shared objects on other systems) you must have a recent version of the GNU compiler suite installed, which is quite standard for Linux. Windows users find all the required tools on \url{http://www.murdoch-sutherland.com/Rtools/}. Getting DLLs produced by other compilers to communicate with R is much more complicated and therefore not recommended. More details can be found on \url{http://cran.r-project.org/doc/manuals/R-admin.html}. The call to the derivative and Jacobian function is more complex for compiled code compared to \proglang{R}-code, because it has to comply with the interface needed by the integrator source codes. Below is an implementation of this model in \proglang{C}: \verbatiminput{mymod.c} The implementation in \proglang{C} consists of three parts: \begin{enumerate} \item After defining the parameters in global \proglang{C}-variables, through the use of \code{\#define} statements, a function called \code{initmod} initialises the parameter values, passed from the \proglang{R}-code. This function has as its sole argument a pointer to \proglang{C}-function \code{odeparms} that fills a double array with double precision values, to copy the parameter values into the global variable. \item Function \code{derivs} then calculates the values of the derivatives. The derivative function is defined as: \begin{verbatim} void derivs (int *neq, double *t, double *y, double *ydot, double *yout, int *ip) \end{verbatim} where \code{*neq} is the number of equations, \code{*t} is the value of the independent variable, \code{*y} points to a double precision array of length \code{*neq} that contains the current value of the state variables, and \code{*ydot} points to an array that will contain the calculated derivatives. \code{*yout} points to a double precision vector whose first \code{nout} values are other output variables (different from the state variables \code{y}), and the next values are double precision values as passed by parameter \code{rpar} when calling the integrator. The key to the elements of \code{*yout} is set in \code{*ip} \code{*ip} points to an integer vector whose length is at least 3; the first element (\code{ip[0]}) contains the number of output values (which should be equal or larger than \code{nout}), its second element contains the length of \code{*yout}, and the third element contains the length of \code{*ip}; next are integer values, as passed by parameter \code{ipar} when calling the integrator.\footnote{Readers familiar with the source code of the \pkg{ODEPACK} solvers may be surprised to find the double precision vector \code{yout} and the integer vector \code{ip} at the end. Indeed none of the \pkg{ODEPACK} functions allow this, although it is standard in the \code{vode} and \code{daspk} codes. To make all integrators compatible, we have altered the \pkg{ODEPACK} \proglang{FORTRAN} codes to consistently pass these vectors.} Note that, in function \code{derivs}, we start by checking whether enough memory is allocated for the output variables (\code{if (ip[0] < 1)}), else an error is passed to \proglang{R} and the integration is stopped. \item In \proglang{C}, the call to the function that generates the Jacobian is as: \begin{verbatim} void jac(int *neq, double *t, double *y, int *ml, int *mu, double *pd, int *nrowpd, double *yout, int *ip) \end{verbatim} where \code{*ml} and \code{*mu} are the number of non-zero bands below and above the diagonal of the Jacobian respectively. These integers are only relevant if the option of a banded Jacobian is selected. \code{*nrow} contains the number of rows of the Jacobian. Only for full Jacobian matrices, is this equal to \code{*neq}. In case the Jacobian is banded, the size of \code{*nrowpd} depends on the integrator. If the method is one of \code{lsode, lsoda, vode}, then \code{*nrowpd} will be equal to \code{*mu + 2 * *ml + 1}, where the last \code{*ml} rows should be filled with $0$s. For \code{radau}, \code{*nrowpd} will be equal to \code{*mu + *ml + 1} See example ``odeband'' in the directory \url{doc/examples/dynload}, and chapter \ref{band}. \end{enumerate} \subsection{ODE model implementation in FORTRAN} \label{sec:forexamp} Models may also be defined in \proglang{FORTRAN}. \verbatiminput{mymod.f} In \proglang{FORTRAN}, parameters may be stored in a common block (here called \code{myparms}). During the initialisation, this common block is defined to consist of a 3-valued vector (unnamed), but in the subroutines \code{derivs} and \code{jac}, the parameters are given a name (\code{k1}, ...). \subsection{Running ODE models implemented in compiled code} To run the models described above, the code in \code{mymod.f} and \code{mymod.c} must first be compiled\footnote{This requires a correctly installed GNU compiler, see above.}. This can simply be done in \proglang{R} itself, using the \code{system} command: <>= system("R CMD SHLIB mymod.f") @ for the \proglang{FORTRAN} code or <>= system("R CMD SHLIB mymod.c") @ for the \proglang{C} code. This will create file \code{mymod.dll} on windows, or \code{mymod.so} on other platforms. We load the DLL, in windows as: \begin{verbatim} dyn.load("mymod.dll") \end{verbatim} and in unix: \begin{verbatim} dyn.load("mymod.so") \end{verbatim} or, using a general statement: \begin{verbatim} dyn.load(paste("mymod", .Platform$dynlib.ext, sep = "")) \end{verbatim} The model can now be run as follows: \begin{verbatim} parms <- c(k1 = 0.04, k2 = 1e4, k3=3e7) Y <- c(y1 = 1.0, y2 = 0.0, y3 = 0.0) times <- c(0, 0.4*10^(0:11) ) out <- ode(Y, times, func = "derivs", parms = parms, jacfunc = "jac", dllname = "mymod", initfunc = "initmod", nout = 1, outnames = "Sum") \end{verbatim} The integration routine (here \code{ode}) recognizes that the model is specified as a DLL due to the fact that arguments \code{func} and \code{jacfunc} are not regular \proglang{R}-functions but character strings. Thus, the integrator will check whether the function is loaded in the DLL with name \code{mymod}. Note that \code{mymod}, as specified by \code{dllname} gives the name of the shared library \emph{without extension}. This DLL should contain all the compiled function or subroutine definitions referred to in \code{func}, \code{jacfunc} and \code{initfunc}. Also, if \code{func} is specified in compiled code, then \code{jacfunc} and \code{initfunc} (if present) should also be specified in a compiled language. It is not allowed to mix \proglang{R}-functions and compiled functions. Note also that, when invoking the integrator, we have to specify the number of ordinary output variables, \code{nout}. This is because the integration routine has to allocate memory to pass these output variables back to \proglang{R}. There is no way to check for the number of output variables in a DLL automatically. If in the calling of the integration routine the number of output variables is too low, then \proglang{R} may freeze and need to be terminated! Therefore it is advised that one checks in the code whether \code{nout} has been specified correctly. In the \proglang{FORTRAN} example above, the statement \code{if (ip(1) < 1) call rexit("nout should be at least 1")} does this. Note that it is not an error (just a waste of memory) to set \code{nout} to a too large value. Finally, in order to label the output matrix, the names of the ordinary output variables have to be passed explicitly (\code{outnames}). This is not necessary for the state variables, as their names are known through their initial condition (\code{y}). \section{Alternative way of passing parameters and data in compiled code} \label{sec:parms} All of the solvers in \pkg{deSolve} take an argument \code{parms} which may be an arbitrary \proglang{R} object. In models defined in \proglang{R} code, this argument is passed unprocessed to the various functions that make up the model. It is possible, as well, to pass such R-objects to models defined in native code. The problem is that data passed to, say, \code{ode} in the argument \code{parms} is not visible by default to the routines that define the model. This is handled by a user-written initialization function, for example \code{initmod} in the \proglang{C} and \proglang{FORTRAN} examples from sections \ref{sec:Cexamp} and \ref{sec:forexamp}. However, these set only the \emph{values} of the parameters. R-objects have many attributes that may also be of interest. To have access to these, we need to do more work, and this mode of passing parameters and data is much more complex than what we saw in previous chapters. In \proglang{C}, the initialization routine is declared: \begin{verbatim} void initmod(void (* odeparms)(int *, double *)); \end{verbatim} That is, \code{initmod} has a single argument, a pointer to a function that has as arguments a pointer to an \texttt{int} and a pointer to a \texttt{double}. In \proglang{FORTRAN}, the initialization routine has a single argument, a subroutine declared to be external. The name of the initialization function is passed as an argument to the \pkg{deSolve} solver functions. In \proglang{C}, two approaches are available for making the values passed in \code{parms} visible to the model routines, while only the simpler approach is available in \proglang{FORTRAN}. The simpler requires that \code{parms} be a numeric vector. In \proglang{C}, the function passed from \pkg{deSolve} to the initialization function (called \code{odeparms} in the example) copies the values from the parameter vector to a static array declared globally in the file where the model is defined. In \proglang{FORTRAN}, the values are copied into a \code{COMMON} block. It is possible to pass more complicated structures to \proglang{C} functions. Here is an example, an initializer called \code{deltamethrin} from a model describing the pharmacokinetics of that pesticide: \begin{verbatim} #include #include #include #include "deltamethrin.h" /* initializer */ void deltamethrin(void(* odeparms)(int *, double *)) { int Nparms; DL_FUNC get_deSolve_gparms; SEXP gparms; get_deSolve_gparms = R_GetCCallable("deSolve","get_deSolve_gparms"); gparms = get_deSolve_gparms(); Nparms = LENGTH(gparms); if (Nparms != N_PARMS) { PROBLEM "Confusion over the length of parms" ERROR; } else { _RDy_deltamethrin_parms = REAL(gparms); } } \end{verbatim} In \texttt{deltamethrin.h}, the variable \code{\_RDy\_deltamethrin\_parms} and macro N\_PARMS are declared: \begin{verbatim} #define N_PARMS 63 static double *_RDy_deltamethrin_parms; \end{verbatim} The critical element of this method is the function \code{R\_GetCCallable} which returns a function (called \code{get\_deSolve\_gparms} in this implementation) that returns the parms argument as a \code{SEXP} data type. In this example, \code{parms} was just a real vector, but in principle, this method can handle arbitrarily complex objects. For more detail on handling \proglang{R} objects in native code, see \proglang{R} Development Core Team (2008). \section{deSolve integrators that support DLL models} In the most recent version of \pkg{deSolve} all integration routines can solve \DLLmodels. They are: \begin{itemize} \item all solvers of the \code{lsode} familiy: \code{lsoda}, \code{lsode}, \code{lsodar}, \code {lsodes}, \item \code{vode}, \code{zvode}, \item \code{daspk}, \item \code{radau}, \item the Runge-Kutta integration routines (including the Euler method). \end{itemize} For some of these solvers the interface is slightly different (e.g. \code{zvode, daspk}), while in others (\code{lsodar}, \code{lsodes}) different functions can be defined. How this is implemented in a compiled language is discussed next. \subsection{Complex numbers, function zvode} \code{zvode} solves ODEs that are composed of complex variables. The program below uses \code{zvode} to solve the following system of 2 ODEs: \begin{align*} \frac{{dz}}{{dt}} &= i \cdot z\\ \frac{{dw}}{{dt}} &= -i \cdot w \cdot w \cdot z\\ \end{align*} where \begin{align*} w(0) = 1/2.1 +0i\\ z(0) = 1i \end{align*} on the interval t = [0, 2 $\pi$] The example is implemented in \proglang{FORTRAN}% \footnote{this can be found in file "zvodedll.f", in the dynload subdirectory of the package}, \code{FEX} implements the function \code{func}: \begin{verbatim} SUBROUTINE FEX (NEQ, T, Y, YDOT, RPAR, IPAR) INTEGER NEQ, IPAR(*) DOUBLE COMPLEX Y(NEQ), YDOT(NEQ), RPAR(*), CMP DOUBLE PRECISION T character(len=100) msg c the imaginary unit i CMP = DCMPLX(0.0D0,1.0D0) YDOT(1) = CMP*Y(1) YDOT(2) = -CMP*Y(2)*Y(2)*Y(1) RETURN END \end{verbatim} \code{JEX} implements the function \code{jacfunc} \begin{verbatim} SUBROUTINE JEX (NEQ, T, Y, ML, MU, PD, NRPD, RPAR, IPAR) INTEGER NEQ, ML, MU, NRPD, IPAR(*) DOUBLE COMPLEX Y(NEQ), PD(NRPD,NEQ), RPAR(*), CMP DOUBLE PRECISION T c the imaginary unit i CMP = DCMPLX(0.0D0,1.0D0) PD(2,3) = -2.0D0*CMP*Y(1)*Y(2) PD(2,1) = -CMP*Y(2)*Y(2) PD(1,1) = CMP RETURN END \end{verbatim} Assuming this code has been compiled and is in a DLL called "zvodedll.dll", this model is solved in R as follows: \begin{verbatim} dyn.load("zvodedll.dll") outF <- zvode(func = "fex", jacfunc = "jex", y = yini, parms = NULL, times = times, atol = 1e-10, rtol = 1e-10, dllname = "zvodedll", initfunc = NULL) \end{verbatim} Note that in \proglang{R} names of \proglang{FORTRAN} DLL functions (e.g. for \code{func} and \code{jacfunc}) have to be given in lowercase letters, even if they are defined upper case in \proglang{FORTRAN}. Also, there is no initialiser function here (\code{initfunc = NULL}). \subsection{DAE models, integrator daspk} \code{daspk} is one of the integrators in the package that solve DAE models. In order to be used with DASPK, DAEs are specified in implicit form: \[0 = F(t, y, y', p)\] i.e. the DAE function (passed via argument \code{res}) specifies the ``residuals'' rather than the derivatives (as for ODEs). Consequently the DAE function specification in a compiled language is also different. For code written in \proglang{C}, the calling sequence for \code{res} must be: \begin{verbatim} void myres(double *t, double *y, double *ydot, double *cj, double *delta, int *ires, double *yout, int *ip) \end{verbatim} where \code{*t} is the value of the independent variable, \code{*y} points to a double precision vector that contains the current value of the state variables, \code{*ydot} points to an array that will contain the derivatives, \code{*delta} points to a vector that will contain the calculated residuals. \code{*cj} points to a scalar, which is normally proportional to the inverse of the stepsize, while \code{*ires} points to an integer (not used). \code{*yout} points to any other output variables (different from the state variables y), followed by the double precision values as passed via argument \code{rpar}; finally \code{*ip} is an integer vector containing at least 3 elements, its first value (\code{*ip[0]}) equals the number of output variables, calculated in the function (and which should be equal to \code{nout}), its second element equals the total length of \code{*yout}, its third element equals the total length of \code{*ip}, and finally come the integer values as passed via argument \code{ipar}. For code written in \proglang{FORTRAN}, the calling sequence for \code{res} must be as in the following example: \begin{verbatim} subroutine myresf(t, y, ydot, cj, delta, ires, out, ip) integer :: ires, ip(*) integer, parameter :: neq = 3 double precision :: t, y(neq), ydot(neq), delta(neq), out(*) double precision :: K, ka, r, prod, ra, rb common /myparms/K,ka,r,prod if(ip(1) < 1) call rexit("nout should be at least 1") ra = ka* y(3) rb = ka/K *y(1) * y(2) !! residuals of rates of changes delta(3) = -ydot(3) - ra + rb + prod delta(1) = -ydot(1) + ra - rb delta(2) = -ydot(2) + ra - rb - r*y(2) out(1) = y(1) + y(2) + y(3) return end \end{verbatim} Similarly as for the ODE model discussed above, the parameters are kept in a common block which is initialised by an initialiser subroutine: \begin{verbatim} subroutine initpar(daspkparms) external daspkparms integer, parameter :: N = 4 double precision parms(N) common /myparms/parms call daspkparms(N, parms) return end \end{verbatim} See the ODE example for how to initialise parameter values in \proglang{C}. Similarly, the function that specifies the Jacobian in a DAE differs from the Jacobian when the model is an ODE. The DAE Jacobian is set with argument \code{jacres} rather than \code{jacfunc} when an ODE. For code written in \proglang{FORTRAN}, the \code{jacres} must be as: \begin{verbatim} subroutine resjacfor (t, y, dy, pd, cj, out, ipar) integer, parameter :: neq = 3 integer :: ipar(*) double precision :: K, ka, r, prod double precision :: pd(neq,neq),y(neq),dy(neq),out(*) common /myparms/K,ka,r,prod !res1 = -dD - ka*D + ka/K *A*B + prod PD(1,1) = ka/K *y(2) PD(1,2) = ka/K *y(1) PD(1,3) = -ka -cj !res2 = -dA + ka*D - ka/K *A*B PD(2,1) = -ka/K *y(2) -cj PD(2,2) = -ka/K *y(2) PD(2,3) = ka !res3 = -dB + ka*D - ka/K *A*B - r*B PD(3,1) = -ka/K *y(2) PD(3,2) = -ka/K *y(2) -r -cj PD(3,3) = ka return end \end{verbatim} \subsection{DAE models, integrator radau} Function \code{radau} solves DAEs in linearly implicit form, i.e. in the form $M y' = f(t, y, p)$. The derivative function $f$ is specified in the same way as for an ODE, i.e. \begin{verbatim} void derivs (int *neq, double *t, double *y, double *ydot, double *yout, int *ip) \end{verbatim} and \begin{verbatim} subroutine derivs (neq, t, y, ydot, out, IP) \end{verbatim} for \proglang{C} and \proglang{FORTRAN} code respectively. To show how it should be used, we implement the caraxis problem as in \citep{testset}. The implementation of this index 3 DAE, comprising 8 differential, and 2 algebraic equations in R is the last example of the \code{radau} help page. We first repeat the R implementation: <<>>= caraxisfun <- function(t, y, parms) { with(as.list(c(y, parms)), { yb <- r * sin(w * t) xb <- sqrt(L * L - yb * yb) Ll <- sqrt(xl^2 + yl^2) Lr <- sqrt((xr - xb)^2 + (yr - yb)^2) dxl <- ul; dyl <- vl; dxr <- ur; dyr <- vr dul <- (L0-Ll) * xl/Ll + 2 * lam2 * (xl-xr) + lam1*xb dvl <- (L0-Ll) * yl/Ll + 2 * lam2 * (yl-yr) + lam1*yb - k * g dur <- (L0-Lr) * (xr-xb)/Lr - 2 * lam2 * (xl-xr) dvr <- (L0-Lr) * (yr-yb)/Lr - 2 * lam2 * (yl-yr) - k * g c1 <- xb * xl + yb * yl c2 <- (xl - xr)^2 + (yl - yr)^2 - L * L list(c(dxl, dyl, dxr, dyr, dul, dvl, dur, dvr, c1, c2)) }) } eps <- 0.01; M <- 10; k <- M * eps^2/2; L <- 1; L0 <- 0.5; r <- 0.1; w <- 10; g <- 1 parameter <- c(eps = eps, M = M, k = k, L = L, L0 = L0, r = r, w = w, g = g) yini <- c(xl = 0, yl = L0, xr = L, yr = L0, ul = -L0/L, vl = 0, ur = -L0/L, vr = 0, lam1 = 0, lam2 = 0) # the mass matrix Mass <- diag(nrow = 10, 1) Mass[5,5] <- Mass[6,6] <- Mass[7,7] <- Mass[8,8] <- M * eps * eps/2 Mass[9,9] <- Mass[10,10] <- 0 Mass # index of the variables: 4 of index 1, 4 of index 2, 2 of index 3 index <- c(4, 4, 2) times <- seq(0, 3, by = 0.01) out <- radau(y = yini, mass = Mass, times = times, func = caraxisfun, parms = parameter, nind = index) @ <>= plot(out, which = 1:4, type = "l", lwd = 2) @ \setkeys{Gin}{width=0.8\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{Solution of the caraxis model - see text for R-code} \label{fig:caraxis} \end{figure} The implementation in \proglang{FORTRAN} consists of an initialiser function and a derivative function. \begin{verbatim} c---------------------------------------------------------------- c Initialiser for parameter common block c---------------------------------------------------------------- subroutine initcaraxis(daeparms) external daeparms integer, parameter :: N = 8 double precision parms(N) common /myparms/parms call daeparms(N, parms) return end c---------------------------------------------------------------- c rate of change c---------------------------------------------------------------- subroutine caraxis(neq, t, y, ydot, out, ip) implicit none integer neq, IP(*) double precision t, y(neq), ydot(neq), out(*) double precision eps, M, k, L, L0, r, w, g common /myparms/ eps, M, k, L, L0, r, w, g double precision xl, yl, xr, yr, ul, vl, ur, vr, lam1, lam2 double precision yb, xb, Ll, Lr, dxl, dyl, dxr, dyr double precision dul, dvl, dur, dvr, c1, c2 c expand state variables xl = y(1) yl = y(2) xr = y(3) yr = y(4) ul = y(5) vl = y(6) ur = y(7) vr = y(8) lam1 = y(9) lam2 = y(10) yb = r * sin(w * t) xb = sqrt(L * L - yb * yb) Ll = sqrt(xl**2 + yl**2) Lr = sqrt((xr - xb)**2 + (yr - yb)**2) dxl = ul dyl = vl dxr = ur dyr = vr dul = (L0-Ll) * xl/Ll + 2 * lam2 * (xl-xr) + lam1*xb dvl = (L0-Ll) * yl/Ll + 2 * lam2 * (yl-yr) + lam1*yb - k*g dur = (L0-Lr) * (xr-xb)/Lr - 2 * lam2 * (xl-xr) dvr = (L0-Lr) * (yr-yb)/Lr - 2 * lam2 * (yl-yr) - k*g c1 = xb * xl + yb * yl c2 = (xl - xr)**2 + (yl - yr)**2 - L * L c function values in ydot ydot(1) = dxl ydot(2) = dyl ydot(3) = dxr ydot(4) = dyr ydot(5) = dul ydot(6) = dvl ydot(7) = dur ydot(8) = dvr ydot(9) = c1 ydot(10) = c2 return end \end{verbatim} Assuming that the code is in file ``radaudae.f'', this model is compiled, loaded and solved in R as: \begin{verbatim} system("R CMD SHLIB radaudae.f") dyn.load(paste("radaudae", .Platform$dynlib.ext, sep = "")) outDLL <- radau(y = yini, mass = Mass, times = times, func = "caraxis", initfunc = "initcaraxis", parms = parameter, dllname = "radaudae", nind = index) dyn.unload(paste("radaudae", .Platform$dynlib.ext, sep = "")) \end{verbatim} \subsection{The root function from integrators lsodar and lsode} \code{lsodar} is an extended version of integrator \code{lsoda} that includes a root finding function. This function is spedified via argument \code{rootfunc}. In \code{deSolve} version 1.7, \code{lsode} has also been extended with root finding capabilities. Here is how to program such a function in a lower-level language. For code written in \proglang{C}, the calling sequence for \code{rootfunc} must be: \begin{verbatim} void myroot(int *neq, double *t, double *y, int *ng, double *gout, double *out, int *ip ) \end{verbatim} where \code{*neq} and \code{*ng} are the number of state variables and root functions respectively, \code{*t} is the value of the independent variable, \code{y} points to a double precision array that contains the current value of the state variables, and \code{gout} points to an array that will contain the values of the constraint function whose root is sought. \code{*out} and \code{*ip} are a double precision and integer vector respectively, as described in the ODE example above. For code written in \proglang{FORTRAN}, the calling sequence for \code{rootfunc} must be as in following example: \begin{verbatim} subroutine myroot(neq, t, y, ng, gout, out, ip) integer :: neq, ng, ip(*) double precision :: t, y(neq), gout(ng), out(*) gout(1) = y(1) - 1.e-4 gout(2) = y(3) - 1e-2 return end \end{verbatim} \subsection{jacvec, the Jacobian vector for integrator lsodes} Finally, in integration function \code{lsodes}, not the Jacobian \emph{matrix} is specified, but a \emph{vector}, one for each column of the Jacobian. This function is specified via argument \code{jacvec}. In \proglang{FORTRAN}, the calling sequence for \code{jacvec} is: \begin{verbatim} SUBROUTINE JAC (NEQ, T, Y, J, IAN, JAN, PDJ, OUT, IP) DOUBLE PRECISION T, Y(*), IAN(*), JAN(*), PDJ(*), OUT(*) INTEGER NEQ, J, IP(*) \end{verbatim} \subsection{Banded jacobians in compiled code}\label{band} In the call of the jacobian function, the number of bands below and above the diagonal (\code{ml, mu}) and the number of rows of the Jacobian matrix, \code{nrowPD} is specified, e.g. for \proglang{FORTRAN} code: \begin{verbatim} SUBROUTINE JAC (neq, T, Y, ml, mu, PD, nrowPD, RPAR, IPAR) \end{verbatim} The jacobian matrix to be returned should have dimension \code{nrowPD, neq}. In case the Jacobian is banded, the size of \code{nrowPD} depends on the integrator. If the method is one of \code{lsode, lsoda, vode}, or related, then \code{nrowPD} will be equal to \code{mu + 2 * ml + 1}, where the last ml rows should be filled with $0$s. For \code{radau}, \code{nrowpd} will be equal to \code{mu + ml + 1} Thus, it is important to write the FORTRAN or C-code in such a way that it can be used with both types of integrators - else it is likely that R will freeze if the wrong integrator is used. We implement in FORTRAN, the example of the \code{lsode} help file. The R-code reads: <<>>= ## the model, 5 state variables f1 <- function (t, y, parms) { ydot <- vector(len = 5) ydot[1] <- 0.1*y[1] -0.2*y[2] ydot[2] <- -0.3*y[1] +0.1*y[2] -0.2*y[3] ydot[3] <- -0.3*y[2] +0.1*y[3] -0.2*y[4] ydot[4] <- -0.3*y[3] +0.1*y[4] -0.2*y[5] ydot[5] <- -0.3*y[4] +0.1*y[5] return(list(ydot)) } ## the Jacobian, written in banded form bandjac <- function (t, y, parms) { jac <- matrix(nrow = 3, ncol = 5, byrow = TRUE, data = c( 0 , -0.2, -0.2, -0.2, -0.2, 0.1, 0.1, 0.1, 0.1, 0.1, -0.3, -0.3, -0.3, -0.3, 0)) return(jac) } ## initial conditions and output times yini <- 1:5 times <- 1:20 ## stiff method, user-generated banded Jacobian out <- lsode(yini, times, f1, parms = 0, jactype = "bandusr", jacfunc = bandjac, bandup = 1, banddown = 1) @ In FORTRAN, the code might look like this: \begin{verbatim} c Rate of change subroutine derivsband (neq, t, y, ydot,out,IP) integer neq, IP(*) DOUBLE PRECISION T, Y(5), YDOT(5), out(*) ydot(1) = 0.1*y(1) -0.2*y(2) ydot(2) = -0.3*y(1) +0.1*y(2) -0.2*y(3) ydot(3) = -0.3*y(2) +0.1*y(3) -0.2*y(4) ydot(4) = -0.3*y(3) +0.1*y(4) -0.2*y(5) ydot(5) = -0.3*y(4) +0.1*y(5) RETURN END c The banded jacobian subroutine jacband (neq, t, y, ml, mu, pd, nrowpd, RP, IP) INTEGER neq, ml, mu, nrowpd, ip(*) DOUBLE PRECISION T, Y(5), PD(nrowpd,5), rp(*) PD(:,:) = 0.D0 PD(1,1) = 0.D0 PD(1,2) = -.02D0 PD(1,3) = -.02D0 PD(1,4) = -.02D0 PD(1,5) = -.02D0 PD(2,:) = 0.1D0 PD(3,1) = -0.3D0 PD(3,2) = -0.3D0 PD(3,3) = -0.3D0 PD(3,4) = -0.3D0 PD(3,5) = 0.D0 RETURN END \end{verbatim} Assuming that this code is in file \code{"odeband.f"}, we compile from within R and load the shared library (assuming the working directory holds the source file) with: \begin{verbatim} system("R CMD SHLIB odeband.f") dyn.load(paste("odeband", .Platform$dynlib.ext, sep = "")) \end{verbatim} To solve this problem, we write in R \begin{verbatim} out2 <- lsode(yini, times, "derivsband", parms = 0, jactype = "bandusr", jacfunc = "jacband", bandup = 1, banddown = 1, dllname = "odeband") out2 <- radau(yini, times, "derivsband", parms = 0, jactype = "bandusr", jacfunc = "jacband", bandup = 1, banddown = 1, dllname = "odeband") \end{verbatim} This will work both for the \code{lsode} family as for \code{radau}. In the first case, when entering subroutine \code{jacband}, \code{nrowpd} will have the value $5$, in the second case, it will be equal to $4$. \section{Testing functions written in compiled code} Two utilities have been included to test the function implementation in compiled code: \begin{itemize} \item \code{DLLfunc} to test the implementation of the derivative function as used in ODEs. This function returns the derivative $\frac{dy}{dt}$ and the output variables. \item \code{DLLres} to test the implementation of the residual function as used in DAEs. This function returns the residual function $\frac{dy}{dt}-f(y,t)$ and the output variables. \end{itemize} These functions serve no other purpose than to test whether the compiled code returns what it should. \subsection{DLLfunc} We test whether the ccl4 model, which is part of \code{deSolve} package, returns the proper rates of changes. (Note: see \code{example(ccl4model)} for a more comprehensive implementation) <<>>= ## Parameter values and initial conditions Parms <- c(0.182, 4.0, 4.0, 0.08, 0.04, 0.74, 0.05, 0.15, 0.32, 16.17, 281.48, 13.3, 16.17, 5.487, 153.8, 0.04321671, 0.4027255, 1000, 0.02, 1.0, 3.8) yini <- c( AI=21, AAM=0, AT=0, AF=0, AL=0, CLT=0, AM=0 ) ## the rate of change DLLfunc(y = yini, dllname = "deSolve", func = "derivsccl4", initfunc = "initccl4", parms = Parms, times = 1, nout = 3, outnames = c("DOSE", "MASS", "CP") ) @ \subsection{DLLres} The deSolve package contains a FORTRAN implementation of the chemical model described above (section 4.1), where the production rate is included as a forcing function (see next section). Here we use \code{DLLres} to test it: <<>>= pars <- c(K = 1, ka = 1e6, r = 1) ## Initial conc; D is in equilibrium with A,B y <- c(A = 2, B = 3, D = 2*3/pars["K"]) ## Initial rate of change dy <- c(dA = 0, dB = 0, dD = 0) ## production increases with time prod <- matrix(nc=2,data=c(seq(0,100,by=10),seq(0.1,0.5,len=11))) DLLres(y=y,dy=dy,times=5,res="chemres", dllname="deSolve", initfunc="initparms", initforc="initforcs", parms=pars, forcings=prod, nout=2, outnames=c("CONC","Prod")) @ \section{Using forcing functions} Forcing functions in DLLs are implemented in a similar way as parameters. This means: \begin{itemize} \item They are initialised by means of an initialiser function. Its name should be passed to the solver via argument \code{initforc}. Similar as the parameter initialiser function, the function denoted by \code{initforc} has as its sole argument a pointer to the vector that contains the forcing funcion values in the compiled code. In case of \proglang{C} code, this will be a global vector; in case of \proglang{FORTRAN}, this will be a vector in a common block. The solver puts a pointer to this vector and updates the forcing functions in this memory area at each time step. Hence, within the compiled code, forcing functions can be assessed as if they are parameters (although, in contrast to the latter, their values will generally change). No need to update the values for the current time step; this has been done before entering the \code{derivs} function. \item The forcing function data series are passed to the integrator, via argument \code{forcings}; if there is only one forcing function data set, then a 2-columned matrix (time, value) will do; else the data should be passed as a list, containing (time, value) matrices with the individual forcing function data sets. Note that the data sets in this list should be \emph{in the same ordering} as the declaration of the forcings in the compiled code. \end{itemize} A number of options allow to finetune certain settings. They are in a list called \code{fcontrol} which can be supplied as argument when calling the solvers. The options are similar to the arguments from R function \code{approx}, howevers the default settings are often different. The following options can be specified: \begin{itemize} \item \code{method} specifies the interpolation method to be used. Choices are "linear" or "constant", the default is "linear", which means linear interpolation (same as \code{approx}) \item \code{rule}, an integer describing how interpolation is to take place \emph{outside} the interval [min(times), max(times)]. If \code{rule} is \code{1} then an error will be triggered and the calculation will stop if extrapolation is necessary. If it is \code{2}, the default, the value at the closest data extreme is used, a warning will be printed if \code{verbose} is TRUE. Note that the default differs from the \code{approx} default. \item \code{f}, for method=\code{"constant"} is a number between \code{0} and \code{1} inclusive, indicating a compromise between left- and right-continuous step functions. If \code{y0} and \code{y1} are the values to the left and right of the point then the value is \code{y0*(1-f)+y1*f} so that \code{f=0} is right-continuous and \code{f=1} is left-continuous. The default is to have \code{f=0}. For some data sets it may be more realistic to set \code{f=0.5}. \item \code{ties}, the handling of tied \code{times} values. Either a function with a single vector argument returning a single number result or the string "ordered". Note that the default is "ordered", hence the existence of ties will NOT be investigated; in practice this means that, if ties exist, the first value will be used; if the dataset is not ordered, then nonsense will be produced. Alternative values for \code{ties} are \code{mean}, \code{min} etc... which will average, or take the minimal value if multiple values exist at one time level. \end{itemize} The default settings of \code{fcontrol} are: \code{fcontrol=list(method="linear", rule = 2, f = 0, ties = "ordered")} Note that only ONE specification is allowed, even if there is more than one forcing function data set. (may/should change in the future). \subsection{A simple FORTRAN example} We implement the example from chapter 3 of the book \citep{Soetaert08} in FORTRAN. This model describes the oxygen consumption of a (marine) sediment in response to deposition of organic matter (the forcing function). One state variable, the organic matter content in the sediment is modeled; it changes as a function of the deposition \code{Flux} (forcing) and organic matter decay (first-order decay rate \code{k}). \[ \frac{dC}{dt}=Flux_t-k \cdot C \] with initial condition $C(t=0)=C_0$; the latter is estimated as the mean of the flux divided by the decay rate. The FORTRAN code looks like this: \begin{verbatim} c Initialiser for parameter common block subroutine scocpar(odeparms) external odeparms integer N double precision parms(2) common /myparms/parms N = 1 call odeparms(N, parms) return end c Initialiser for forcing common block subroutine scocforc(odeforcs) external odeforcs integer N double precision forcs(1) common /myforcs/forcs N = 1 call odeforcs(N, forcs) return end c Rate of change and output variables subroutine scocder (neq, t, y, ydot,out,IP) integer neq, IP(*) double precision t, y(neq), ydot(neq), out(*), k, depo common /myparms/k common /myforcs/depo if(IP(1) < 2) call rexit("nout should be at least 2") ydot(1) = -k*y(1) + depo out(1)= k*y(1) out(2)= depo return end \end{verbatim} Here the subroutine \code{scocpar} is business as usual; it initialises the parameter common block (there is only one parameter). Subroutine \code{odeforcs} does the same for the forcing function, which is also positioned in a common block, called \code{myforcs}. This common block is made available in the derivative subroutine (here called \code{scocder}), where the forcing function is named \code{depo}. At each time step, the integrator updates the value of this forcing function to the correct time point. In this way, the forcing functions can be used as if they are (time-varying) parameters. All that's left to do is to pass the forcing function data set and the name of the forcing function initialiser routine. This is how to do it in R. First the data are inputted: <<>>= Flux <- matrix(ncol=2,byrow=TRUE,data=c( 1, 0.654, 11, 0.167, 21, 0.060, 41, 0.070, 73,0.277, 83,0.186, 93,0.140,103, 0.255, 113, 0.231,123, 0.309,133,1.127,143,1.923, 153,1.091,163,1.001, 173, 1.691,183, 1.404,194,1.226,204,0.767, 214, 0.893,224,0.737, 234,0.772,244, 0.726,254,0.624,264,0.439, 274,0.168,284 ,0.280, 294,0.202,304, 0.193,315,0.286,325,0.599, 335, 1.889,345, 0.996,355,0.681,365,1.135)) head(Flux) @ and the parameter given a value (there is only one) <<>>= parms <- 0.01 @ The initial condition \code{Yini} is estimated as the annual mean of the Flux and divided by the decay rate (parameter). <<>>= meanDepo <- mean(approx(Flux[,1],Flux[,2], xout=seq(1,365,by=1))$y) Yini <- c(y=meanDepo/parms) @ After defining the output times, the model is run, using integration routine \code{ode}. The \emph{name} of the derivate function \code{"scocder"}, of the dll \code{"deSolve"}\footnote{this example is made part of the deSolve package, hence the name of the dll is "deSolve"} and of the initialiser function \code{"scocpar"} are passed, as in previous examples. In addition, the forcing function data set is also passed (\code{forcings=Flux}) as is the name of the forcing initialisation function (\code{initforc="scocforc"}). <<>>= times <- 1:365 out <- ode(y=Yini, times, func = "scocder", parms = parms, dllname = "deSolve", initforc="scocforc", forcings=Flux, initfunc = "scocpar", nout = 2, outnames = c("Mineralisation","Depo")) head(out) @ Now, the way the forcing functions are interpolated are changed: Rather than linear interpolation, constant (block, step) interpolation is used. <<>>= fcontrol <- list(method="constant") out2 <- ode(y=Yini, times, func = "scocder", parms = parms, dllname = "deSolve", initforc="scocforc", forcings=Flux, fcontrol=fcontrol, initfunc = "scocpar", nout = 2, outnames = c("Mineralisation","Depo")) @ Finally, the results are plotted: <>= par (mfrow=c(1,2)) plot(out, which = "Depo", col="red", xlab="days", ylab="mmol C/m2/ d", main="method='linear'") lines(out[,"time"], out[,"Mineralisation"], lwd=2, col="blue") legend("topleft",lwd=1:2,col=c("red","blue"), c("Flux","Mineralisation")) plot(out, which = "Depo", col="red", xlab="days", ylab="mmol C/m2/ d", main="method='constant'") lines(out2[,"time"], out2[,"Mineralisation"], lwd=2, col="blue") @ \setkeys{Gin}{width=0.8\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{Solution of the SCOC model, implemented in compiled code, and including a forcing function - see text for R-code} \label{fig:scoc} \end{figure} \subsection{An example in C} Consider the following R-code which implements a resource-producer-consumer Lotka-Volterra type of model in R (it is a modified version of the example of function \code{ode}): <<>>= SPCmod <- function(t, x, parms, input) { with(as.list(c(parms, x)), { import <- input(t) dS <- import - b*S*P + g*C # substrate dP <- c*S*P - d*C*P # producer dC <- e*P*C - f*C # consumer res <- c(dS, dP, dC) list(res, signal = import) }) } ## The parameters parms <- c(b = 0.1, c = 0.1, d = 0.1, e = 0.1, f = 0.1, g = 0.0) ## vector of timesteps times <- seq(0, 100, by=0.1) ## external signal with several rectangle impulses signal <- as.data.frame(list(times = times, import = rep(0, length(times)))) signal$import <- ifelse((trunc(signal$times) %% 2 == 0), 0, 1) sigimp <- approxfun(signal$times, signal$import, rule = 2) ## Start values for steady state xstart <- c(S = 1, P = 1, C = 1) ## Solve model print (system.time( out <- ode(y = xstart,times = times, func = SPCmod, parms, input = sigimp) )) @ All output is printed at once: <>= plot(out) @ \setkeys{Gin}{width=1.0\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{Solution of the Lotka-Volterra resource (S)-producer (P) - consumer (C) model with time-variable input (signal) - see text for R-code} \label{fig:lv} \end{figure} The C-code, in file \url{Forcing\_lv.c}, can be found in the packages \url{/doc/examples/dynload} subdirectory\footnote{this can be opened by typing \code{browseURL(paste(system.file(package = "deSolve"), "/doc/examples/dynload", sep = ""))}}. It can be compiled, from within R by \begin{verbatim} system("R CMD SHLIB Forcing_lv.c") \end{verbatim} After defining the parameter and forcing vectors, and giving them comprehensible names, the parameter and forcing initialiser functions are defined (\code{parmsc} and \code{forcc} respectively). Next is the derivative function, \code{derivsc}. \begin{verbatim} #include static double parms[6]; static double forc[1]; /* A trick to keep up with the parameters and forcings */ #define b parms[0] #define c parms[1] #define d parms[2] #define e parms[3] #define f parms[4] #define g parms[5] #define import forc[0] /* initializers: */ void odec(void (* odeparms)(int *, double *)) { int N=6; odeparms(&N, parms); } void forcc(void (* odeforcs)(int *, double *)) { int N=1; odeforcs(&N, forc); } /* derivative function */ void derivsc(int *neq, double *t, double *y, double *ydot, double *yout, int*ip) { if (ip[0] <2) error("nout should be at least 2"); ydot[0] = import - b*y[0]*y[1] + g*y[2]; ydot[1] = c*y[0]*y[1] - d*y[2]*y[1]; ydot[2] = e*y[1]*y[2] - f*y[2]; yout[0] = y[0] + y[1] + y[2]; yout[1] = import; } \end{verbatim} After defining the forcing function time series, which is to be interpolated by the integration routine, and loading the DLL, the model is run: \begin{verbatim} Sigimp <- approx(signal$times, signal$import, xout=ftime,rule = 2)$y forcings <- cbind(ftime,Sigimp) dyn.load("Forcing_lv.dll") out <- ode(y=xstart, times, func = "derivsc", parms = parms, dllname = "Forcing_lv",initforc = "forcc", forcings=forcings, initfunc = "parmsc", nout = 2, outnames = c("Sum","signal"), method = rkMethod("rk34f")) dyn.unload("Forcing_lv.dll") \end{verbatim} This code executes about 30 times faster than the \proglang{R}-code. With a longer simulation time, the difference becomes more pronounced, e.g. with times till 800 days, the DLL code executes 200 times faster% \footnote{this is due to the sequential update of the forcing functions by the solvers, compared to the bisectioning approach used by approxfun}. \section{Implementing events in compiled code} An \code{event} occurs when the value of a state variable is suddenly changed, e.g. a certain amount is added, or part is removed. The integration routines cannot deal easily with such state variable changes. Typically these events occur only at specific times. In \code{deSolve}, events can be imposed by means of an input file that specifies at which time a certain state variable is altered, or via an event function. Both types of events combine with compiled code. Take the previous example, the Lotka-Volterra SPC model. Suppose that every 10 days, half of the consumer is removed. We first implement these events as a \code{data.frame} <<>>= eventdata <- data.frame(var=rep("C",10),time=seq(10,100,10),value=rep(0.5,10), method=rep("multiply",10)) eventdata @ This model is solved, and plotted as: \begin{verbatim} dyn.load("Forcing_lv.dll") out2 <- ode(y = y, times, func = "derivsc", parms = parms, dllname = "Forcing_lv", initforc="forcc", forcings = forcings, initfunc = "parmsc", nout = 2, outnames = c("Sum", "signal"), events=list(data=eventdata)) dyn.unload("Forcing_lv.dll") plot(out2, which = c("S","P","C"), type = "l") \end{verbatim} The event can also be implemented in \proglang{C} as: \begin{verbatim} void event(int *n, double *t, double *y) { y[2] = y[2]*0.5; } \end{verbatim} Here n is the length of the state variable vector \code{y}. and is then solved as: \begin{verbatim} dyn.load("Forcing_lv.dll") out3 <- ode(y = y, times, func = "derivsc", parms = parms, dllname = "Forcing_lv", initforc="forcc", forcings = forcings, initfunc = "parmsc", nout = 2, outnames = c("Sum", "signal"), events = list(func="event",time=seq(10,90,10))) dyn.unload("Forcing_lv.dll") \end{verbatim} \setkeys{Gin}{width=1.0\textwidth} \begin{figure} \begin{center} \includegraphics{comp-event} \end{center} \caption{Solution of the Lotka-Volterra resource (S)~-- producer (P)~-- consumer (C) model with time-variable input (signal) and with half of the consumer removed every 10 days - see text for R-code} \label{fig:lv2} \end{figure} \section{Delay differential equations} It is now also very simple to implement delay differential equations in compiled code and solve them with \code{dede}. In order to do so, you need to get access to the R-functions \code{lagvalue} and \code{lagderiv} that will give you the past value of the state variable or its derivative respectively. \subsection{Delays implemented in Fortran} If you use \proglang{Fortran}, then the easiest way is to link your code with a file called \code{dedeUtils.c} that you will find in the packages subdirectory \code{inst/doc/dynload-dede}. This file contains Fortran-callable interfaces to the delay-differential utility functions from package \pkg{deSolve}, and that are written in \proglang{C}. Its content is: \begin{verbatim} void F77_SUB(lagvalue)(double *T, int *nr, int *N, double *ytau) { static void(*fun)(double, int*, int, double*) = NULL; if (fun == NULL) fun = (void(*)(double, int*, int, double*))R_GetCCallable("deSolve", "lagvalue"); fun(*T, nr, *N, ytau); return; } void F77_SUB(lagderiv)(double *T, int *nr, int *N, double *ytau) { static void(*fun)(double, int*, int, double*) = NULL; if (fun == NULL) fun = (void(*)(double, int*, int, double*))R_GetCCallable("deSolve", "lagderiv"); fun(*T, nr, *N, ytau); return; } \end{verbatim} Here \code{T} is the time at which the value needs to be retrieved, \code{nr} is an integer that defines the number of the state variable or its derivative whose delay we want, \code{N} is the total number of state variabes and \code{ytau} will have the result. We start with an example, a Lotka-Volterra system with delay, that we will implement in \proglang{Fortran} (you will find this example in the package directory \code{inst/doc/dynload-dede}, in file \code{dede_lvF.f} The R-code would be: <<>>= derivs <- function(t, y, parms) { with(as.list(c(y, parms)), { if (t < tau) ytau <- c(1, 1) else ytau <- lagvalue(t - tau, c(1, 2)) dN <- f * N - g * N * P dP <- e * g * ytau[1] * ytau[2] - m * P list(c(dN, dP), tau=ytau[1], tau=ytau[2]) }) } yinit <- c(N = 1, P = 1) times <- seq(0, 500) parms <- c(f = 0.1, g = 0.2, e = 0.1, m = 0.1, tau = .2) yout <- dede(y = yinit, times = times, func = derivs, parms = parms) head(yout) @ In Fortran the code looks like this: \begin{verbatim} ! file dede_lfF.f ! Initializer for parameter common block subroutine initmod(odeparms) external odeparms double precision parms(5) common /myparms/parms call odeparms(5, parms) return end ! Derivatives and one output variable subroutine derivs(neq, t, y, ydot, yout, ip) integer neq, ip(*) double precision t, y(neq), ydot(neq), yout(*) double precision N, P, ytau(2), tlag integer nr(2) double precision f, g, e, m, tau common /myparms/f, g, e, m, tau if (ip(1) < 2) call rexit("nout should be at least 2") N = y(1) P = y(2) nr(1) = 0 nr(2) = 1 ytau(1) = 1.0 ytau(2) = 1.0 tlag = t - tau if (tlag .GT. 0.0) call lagvalue(tlag, nr, 2, ytau) ydot(1) = f * N - g * N * P ydot(2) = e * g * ytau(1) * ytau(2) - m * P yout(1) = ytau(1) yout(2) = ytau(2) return end \end{verbatim} During compilation, we need to also compile the file \code{dedeUtils.c}. Assuming that the above \proglang{Fortran} code is in file \code{dede_lvF.f}, which is found in the working directory that also contains file \code{dedeUtils.c}, the problem is compiled and run as: \begin{verbatim} system("R CMD SHLIB dede_lvF.f dedeUtils.c") dyn.load(paste("dede_lvF", .Platform$dynlib.ext, sep="")) yout3 <- dede(yinit, times = times, func = "derivs", parms = parms, dllname = "dede_lvF", initfunc = "initmod", nout = 2) \end{verbatim} \subsection{Delays implemented in C} We now give the same example in \proglang{C}-code (you will find this in directory \code{inst/doc/dynload-dede/dede_lv.c}). \begin{verbatim} #include #include #include #include static double parms[5]; #define f parms[0] #define g parms[1] #define e parms[2] #define m parms[3] #define tau parms[4] /* Interface to dede utility functions in package deSolve */ void lagvalue(double T, int *nr, int N, double *ytau) { static void(*fun)(double, int*, int, double*) = NULL; if (fun == NULL) fun = (void(*)(double, int*, int, double*))R_GetCCallable("deSolve", "lagvalue"); return fun(T, nr, N, ytau); } void lagderiv(double T, int *nr, int N, double *ytau) { static void(*fun)(double, int*, int, double*) = NULL; if (fun == NULL) fun = (void(*)(double, int*, int, double*))R_GetCCallable("deSolve", "lagderiv"); return fun(T, nr, N, ytau); } /* Initializer */ void initmod(void (* odeparms)(int *, double *)) { int N = 5; odeparms(&N, parms); } /* Derivatives */ void derivs (int *neq, double *t, double *y, double *ydot, double *yout, int *ip) { if (ip[0] < 2) error("nout should be at least 1"); double N = y[0]; double P = y[1]; int Nout = 2; // number of returned lags ( <= n_eq !!) int nr[2] = {0, 1}; // which lags are needed? // numbering starts from zero ! double ytau[2] = {1.0, 1.0}; // array; initialize with default values ! double T = *t - tau; if (*t > tau) { lagvalue(T, nr, Nout, ytau); } ydot[0] = f * N - g * N * P; ydot[1] = e * g * ytau[0] * ytau[1] - m * P; yout[0] = ytau[0]; yout[1] = ytau[1]; } \end{verbatim} Assuming this code is in a file called \code{dede_lv.c}, which is in the working directory, this file is then compiled and run as: \begin{verbatim} system("R CMD SHLIB dede_lv.c") dyn.load(paste("dede_lv", .Platform$dynlib.ext, sep="")) yout2 <- dede(yinit, times = times, func = "derivs", parms = parms, dllname = "dede_lv", initfunc = "initmod", nout = 2) dyn.unload(paste("dede_lv", .Platform$dynlib.ext, sep="")) \end{verbatim} \section{Difference equations in compiled code} There is one special-purpose solver, triggered with \code{method = "iteration"} which can be used in cases where the new values of the state variables are estimated by the user, and need not be found by integration. This is for instance useful when the model consists of difference equations, or for 1-D models when transport is implemented by an implicit or a semi-implicit method. An example of a discrete time model, represented by a difference equation is given in the help file of solver \code{ode}. It consists of the host-parasitoid model described as from \citet[p283]{Soetaert08}. We first give the R-code, and how it is solved: \begin{verbatim} Parasite <- function (t, y, ks) { P <- y[1] H <- y[2] f <- A * P / (ks +H) Pnew <- H* (1-exp(-f)) Hnew <- H * exp(rH*(1.-H) - f) list (c(Pnew, Hnew)) } rH <- 2.82 # rate of increase A <- 100 # attack rate ks <- 15. # half-saturation density out <- ode (func = Parasite, y = c(P = 0.5, H = 0.5), times = 0:50, parms = ks, method = "iteration") \end{verbatim} Note that the function returns the updated value of the state variables rather than the rate of change (derivative). The method ``iteration'' does not perform any integration. The implementation in \proglang{FORTRAN} consists of an initialisation function to pass the parameter values (\code{initparms}) and the "update" function that returns the new values of the state variables (\code{parasite}): \begin{verbatim} subroutine initparms(odeparms) external odeparms double precision parms(3) common /myparms/parms call odeparms(3, parms) return end subroutine parasite (neq, t, y, ynew, out, iout) integer neq, iout(*) double precision t, y(neq), ynew(neq), out(*), rH, A, ks common /myparms/ rH, A, ks double precision P, H, f P = y(1) H = y(2) f = A * P / (ks + H) ynew(1) = H * (1.d0 - exp(-f)) ynew(2) = H * exp (rH * (1.d0 - H) - f) return end \end{verbatim} The model is compiled, loaded and executed in R as: \begin{verbatim} system("R CMD SHLIB difference.f") dyn.load(paste("difference", .Platform$dynlib.ext, sep = "")) require(deSolve) rH <- 2.82 # rate of increase A <- 100 # attack rate ks <- 15. # half-saturation density parms <- c(rH = rH, A = A, ks = ks) out <- ode (func = "parasite", y = c(P = 0.5, H = 0.5), times = 0:50, initfunc = "initparms", dllname = "difference", parms = parms, method = "iteration") \end{verbatim} \section{Final remark} Detailed information about communication between \proglang{C}, \proglang{FORTRAN} and \proglang{R} can be found in \citet{Rexts2009}. Notwithstanding the speed gain when using compiled code, one should not carelessly decide to always resort to this type of modelling. Because the code needs to be formally compiled and linked to \proglang{R} much of the elegance when using pure \proglang{R} models is lost. Moreover, mistakes are easily made and paid harder in compiled code: often a programming error will terminate \proglang{R}. In addition, these errors may not be simple to trace. \clearpage %% this adds References to the PDF-Index without adding an obsolete section \phantomsection \addcontentsline{toc}{section}{References} \bibliography{integration} \end{document} deSolve/inst/doc/deSolve.Rnw0000754000175100001440000020043212352122166015507 0ustar hornikusers\documentclass[article,nojss]{jss} \DeclareGraphicsExtensions{.pdf, .eps, .png, .jpeg} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Add-on packages and fonts \usepackage{graphicx} \usepackage{amsmath} \newcommand{\noun}[1]{\textsc{#1}} %% Bold symbol macro for standard LaTeX users \providecommand{\boldsymbol}[1]{\mbox{\boldmath $#1$}} %% Because html converters don't know tabularnewline \providecommand{\tabularnewline}{\\} \usepackage{array} % table commands \setlength{\extrarowheight}{0.1cm} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% User specified LaTeX commands. \newcommand{\R}{\proglang{R }} \newcommand{\ds}{\textbf{\textsf{deSolve }}} \newcommand{\bs}{\textbf{\textsf{bvpSolve }}} \newcommand{\rt}{\textbf{\textsf{ReacTran }}} \newcommand{\rb}[1]{\raisebox{1.5ex}{#1}} \title{Package \pkg{deSolve}: Solving Initial Value Differential Equations in \proglang{R}} \Plaintitle{Package deSolve: Solving Initial Value Differential Equations in R} \Keywords{differential equations, ordinary differential equations, differential algebraic equations, partial differential equations, initial value problems, \proglang{R}} \Plainkeywords{differential equations, ordinary differential equations, differential algebraic equations, partial differential equations, initial value problems, R} \author{ Karline Soetaert\\ Royal Netherlands Institute\\ of Sea Research (NIOZ)\\ Yerseke, The Netherlands \And Thomas Petzoldt\\ Technische Universit\"at \\ Dresden\\ Germany \And R. Woodrow Setzer\\ National Center for\\ Computational Toxicology\\ US Environmental Protection Agency } \Plainauthor{Karline Soetaert, Thomas Petzoldt, R. Woodrow Setzer} \Abstract{ \R package \ds \citep{deSolve_jss,deSolve} the successor of \proglang{R} package \pkg{odesolve} is a package to solve initial value problems (IVP) of: \begin{itemize} \item ordinary differential equations (ODE), \item differential algebraic equations (DAE), \item partial differential equations (PDE) and \item delay differential equations (DeDE). \end{itemize} The implementation includes stiff and nonstiff integration routines based on the \pkg{ODEPACK} \proglang{FORTRAN} codes \citep{Hindmarsh83}. It also includes fixed and adaptive time-step explicit Runge-Kutta solvers and the Euler method \citep{Press92}, and the implicit Runge-Kutta method RADAU \citep{Hairer2}. In this vignette we outline how to implement differential equations as \R-functions. Another vignette (``compiledCode'') \citep{compiledCode}, deals with differential equations implemented in lower-level languages such as \proglang{FORTRAN}, \proglang{C}, or \proglang{C++}, which are compiled into a dynamically linked library (DLL) and loaded into \proglang{R} \citep{Rcore}. Note that another package, \bs provides methods to solve boundary value problems \citep{bvpSolve}. } %% The address of (at least) one author should be given %% in the following format: \Address{ Karline Soetaert\\ Centre for Estuarine and Marine Ecology (CEME)\\ Royal Netherlands Institute of Sea Research (NIOZ)\\ 4401 NT Yerseke, Netherlands \\ E-mail: \email{karline.soetaert@nioz.nl}\\ URL: \url{http://www.nioz.nl}\\ \\ Thomas Petzoldt\\ Institut f\"ur Hydrobiologie\\ Technische Universit\"at Dresden\\ 01062 Dresden, Germany\\ E-mail: \email{thomas.petzoldt@tu-dresden.de}\\ URL: \url{http://tu-dresden.de/Members/thomas.petzoldt/}\\ \\ R. Woodrow Setzer\\ National Center for Computational Toxicology\\ US Environmental Protection Agency\\ URL: \url{http://www.epa.gov/comptox} } %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% R/Sweave specific LaTeX commands. %% need no \usepackage{Sweave} %\VignetteIndexEntry{R Package deSolve: Solving Initial Value Differential Equations in R} %\VignetteKeywords{differential equations, ordinary differential equations, differential algebraic equations, partial differential equations, initial value problems, R} %\VignettePackage{deSolve} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Begin of the document \begin{document} \SweaveOpts{engine=R,eps=FALSE} \SweaveOpts{keep.source=TRUE} <>= library("deSolve") options(prompt = "> ") options(width=70) @ \maketitle \section{A simple ODE: chaos in the atmosphere} The Lorenz equations (Lorenz, 1963) were the first chaotic dynamic system to be described. They consist of three differential equations that were assumed to represent idealized behavior of the earth's atmosphere. We use this model to demonstrate how to implement and solve differential equations in \proglang{R}. The Lorenz model describes the dynamics of three state variables, $X$, $Y$ and $Z$. The model equations are: \begin{align*} \frac{dX}{dt} &= a \cdot X + Y \cdot Z \\ \frac{dY}{dt} &= b \cdot (Y - Z) \\ \frac{dZ}{dt} &= - X \cdot Y + c \cdot Y - Z \end{align*} with the initial conditions: \[ X(0) = Y(0) = Z(0) = 1 \] Where $a$, $b$ and $c$ are three parameters, with values of -8/3, -10 and 28 respectively. Implementation of an IVP ODE in \R can be separated in two parts: the model specification and the model application. Model specification consists of: \begin{itemize} \item Defining model parameters and their values, \item Defining model state variables and their initial conditions, \item Implementing the model equations that calculate the rate of change (e.g. $dX/dt$) of the state variables. \end{itemize} The model application consists of: \begin{itemize} \item Specification of the time at which model output is wanted, \item Integration of the model equations (uses R-functions from \pkg{deSolve}), \item Plotting of model results. \end{itemize} Below, we discuss the \proglang{R}-code for the Lorenz model. \subsection{Model specification} \subsubsection{Model parameters} There are three model parameters: $a$, $b$, and $c$ that are defined first. Parameters are stored as a vector with assigned names and values: <<>>= parameters <- c(a = -8/3, b = -10, c = 28) @ \subsubsection{State variables} The three state variables are also created as a vector, and their initial values given: <<>>= state <- c(X = 1, Y = 1, Z = 1) @ \subsubsection{Model equations} The model equations are specified in a function (\code{Lorenz}) that calculates the rate of change of the state variables. Input to the function is the model time (\code{t}, not used here, but required by the calling routine), and the values of the state variables (\code{state}) and the parameters, in that order. This function will be called by the \R routine that solves the differential equations (here we use \code{ode}, see below). The code is most readable if we can address the parameters and state variables by their names. As both parameters and state variables are `vectors', they are converted into a list. The statement \code{with(as.list(c(state, parameters)), {...})} then makes available the names of this list. The main part of the model calculates the rate of change of the state variables. At the end of the function, these rates of change are returned, packed as a list. Note that it is necessary \textbf{to return the rate of change in the same ordering as the specification of the state variables. This is very important.} In this case, as state variables are specified $X$ first, then $Y$ and $Z$, the rates of changes are returned as $dX, dY, dZ$. <<>>= Lorenz<-function(t, state, parameters) { with(as.list(c(state, parameters)),{ # rate of change dX <- a*X + Y*Z dY <- b * (Y-Z) dZ <- -X*Y + c*Y - Z # return the rate of change list(c(dX, dY, dZ)) }) # end with(as.list ... } @ \subsection{Model application} \subsubsection{Time specification} We run the model for 100 days, and give output at 0.01 daily intervals. R's function \code{seq()} creates the time sequence: <<>>= times <- seq(0, 100, by = 0.01) @ \subsubsection{Model integration} The model is solved using \ds function \code{ode}, which is the default integration routine. Function \code{ode} takes as input, a.o. the state variable vector (\code{y}), the times at which output is required (\code{times}), the model function that returns the rate of change (\code{func}) and the parameter vector (\code{parms}). Function \code{ode} returns an object of class \code{deSolve} with a matrix that contains the values of the state variables (columns) at the requested output times. <<>>= library(deSolve) out <- ode(y = state, times = times, func = Lorenz, parms = parameters) head(out) @ \subsubsection{Plotting results} Finally, the model output is plotted. We use the plot method designed for objects of class \code{deSolve}, which will neatly arrange the figures in two rows and two columns; before plotting, the size of the outer upper margin (the third margin) is increased (\code{oma}), such as to allow writing a figure heading (\code{mtext}). First all model variables are plotted versus \code{time}, and finally \code{Z} versus \code{X}: <>= par(oma = c(0, 0, 3, 0)) plot(out, xlab = "time", ylab = "-") plot(out[, "X"], out[, "Z"], pch = ".") mtext(outer = TRUE, side = 3, "Lorenz model", cex = 1.5) @ \setkeys{Gin}{width=0.8\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{Solution of the ordinary differential equation - see text for R-code} \label{fig:dae} \end{figure} \clearpage \section{Solvers for initial value problems of ordinary differential equations} Package \ds contains several IVP ordinary differential equation solvers, that belong to the most important classes of solvers. Most functions are based on original (\proglang{FORTRAN}) implementations, e.g. the Backward Differentiation Formulae and Adams methods from \pkg{ODEPACK} \citep{Hindmarsh83}, or from \citep{Brown89,Petzold1983}, the implicit Runge-Kutta method RADAU \citep{Hairer2}. The package contains also a de novo implementation of several Runge-Kutta methods \citep{Butcher1987, Press92, Hairer1}. All integration methods\footnote{except \code{zvode}, the solver used for systems containing complex numbers.} can be triggered from function \code{ode}, by setting \code{ode}'s argument \code{method}), or can be run as stand-alone functions. Moreover, for each integration routine, several options are available to optimise performance. For instance, the next statements will use integration method \code{radau} to solve the model, and set the tolerances to a higher value than the default. Both statements are the same: <<>>= outb <- radau(state, times, Lorenz, parameters, atol = 1e-4, rtol = 1e-4) outc <- ode(state, times, Lorenz, parameters, method = "radau", atol = 1e-4, rtol = 1e-4) @ The default integration method, based on the \proglang{FORTRAN} code LSODA is one that switches automatically between stiff and non-stiff systems \citep{Petzold1983}. This is a very robust method, but not necessarily the most efficient solver for one particular problem. See \citep{deSolve_jss} for more information about when to use which solver in \pkg{deSolve}. For most cases, the default solver, \code{ode} and using the default settings will do. Table \ref{tb:rs} also gives a short overview of the available methods. To show how to trigger the various methods, we solve the model with several integration routines, each time printing the time it took (in seconds) to find the solution: <<>>= print(system.time(out1 <- rk4 (state, times, Lorenz, parameters))) print(system.time(out2 <- lsode (state, times, Lorenz, parameters))) print(system.time(out <- lsoda (state, times, Lorenz, parameters))) print(system.time(out <- lsodes(state, times, Lorenz, parameters))) print(system.time(out <- daspk (state, times, Lorenz, parameters))) print(system.time(out <- vode (state, times, Lorenz, parameters))) @ \subsection{Runge-Kutta methods and Euler} The explicit Runge-Kutta methods are de novo implementations in \proglang{C}, based on the Butcher tables \citep{Butcher1987}. They comprise simple Runge-Kutta formulae (Euler's method \code{euler}, Heun's method \code{rk2}, the classical 4th order Runge-Kutta, \code{rk4}) and several Runge-Kutta pairs of order 3(2) to order 8(7). The embedded, explicit methods are according to \citet{Fehlberg1967} (\code{rk..f}, \code{ode45}), \citet{Dormand1980,Dormand1981} (\code{rk..dp.}), \citet{Bogacki1989} (\code{rk23bs}, \code{ode23}) and \citet{Cash1990} (\code{rk45ck}), where \code{ode23} and \code{ode45} are aliases for the popular methods \code{rk23bs} resp. \code{rk45dp7}. With the following statement all implemented methods are shown: <<>>= rkMethod() @ This list also contains implicit Runge-Kutta's (\code{irk..}), but they are not yet optimally coded. The only well-implemented implicit Runge-Kutta is the \code{radau} method \citep{Hairer2} that will be discussed in the section dealing with differential algebraic equations. The properties of a Runge-Kutta method can be displayed as follows: <<>>= rkMethod("rk23") @ Here \code{varstep} informs whether the method uses a variable time-step; \code{FSAL} whether the first same as last strategy is used, while \code{stage} and \code{Qerr} give the number of function evaluations needed for one step, and the order of the local truncation error. \code{A, b1, b2, c} are the coefficients of the Butcher table. Two formulae (\code{rk45dp7, rk45ck}) support dense output. It is also possible to modify the parameters of a method (be very careful with this) or define and use a new Runge-Kutta method: <<>>= func <- function(t, x, parms) { with(as.list(c(parms, x)),{ dP <- a * P - b * C * P dC <- b * P * C - c * C res <- c(dP, dC) list(res) }) } rKnew <- rkMethod(ID = "midpoint", varstep = FALSE, A = c(0, 1/2), b1 = c(0, 1), c = c(0, 1/2), stage = 2, Qerr = 1 ) out <- ode(y = c(P = 2, C = 1), times = 0:100, func, parms = c(a = 0.1, b = 0.1, c = 0.1), method = rKnew) head(out) @ \subsubsection{Fixed time-step methods} There are two explicit methods that do not adapt the time step: the \code{euler} method and the \code{rk4} method. They are implemented in two ways: \begin{itemize} \item as a \code{rkMethod} of the \textbf{general} \code{rk} solver. In this case the time step used can be specified independently from the \code{times} argument, by setting argument \code{hini}. Function \code{ode} uses this general code. \item as \textbf{special} solver codes \code{euler} and \code{rk4}. These implementations are simplified and with less options to avoid overhead. The timestep used is determined by the time increment in the \code{times} argument. \end{itemize} For example, the next two statements both trigger the Euler method, the first using the ``special'' code with a time step = 1, as imposed by the \code{times} argument, the second using the generalized method with a time step set by \code{hini}. Unsurprisingly, the first solution method completely fails (the time step $= 1$ is much too large for this problem). \begin{verbatim} out <- euler(y = state, times = 0:40, func = Lorenz, parms = parameters) outb <- ode(y = state, times = 0:40, func = Lorenz, parms = parameters, method = "euler", hini = 0.01) \end{verbatim} \subsection{Model diagnostics and summaries} Function \code{diagnostics} prints several diagnostics of the simulation to the screen. For the Runge-Kutta and \code{lsode} routine called above they are: <<>>= diagnostics(out1) diagnostics(out2) @ There is also a \code{summary} method for \code{deSolve} objects. This is especially handy for multi-dimensional problems (see below) <<>>= summary(out1) @ \clearpage \section{Partial differential equations} As package \ds includes integrators that deal efficiently with arbitrarily sparse and banded Jacobians, it is especially well suited to solve initial value problems resulting from 1, 2 or 3-dimensional partial differential equations (PDE), using the method-of-lines approach. The PDEs are first written as ODEs, using finite differences. This can be efficiently done with functions from R-package \rt \citep{ReacTran}. However, here we will create the finite differences in R-code. Several special-purpose solvers are included in \pkg{deSolve}: \begin{itemize} \item \code{ode.band} integrates 1-dimensional problems comprizing one species, \item \code{ode.1D} integrates 1-dimensional problems comprizing one or many species, \item \code{ode.2D} integrates 2-dimensional problems, \item \code{ode.3D} integrates 3-dimensional problems. \end{itemize} As an example, consider the Aphid model described in \citet{Soetaert08}. It is a model where aphids (a pest insect) slowly diffuse and grow on a row of plants. The model equations are: \[ \frac{{\partial N}}{{\partial t}} = - \frac{{\partial Flux}}{{\partial {\kern 1pt} x}} + g \cdot N \] and where the diffusive flux is given by: \[ Flux = - D\frac{{\partial N}}{{\partial {\kern 1pt} x}} \] with boundary conditions \[ N_{x=0}=N_{x=60}=0 \] and initial condition \begin{center} $N_x=0$ for $x \neq 30$ $N_x=1$ for $x = 30$ \end{center} In the method of lines approach, the spatial domain is subdivided in a number of boxes and the equation is discretized as: \[ \frac{{dN_i }}{{dt}} = - \frac{{Flux_{i,i + 1} - Flux_{i - 1,i} }}{{\Delta x_i }} + g \cdot N_i \] with the flux on the interface equal to: \[ Flux_{i - 1,i} = - D_{i - 1,i} \cdot \frac{{N_i - N_{i - 1} }}{{\Delta x_{i - 1,i} }} \] Note that the values of state variables (here densities) are defined in the centre of boxes (i), whereas the fluxes are defined on the box interfaces. We refer to \citet{Soetaert08} for more information about this model and its numerical approximation. Here is its implementation in \proglang{R}. First the model equations are defined: <<>>= Aphid <- function(t, APHIDS, parameters) { deltax <- c (0.5, rep(1, numboxes - 1), 0.5) Flux <- -D * diff(c(0, APHIDS, 0)) / deltax dAPHIDS <- -diff(Flux) / delx + APHIDS * r # the return value list(dAPHIDS ) } # end @ Then the model parameters and spatial grid are defined <<>>= D <- 0.3 # m2/day diffusion rate r <- 0.01 # /day net growth rate delx <- 1 # m thickness of boxes numboxes <- 60 # distance of boxes on plant, m, 1 m intervals Distance <- seq(from = 0.5, by = delx, length.out = numboxes) @ Aphids are initially only present in two central boxes: <<>>= # Initial conditions: # ind/m2 APHIDS <- rep(0, times = numboxes) APHIDS[30:31] <- 1 state <- c(APHIDS = APHIDS) # initialise state variables @ The model is run for 200 days, producing output every day; the time elapsed in seconds to solve this 60 state-variable model is estimated (\code{system.time}): <<>>= times <-seq(0, 200, by = 1) print(system.time( out <- ode.1D(state, times, Aphid, parms = 0, nspec = 1, names = "Aphid") )) @ Matrix \code{out} consist of times (1st column) followed by the densities (next columns). <<>>= head(out[,1:5]) @ The \code{summary} method gives the mean, min, max, ... of the entire 1-D variable: <<>>= summary(out) @ Finally, the output is plotted. It is simplest to do this with \pkg{deSolve}'s \proglang{S3}-method \code{image} %% Do this offline %%<>= \begin{verbatim} image(out, method = "filled.contour", grid = Distance, xlab = "time, days", ylab = "Distance on plant, m", main = "Aphid density on a row of plants") \end{verbatim} %%@ \setkeys{Gin}{width=0.8\textwidth} \begin{figure} \begin{center} %%<>= %%<> %%@ \includegraphics{aphid.png} \end{center} \caption{Solution of the 1-dimensional aphid model - see text for \R-code} \label{fig:aphid} \end{figure} As this is a 1-D model, it is best solved with \ds function \code{ode.1D}. A multi-species IVP example can be found in \citet{Soetaert08}. For 2-D and 3-D problems, we refer to the help-files of functions \code{ode.2D} and \code{ode.3D}. The output of one-dimensional models can also be plotted using S3-method \code{plot.1D} and \code{matplot.1D}. In both cases, we can simply take a \code{subset} of the output, and add observations. <<>>= data <- cbind(dist = c(0,10, 20, 30, 40, 50, 60), Aphid = c(0,0.1,0.25,0.5,0.25,0.1,0)) @ <>= par (mfrow = c(1,2)) matplot.1D(out, grid = Distance, type = "l", mfrow = NULL, subset = time %in% seq(0, 200, by = 10), obs = data, obspar = list(pch = 18, cex = 2, col="red")) plot.1D(out, grid = Distance, type = "l", mfrow = NULL, subset = time == 100, obs = data, obspar = list(pch = 18, cex = 2, col="red")) @ \setkeys{Gin}{width=1.0\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{Solution of the Aphid model - plotted with matplot.1D, plot.1D - see text for R-code} \label{fig:matplot1d} \end{figure} \clearpage \section{Differential algebraic equations} Package \ds contains two functions that solve initial value problems of differential algebraic equations. They are: \begin{itemize} \item \code{radau} which implements the implicit Runge-Kutta RADAU5 \citep{Hairer2}, \item \code{daspk}, based on the backward differentiation code DASPK \citep{Brenan96}. \end{itemize} Function \code{radau} needs the input in the form $M y' = f(t,y,y')$ where $M$ is the mass matrix. Function \code{daspk} also supports this input, but can also solve problems written in the form $F(t, y, y') = 0$. \code{radau} solves problems up to index 3; \code{daspk} solves problems of index $\leq$ 1. \subsection{DAEs of index maximal 1} Function \code{daspk} from package \ds solves (relatively simple) DAEs of index\footnote{note that many -- apparently simple -- DAEs are higher-index DAEs} maximal 1. The DAE has to be specified by the \emph{residual function} instead of the rates of change (as in ODE). Consider the following simple DAE: \begin{eqnarray*} \frac{dy_1}{dt}&=&-y_1+y_2\\ y_1 \cdot y_2 &=& t \end{eqnarray*} where the first equation is a differential, the second an algebraic equation. To solve it, it is first rewritten as residual functions: \begin{eqnarray*} 0&=&\frac{dy_1}{dt}+y_1-y_2\\ 0&=&y_1 \cdot y_2 - t \end{eqnarray*} In \R we write: <<>>= daefun <- function(t, y, dy, parameters) { res1 <- dy[1] + y[1] - y[2] res2 <- y[2] * y[1] - t list(c(res1, res2)) } library(deSolve) yini <- c(1, 0) dyini <- c(1, 0) times <- seq(0, 10, 0.1) ## solver system.time(out <- daspk(y = yini, dy = dyini, times = times, res = daefun, parms = 0)) @ <>= matplot(out[,1], out[,2:3], type = "l", lwd = 2, main = "dae", xlab = "time", ylab = "y") @ \setkeys{Gin}{width=0.4\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{Solution of the differential algebraic equation model - see text for R-code} \label{fig:dae2} \end{figure} \subsection{DAEs of index up to three} Function \code{radau} from package \ds can solve DAEs of index up to three provided that they can be written in the form $M dy/dt = f(t,y)$. Consider the well-known pendulum equation: \begin{eqnarray*} x' &=& u\\ y' &=& v\\ u' &=& -\lambda x\\ v' &=& -\lambda y - 9.8\\ 0 &=& x^2 + y^2 - 1 \end{eqnarray*} where the dependent variables are $x, y, u, v$ and $\lambda$. Implemented in \R to be used with function \code{radau} this becomes: <<>>= pendulum <- function (t, Y, parms) { with (as.list(Y), list(c(u, v, -lam * x, -lam * y - 9.8, x^2 + y^2 -1 )) ) } @ A consistent set of initial conditions are: <<>>= yini <- c(x = 1, y = 0, u = 0, v = 1, lam = 1) @ and the mass matrix $M$: <<>>= M <- diag(nrow = 5) M[5, 5] <- 0 M @ Function \code{radau} requires that the index of each equation is specified; there are 2 equations of index 1, two of index 2, one of index 3: <<>>= index <- c(2, 2, 1) times <- seq(from = 0, to = 10, by = 0.01) out <- radau (y = yini, func = pendulum, parms = NULL, times = times, mass = M, nind = index) @ <>= plot(out, type = "l", lwd = 2) plot(out[, c("x", "y")], type = "l", lwd = 2) @ \setkeys{Gin}{width=0.8\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{Solution of the pendulum problem, an index 3 differential algebraic equation using \code{radau} - see text for \proglang{R}-code} \label{fig:pendulum} \end{figure} \clearpage \section{Integrating systems containing complex numbers, function zvode} Function \code{zvode} solves ODEs that are composed of complex variables. We use \code{zvode} to solve the following system of 2 ODEs: \begin{align*} \frac{dz}{dt} &= i \cdot z\\ \frac{dw}{dt} &= -i \cdot w \cdot w \cdot z\\ \intertext{where} w(0) &= 1/2.1 \\ z(0) &= 1 \end{align*} on the interval $t = [0, 2 \pi]$ <<>>= ZODE2 <- function(Time, State, Pars) { with(as.list(State), { df <- 1i * f dg <- -1i * g * g * f return(list(c(df, dg))) }) } yini <- c(f = 1+0i, g = 1/2.1+0i) times <- seq(0, 2 * pi, length = 100) out <- zvode(func = ZODE2, y = yini, parms = NULL, times = times, atol = 1e-10, rtol = 1e-10) @ The analytical solution is: \begin{align*} f(t) &= \exp (1i \cdot t) \intertext{and} g(t) &= 1/(f(t) + 1.1) \end{align*} The numerical solution, as produced by \code{zvode} matches the analytical solution: <<>>= analytical <- cbind(f = exp(1i*times), g = 1/(exp(1i*times)+1.1)) tail(cbind(out[,2], analytical[,1])) @ \clearpage \section{Making good use of the integration options} The solvers from \pkg{ODEPACK} can be fine-tuned if it is known whether the problem is stiff or non-stiff, or if the structure of the Jacobian is sparse. We repeat the example from \code{lsode} to show how we can make good use of these options. The model describes the time evolution of 5 state variables: <<>>= f1 <- function (t, y, parms) { ydot <- vector(len = 5) ydot[1] <- 0.1*y[1] -0.2*y[2] ydot[2] <- -0.3*y[1] +0.1*y[2] -0.2*y[3] ydot[3] <- -0.3*y[2] +0.1*y[3] -0.2*y[4] ydot[4] <- -0.3*y[3] +0.1*y[4] -0.2*y[5] ydot[5] <- -0.3*y[4] +0.1*y[5] return(list(ydot)) } @ and the initial conditions and output times are: <<>>= yini <- 1:5 times <- 1:20 @ The default solution, using \code{lsode} assumes that the model is stiff, and the integrator generates the Jacobian, which is assummed to be \emph{full}: <<>>= out <- lsode(yini, times, f1, parms = 0, jactype = "fullint") @ It is possible for the user to provide the Jacobian. Especially for large problems this can result in substantial time savings. In a first case, the Jacobian is written as a full matrix: <<>>= fulljac <- function (t, y, parms) { jac <- matrix(nrow = 5, ncol = 5, byrow = TRUE, data = c(0.1, -0.2, 0 , 0 , 0 , -0.3, 0.1, -0.2, 0 , 0 , 0 , -0.3, 0.1, -0.2, 0 , 0 , 0 , -0.3, 0.1, -0.2, 0 , 0 , 0 , -0.3, 0.1)) return(jac) } @ and the model solved as: <<>>= out2 <- lsode(yini, times, f1, parms = 0, jactype = "fullusr", jacfunc = fulljac) @ The Jacobian matrix is banded, with one nonzero band above (up) and one below(down) the diagonal. First we let \code{lsode} estimate the banded Jacobian internally (\code{jactype = "bandint"}): <<>>= out3 <- lsode(yini, times, f1, parms = 0, jactype = "bandint", bandup = 1, banddown = 1) @ It is also possible to provide the nonzero bands of the Jacobian in a function: <<>>= bandjac <- function (t, y, parms) { jac <- matrix(nrow = 3, ncol = 5, byrow = TRUE, data = c( 0 , -0.2, -0.2, -0.2, -0.2, 0.1, 0.1, 0.1, 0.1, 0.1, -0.3, -0.3, -0.3, -0.3, 0)) return(jac) } @ in which case the model is solved as: <<>>= out4 <- lsode(yini, times, f1, parms = 0, jactype = "bandusr", jacfunc = bandjac, bandup = 1, banddown = 1) @ Finally, if the model is specified as ``non-stiff'' (by setting \code{mf=10}), there is no need to specify the Jacobian: <<>>= out5 <- lsode(yini, times, f1, parms = 0, mf = 10) @ \clearpage \section{Events and roots} As from version 1.6, \code{events} are supported. Events occur when the values of state variables are instantaneously changed. They can be specified as a \code{data.frame}, or in a function. Events can also be triggered by a root function. Several integrators (\code{lsoda}, \code{lsodar}, \code{lsode}, \code{lsodes} and \code{radau}) can estimate the root of one or more functions. For the first 4 integration methods, the root finding algorithm is based on the algorithm in solver LSODAR, and implemented in FORTRAN. For \code{radau}, the root solving algorithm is written in C-code, and it works slightly different. Thus, some problems involving roots may be more efficient to solve with either \code{lsoda, lsode}, or \code{lsodes}, while other problems are more efficiently solved with \code{radau}. If a root is found, then the integration will be terminated, unless an event function is defined. A help file with information on roots and events can be opened by typing \code{?events} or \code{?roots}. \subsection{Event specified in a data.frame} In this example, two state variables with constant decay are modeled: <<>>= eventmod <- function(t, var, parms) { list(dvar = -0.1*var) } yini <- c(v1 = 1, v2 = 2) times <- seq(0, 10, by = 0.1) @ At time 1 and 9 a value is added to variable \code{v1}, at time 1 state variable \code{v2} is multiplied with 2, while at time 5 the value of \code{v2} is replaced with 3. These events are specified in a \code{data.frame}, eventdat: <<>>= eventdat <- data.frame(var = c("v1", "v2", "v2", "v1"), time = c(1, 1, 5, 9), value = c(1, 2, 3, 4), method = c("add", "mult", "rep", "add")) eventdat @ The model is solved with \code{ode}: <<>>= out <- ode(func = eventmod, y = yini, times = times, parms = NULL, events = list(data = eventdat)) @ <>= plot(out, type = "l", lwd = 2) @ \setkeys{Gin}{width=0.8\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{A simple model that contains events} \label{fig:event1} \end{figure} \subsection{Event triggered by a root function} This model describes the position (\code{y1}) and velocity (\code{y2}) of a bouncing ball: <<>>= ballode<- function(t, y, parms) { dy1 <- y[2] dy2 <- -9.8 list(c(dy1, dy2)) } @ An event is triggered when the ball hits the ground (height = 0) Then velocity (\code{y2}) is reversed and reduced by 10 percent. The root function, \code{y[1] = 0}, triggers the event: <<>>= root <- function(t, y, parms) y[1] @ The event function imposes the bouncing of the ball <<>>= event <- function(t, y, parms) { y[1]<- 0 y[2]<- -0.9 * y[2] return(y) } @ After specifying the initial values and times, the model is solved, here using \code{lsode}. <<>>= yini <- c(height = 0, v = 20) times <- seq(from = 0, to = 20, by = 0.01) out <- lsode(times = times, y = yini, func = ballode, parms = NULL, events = list(func = event, root = TRUE), rootfun = root) @ <>= plot(out, which = "height", type = "l",lwd = 2, main = "bouncing ball", ylab = "height") @ \setkeys{Gin}{width=0.4\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{A model, with event triggered by a root function} \label{fig:event2} \end{figure} \subsection{Events and time steps} The use of events requires that all event times are contained in the output time steps, otherwise such events would be skipped. This sounds easy but sometimes problems can occur due to the limited accuracy of floating point arithmetics of the computer. To make things work as excpected, two requirements have to be fulfilled: \begin{enumerate} \item all event times have to be contained \textbf{exactly} in times, i.e. with the maximum possible accuracy of floating point arithmetics. \item two time steps should not be too close together, otherwise numerical problems would occur during the integration. \end{enumerate} Starting from version 1.10 of \pkg{deSolve} this is now checked (and if necessary also fixed) automatically by the solver functions. A warning is issued to inform the user about possible problems, especially that the output time steps were now adjusted and therefore different from the ones originally specified by the user. This means that all values of \code{eventtimes} are now contained but only the subset of times that have no exact or ``rather close'' neighbors in \code{eventtimes}. Instead of relying on this automatism, matching times and eventtimes can also be managed by the user, either by appropriate rounding or by using function \code{cleanEventTimes} shown below. Let's assume we have a vector of time steps \code{times} and another vector of event times \code{eventtimes}: <<>>= times <- seq(0, 1, 0.1) eventtimes <- c(0.7, 0.9) @ If we now check whether the \code{eventtimes} are in \code{times}: <<>>= eventtimes %in% times @ we get the surprising answer that this is only partly the case, because \code{seq} made small numerical errors. The easiest method to get rid of this is rounding: <<>>= times2 <- round(times, 1) times - times2 @ The last line shows us that the error was always smaller than, say $10^{-15}$, what is typical for ordinary double precision arithmetics. The accuracy of the machine can be determined with \code{.Machine\$double.eps}. To check if all \code{eventtimes} are now contained in the new times vector \code{times2}, we use: <<>>= eventtimes %in% times2 @ or <<>>= all(eventtimes %in% times2) @ and see that everything is o.k. now. In few cases, rounding may not work properly, for example if a pharmacokinetic model is simulated with a daily time step, but drug injection occurs at precisely fixed times within the day. Then one has to add all additional event times to the ordinary time stepping: <<>>= times <- 1:10 eventtimes <- c(1.3, 3.4, 4, 7.9, 8.5) newtimes <- sort(unique(c(times, eventtimes))) @ If, however, an event and a time step are almost (but not exactly) the same, then it is more safe to use: <<>>= times <- 1:10 eventtimes <- c(1.3, 3.4, 4, 7.9999999999999999, 8.5) newtimes <- sort(c(eventtimes, cleanEventTimes(times, eventtimes))) @ because \code{cleanEventTimes} removes not only the doubled 4 (like \code{unique}, but also the ``almost doubled'' 8, while keeping the exact event time. The tolerance of \code{cleanEventTimes} can be adjusted using an optional argument \code{eps}. As said, this is normally done automatically by the differential equation solvers and in most cases appropriate rounding will be sufficient to get rid of the warnings. \clearpage \section{Delay differential equations} As from \pkg{deSolve} version 1.7, time lags are supported, and a new general solver for delay differential equations, \code{dede} has been added. We implement the lemming model, example 6 from \citep{ST2000}. Function \code{lagvalue} calculates the value of the state variable at \code{t - 0.74}. As long a these lag values are not known, the value 19 is assigned to the state variable. Note that the simulation starts at \code{time = - 0.74}. <<>>= library(deSolve) #----------------------------- # the derivative function #----------------------------- derivs <- function(t, y, parms) { if (t < 0) lag <- 19 else lag <- lagvalue(t - 0.74) dy <- r * y * (1 - lag/m) list(dy, dy = dy) } #----------------------------- # parameters #----------------------------- r <- 3.5; m <- 19 #----------------------------- # initial values and times #----------------------------- yinit <- c(y = 19.001) times <- seq(-0.74, 40, by = 0.01) #----------------------------- # solve the model #----------------------------- yout <- dede(y = yinit, times = times, func = derivs, parms = NULL, atol = 1e-10) @ <>= plot(yout, which = 1, type = "l", lwd = 2, main = "Lemming model", mfrow = c(1,2)) plot(yout[,2], yout[,3], xlab = "y", ylab = "dy", type = "l", lwd = 2) @ \setkeys{Gin}{width=\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{A delay differential equation model} \label{fig:dde} \end{figure} \clearpage \section{Discrete time models, difference equations} There is one special-purpose solver, triggered with \code{method = "iteration"} which can be used in cases where the new values of the state variables are directly estimated by the user, and need not be found by numerical integration. This is for instance useful when the model consists of difference equations, or for 1-D models when transport is implemented by an implicit or a semi-implicit method. We give here an example of a discrete time model, represented by a difference equation: the Teasel model as from \citet[p287]{Soetaert08}. The dynamics of this plant is described by 6 stages and the transition from one stage to another is in a transition matrix: We define the stages and the transition matrix first: <<>>= Stages <- c("DS 1yr", "DS 2yr", "R small", "R medium", "R large", "F") NumStages <- length(Stages) # Population matrix A <- matrix(nrow = NumStages, ncol = NumStages, byrow = TRUE, data = c( 0, 0, 0, 0, 0, 322.38, 0.966, 0, 0, 0, 0, 0 , 0.013, 0.01, 0.125, 0, 0, 3.448 , 0.007, 0, 0.125, 0.238, 0, 30.170, 0.008, 0, 0.038, 0.245, 0.167, 0.862 , 0, 0, 0, 0.023, 0.75, 0 ) ) @ The difference function is defined as usual, but does not return the ``rate of change'' but rather the new relative stage densities are returned. Thus, each time step, the updated values are divided by the summed densities: <<>>= Teasel <- function (t, y, p) { yNew <- A %*% y list (yNew / sum(yNew)) } @ The model is solved using method ``iteration'': <<>>= out <- ode(func = Teasel, y = c(1, rep(0, 5) ), times = 0:50, parms = 0, method = "iteration") @ and plotted using R-function \code{matplot}: <>= matplot(out[,1], out[,-1], main = "Teasel stage distribution", type = "l") legend("topright", legend = Stages, lty = 1:6, col = 1:6) @ \setkeys{Gin}{width=0.6\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{A difference model solved with method = ``iteration''} \label{fig:difference} \end{figure} \section{Plotting deSolve Objects} There are \proglang{S3} \code{plot} and \code{image} methods for plotting 0-D (plot), and 1-D and 2-D model output (image) as generated with \code{ode}, \code{ode.1D}, \code{ode.2D}. How to use it and examples can be found by typing \code{?plot.deSolve}. \subsection{Plotting Multiple Scenario's} The \code{plot} method for \code{deSolve} objects can also be used to compare different scenarios, e.g from the same model but with different sets of parameters or initial values, with one single call to \code{plot}. As an example we implement the simple combustion model, which can be found on \url{http://www.scholarpedia.org/article/Stiff_systems}: \[ y' = y^2 \cdot (1-y) \] The model is run with 4 different values of the initial conditions: $y = 0.01, 0.02, 0.03, 0.04$ and written to \code{deSolve} objects \code{out}, \code{out2}, \code{out3}, \code{out4}. <<>>= library(deSolve) combustion <- function (t, y, parms) list(y^2 * (1-y) ) @ <<>>= yini <- 0.01 times <- 0 : 200 @ <<>>= out <- ode(times = times, y = yini, parms = 0, func = combustion) out2 <- ode(times = times, y = yini*2, parms = 0, func = combustion) out3 <- ode(times = times, y = yini*3, parms = 0, func = combustion) out4 <- ode(times = times, y = yini*4, parms = 0, func = combustion) @ The different scenarios are plotted at once, and a suitable legend is written. <>= plot(out, out2, out3, out4, main = "combustion") legend("bottomright", lty = 1:4, col = 1:4, legend = 1:4, title = "yini*i") @ \setkeys{Gin}{width=\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{Plotting 4 outputs in one figure} \label{fig:plotdeSolve} \end{figure} \subsection{Plotting Output with Observations} With the help of the optional argument \code{obs} it is possible to specify observed data that should be added to a \code{deSolve} plot. We exemplify this using the \code{ccl4model} in package \code{deSolve}. (see \code{?ccl4model} for what this is about). This model example has been implemented in compiled code. An observed data set is also available, called \code{ccl4data}. It contains toxicant concentrations in a chamber where rats were dosed with CCl4. <<>>= head(ccl4data) @ We select the data from animal ``A'': <<>>= obs <- subset (ccl4data, animal == "A", c(time, ChamberConc)) names(obs) <- c("time", "CP") head(obs) @ After assigning values to the parameters and providing initial conditions, the \code{ccl4model} can be run. We run the model three times, each time with a different value for the first parameter. Output is written to matrices \code{out} \code{out2}, and \code{out3}. <<>>= parms <- c(0.182, 4.0, 4.0, 0.08, 0.04, 0.74, 0.05, 0.15, 0.32, 16.17, 281.48, 13.3, 16.17, 5.487, 153.8, 0.04321671, 0.40272550, 951.46, 0.02, 1.0, 3.80000000) yini <- c(AI = 21, AAM = 0, AT = 0, AF = 0, AL = 0, CLT = 0, AM = 0) out <- ccl4model(times = seq(0, 6, by = 0.05), y = yini, parms = parms) par2 <- parms par2[1] <- 0.1 out2 <- ccl4model(times = seq(0, 6, by = 0.05), y = yini, parms = par2) par3 <- parms par3[1] <- 0.05 out3 <- ccl4model(times = seq(0, 6, by = 0.05), y = yini, parms = par3) @ We plot all these scenarios and the observed data at once: <>= plot(out, out2, out3, which = c("AI", "MASS", "CP"), col = c("black", "red", "green"), lwd = 2, obs = obs, obspar = list(pch = 18, col = "blue", cex = 1.2)) legend("topright", lty = c(1,2,3,NA), pch = c(NA, NA, NA, 18), col = c("black", "red", "green", "blue"), lwd = 2, legend = c("par1", "par2", "par3", "obs")) @ \setkeys{Gin}{width=\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{Plotting output and observations in one figure} \label{fig:plotobs} \end{figure} If we do not select specific variables, then only the ones for which there are observed data are plotted. Assume we have measured the total mass at the end of day 6. We put this in a second data set: <<>>= obs2 <- data.frame(time = 6, MASS = 12) obs2 @ then we plot the data together with the three model runs as follows: <>= plot(out, out2, out3, lwd = 2, obs = list(obs, obs2), obspar = list(pch = c(16, 18), col = c("blue", "black"), cex = c(1.2 , 2)) ) @ \setkeys{Gin}{width=1.0\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{Plotting variables in common with observations} \label{fig:plotobs2} \end{figure} \subsection{Plotting Summary Histograms} The \code{hist} function plots the histogram for each variable; all plot parameters can be set individually (here for \code{col}). To generate the next plot, we overrule the default \code{mfrow} setting which would plot the figures in 3 rows and 3 columns (and hence plot one figure in isolation) <>= hist(out, col = grey(seq(0, 1, by = 0.1)), mfrow = c(3, 4)) @ \setkeys{Gin}{width=1.0\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{Plotting histograms of all output variables} \label{fig:plothist} \end{figure} \subsection{Plotting multi-dimensional output} The \code{image} function plots time versus x images for models solved with \code{ode.1D}, or generates x-y plots for models solved with \code{ode.2D}. \subsubsection{1-D model output} We exemplify its use by means of a Lotka-Volterra model, implemented in 1-D. The model describes a predator and its prey diffusing on a flat surface and in concentric circles. This is a 1-D model, solved in the cylindrical coordinate system. Note that it is simpler to implement this model in R-package \code{ReacTran} \citep{ReacTran}. <>= options(prompt = " ") options(continue = " ") @ We start by defining the derivative function <<>>= lvmod <- function (time, state, parms, N, rr, ri, dr, dri) { with (as.list(parms), { PREY <- state[1:N] PRED <- state[(N+1):(2*N)] ## Fluxes due to diffusion ## at internal and external boundaries: zero gradient FluxPrey <- -Da * diff(c(PREY[1], PREY, PREY[N]))/dri FluxPred <- -Da * diff(c(PRED[1], PRED, PRED[N]))/dri ## Biology: Lotka-Volterra model Ingestion <- rIng * PREY * PRED GrowthPrey <- rGrow * PREY * (1-PREY/cap) MortPredator <- rMort * PRED ## Rate of change = Flux gradient + Biology dPREY <- -diff(ri * FluxPrey)/rr/dr + GrowthPrey - Ingestion dPRED <- -diff(ri * FluxPred)/rr/dr + Ingestion * assEff - MortPredator return (list(c(dPREY, dPRED))) }) } @ <>= options(prompt = " ") options(continue = " ") @ Then we define the parameters, which we put in a list <<>>= R <- 20 # total radius of surface, m N <- 100 # 100 concentric circles dr <- R/N # thickness of each layer r <- seq(dr/2,by = dr,len = N) # distance of center to mid-layer ri <- seq(0,by = dr,len = N+1) # distance to layer interface dri <- dr # dispersion distances parms <- c(Da = 0.05, # m2/d, dispersion coefficient rIng = 0.2, # /day, rate of ingestion rGrow = 1.0, # /day, growth rate of prey rMort = 0.2 , # /day, mortality rate of pred assEff = 0.5, # -, assimilation efficiency cap = 10) # density, carrying capacity @ After defining initial conditions, the model is solved with routine \code{ode.1D} <<>>= state <- rep(0, 2 * N) state[1] <- state[N + 1] <- 10 times <- seq(0, 200, by = 1) # output wanted at these time intervals print(system.time( out <- ode.1D(y = state, times = times, func = lvmod, parms = parms, nspec = 2, names = c("PREY", "PRED"), N = N, rr = r, ri = ri, dr = dr, dri = dri) )) @ The \code{summary} method provides summaries for both 1-dimensional state variables: <<>>= summary(out) @ while the S3-method \code{subset} can be used to extract only specific values of the variables: <<>>= p10 <- subset(out, select = "PREY", subset = time == 10) head(p10, n = 5) @ We first plot both 1-dimensional state variables at once; we specify that the figures are arranged in two rows, and 2 columns; when we call \code{image}, we overrule the default mfrow setting (\code{mfrow = NULL}). Next we plot "PREY" again, once with the default xlim and ylim, and next zooming in. Note that xlim and ylim are a list here. When we call \code{image} for the second time, we overrule the default \code{mfrow} setting by specifying (\code{mfrow = NULL}). %% This is done offline. %%<>= \begin{verbatim} image(out, grid = r, mfrow = c(2, 2), method = "persp", border = NA, ticktype = "detailed", legend = TRUE) image(out, grid = r, which = c("PREY", "PREY"), mfrow = NULL, xlim = list(NULL, c(0, 10)), ylim = list(NULL, c(0, 5)), add.contour = c(FALSE, TRUE)) \end{verbatim} %%@ \setkeys{Gin}{width=1.0\textwidth} \begin{figure} \begin{center} %%<>= %%<> %%@ \includegraphics{image1D.png} \end{center} \caption{image plots} \label{fig:plotimg} \end{figure} \subsubsection{2-D model output} When using \code{image} with a 2-D model, then the 2-D values at all output times will be plotted. Sometimes we want only output at a specific time value. We then use \proglang{S3}-method \code{subset} to extract 2-D variables at suitable time-values and use \proglang{R}'s \code{image}, \code{filled.contour} or \code{contour} method to depict them. Consider the very simple 2-D model (100*100), containing just 1-st order consumption, at a rate \code{r_x2y2}, where \code{r_x2y2} depends on the position along the grid. First the derivative function is defined: <<>>= Simple2D <- function(t, Y, par) { y <- matrix(nrow = nx, ncol = ny, data = Y) # vector to 2-D matrix dY <- - r_x2y2 * y # consumption return(list(dY)) } @ Then the grid is created, and the consumption rate made a function of grid position (\code{outer}). <<>>= dy <- dx <- 1 # grid size nx <- ny <- 100 x <- seq (dx/2, by = dx, len = nx) y <- seq (dy/2, by = dy, len = ny) # in each grid cell: consumption depending on position r_x2y2 <- outer(x, y, FUN=function(x,y) ((x-50)^2 + (y-50)^2)*1e-4) @ After defining the initial values, the model is solved using solver \code{ode.2D}. We use Runge-Kutta method \code{ode45}. <<>>= C <- matrix(nrow = nx, ncol = ny, 1) ODE3 <- ode.2D(y = C, times = 1:100, func = Simple2D, parms = NULL, dimens = c(nx, ny), names = "C", method = "ode45") @ We print a summary, and extract the 2-D variable at \code{time = 50} <<>>= summary(ODE3) t50 <- matrix(nrow = nx, ncol = ny, data = subset(ODE3, select = "C", subset = (time == 50))) @ We use function \code{contour} to plot both the consumption rate and the values of the state variables at \code{time = 50}. <>= par(mfrow = c(1, 2)) contour(x, y, r_x2y2, main = "consumption") contour(x, y, t50, main = "Y(t = 50)") @ \setkeys{Gin}{width=1.0\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{Contour plot of 2-D variables} \label{fig:twoD} \end{figure} \clearpage \section{Troubleshooting} \subsection{Avoiding numerical errors} The solvers from \pkg{ODEPACK} should be first choice for any problem and the defaults of the control parameters are reasonable for many practical problems. However, there are cases where they may give dubious results. Consider the following Lotka-Volterra type of model: <<>>= PCmod <- function(t, x, parms) { with(as.list(c(parms, x)), { dP <- c*P - d*C*P # producer dC <- e*P*C - f*C # consumer res <- c(dP, dC) list(res) }) } @ and with the following (biologically not very realistic)% \footnote{they are not realistic because producers grow unlimited with a high rate and consumers with 100 \% efficiency} parameter values: <<>>= parms <- c(c = 10, d = 0.1, e = 0.1, f = 0.1) @ After specification of initial conditions and output times, the model is solved -- using \code{lsoda}: <<>>= xstart <- c(P = 0.5, C = 1) times <- seq(0, 200, 0.1) out <- ode(y = xstart, times = times, func = PCmod, parms = parms) tail(out) @ We see that the simulation was stopped before reaching the final simulation time and both producers and consumer values may have negative values. What has happened? Being an implicit method, \code{lsoda} generates very small negative values for producers, from day 40 on; these negative values, small at first grow in magnitude until they become infinite or even NaNs (not a number). This is because the model equations are not intended to be used with negative numbers, as negative concentrations are not realistic. A quick-and-dirty solution is to reduce the maximum time step to a considerably small value (e.g. \code{hmax = 0.02} which, of course, reduces computational efficiency. However, a much better solution is to think about the reason of the failure, i.e in our case the \textbf{absolute} accuracy because the states can reach very small absolute values. Therefore, it helps here to reduce \code{atol} to a very small number or even to zero: <<>>= out <- ode(y = xstart,times = times, func = PCmod, parms = parms, atol = 0) matplot(out[,1], out[,2:3], type = "l", xlab = "time", ylab = "Producer, Consumer") @ It is, of course, not possible to set both, \code{atol} and \code{rtol} simultaneously to zero. As we see from this example, it is always a good idea to test simulation results for plausibility. This can be done by theoretical considerations or by comparing the outcome of different ODE solvers and parametrizations. \subsection{Checking model specification} If a model outcome is obviously unrealistic or one of the \ds functions complains about numerical problems it is even more likely that the ``numerical problem'' is in fact a result of an unrealistic model or a programming error. In such cases, playing with solver parameters will not help. Here are some common mistakes we observed in our models and the codes of our students: \begin{itemize} \item The function with the model definition must return a list with the derivatives of all state variables in correct order (and optionally some global values). Check if the number and order of your states is identical in the initial states \code{y} passed to the solver, in the assignments within your model equations and in the returned values. Check also whether the return value is the last statement of your model definition. \item The order of function arguments in the model definition is \code{t, y, parms, ...}. This order is strictly fixed, so that the \ds solvers can pass their data, but naming is flexible and can be adapted to your needs, e.g. \code{time, init, params}. Note also that all three arguments must be given, even if \code{t} is not used in your model. \item Mixing of variable names: if you use the \code{with()}-construction explained above, you must ensure to avoid naming conflicts between parameters (\code{parms}) and state variables (\code{y}). \end{itemize} The solvers included in package \ds are thorougly tested, however they come with \textbf{no warranty} and the user is solely responsible for their correct application. If you encounter unexpected behavior, first check your model and read the documentation. If this doesn't help, feel free to ask a question to an appropriate mailing list, e.g. \url{r-help@r-project.org} or, more specific, \url{r-sig-dynamic-models@r-project.org}. \subsection{Making sense of deSolve's error messages} As many of \pkg{deSolve}'s functions are wrappers around existing \proglang{FORTRAN} codes, the warning and error messages are derived from these codes. Whereas these codes are highly robust, well tested, and efficient, they are not always as user-friendly as we would like. Especially some of the warnings/error messages may appear to be difficult to understand. Consider the first example on the \code{ode} function: <<>>= LVmod <- function(Time, State, Pars) { with(as.list(c(State, Pars)), { Ingestion <- rIng * Prey * Predator GrowthPrey <- rGrow * Prey * (1 - Prey/K) MortPredator <- rMort * Predator dPrey <- GrowthPrey - Ingestion dPredator <- Ingestion * assEff - MortPredator return(list(c(dPrey, dPredator))) }) } pars <- c(rIng = 0.2, # /day, rate of ingestion rGrow = 1.0, # /day, growth rate of prey rMort = 0.2 , # /day, mortality rate of predator assEff = 0.5, # -, assimilation efficiency K = 10) # mmol/m3, carrying capacity yini <- c(Prey = 1, Predator = 2) times <- seq(0, 200, by = 1) out <- ode(func = LVmod, y = yini, parms = pars, times = times) @ This model is easily solved by the default integration method, \code{lsoda}. Now we change one of the parameters to an unrealistic value: \code{rIng} is set to $100$. This means that the predator ingests 100 times its own body-weight per day if there are plenty of prey. Needless to say that this is very unhealthy, if not lethal. Also, \code{lsoda} cannot solve the model anymore. Thus, if we try: <>= pars["rIng"] <- 100 out2 <- ode(func = LVmod, y = yini, parms = pars, times = times) @ A lot of seemingly incomprehensible messages will be written to the screen. We repeat the latter part of them: \begin{verbatim} DLSODA- Warning..Internal T (=R1) and H (=R2) are such that in the machine, T + H = T on the next step (H = step size). Solver will continue anyway. In above message, R1 = 53.4272, R2 = 2.44876e-15 DLSODA- Above warning has been issued I1 times. It will not be issued again for this problem. In above message, I1 = 10 DLSODA- At current T (=R1), MXSTEP (=I1) steps taken on this call before reaching TOUT In above message, I1 = 5000 In above message, R1 = 53.4272 Warning messages: 1: In lsoda(y, times, func, parms, ...) : an excessive amount of work (> maxsteps ) was done, but integration was not successful - increase maxsteps 2: In lsoda(y, times, func, parms, ...) : Returning early. Results are accurate, as far as they go \end{verbatim} The first sentence tells us that at T = 53.4272, the solver used a step size H = 2.44876e-15. This step size is so small that it cannot tell the difference between T and T + H. Nevertheless, the solver tried again. The second sentence tells that, as this warning has been occurring 10 times, it will not be outputted again. As expected, this error did not go away, so soon the maximal number of steps (5000) has been exceeded. This is indeed what the next message is about: The third sentence tells that at T = 53.4272, maxstep = 5000 steps have been done. The one before last message tells why the solver returned prematurely, and suggests a solution. Simply increasing maxsteps will not work and it makes more sense to first see if the output tells what happens: <>= plot(out2, type = "l", lwd = 2, main = "corrupt Lotka-Volterra model") @ You may, of course, consider to use another solver: <>= pars["rIng"] <- 100 out3 <- ode(func = LVmod, y = yini, parms = pars, times = times, method = "ode45", atol = 1e-14, rtol = 1e-14) @ but don't forget to think about this too and, for example, increase simulation time to 1000 and try different values of \code{atol} and \code{rtol}. We leave this open as an exercise to the reader. \setkeys{Gin}{width=\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{A model that cannot be solved correctly} \label{fig:err} \end{figure} \clearpage %\section{Function overview} \begin{table*}[b] \caption{Summary of the functions that solve differential equations}\label{tb:rs} \centering \begin{tabular}{p{.15\textwidth}p{.75\textwidth}}\hline \rule[-3mm]{0mm}{8mm} Function &Description\\ \hline \hline \code{ode} & integrates systems of ordinary differential equations, assumes a full, banded or arbitrary sparse Jacobian \\ \hline \code{ode.1D} & integrates systems of ODEs resulting from 1-dimensional reaction-transport problems \\ \hline \code{ode.2D} & integrates systems of ODEs resulting from 2-dimensional reaction-transport problems \\ \hline \code{ode.3D} & integrates systems of ODEs resulting from 3-dimensional reaction-transport problems \\ \hline \code{ode.band} & integrates systems of ODEs resulting from unicomponent 1-dimensional reaction-transport problems \\ \hline \code{dede} & integrates systems of delay differential equations \\ \hline \code{daspk} & solves systems of differential algebraic equations, assumes a full or banded Jacobian \\ \hline \code{radau} & solves systems of ordinary or differential algebraic equations, assumes a full or banded Jacobian; includes a root solving procedure \\ \hline \code{lsoda} & integrates ODEs, automatically chooses method for stiff or non-stiff problems, assumes a full or banded Jacobian \\ \hline \code{lsodar} & same as \code{lsoda}, but includes a root-solving procedure \\ \hline \code{lsode} or \code{vode} & integrates ODEs, user must specify if stiff or non-stiff assumes a full or banded Jacobian; Note that, as from version 1.7, \code{lsode} includes a root finding procedure, similar to \code{lsodar}. \\ \hline \code{lsodes} & integrates ODEs, using stiff method and assuming an arbitrary sparse Jacobian. Note that, as from version 1.7, \code{lsodes} includes a root finding procedure, similar to \code{lsodar} \\ \hline \code{rk} & integrates ODEs, using Runge-Kutta methods (includes Runge-Kutta 4 and Euler as special cases) \\ \hline \code{rk4} & integrates ODEs, using the classical Runge-Kutta 4th order method (special code with less options than \code{rk}) \\ \hline \code{euler} & integrates ODEs, using Euler's method (special code with less options than \code{rk}) \\ \hline \code{zvode} & integrates ODEs composed of complex numbers, full, banded, stiff or nonstiff \\ \hline \hline \end{tabular} \end{table*} \begin{table*}[b] \caption{Meaning of the integer return parameters in the different integration routines. If \code{out} is the output matrix, then this vector can be retrieved by function \code{attributes(out)\$istate}; its contents is displayed by function \code{diagnostics(out)}. Note that the number of function evaluations, is without the extra evaluations needed to generate the output for the ordinary variables. } \centering \begin{tabular}{p{.05\textwidth}p{.95\textwidth}}\hline \rule[-3mm]{0mm}{8mm} Nr &Description\\ \hline \hline 1 & the return flag; the conditions under which the last call to the solver returned. For \code{lsoda, lsodar, lsode, lsodes, vode, rk, rk4, euler} these are: 2: the solver was successful, -1: excess work done, -2: excess accuracy requested, -3: illegal input detected, -4: repeated error test failures, -5: repeated convergence failures, -6: error weight became zero \\ \hline 2 & the number of steps taken for the problem so far\\ \hline 3 & the number of function evaluations for the problem so far\\ \hline 4 & the number of Jacobian evaluations so far\\ \hline 5 & the method order last used (successfully)\\ \hline 6 & the order of the method to be attempted on the next step\\ \hline 7 & If return flag = -4,-5: the largest component in the error vector\\ \hline 8 & the length of the real work array actually required. (\proglang{FORTRAN} code)\\ \hline 9 & the length of the integer work array actually required. (\proglang{FORTRAN} code)\\ \hline 10 & the number of matrix LU decompositions so far\\ \hline 11 & the number of nonlinear (Newton) iterations so far\\ \hline 12 & the number of convergence failures of the solver so far\\ \hline 13 & the number of error test failures of the integrator so far\\ \hline 14 & the number of Jacobian evaluations and LU decompositions so far\\ \hline 15 & the method indicator for the last succesful step, 1 = adams (nonstiff), 2 = bdf (stiff)\\ \hline 17 & the number of nonzero elements in the sparse Jacobian\\ \hline 18 & the current method indicator to be attempted on the next step, 1 = adams (nonstiff), 2 = bdf (stiff)\\ \hline 19 & the number of convergence failures of the linear iteration so far\\ \hline \hline \end{tabular} \end{table*} \begin{table*}[b] \caption{Meaning of the double precision return parameters in the different integration routines. If \code{out} is the output matrix, then this vector can be retrieved by function \code{attributes(out)\$rstate}; its contents is displayed by function \code{diagnostics(out)}} \centering \begin{tabular}{p{.05\textwidth}p{.95\textwidth}}\hline \rule[-3mm]{0mm}{8mm} Nr &Description\\ \hline \hline 1 & the step size in t last used (successfully)\\ \hline 2 & the step size to be attempted on the next step\\ \hline 3 & the current value of the independent variable which the solver has actually reached\\ \hline 4 & a tolerance scale factor, greater than 1.0, computed when a request for too much accuracy was detected\\ \hline 5 & the value of t at the time of the last method switch, if any (only \code{lsoda, lsodar}) \\ \hline \hline \end{tabular} \end{table*} %% this adds References to the PDF-Index without adding an obsolete section \phantomsection \addcontentsline{toc}{section}{References} \bibliography{integration} \end{document} deSolve/inst/doc/dynload-dede/0000755000175100001440000000000013131750050015737 5ustar hornikusersdeSolve/inst/doc/dynload-dede/dedeUtils.c0000754000175100001440000000132612352122173020034 0ustar hornikusers/* File dedeUtils.c */ #include #include #include #include /* FORTRAN-callable interface to dede utility functions in package deSolve */ void F77_SUB(lagvalue)(double *T, int *nr, int *N, double *ytau) { static void(*fun)(double, int*, int, double*) = NULL; if (fun == NULL) fun = (void(*)(double, int*, int, double*))R_GetCCallable("deSolve", "lagvalue"); fun(*T, nr, *N, ytau); return; } void F77_SUB(lagderiv)(double *T, int *nr, int *N, double *ytau) { static void(*fun)(double, int*, int, double*) = NULL; if (fun == NULL) fun = (void(*)(double, int*, int, double*))R_GetCCallable("deSolve", "lagderiv"); fun(*T, nr, *N, ytau); return; } deSolve/inst/doc/dynload-dede/dede_lv.R0000754000175100001440000000312112352122173017466 0ustar hornikusers### Simple DDE, adapted version of ?dede example from package deSolve library(deSolve) derivs <- function(t, y, parms) { with(as.list(c(y, parms)), { if (t < tau) ytau <- c(1, 1) else ytau <- lagvalue(t - tau, c(1, 2)) dN <- f * N - g * N * P dP <- e * g * ytau[1] * ytau[2] - m * P list(c(dN, dP), tau=ytau[1], tau=ytau[2]) }) } yinit <- c(N=1, P=1) times <- seq(0, 500) parms <- c(f=0.1, g=0.2, e=0.1, m=0.1, tau = .2) ## one single run system.time( yout <- dede(y = yinit, times = times, func = derivs, parms = parms) ) if(!interactive()) pdf(file="dede_lv.pdf") plot(yout) system("R CMD SHLIB dede_lv.c") dyn.load(paste("dede_lv", .Platform$dynlib.ext, sep="")) ## 100 runs system.time( for (i in 1:100) yout2 <- dede(yinit, times = times, func = "derivs", parms = parms, dllname = "dede_lv", initfunc = "initmod", nout = 2) ) dyn.unload(paste("dede_lv", .Platform$dynlib.ext, sep="")) plot(yout2, main=c("y", "ytau")) ## Fortran models still need the c code in dedeUtils.c. ## However, as long as you just use the lagvalue() and lagderiv() ## supplied with deSolve, dedeUtils.c works as is. system("R CMD SHLIB dede_lvF.f dedeUtils.c") dyn.load(paste("dede_lvF", .Platform$dynlib.ext, sep="")) ## 100 runs system.time( for (i in 1:100) yout3 <- dede(yinit, times = times, func = "derivs", parms = parms, dllname = "dede_lvF", initfunc = "initmod", nout = 2) ) dyn.unload(paste("dede_lvF", .Platform$dynlib.ext, sep="")) plot(yout3, main=c("y", "ytau")) if(!interactive()) dev.off() deSolve/inst/doc/dynload-dede/dedesimple.c0000754000175100001440000000256212352122173020230 0ustar hornikusers/* File dedesimple.c */ #include #include #include #include static double parms[2]; #define tau parms[0] #define k parms[1] /* Interface to dede utility functions in package deSolve */ void lagvalue(double T, int *nr, int N, double *ytau) { static void(*fun)(double, int*, int, double*) = NULL; if (fun == NULL) fun = (void(*)(double, int*, int, double*))R_GetCCallable("deSolve", "lagvalue"); return fun(T, nr, N, ytau); } void lagderiv(double T, int *nr, int N, double *ytau) { static void(*fun)(double, int*, int, double*) = NULL; if (fun == NULL) fun = (void(*)(double, int*, int, double*))R_GetCCallable("deSolve", "lagderiv"); return fun(T, nr, N, ytau); } /* Initializer */ void initmod(void (* odeparms)(int *, double *)) { int N = 2; odeparms(&N, parms); } /* Derivatives */ void derivs (int *neq, double *t, double *y, double *ydot, double *yout, int *ip) { if (ip[0] < 1) error("nout should be at least 1"); int nr[1] = {0}; // which lags are needed? // numbering starts from zero ! double ytau[1] = {1.0}; // array; initialize with default values ! double T = *t - tau; if (*t > tau) { lagvalue(T, nr, 1, ytau); //Rprintf("test %g %g %g \n", T, y[0], ytau[0]); } yout[0] = ytau[0]; ydot[0] = k * ytau[0]; } deSolve/inst/doc/dynload-dede/dede_lv2F.f0000754000175100001440000000375712352122173017721 0ustar hornikusersC file dede_lf2F.f C Initializer for parameter common block subroutine initmod(odeparms) external odeparms double precision parms(6) common /myparms/parms call odeparms(6, parms) return end C Derivatives and one output variable subroutine derivs(neq, t, y, ydot, yout, ip) integer neq, ip(*) double precision t, y(neq), ydot(neq), yout(*) double precision N, P, ytau(2), tlag1, tlag2 integer nr(2) double precision f, g, e, m, tau1, tau2 common /myparms/f, g, e, m, tau1, tau2 if (ip(1) < 2) call rexit("nout should be at least 2") N = y(1) P = y(2) nr(1) = 0 nr(2) = 1 ytau(1) = 1.0 ytau(2) = 1.0 tlag1 = t - tau1 tlag2 = t - tau2 if (min(tlag1, tlag2) .GE. 0.0) then call lagvalue(tlag1, nr(1), 1, ytau(1)) call lagvalue(tlag2, nr(2), 1, ytau(2)) endif ydot(1) = f * N - g * N * P ydot(2) = e * g * ytau(1) * ytau(2) - m * P yout(1) = ytau(1) yout(2) = ytau(2) return end double precision function getlag(t0, t, tau, ydef, nr) double precision t0, t, tau, ydef integer nr double precision tlag, y tlag = t - tau y = ydef if (tlag .GE. t0) call lagvalue(tlag, nr, 1, y) getlag = y return end subroutine derivs2(neq, t, y, ydot, yout, ip) integer neq, ip(*) double precision t, y(neq), ydot(neq), yout(*) double precision N, P, ytau(2), getlag double precision f, g, e, m, tau1, tau2 common /myparms/f, g, e, m, tau1, tau2 if (ip(1) < 2) call rexit("nout should be at least 2") N = y(1) P = y(2) ytau(1) = 1.0 ytau(2) = 1.0 ytau(1) = getlag(0.0, t, tau1, ytau(1), 0) ytau(2) = getlag(0.0, t, tau2, ytau(2), 1) ydot(1) = f * N - g * N * P ydot(2) = e * g * ytau(1) * ytau(2) - m * P yout(1) = ytau(1) yout(2) = ytau(2) return end deSolve/inst/doc/dynload-dede/dede_lv2.c0000754000175100001440000000520112352122173017572 0ustar hornikusers/* File dedesimple.c */ #include #include #include #include static double parms[6]; #define f parms[0] #define g parms[1] #define e parms[2] #define m parms[3] #define tau1 parms[4] #define tau2 parms[5] /* Interface to dede utility functions in package deSolve */ void lagvalue(double T, int *nr, int N, double *ytau) { static void(*fun)(double, int*, int, double*) = NULL; if (fun == NULL) fun = (void(*)(double, int*, int, double*))R_GetCCallable("deSolve", "lagvalue"); return fun(T, nr, N, ytau); } void lagderiv(double T, int *nr, int N, double *ytau) { static void(*fun)(double, int*, int, double*) = NULL; if (fun == NULL) fun = (void(*)(double, int*, int, double*))R_GetCCallable("deSolve", "lagderiv"); return fun(T, nr, N, ytau); } /* Initializer */ void initmod(void (* odeparms)(int *, double *)) { int N = 6; odeparms(&N, parms); } /* Derivatives */ void derivs(int *neq, double *t, double *y, double *ydot, double *yout, int *ip) { if (ip[0] < 2) error("nout should be at least 2"); double N = y[0]; double P = y[1]; int nr[2] = {0, 1}; // which lags are needed? try: (0, 0) // numbering starts from zero ! double ytau[2] = {1.0, 1.0}; // array; initialize with default values ! double T1 = *t - tau1; double T2 = *t - tau2; if (*t >= fmax(tau1, tau2)) { // time, lag ID, number of returned lags, return value lagvalue(T1, &nr[0], 1, &ytau[0]); lagvalue(T2, &nr[1], 1, &ytau[1]); } ydot[0] = f * N - g * N * P; ydot[1] = e * g * ytau[0] * ytau[1] - m * P; yout[0] = ytau[0]; yout[1] = ytau[1]; } /* ---------------------------------------------------------------------------*/ /* Version 2: A helper function and "derivs2" */ double getlag(double t0, double t, double tau, double ydef, int nr) { double T = t - tau; double y = ydef; if ((t - tau) >= t0) lagvalue(T, &nr, 1, &y); return y; } void derivs2(int *neq, double *t, double *y, double *ydot, double *yout, int *ip) { if (ip[0] < 2) error("nout should be at least 2"); double N = y[0]; double P = y[1]; double ytau[2] = {1.0, 1.0}; ytau[0] = getlag (0, *t, tau1, ytau[0], 0); ytau[1] = getlag (0, *t, tau2, ytau[1], 1); ydot[0] = f * N - g * N * P; ydot[1] = e * g * ytau[0] * ytau[1] - m * P; yout[0] = ytau[0]; yout[1] = ytau[1]; } deSolve/inst/doc/dynload-dede/dede_lv2.R0000754000175100001440000000441412352122173017556 0ustar hornikusers### Lotka-Volterra system with delay library(deSolve) derivs <- function(t, y, parms) { with(as.list(c(y, parms)), { if (t < max(tau1, tau2)) ytau <- c(1, 1) else { ytau <- c( lagvalue(t - tau1, 1), lagvalue(t - tau2, 2) ) } dN <- f * N - g * N * P dP <- e * g * ytau[1] * ytau[2] - m * P list(c(dN, dP), tau=ytau[1], tau=ytau[2]) }) } yinit <- c(N=1, P=1) times <- seq(0, 500) parms <- c(f=0.1, g=0.2, e=0.1, m=0.1, tau1 = 0.2, tau2 = 50) ## one single run system.time( yout <- dede(y = yinit, times = times, func = derivs, parms = parms) ) if (!interactive()) pdf(file="dede_lf2.pdf") plot(yout) system("R CMD SHLIB dede_lv2.c") dyn.load(paste("dede_lv2", .Platform$dynlib.ext, sep="")) ## 100 runs system.time( for (i in 1:100) yout2 <- dede(yinit, times = times, func = "derivs", parms = parms, dllname = "dede_lv2", initfunc = "initmod", nout = 2) ) ## version "derivs2" (different if tau1 != tau2; respects individual tau system.time( for (i in 1:100) yout3 <- dede(yinit, times = times, func = "derivs2", parms = parms, dllname = "dede_lv2", initfunc = "initmod", nout = 2) ) plot(yout2, yout3) # identical if tau1=tau2 dyn.unload(paste("dede_lv2", .Platform$dynlib.ext, sep="")) # should be zero summary(as.vector(yout) - as.vector(yout2)) # can be different from zero summary(as.vector(yout) - as.vector(yout3)) ## ## Fortran Example ## system("R CMD SHLIB dede_lv2F.f dedeUtils.c") dyn.load(paste("dede_lv2F", .Platform$dynlib.ext, sep="")) ## 100 runs system.time( for (i in 1:100) yout4 <- dede(yinit, times = times, func = "derivs", parms = parms, dllname = "dede_lv2F", initfunc = "initmod", nout = 2) ) ## version "derivs2" (different if tau1 != tau2; respects individual tau system.time( for (i in 1:100) yout5 <- dede(yinit, times = times, func = "derivs2", parms = parms, dllname = "dede_lv2F", initfunc = "initmod", nout = 2) ) plot(yout4, yout5) # identical if tau1=tau2 dyn.unload(paste("dede_lv2F", .Platform$dynlib.ext, sep="")) # should be zero summary(as.vector(yout) - as.vector(yout4)) # can be different from zero summary(as.vector(yout) - as.vector(yout5)) if (!interactive()) dev.off() deSolve/inst/doc/dynload-dede/dede_lv.c0000754000175100001440000000320612352122173017513 0ustar hornikusers/* File dedesimple.c */ #include #include #include #include static double parms[5]; #define f parms[0] #define g parms[1] #define e parms[2] #define m parms[3] #define tau parms[4] /* Interface to dede utility functions in package deSolve */ void lagvalue(double T, int *nr, int N, double *ytau) { static void(*fun)(double, int*, int, double*) = NULL; if (fun == NULL) fun = (void(*)(double, int*, int, double*))R_GetCCallable("deSolve", "lagvalue"); return fun(T, nr, N, ytau); } void lagderiv(double T, int *nr, int N, double *ytau) { static void(*fun)(double, int*, int, double*) = NULL; if (fun == NULL) fun = (void(*)(double, int*, int, double*))R_GetCCallable("deSolve", "lagderiv"); return fun(T, nr, N, ytau); } /* Initializer */ void initmod(void (* odeparms)(int *, double *)) { int N = 5; odeparms(&N, parms); } /* Derivatives */ void derivs (int *neq, double *t, double *y, double *ydot, double *yout, int *ip) { if (ip[0] < 2) error("nout should be at least 1"); double N = y[0]; double P = y[1]; int Nout = 2; // number of returned lags ( <= n_eq !!) int nr[2] = {0, 1}; // which lags are needed? try: (0, 0) // numbering starts from zero ! double ytau[2] = {1.0, 1.0}; // array; initialize with default values ! double T = *t - tau; if (*t > tau) { lagvalue(T, nr, Nout, ytau); //Rprintf("test %g %g %g \n", T, y[0], ytau[0]); } ydot[0] = f * N - g * N * P; ydot[1] = e * g * ytau[0] * ytau[1] - m * P; yout[0] = ytau[0]; yout[1] = ytau[1]; } deSolve/inst/doc/dynload-dede/dedesimple.R0000754000175100001440000000273412352122173020210 0ustar hornikusers### Simple DDE, adapted version of ?dede example from package deSolve library(deSolve) derivs <- function(t, y, parms) { with(as.list(parms), { if (t < tau) ytau <- 1 else ytau <- lagvalue(t - tau) dy <- k * ytau list(c(dy), ytau=ytau) }) } yinit <- c(y=1) times <- seq(0, 30, 0.1) parms <- c(tau = 1, k = -1) ## one single run system.time( yout <- dede(y = yinit, times = times, func = derivs, parms = parms) ) if (!interactive()) pdf(file="dedesimple.pdf") plot(yout, main = c("dy/dt = -y(t-1)", "ytau")) system("R CMD SHLIB dedesimple.c") #dyn.load("dedesimple.dll") dyn.load(paste("dedesimple", .Platform$dynlib.ext, sep="")) ## 100 runs system.time( for (i in 1:100) yout2 <- dede(yinit, times = times, func = "derivs", parms = parms, dllname = "dedesimple", initfunc = "initmod", nout = 1) ) #dyn.unload("dedesimple.dll") dyn.unload(paste("dedesimple", .Platform$dynlib.ext, sep="")) plot(yout2, main=c("y", "ytau")) ## Fortran example system("R CMD SHLIB dedesimpleF.f dedeUtils.c") dyn.load(paste("dedesimpleF", .Platform$dynlib.ext, sep="")) ## 100 runs system.time( for (i in 1:100) yout3 <- dede(yinit, times = times, func = "derivs", parms = parms, dllname = "dedesimpleF", initfunc = "initmod", nout = 1) ) #dyn.unload("dedesimple.dll") dyn.unload(paste("dedesimpleF", .Platform$dynlib.ext, sep="")) plot(yout3, main=c("y", "ytau")) if (!interactive()) dev.off() deSolve/inst/doc/dynload-dede/dede_lvF.f0000754000175100001440000000166612352122173017634 0ustar hornikusersC file dede_lfF.f C Initializer for parameter common block subroutine initmod(odeparms) external odeparms double precision parms(5) common /myparms/parms call odeparms(5, parms) return end C Derivatives and one output variable subroutine derivs(neq, t, y, ydot, yout, ip) integer neq, ip(*) double precision t, y(neq), ydot(neq), yout(*) double precision N, P, ytau(2), tlag integer nr(2) double precision f, g, e, m, tau common /myparms/f, g, e, m, tau if (ip(1) < 2) call rexit("nout should be at least 2") N = y(1) P = y(2) nr(1) = 0 nr(2) = 1 ytau(1) = 1.0 ytau(2) = 1.0 tlag = t - tau if (tlag .GT. 0.0) call lagvalue(tlag, nr, 2, ytau) ydot(1) = f * N - g * N * P ydot(2) = e * g * ytau(1) * ytau(2) - m * P yout(1) = ytau(1) yout(2) = ytau(2) return end deSolve/inst/doc/dynload-dede/dedesimpleF.f0000754000175100001440000000136112352122173020335 0ustar hornikusersC file dedesimpleF.f C Initializer for parameter common block subroutine initmod(odeparms) external odeparms double precision parms(2) common /myparms/parms call odeparms(2, parms) return end C Derivatives and one output variable subroutine derivs(neq, t, y, ydot, yout, ip) integer neq, ip(*) double precision t, y(neq), ydot(neq), yout(*) double precision tau, k, ytau(1), tlag integer nr(1) common /myparms/tau, k if (ip(1) < 1) call rexit("nout should be at least 1") nr(1) = 0 ytau(1) = 1.0 tlag = t - tau if (tlag .GT. 0.0) call lagvalue(tlag, nr, 1, ytau) yout(1) = ytau(1) ydot(1) = k * ytau(1) return end deSolve/inst/doc/deSolve.R0000644000175100001440000010064413131751000015133 0ustar hornikusers### R code from vignette source 'deSolve.Rnw' ################################################### ### code chunk number 1: preliminaries ################################################### library("deSolve") options(prompt = "> ") options(width=70) ################################################### ### code chunk number 2: deSolve.Rnw:181-184 ################################################### parameters <- c(a = -8/3, b = -10, c = 28) ################################################### ### code chunk number 3: deSolve.Rnw:192-195 ################################################### state <- c(X = 1, Y = 1, Z = 1) ################################################### ### code chunk number 4: deSolve.Rnw:222-233 ################################################### Lorenz<-function(t, state, parameters) { with(as.list(c(state, parameters)),{ # rate of change dX <- a*X + Y*Z dY <- b * (Y-Z) dZ <- -X*Y + c*Y - Z # return the rate of change list(c(dX, dY, dZ)) }) # end with(as.list ... } ################################################### ### code chunk number 5: deSolve.Rnw:243-244 ################################################### times <- seq(0, 100, by = 0.01) ################################################### ### code chunk number 6: deSolve.Rnw:259-262 ################################################### library(deSolve) out <- ode(y = state, times = times, func = Lorenz, parms = parameters) head(out) ################################################### ### code chunk number 7: ode ################################################### par(oma = c(0, 0, 3, 0)) plot(out, xlab = "time", ylab = "-") plot(out[, "X"], out[, "Z"], pch = ".") mtext(outer = TRUE, side = 3, "Lorenz model", cex = 1.5) ################################################### ### code chunk number 8: figode ################################################### par(oma = c(0, 0, 3, 0)) plot(out, xlab = "time", ylab = "-") plot(out[, "X"], out[, "Z"], pch = ".") mtext(outer = TRUE, side = 3, "Lorenz model", cex = 1.5) ################################################### ### code chunk number 9: deSolve.Rnw:316-319 ################################################### outb <- radau(state, times, Lorenz, parameters, atol = 1e-4, rtol = 1e-4) outc <- ode(state, times, Lorenz, parameters, method = "radau", atol = 1e-4, rtol = 1e-4) ################################################### ### code chunk number 10: deSolve.Rnw:335-341 ################################################### print(system.time(out1 <- rk4 (state, times, Lorenz, parameters))) print(system.time(out2 <- lsode (state, times, Lorenz, parameters))) print(system.time(out <- lsoda (state, times, Lorenz, parameters))) print(system.time(out <- lsodes(state, times, Lorenz, parameters))) print(system.time(out <- daspk (state, times, Lorenz, parameters))) print(system.time(out <- vode (state, times, Lorenz, parameters))) ################################################### ### code chunk number 11: deSolve.Rnw:359-360 ################################################### rkMethod() ################################################### ### code chunk number 12: deSolve.Rnw:369-370 ################################################### rkMethod("rk23") ################################################### ### code chunk number 13: deSolve.Rnw:383-404 ################################################### func <- function(t, x, parms) { with(as.list(c(parms, x)),{ dP <- a * P - b * C * P dC <- b * P * C - c * C res <- c(dP, dC) list(res) }) } rKnew <- rkMethod(ID = "midpoint", varstep = FALSE, A = c(0, 1/2), b1 = c(0, 1), c = c(0, 1/2), stage = 2, Qerr = 1 ) out <- ode(y = c(P = 2, C = 1), times = 0:100, func, parms = c(a = 0.1, b = 0.1, c = 0.1), method = rKnew) head(out) ################################################### ### code chunk number 14: deSolve.Rnw:438-440 ################################################### diagnostics(out1) diagnostics(out2) ################################################### ### code chunk number 15: deSolve.Rnw:444-445 ################################################### summary(out1) ################################################### ### code chunk number 16: deSolve.Rnw:519-527 ################################################### Aphid <- function(t, APHIDS, parameters) { deltax <- c (0.5, rep(1, numboxes - 1), 0.5) Flux <- -D * diff(c(0, APHIDS, 0)) / deltax dAPHIDS <- -diff(Flux) / delx + APHIDS * r # the return value list(dAPHIDS ) } # end ################################################### ### code chunk number 17: deSolve.Rnw:532-539 ################################################### D <- 0.3 # m2/day diffusion rate r <- 0.01 # /day net growth rate delx <- 1 # m thickness of boxes numboxes <- 60 # distance of boxes on plant, m, 1 m intervals Distance <- seq(from = 0.5, by = delx, length.out = numboxes) ################################################### ### code chunk number 18: deSolve.Rnw:544-548 ################################################### # Initial conditions: # ind/m2 APHIDS <- rep(0, times = numboxes) APHIDS[30:31] <- 1 state <- c(APHIDS = APHIDS) # initialise state variables ################################################### ### code chunk number 19: deSolve.Rnw:555-559 ################################################### times <-seq(0, 200, by = 1) print(system.time( out <- ode.1D(state, times, Aphid, parms = 0, nspec = 1, names = "Aphid") )) ################################################### ### code chunk number 20: deSolve.Rnw:565-566 ################################################### head(out[,1:5]) ################################################### ### code chunk number 21: deSolve.Rnw:570-571 ################################################### summary(out) ################################################### ### code chunk number 22: deSolve.Rnw:604-606 ################################################### data <- cbind(dist = c(0,10, 20, 30, 40, 50, 60), Aphid = c(0,0.1,0.25,0.5,0.25,0.1,0)) ################################################### ### code chunk number 23: matplot1d ################################################### par (mfrow = c(1,2)) matplot.1D(out, grid = Distance, type = "l", mfrow = NULL, subset = time %in% seq(0, 200, by = 10), obs = data, obspar = list(pch = 18, cex = 2, col="red")) plot.1D(out, grid = Distance, type = "l", mfrow = NULL, subset = time == 100, obs = data, obspar = list(pch = 18, cex = 2, col="red")) ################################################### ### code chunk number 24: matplot1d ################################################### par (mfrow = c(1,2)) matplot.1D(out, grid = Distance, type = "l", mfrow = NULL, subset = time %in% seq(0, 200, by = 10), obs = data, obspar = list(pch = 18, cex = 2, col="red")) plot.1D(out, grid = Distance, type = "l", mfrow = NULL, subset = time == 100, obs = data, obspar = list(pch = 18, cex = 2, col="red")) ################################################### ### code chunk number 25: deSolve.Rnw:672-687 ################################################### daefun <- function(t, y, dy, parameters) { res1 <- dy[1] + y[1] - y[2] res2 <- y[2] * y[1] - t list(c(res1, res2)) } library(deSolve) yini <- c(1, 0) dyini <- c(1, 0) times <- seq(0, 10, 0.1) ## solver system.time(out <- daspk(y = yini, dy = dyini, times = times, res = daefun, parms = 0)) ################################################### ### code chunk number 26: dae ################################################### matplot(out[,1], out[,2:3], type = "l", lwd = 2, main = "dae", xlab = "time", ylab = "y") ################################################### ### code chunk number 27: figdae ################################################### matplot(out[,1], out[,2:3], type = "l", lwd = 2, main = "dae", xlab = "time", ylab = "y") ################################################### ### code chunk number 28: deSolve.Rnw:720-730 ################################################### pendulum <- function (t, Y, parms) { with (as.list(Y), list(c(u, v, -lam * x, -lam * y - 9.8, x^2 + y^2 -1 )) ) } ################################################### ### code chunk number 29: deSolve.Rnw:733-734 ################################################### yini <- c(x = 1, y = 0, u = 0, v = 1, lam = 1) ################################################### ### code chunk number 30: deSolve.Rnw:737-740 ################################################### M <- diag(nrow = 5) M[5, 5] <- 0 M ################################################### ### code chunk number 31: deSolve.Rnw:744-748 ################################################### index <- c(2, 2, 1) times <- seq(from = 0, to = 10, by = 0.01) out <- radau (y = yini, func = pendulum, parms = NULL, times = times, mass = M, nind = index) ################################################### ### code chunk number 32: pendulum ################################################### plot(out, type = "l", lwd = 2) plot(out[, c("x", "y")], type = "l", lwd = 2) ################################################### ### code chunk number 33: pendulum ################################################### plot(out, type = "l", lwd = 2) plot(out[, c("x", "y")], type = "l", lwd = 2) ################################################### ### code chunk number 34: deSolve.Rnw:782-795 ################################################### ZODE2 <- function(Time, State, Pars) { with(as.list(State), { df <- 1i * f dg <- -1i * g * g * f return(list(c(df, dg))) }) } yini <- c(f = 1+0i, g = 1/2.1+0i) times <- seq(0, 2 * pi, length = 100) out <- zvode(func = ZODE2, y = yini, parms = NULL, times = times, atol = 1e-10, rtol = 1e-10) ################################################### ### code chunk number 35: deSolve.Rnw:807-809 ################################################### analytical <- cbind(f = exp(1i*times), g = 1/(exp(1i*times)+1.1)) tail(cbind(out[,2], analytical[,1])) ################################################### ### code chunk number 36: deSolve.Rnw:822-833 ################################################### f1 <- function (t, y, parms) { ydot <- vector(len = 5) ydot[1] <- 0.1*y[1] -0.2*y[2] ydot[2] <- -0.3*y[1] +0.1*y[2] -0.2*y[3] ydot[3] <- -0.3*y[2] +0.1*y[3] -0.2*y[4] ydot[4] <- -0.3*y[3] +0.1*y[4] -0.2*y[5] ydot[5] <- -0.3*y[4] +0.1*y[5] return(list(ydot)) } ################################################### ### code chunk number 37: deSolve.Rnw:838-840 ################################################### yini <- 1:5 times <- 1:20 ################################################### ### code chunk number 38: deSolve.Rnw:847-848 ################################################### out <- lsode(yini, times, f1, parms = 0, jactype = "fullint") ################################################### ### code chunk number 39: deSolve.Rnw:855-864 ################################################### fulljac <- function (t, y, parms) { jac <- matrix(nrow = 5, ncol = 5, byrow = TRUE, data = c(0.1, -0.2, 0 , 0 , 0 , -0.3, 0.1, -0.2, 0 , 0 , 0 , -0.3, 0.1, -0.2, 0 , 0 , 0 , -0.3, 0.1, -0.2, 0 , 0 , 0 , -0.3, 0.1)) return(jac) } ################################################### ### code chunk number 40: deSolve.Rnw:869-871 ################################################### out2 <- lsode(yini, times, f1, parms = 0, jactype = "fullusr", jacfunc = fulljac) ################################################### ### code chunk number 41: deSolve.Rnw:878-880 ################################################### out3 <- lsode(yini, times, f1, parms = 0, jactype = "bandint", bandup = 1, banddown = 1) ################################################### ### code chunk number 42: deSolve.Rnw:885-892 ################################################### bandjac <- function (t, y, parms) { jac <- matrix(nrow = 3, ncol = 5, byrow = TRUE, data = c( 0 , -0.2, -0.2, -0.2, -0.2, 0.1, 0.1, 0.1, 0.1, 0.1, -0.3, -0.3, -0.3, -0.3, 0)) return(jac) } ################################################### ### code chunk number 43: deSolve.Rnw:897-899 ################################################### out4 <- lsode(yini, times, f1, parms = 0, jactype = "bandusr", jacfunc = bandjac, bandup = 1, banddown = 1) ################################################### ### code chunk number 44: deSolve.Rnw:905-906 ################################################### out5 <- lsode(yini, times, f1, parms = 0, mf = 10) ################################################### ### code chunk number 45: deSolve.Rnw:937-943 ################################################### eventmod <- function(t, var, parms) { list(dvar = -0.1*var) } yini <- c(v1 = 1, v2 = 2) times <- seq(0, 10, by = 0.1) ################################################### ### code chunk number 46: deSolve.Rnw:950-954 ################################################### eventdat <- data.frame(var = c("v1", "v2", "v2", "v1"), time = c(1, 1, 5, 9), value = c(1, 2, 3, 4), method = c("add", "mult", "rep", "add")) eventdat ################################################### ### code chunk number 47: deSolve.Rnw:959-961 ################################################### out <- ode(func = eventmod, y = yini, times = times, parms = NULL, events = list(data = eventdat)) ################################################### ### code chunk number 48: event1 ################################################### plot(out, type = "l", lwd = 2) ################################################### ### code chunk number 49: figevent1 ################################################### plot(out, type = "l", lwd = 2) ################################################### ### code chunk number 50: deSolve.Rnw:983-988 ################################################### ballode<- function(t, y, parms) { dy1 <- y[2] dy2 <- -9.8 list(c(dy1, dy2)) } ################################################### ### code chunk number 51: deSolve.Rnw:995-996 ################################################### root <- function(t, y, parms) y[1] ################################################### ### code chunk number 52: deSolve.Rnw:1001-1006 ################################################### event <- function(t, y, parms) { y[1]<- 0 y[2]<- -0.9 * y[2] return(y) } ################################################### ### code chunk number 53: deSolve.Rnw:1012-1017 ################################################### yini <- c(height = 0, v = 20) times <- seq(from = 0, to = 20, by = 0.01) out <- lsode(times = times, y = yini, func = ballode, parms = NULL, events = list(func = event, root = TRUE), rootfun = root) ################################################### ### code chunk number 54: event2 ################################################### plot(out, which = "height", type = "l",lwd = 2, main = "bouncing ball", ylab = "height") ################################################### ### code chunk number 55: figevent2 ################################################### plot(out, which = "height", type = "l",lwd = 2, main = "bouncing ball", ylab = "height") ################################################### ### code chunk number 56: deSolve.Rnw:1066-1068 ################################################### times <- seq(0, 1, 0.1) eventtimes <- c(0.7, 0.9) ################################################### ### code chunk number 57: deSolve.Rnw:1073-1074 ################################################### eventtimes %in% times ################################################### ### code chunk number 58: deSolve.Rnw:1081-1083 ################################################### times2 <- round(times, 1) times - times2 ################################################### ### code chunk number 59: deSolve.Rnw:1094-1095 ################################################### eventtimes %in% times2 ################################################### ### code chunk number 60: deSolve.Rnw:1100-1101 ################################################### all(eventtimes %in% times2) ################################################### ### code chunk number 61: deSolve.Rnw:1111-1114 ################################################### times <- 1:10 eventtimes <- c(1.3, 3.4, 4, 7.9, 8.5) newtimes <- sort(unique(c(times, eventtimes))) ################################################### ### code chunk number 62: deSolve.Rnw:1120-1123 ################################################### times <- 1:10 eventtimes <- c(1.3, 3.4, 4, 7.9999999999999999, 8.5) newtimes <- sort(c(eventtimes, cleanEventTimes(times, eventtimes))) ################################################### ### code chunk number 63: deSolve.Rnw:1152-1186 ################################################### library(deSolve) #----------------------------- # the derivative function #----------------------------- derivs <- function(t, y, parms) { if (t < 0) lag <- 19 else lag <- lagvalue(t - 0.74) dy <- r * y * (1 - lag/m) list(dy, dy = dy) } #----------------------------- # parameters #----------------------------- r <- 3.5; m <- 19 #----------------------------- # initial values and times #----------------------------- yinit <- c(y = 19.001) times <- seq(-0.74, 40, by = 0.01) #----------------------------- # solve the model #----------------------------- yout <- dede(y = yinit, times = times, func = derivs, parms = NULL, atol = 1e-10) ################################################### ### code chunk number 64: dde ################################################### plot(yout, which = 1, type = "l", lwd = 2, main = "Lemming model", mfrow = c(1,2)) plot(yout[,2], yout[,3], xlab = "y", ylab = "dy", type = "l", lwd = 2) ################################################### ### code chunk number 65: figdde ################################################### plot(yout, which = 1, type = "l", lwd = 2, main = "Lemming model", mfrow = c(1,2)) plot(yout[,2], yout[,3], xlab = "y", ylab = "dy", type = "l", lwd = 2) ################################################### ### code chunk number 66: deSolve.Rnw:1223-1235 ################################################### Stages <- c("DS 1yr", "DS 2yr", "R small", "R medium", "R large", "F") NumStages <- length(Stages) # Population matrix A <- matrix(nrow = NumStages, ncol = NumStages, byrow = TRUE, data = c( 0, 0, 0, 0, 0, 322.38, 0.966, 0, 0, 0, 0, 0 , 0.013, 0.01, 0.125, 0, 0, 3.448 , 0.007, 0, 0.125, 0.238, 0, 30.170, 0.008, 0, 0.038, 0.245, 0.167, 0.862 , 0, 0, 0, 0.023, 0.75, 0 ) ) ################################################### ### code chunk number 67: deSolve.Rnw:1240-1244 ################################################### Teasel <- function (t, y, p) { yNew <- A %*% y list (yNew / sum(yNew)) } ################################################### ### code chunk number 68: deSolve.Rnw:1247-1249 ################################################### out <- ode(func = Teasel, y = c(1, rep(0, 5) ), times = 0:50, parms = 0, method = "iteration") ################################################### ### code chunk number 69: difference ################################################### matplot(out[,1], out[,-1], main = "Teasel stage distribution", type = "l") legend("topright", legend = Stages, lty = 1:6, col = 1:6) ################################################### ### code chunk number 70: difference ################################################### matplot(out[,1], out[,-1], main = "Teasel stage distribution", type = "l") legend("topright", legend = Stages, lty = 1:6, col = 1:6) ################################################### ### code chunk number 71: deSolve.Rnw:1292-1296 ################################################### library(deSolve) combustion <- function (t, y, parms) list(y^2 * (1-y) ) ################################################### ### code chunk number 72: deSolve.Rnw:1298-1300 ################################################### yini <- 0.01 times <- 0 : 200 ################################################### ### code chunk number 73: deSolve.Rnw:1302-1306 ################################################### out <- ode(times = times, y = yini, parms = 0, func = combustion) out2 <- ode(times = times, y = yini*2, parms = 0, func = combustion) out3 <- ode(times = times, y = yini*3, parms = 0, func = combustion) out4 <- ode(times = times, y = yini*4, parms = 0, func = combustion) ################################################### ### code chunk number 74: plotdeSolve ################################################### plot(out, out2, out3, out4, main = "combustion") legend("bottomright", lty = 1:4, col = 1:4, legend = 1:4, title = "yini*i") ################################################### ### code chunk number 75: plotdeSolve ################################################### plot(out, out2, out3, out4, main = "combustion") legend("bottomright", lty = 1:4, col = 1:4, legend = 1:4, title = "yini*i") ################################################### ### code chunk number 76: deSolve.Rnw:1336-1337 ################################################### head(ccl4data) ################################################### ### code chunk number 77: deSolve.Rnw:1340-1343 ################################################### obs <- subset (ccl4data, animal == "A", c(time, ChamberConc)) names(obs) <- c("time", "CP") head(obs) ################################################### ### code chunk number 78: deSolve.Rnw:1349-1363 ################################################### parms <- c(0.182, 4.0, 4.0, 0.08, 0.04, 0.74, 0.05, 0.15, 0.32, 16.17, 281.48, 13.3, 16.17, 5.487, 153.8, 0.04321671, 0.40272550, 951.46, 0.02, 1.0, 3.80000000) yini <- c(AI = 21, AAM = 0, AT = 0, AF = 0, AL = 0, CLT = 0, AM = 0) out <- ccl4model(times = seq(0, 6, by = 0.05), y = yini, parms = parms) par2 <- parms par2[1] <- 0.1 out2 <- ccl4model(times = seq(0, 6, by = 0.05), y = yini, parms = par2) par3 <- parms par3[1] <- 0.05 out3 <- ccl4model(times = seq(0, 6, by = 0.05), y = yini, parms = par3) ################################################### ### code chunk number 79: plotobs ################################################### plot(out, out2, out3, which = c("AI", "MASS", "CP"), col = c("black", "red", "green"), lwd = 2, obs = obs, obspar = list(pch = 18, col = "blue", cex = 1.2)) legend("topright", lty = c(1,2,3,NA), pch = c(NA, NA, NA, 18), col = c("black", "red", "green", "blue"), lwd = 2, legend = c("par1", "par2", "par3", "obs")) ################################################### ### code chunk number 80: plotobs ################################################### plot(out, out2, out3, which = c("AI", "MASS", "CP"), col = c("black", "red", "green"), lwd = 2, obs = obs, obspar = list(pch = 18, col = "blue", cex = 1.2)) legend("topright", lty = c(1,2,3,NA), pch = c(NA, NA, NA, 18), col = c("black", "red", "green", "blue"), lwd = 2, legend = c("par1", "par2", "par3", "obs")) ################################################### ### code chunk number 81: deSolve.Rnw:1389-1391 ################################################### obs2 <- data.frame(time = 6, MASS = 12) obs2 ################################################### ### code chunk number 82: obs2 ################################################### plot(out, out2, out3, lwd = 2, obs = list(obs, obs2), obspar = list(pch = c(16, 18), col = c("blue", "black"), cex = c(1.2 , 2)) ) ################################################### ### code chunk number 83: plotobs2 ################################################### plot(out, out2, out3, lwd = 2, obs = list(obs, obs2), obspar = list(pch = c(16, 18), col = c("blue", "black"), cex = c(1.2 , 2)) ) ################################################### ### code chunk number 84: hist ################################################### hist(out, col = grey(seq(0, 1, by = 0.1)), mfrow = c(3, 4)) ################################################### ### code chunk number 85: plothist ################################################### hist(out, col = grey(seq(0, 1, by = 0.1)), mfrow = c(3, 4)) ################################################### ### code chunk number 86: deSolve.Rnw:1450-1452 ################################################### options(prompt = " ") options(continue = " ") ################################################### ### code chunk number 87: deSolve.Rnw:1455-1479 ################################################### lvmod <- function (time, state, parms, N, rr, ri, dr, dri) { with (as.list(parms), { PREY <- state[1:N] PRED <- state[(N+1):(2*N)] ## Fluxes due to diffusion ## at internal and external boundaries: zero gradient FluxPrey <- -Da * diff(c(PREY[1], PREY, PREY[N]))/dri FluxPred <- -Da * diff(c(PRED[1], PRED, PRED[N]))/dri ## Biology: Lotka-Volterra model Ingestion <- rIng * PREY * PRED GrowthPrey <- rGrow * PREY * (1-PREY/cap) MortPredator <- rMort * PRED ## Rate of change = Flux gradient + Biology dPREY <- -diff(ri * FluxPrey)/rr/dr + GrowthPrey - Ingestion dPRED <- -diff(ri * FluxPred)/rr/dr + Ingestion * assEff - MortPredator return (list(c(dPREY, dPRED))) }) } ################################################### ### code chunk number 88: deSolve.Rnw:1481-1483 ################################################### options(prompt = " ") options(continue = " ") ################################################### ### code chunk number 89: deSolve.Rnw:1486-1500 ################################################### R <- 20 # total radius of surface, m N <- 100 # 100 concentric circles dr <- R/N # thickness of each layer r <- seq(dr/2,by = dr,len = N) # distance of center to mid-layer ri <- seq(0,by = dr,len = N+1) # distance to layer interface dri <- dr # dispersion distances parms <- c(Da = 0.05, # m2/d, dispersion coefficient rIng = 0.2, # /day, rate of ingestion rGrow = 1.0, # /day, growth rate of prey rMort = 0.2 , # /day, mortality rate of pred assEff = 0.5, # -, assimilation efficiency cap = 10) # density, carrying capacity ################################################### ### code chunk number 90: deSolve.Rnw:1503-1513 ################################################### state <- rep(0, 2 * N) state[1] <- state[N + 1] <- 10 times <- seq(0, 200, by = 1) # output wanted at these time intervals print(system.time( out <- ode.1D(y = state, times = times, func = lvmod, parms = parms, nspec = 2, names = c("PREY", "PRED"), N = N, rr = r, ri = ri, dr = dr, dri = dri) )) ################################################### ### code chunk number 91: deSolve.Rnw:1516-1517 ################################################### summary(out) ################################################### ### code chunk number 92: deSolve.Rnw:1521-1523 ################################################### p10 <- subset(out, select = "PREY", subset = time == 10) head(p10, n = 5) ################################################### ### code chunk number 93: deSolve.Rnw:1569-1574 ################################################### Simple2D <- function(t, Y, par) { y <- matrix(nrow = nx, ncol = ny, data = Y) # vector to 2-D matrix dY <- - r_x2y2 * y # consumption return(list(dY)) } ################################################### ### code chunk number 94: deSolve.Rnw:1578-1585 ################################################### dy <- dx <- 1 # grid size nx <- ny <- 100 x <- seq (dx/2, by = dx, len = nx) y <- seq (dy/2, by = dy, len = ny) # in each grid cell: consumption depending on position r_x2y2 <- outer(x, y, FUN=function(x,y) ((x-50)^2 + (y-50)^2)*1e-4) ################################################### ### code chunk number 95: deSolve.Rnw:1589-1592 ################################################### C <- matrix(nrow = nx, ncol = ny, 1) ODE3 <- ode.2D(y = C, times = 1:100, func = Simple2D, parms = NULL, dimens = c(nx, ny), names = "C", method = "ode45") ################################################### ### code chunk number 96: deSolve.Rnw:1595-1598 ################################################### summary(ODE3) t50 <- matrix(nrow = nx, ncol = ny, data = subset(ODE3, select = "C", subset = (time == 50))) ################################################### ### code chunk number 97: twoD ################################################### par(mfrow = c(1, 2)) contour(x, y, r_x2y2, main = "consumption") contour(x, y, t50, main = "Y(t = 50)") ################################################### ### code chunk number 98: twoD ################################################### par(mfrow = c(1, 2)) contour(x, y, r_x2y2, main = "consumption") contour(x, y, t50, main = "Y(t = 50)") ################################################### ### code chunk number 99: deSolve.Rnw:1628-1636 ################################################### PCmod <- function(t, x, parms) { with(as.list(c(parms, x)), { dP <- c*P - d*C*P # producer dC <- e*P*C - f*C # consumer res <- c(dP, dC) list(res) }) } ################################################### ### code chunk number 100: deSolve.Rnw:1643-1644 ################################################### parms <- c(c = 10, d = 0.1, e = 0.1, f = 0.1) ################################################### ### code chunk number 101: deSolve.Rnw:1650-1656 ################################################### xstart <- c(P = 0.5, C = 1) times <- seq(0, 200, 0.1) out <- ode(y = xstart, times = times, func = PCmod, parms = parms) tail(out) ################################################### ### code chunk number 102: deSolve.Rnw:1677-1681 ################################################### out <- ode(y = xstart,times = times, func = PCmod, parms = parms, atol = 0) matplot(out[,1], out[,2:3], type = "l", xlab = "time", ylab = "Producer, Consumer") ################################################### ### code chunk number 103: deSolve.Rnw:1737-1761 ################################################### LVmod <- function(Time, State, Pars) { with(as.list(c(State, Pars)), { Ingestion <- rIng * Prey * Predator GrowthPrey <- rGrow * Prey * (1 - Prey/K) MortPredator <- rMort * Predator dPrey <- GrowthPrey - Ingestion dPredator <- Ingestion * assEff - MortPredator return(list(c(dPrey, dPredator))) }) } pars <- c(rIng = 0.2, # /day, rate of ingestion rGrow = 1.0, # /day, growth rate of prey rMort = 0.2 , # /day, mortality rate of predator assEff = 0.5, # -, assimilation efficiency K = 10) # mmol/m3, carrying capacity yini <- c(Prey = 1, Predator = 2) times <- seq(0, 200, by = 1) out <- ode(func = LVmod, y = yini, parms = pars, times = times) ################################################### ### code chunk number 104: deSolve.Rnw:1773-1776 ################################################### pars["rIng"] <- 100 out2 <- ode(func = LVmod, y = yini, parms = pars, times = times) ################################################### ### code chunk number 105: err ################################################### plot(out2, type = "l", lwd = 2, main = "corrupt Lotka-Volterra model") ################################################### ### code chunk number 106: deSolve.Rnw:1825-1828 ################################################### pars["rIng"] <- 100 out3 <- ode(func = LVmod, y = yini, parms = pars, times = times, method = "ode45", atol = 1e-14, rtol = 1e-14) ################################################### ### code chunk number 107: err ################################################### plot(out2, type = "l", lwd = 2, main = "corrupt Lotka-Volterra model") deSolve/inst/doc/deSolve.pdf0000644000175100001440000255521413131751003015517 0ustar hornikusers%PDF-1.5 % 1 0 obj << /Type /ObjStm /Length 4863 /Filter /FlateDecode /N 88 /First 742 >> stream x\[w6~?o `֜qܚ8qm7vh,}~ /Cjz, }߸(aI ,3 KY ele2e,Nebbc5qIA8;`U=-g ,}sUWsU>7aż;:./?"&3;b͋.n^#BiGΏsYs32?DUj>Y̧Cm9M :Yq<˓v|*7A(g{tO v9jϫI>͞Wzq2//kE@ëߊ=QYOmSMjz]f5UqW$e(cZyYk*5<7jJՆά/'#A(7+Hi(PnKП eM9Яg%|){!UhaX"@ h6赳Q٬_ }x\e |ٴ @3{l5 I4c`00`p&e4 tgeU҈H:sP, H|~~Xģʟc5N`X>/5~}^]1-r,^ nC4-R#?,G]M4 1 a&& aX70;lQ^\G<jqy%n)6TA@oK̶1YM̴ha;`T`Z:IzNe^2% 滱 /\ f)JηD8XO8؞;.R$kD>Z7Z+#,X+ľNhcYD98,Ґ - (8gb`j(vx.g 4^L x1ƓDxjc$n̿g}V&(j)by3;C 핋 2?w.owK3zj=ٕA!f;EzR8, p5c>ƅlRWZYlA%ژNہ V9׶$+Kuv99Ef_+'Ƈa S߂_'^JOBtEHzzO{rwy(J?|!c&nBti2hn Uڙ]KZwj1k1s%F8?`p=gLQ67OAIsVzi4kZkh>3}׷X+K-7{} ٠/,]oPe {[&ah^I'ҽC5;TvԍA" @tjcʖC\nTNm+Zwuy?VlӴNC+< J STy 3$M#%ϧ*zA+};- /?+JvT4IM fN(Px6Z(X E4%ixRv#ImJpirfXt=5ևnVTZ6Jal7h"MO5f:MTosO4e(ssa MVJ"UnѮsorzȴNw[q"8QkDXD| ^O%kth9)(moWcc}lsꦷNJu)MQi\Aoɱ[}V% J:SC;6mhime2O!dp^dB)Ǔ!3d:,eRlk}lOFg5X{n)ʬ:?jn/TqCXT7Nst&9$i љk4č arK+OݢEwb> X,D KPO =۾i]4da"#ky'M.ܱp!g243L״0LVw됙3r0?HVf8y޿piL~cG/Ъՙo~M=d ?0HM\j Ay17,վZ fAhӇRUI7[5@JEmuj}Az7D_!5jj3(alOFemdV27><~yB@r=V3E/OXb';׍%8)Eh1=VԷIIY󓫋O\ "}=:Ok/%Z̮.ֽm.{KҾVuk9a4]=G<#֦} fkqT^k,UDT%j`nB泃 Qݣ3*.GTZ uQ'y; tUIwN)hZ@jM2Vަ8"ߗj :kdSE+#7o)#ʲH~+DE6$i'% H)"_"؈}TEtQ"q7dȤ-BeiD H5̠#*kIE/{0b#k 7I[,2iFY4tsrܱh 7у|ϟ G;g6)n Y{eLpuG p#,BZA@Dnլbr[W ɤX VOƀ@o%LD+ӣ/.[&yMX>9yӕ;~r 0&@$K55ە-D!Hè%V2n_[ Z]Tk)y)[Y m#T0nMaM7ƁƘeaE[b8w%/rZW>ňg13+?6R\v>U@mPV)4endstream endobj 90 0 obj << /Subtype /XML /Type /Metadata /Length 1823 >> stream GPL Ghostscript 9.20 differential equations, ordinary differential equations, differential algebraic equations, partial differential equations, initial value problems, R 2017-07-13T22:03:13+02:00 2017-07-13T22:03:13+02:00 LaTeX with hyperref package Package deSolve: Solving Initial Value Differential Equations in RKarline Soetaert, Thomas Petzoldt, R. Woodrow Setzer endstream endobj 91 0 obj << /Type /ObjStm /Length 3646 /Filter /FlateDecode /N 88 /First 799 >> stream x[koܸ_-J|?yl`7i`M"(g\$_s)iN) [9$,(&dA3-= YXf3!@ 8Z)LL8ePLxoLr0L 2wLj3iLzPpG=B0%5)m)ԺTB! rH84*<Ӿ$3\"F`FNHɌ'ŌEQ!53ڒ e[*@ ̞Ye<1AWdA[J0%@B)f"' A@;$E$ZT`N-#a ;ChɜV9ndrz\^hǩ1/3,e[3)oa"B`o:zea !ܜ%W,GP^#SZ!%S0%YH@ & kIr1RĶ)4̮. 1RT#|ɧI)rO1#+IVJȔ"Cq?Gl1g*I1rW1\pUUW3\puuO~2.*Y$>]2T(| $gR3O׋秋>Kghi{}5KyOM^DL̸-|aSf7;`[in0rF}S?`KnOl, 9j†>.<]j r#yNw ?]90ۘ~:?'9QN-DdWkkU2~j/FHoZ貍 c.Y 2pT @)K[<8I`(Mi.Ř]Һ0#J@ Xc [E VU`DmRVWz8 I6ܩpU+ Swmex\rpUJ"nG>m$3JT @R컀*Py,"-iܭ0 @9uLy f8ÊW@(1njmGY_~ģiGVLMՃgY6}5]M.k* ~C& EԾa;3ZY|-+y"ʰyl"ux^wϹMs}yi^'*z=_TLT39vVc~m~ý~DŽv '_-֨m[c8øbkc7F~KﲬMYpE­_PKrɌ"- ,Wn3|ۥ>?ձnTE:yY]7?gogyZOֳޑԗڠdW^ԟuێ[܎wRߖY4 ;ԥȃ]_{߼  횸1qyNHτ)GG:?+S gu(P[[,m6I-^!ܔ:wGP`|BA!C7N` ]ސ-oj \^f}tS%f:Ε XL[5XBc@~{;ȥi, i>Za} neCvkPAaj ΍(\},lJcw#q7 ) v;[G=;ZZa`ګm1I `h#&z Lbv1A|@?uGp/cw2wͻGtu\ぱ'YDzN(J{}ŤKL0y[oHcQk}0"zӷ $w|7"dcn?0{bz;L' Ȱ/tpeߛBf(TӤB|DRVam~R|k(tpb7o߼:})_ʾ'hd#}ftuu~~ڐ5oZ_L"o r+ulIv bаA_Â{g\wo;S1X9צE;+GO=4 Aru fLɍs3іcZ2UNᱧa[;9koE1Bw2WeaJ ۮrn)0Y3ᰞ{ prezQ(T1%?r+2cqrە{2;]^Ɣ֒c] 7`~5_\@'RߚtܨŴ׹%]?OR>yIc\su|&Zd֗<IMsHkӐURpۦdDdzj>c71v-<]VxcSuƠTSgsI&'HH"]tViLU6'< PZ rr*=yMչK.u"ꔺ,5@ڥ3>]Dg!ZDXMr*ZYzu]",2rxNEk4ˢ `]V/ͻԸ6YbSS<7S$^4J(xmB%X,'B;p}EE^%ՙ5HЭքz k,&YRBo\AB|sh, #`ȱY@8V:xhHd0P%8@{2w%t,[Mj95HRendstream endobj 180 0 obj << /Type /ObjStm /Length 2617 /Filter /FlateDecode /N 88 /First 788 >> stream xZ޿/+9E @Mc&:qǕ%|w[;0|߼yCwEV"'8Ze %QWQ9Qx".ˑ Ov4.Get}2=^TPF4lĈL@&zA ZF5sy-Z=s,q+1V e=nrl` H%WLxP@c8jS-l{Z矣ۋ6p66$3oy6^[8@ܢF0l,#޾X7@tcgGȃp[maQmpkqYGova'Z8< ۢkXo`:ۗڮ^гڝP'd. F'B>ny(v~@߽;ǞANΛ9g^bN3N < S C6cѓ帨OƄ=D,Itr]틿V/_ϛP봹iy[=^߮ҺiL pV3ta[~Ri.= D=OŜPʇ>$Ee,bpx)7xx6c\^GreSq6=$@J8l__S9w]v>N)Y}u I3pX}kw΋OfS]'O.X-B OD{uw$K'w5ɝ5ia._q?v xX}δ/wT@R@H?izgax%}yz"6aqϑ _>>>b?P/%vXxUC,/LL;m4.CLbu5kj*1PndQ!v5FtN4R\g-bĢPJec _ZRh' ڕ YjQ N-\JrĪso:GXпC!xI5z.gzHk%!YH\qגwn ܆Bߵ3\{e?R)V=GN5m 7rF %3H.N݋`4,c1K/jcIJ^$pl|u &]jq} @T5šsDؘAD`sRF͖5f$KvL!{3f4Fph&bƂxWlYO7xB.}}i1>՚yG[I9VD؎<23d@{`=m͈q@PN [akZkB)%0TDSJT ?Wv+0묕I9gswsɬub}}£KKXCU`z׃endstream endobj 269 0 obj << /Type /ObjStm /Length 2793 /Filter /FlateDecode /N 88 /First 788 >> stream xZks_oI5ELlvovmh HBRn}υHI|Hnx<"{.@ W)PI i/i91ϩ3ιc¥QFB`h>N2nGiƝY!Ӕn`a,ү<iQ? >|4vB5)&Sk&&ä4[&qFPgϤL:)gcx (L%SRPpHlX<4uL<\3O&n%jE`ZXsЧLI Hh6 f24g`Td8# aϦɬ^Ghf CXfΎY3M2]rR &1m"*u,s1F1ԄȈDIǜYHϜ"T<@I%cJ"lR)\W"Ņqtß[K2ɕQ)E/.咾Cܥ$"m\j5҂Z-]IoefU3&/CU34`_/pG ,Kt#_n?fNnކu̥x.+ƶۻybZi~O:/V߰ﾋX!0&i!4VDNJݷlPVwEq#p'1yYgu`YgW0{U ҷ5xĄUmۛxo 3Iwю92Fo^/8q@D {c} co+Xof츙fjzdjr&O{F \5c:f-WsVj{{gJaNn`,Hv] l^l[zY,_e'6˯ I%KJ ť7]g|?o#ESo뎷q/ey*|:<O[K\k٫j>e1_<맱Je-196kV)Cڑ0'MPb0-VuWb^j]oVS"<O# ]M=~% 󢘱M&j9+wݕ>mvw W(Ad_nh]K!]elYrM%V9Xǭ6S#2ϑ3v hһH觨>q~v u,) #D{ţ?=_Ev3og^7zXMKTI/iAVpḄbe?| hysWcve,Rt0K~/ /޾Waz5n5XbӀ&/1ٯ6 L}vd3_=My}9W='_~b{Q(ľϫf.Oե$BDah*%Bfǁ-?g3-Ȥ"v7=ܤ0{Nf.?{Mf9D&"cfVX `"XHǔhH:( яN[-CCEM9 # >X#vx \L/Mvk@&> .?>GQ:c2J'Oa;qb%Ю !Câ[픫gqB=),0KvNr$q'J E8f^܄i,'xzK ?(q*=$NC\B0't$K>UmZAbڬt_UX^`|w#iЬџc3ʆ4"Mk fL,$p8_p/NKpDՠ8R(K$Fc*zrsUGWݠ6P'ځxn\%>(!DϦt$/]z"PXǔ{Pb]0 >XDw޳&t!#F>)BɂTD9@ c#H)ТZL>MhS`ҬxЃ{O CcQ>=xTIxJD&JyBO1wCQ@ !DA6 =SX݅ Kaڅlr}*g &(eP' cZ HOJhxO=(Gu j'Mm HܴמfpAL.ɢ-rk *-Ͷn*Gg-C9f@pAlģLuwhϩT)ۛ/90$==G❈.yX|v</|8gw(CJ~z>v&xp$~uyv뿖g베Ϥ() r 3o蔝1o{ߴy͇]WJɋl}7- \N&I,&d=&6wg^dJyEf0B:[g"<*pa:7uX^n;/l|7rt&O/}s[#.Qe\5N<,; EAKQ?Niendstream endobj 358 0 obj << /Filter /FlateDecode /Length 5972 >> stream x\IwǑC~\Y(Ҷ&!yliMhhb>deFVWy:ʌ%3Jz@N^huUbG8"tnuWY[FOÓգ* SI>Uʆ:(cw5bOoL~8L=/\<ţCpH1,w /:Ib|c&<_G[enUYz3<yxwƒ-Lpt){V·+xU情]޴INڈK]L(t*bOfanYl?{tQ]w@A֩B 4cxan?W\h$: f&@ωj/ji{W;s@W 2R@,?lICÇW<#_]t~RVca%ғhm0=sokMvA"VjRuH-+gePi>!85 Kv 7%Ȥ2LOhE ~i{VKb"41ɚKLoػxвb'݉6aB+P]Bؓ^LJ`Y%xumghH0螲` I$ 0` ӽaQ&rOxH~ol%N:S g:RN;8WM _,p}  8y~lo*9 3+1R<|!9Y2S bkѹk6/hbvQPpˢWH`* H|t%@1Wd1 {L@^ ) !fѨ|˥'%iNi0@NCsy(SQz?&2BXf*/>X@W jJZ9 hytÄx!Ƙ020((ypeK>>LxȈ%7y7m1 fB?L $fXRߟhȁdC .-Im{A?3f0T!&2)".#&@!4< "ipbȵЍI@혀Px^ ։ gbW+,70 %|6u'ĉ)زфKH#x$t6RfT`0b_F%%r.)R65'-XK/uF#,f׽\Amôށ3 UIN&žiy0m1J6 i%ƴ'?>3` |ҁmXi]'A+"ŘnU[[YdM8\6پvⓦ_մJ8JBTSDT$_KUeXB$m4&HA:y&YBDFLe'Rev:.;1 |.ԡDQ-l_Lv"<mERY{]Lv(E0@A<ˡwDwղa1$6z 6}h rIգF+yK[ot˄)HQ3c s4:oOTէG n6:JFOAjuK0 K w%X|X,(J&mkOV[(`U x$otI2YvD_*p1Sb!p\|n@oFae.lڠfF?:V31K 1*t^!hSJ-*/a} b%.m@ ^~Ld!$0.6T!\G}Irw9ݟD 9&|8cl31uNvNvHbr.]#_c6 #ѱdj]e=7u?Rt=C[+oEp%?hZ 4:8Ea{ΥivVFP,t~Db%ePSa\b-gP 7mCpv\ۆr,nT5l;CwʊMzL_߂H=9v_m$QpcC[i4O7\2t =9u#^mLDZVX+jvq&W0ÏHi߻Cvy[@ؠ4ӯ9R13vryb?kWAYB-hiߌ#v6@m=l<;Ԧ!uz"Έ Jt @v$ Wxoybp3DKgL[xbP{+ItASH55eC O\YB6aRRx\e yIwiXDvjmg2TWIxdhY^Ol2 اyj-d*rɜꔹc]^NI*JRև{RΖe sS2I#L;0[s=nL+ڋ*ʐRd#7،1.fr5=ޡ9de'ҫ.1*Au ȏ.qc}=afBmVǙxd1eK90]bdAOg(;#BaXR!M0g,`?em%@UĚ{`NYI{R#B\hƥ,r*#Vi$vgͯ$B}o7x5 @eZW#%-qNEy/j[\rae*5c.O>K?\6NC}N1g{du6>ō,ն/&VK[<13lTu-Jlo1G:8]hKz%t N#,ĻSz/o5}tBQ)KY {jzS`?( 'o|%eGCu{2b9{Dqμ@Pؽ(q'guf)A2%zmj^]Fӕ uAy"B.yKlP$98yW,x]IiWTCYmčOwxբ-OLlsYѳ{%| 62(PeE,m]Xa-Z(C3B>DS#!36QD #deDƮ7kXk*ΜoUo9)m0jBPzT 6<`l@%TGJшZDaP+djNx/.h9t3 ;_Vv;'b*4vO_O4&5Uu@d_f(Sx:1&Ua!R0֛  m%!N(bY)Q^.Ǩ \ tI/"5R 肭@+Km!zorMoUu.SVq>mS.Ǎ{*siJf-/hQ֙ϒuj3f>ɽbהT UR2}ai(,&Nel'۝J .цXats( nꍚy[ov0ӹiG!6`ǣT ta%iΩ>vo'[܁?X`2G"skKt} Hz1NWCm>%h,$U:\ihKlt:5TrY6xZMżaja2pzBsX"vR ^9؆ JxŽ.w}"_Ǔm@)NНϣ^)nC wJP`J0+'W=ގd=boe͔ !d>=.hv5ZdOJa`h/x( J]k#<*fFcZ3ZZYO*3 CɗÉ2|J)UՔIb>W*|<J/'K {Fwx˅lxfki܄j"wz[> SwO0)+{pŪnHF; uKs:i-ftA وn1l}3+Cx^[7(R7O'k'Mmϣ:{$ ;6 }0h9h:$m7#'[q-?p[  7|w #^ʅG_.lÖ^9fŅ0/mw5e`F1,0X·0Ji:_, تOxwpEl>'_[&N]~ayTf|LK% B%TgNxIpAT9@6ϛ_~K  gdI,'k$IpS&=4o;:xR Moeb^^cÇLDg^ju BukƮaG}Sń]VaNendstream endobj 359 0 obj << /Filter /FlateDecode /Length 3303 >> stream xZK N s5z?(ÂAdi8s}hdwGҮd$>$Տ AH~dZg׫'/[_ޮr~%W'"jxE*T\{뻨zըV;EoaUU3Rf{*٠LN Ex?8)8#;䝷ˆ~*b!6/=(\ke'`jFMղ+)߰64Z }n] g6FUݔ,(4ohA| +BpJW w2Bsqi+ eCT )a@_B2H.7;a?Q %A[zpIRW=#PyDђf:cU#0`Ў[6 .tIQbTfpr|d7j~$(A NV߯LoVʈGYM'zW5Rf/@]bJw tQ:0kpW0:==`);+mFvlXFȫ<+v#wdЉr_қݯ6Rc"+S-z D\o>ȌƎU!(#5y;3Vd~ ,ppkMB Ah9L#d9R`?7%̪n0.GWGa막h]R.rs{@wtyFтb ,,/iHjF ۹`=P+3!'b#.'"|1%%61{o8%jD?8*@jg ͛TmLЊrdEuD`y %̦hPze#u2&sOӜ \8 >VEKhd:dkyGK߲Ѳj6&/?"(45 Ún;(U^-Wq0i "4;'q-_HcTJ $°dgT㖴Y0$4ϖlb 7Xmgj_vlgϻ:7v"VBǷ} #tʱa1]"0u_JWU}֑ A^1h6g|Rz'Ug-?+Kf8cW UHmћPEcpp)0EGJ]UKOuɢ#ԑԨޡdI94ovjB'I+A"AZ[ZPK8PQ9+$lٕ'0EpNi bU%Bd9p|sdr~k7cdDh;H vtøO;B>$欷% =bI$-^Iu0JNDæ|VzE%úخ7 #ߦ$0zMXoBpҊuF84Cδ6CBvq6שt) m#"7Mc>9ngo6cIROq].i[ia**S)s&q,cޔ|Ktǔ08BQg8̼ie1@,u상NO9e}cyIyt(/(UQ & N\Ńҵ9's>|TGߕ<sf)$oY_'x Wn<'0T]/0-{x9 uϽj咮9XXBȨdRxCS&ɘ7 ( $5;ǒ4ncl>"4}MwJcvLH 9$J%˜Cwy\ NxzmUAM)%Y^u[1wSš[Hć 68ϩcˁ<3eco)MEc:ibIӡ]KdCu<)˺)f3^yHrjɐޓۅPप.OAbfe@xfBs6Q;.WW|.v|^_y=r#)5& `֪T :.a -[Jck蒰x} ^[(K Jmt"P%> w4t<(_)(p ~tMHW/Y+!iҞyM;|d15<:d^(I( tn}QIR]~ Y·w2(`:eQo\  wZo|&DghzV@L{b(Qq9䗧X^;,`;T~;P6I)T-dX˂zSF/9tITW2f`!BJn`"QŅՅ),|QtÊs= MM9ƀ3doEy}$=+oqC ,~Wc*4;v"0CeysB gX) Fͪ \|*_/wCl>Q\ZŞ"i*}!~0k& rZ=ؚ4}+lt˲%paR*:;D.fn"]@M,i LZA;8ދ@% R:e#B_~7Iendstream endobj 360 0 obj << /Filter /FlateDecode /Length 4429 >> stream xnd9=GD[3$@b lHSIz;goVa@Ў>>jO_=1NM.ޞVh`jTҧ'>!'_])$7l`h3Iw3SL~Y=h{:=1W3k-?l0> ՙJ ڦh}aJX3l`c tR. nx;8|qNIÁo`&!oqڤc6;^n2 Qx88ǔiz ۻrK\QVìv Bagc^^[ 径茁d _1 rx)9aaH8퓕h=d {Q9sNY!/μkaK T6u(f:{Vg/_:i ڻdNwrg`"zxy^=_W+Ʃz7uiĺh>W A% xv{[heFi_b~d˳ ![l'%ѣD4֡~*T?De@]e ݰc@# bjoRjO$mD'9( kB֨a$vBm }$6]AQ! t,c_#1:,Ç::^50$11ezK\Y"a}g\pS%]Wδ+D3P'iQ?تvӒu&M!E@_@Wh:X{zF!FFm#$Z$] ؊)0ζ׃Y><)=K[6D\LJ*8zkeZxdV85I]E`}ȞͿ}*rK%L+vCPk a )"y>N/<  S; a%hs!S{*̣܀:tB5FS- =B0Iή:tg~D14FyRDPT32uM!wR-[O,؃`ZW(Ӻ- A̖52#3;ҙ -x~ \^'fP1e(2x!|"g.-:7‹-mkȓHFz'sb9dNܤǶ0iTE ghyaڌ>Ē7Z>q.Dq8x{0=jӒT{6pJtsjm{len- fJ%CWலϦY y;JWa!|1ţ+jwYl\kpRrCzBLR6Fy8)E`f]7p6S 8' r\k܈$jtɔO~ަŭ¢Yx Xua P*}b\*`W:_lЮ< eb /*mҰt@fNb iTńݾ,%)38/:%5JߙqUʻa,c%pu =NEo\CS2R /:  yk8"`^A;QQ{v|:pב,;,yjB^뚲u+vtAu@_:Yc >wq?2Dcl%j¨ Dž2$?d%hHz-cs:j՜-7#<0vgMUMNj꤀|FAgQHN-)?C1t-(c~Wn֡H\Yu"˽uu7uS\sQr? Ŕ ?{ξn? $Xaɱb< awu1;yB3W2PjS@mn,s"h<%2.=໙@aBW?Op*'i*␛= ,h7!Pib  WrXnN̓"A/fu:ZcJ_͋]lp)i{mb j:4J7?<|3oHgKO(# 6G*>iB&rkDa/i-aL̚:bL&h7ٚۻIX>H{чX+Uܷdn*'/2>6!B5 rcjWr׀(FSQEGqn! 4K\8Es~MLڤ-hݤ{<t(QR? J3rUA`<9Y?֞N$(fkQ6rŃ )ֲ4ZT*o>IK%QjD R`(ng e8c8EJ wQ´)qY"4f#T RD\NY 9 _`0HJ &''J2mXĵ.PB>TJQ#FͰgRn2yBrEPBs *ۚTHf wB|'ԯDԎx6$cG 7&r6:Qĸ4ad6ŰƎ`U-=!&n4'+A,8un2Y&Z`)=jYA3}kэl22t mBp2ۏ,STb$eM#M&=ýikcp½3OGKdghJե ZUݞ1\Oq[E,Tbr:9%s뼜]fܷygІڣƄ; v.&wc秡Dpqe*tMfs`xpaӣ=jW)bد(lMCyc$7%k*fꢥD.%q?(Iy_!`&j]P."k0Y#F'{:wfCET$dȼ?5f%&^Eӛ 8?zinۦu Mlf:0+'K#ϣ w7mmA2t""]OLejǼ]t5UQJV@%=Tԛl"quDdF";a*vs~ЮQ] zk#=fci z.ׯnY{ TkIUQD&Fؾ;l, He"ɔ[Ѩa^k"]g \nSrP7 XsYLwa =:QJ;z?P]'5=]/<H`YJ}S`lr_1Crs;UKXVL5.0FXi5bi. 6{=:ӤCkī*m 5y#t41,ȯЇ2v |p :|6XF[vMʆnpyo)/?{F#TOhK. !pMwżbIJ(#ʚ+E"FYI߅4`fzjv#ykJ?^vʱ 㤲Joz;cAy,N3|BD,Ox endstream endobj 361 0 obj << /Filter /FlateDecode /Length 3024 >> stream xZKs+#X{II6TUIack^h %"%L7(PTAF|A+Gx|s$fGduV,/g=QE㳣T΂y뇨3/0W';;Doaћ^HŲWnAu~.?sJNz1emKAֽLQ 7Bh^AJ*)lXύC `{խWpE:5{bd aFNjm?ƹ-VB A_}PC ZQ`'70H~ Ss0yH-JLDbtgf"H]<`G '6I0Vum 0Mfh&*⨶M^\g Cp./xicLGhgBL'Lt̚Tʨ2?w8AU%A #N#q D['T]msO r :[`8͂9d*k\'c‚7U^Βֽsʠ9r=/aI V?V4|{J3mS\봇 4Qtjݚ0٨q\9Е9l@Vb,ӚƢ,zߤܳd c WD.哅$iC-h",0Y!h(F; Ie .5}Oz,-%@WLxFJP:D0ÎF>-n0Yz:'\H8 ǔE dJSxZr_p{ Og^ӑNxi6rHt }0J h@AyϭA ,lJ/9a"u$ذ,aC\PIAT<Ae1 '%k"WDe-X!&|JK3f Qf#x^&#lSioHOJ>eA}/[, b`C/RJG0I%m.t5;ƒۜ!M5uRh4Qu#W.숫x4W~'lXTIN>xʉRO7> HQepRL4p) YN@D:81rr5hvܪ1-+3.UJWjɆcښY4O8a}C %):eI(eF-: ȝy߉RGǿvT9ٻо,t܊HWD6\19ƚqC˶F4Vh ߮vq FLHlF -Z2 WD.м3f6e@&KJ&,c 4aAu!Rf~glO6GYs>n(3 2SfdXrcvZMs6asSVw:$ogm5)89͕>ܿE6Xr2hI ccc'C.͍D"Ms4rr" osMqt/]?t{"u^G+H>ݳ1y2+vD&LBZ6AM M CtOF<iY='4uj"-i9l{2qH3LC 0&"yi}A8>:L«Z_qp1X*9^v V ijpGX*MD.YL*q:͗\ K607}_XHTZ20Yv.MemY&#teʷSik7R'ޮNa}w67K؃U(v OJ/1+gkaþQA='(A! \w~_&BRƗ _8J8.,"$U)")ujz!4KI6wσc>~P;%%( 4 `bLm&$)T1Ǽ触-key*O`ZWNݟVy<j_U^rk09t=->}۳A٬xmF~!6pF 0YXgO=O`MU*zcI+'#走LDnA j,yl[$u( Ofy:z=Sw[އ *Q:mү?۹sj0*fV/*C@CFlTbeэF*&gAd(:v"dF]Ǻ)?-ò as(E`'8=CrM"ֳS Ѹ6M>#^mH݋Tӄ{!KkUSm _\Yk `wf+Ʀ hӦv%4+)dp౾Hc5SDpaWx,t<7c~Ś9Ak`o&l>7d1g6c|lr5cA 5XٗՅY!3n"HՂVwB܉moJ8Rn6R:>b#K2R]; mrInKm%un~ev'd'"ʇ5nY^]}2yLv{4?l~'BelG.$,{˫e'v>(Ƃ+-o >Iq$ZK/#< -w+UvmO͆ղ͂5 lT7FA;vUHۃn7Eğ/ &V6}K$ &Xe=6lܢBM`+"vK{ӄueø$W~Ii&5]7& '"7ZīρZHC*ztxbvPil\ybϏ ~'endstream endobj 362 0 obj << /Filter /FlateDecode /Length 5708 >> stream x\[su~R [ylXbvشRxX ~}Υg @dE%栧ss~zR_˓*ճÉZ=;D_WO.WlIU֫'^%>IgZe99>GOM6>Yd\(F6g'.\>תW^U99B_^N)]jmuV*T6l 5~Zo} 5s`7 Vt镘lM=H)Lt9f=&Wp '?srJkxf;crx@dV^'-3 0y$VЕ+IOy w9ȋmCDSFwd8QDMymo p@86b҈1O&Ue OOq]o]08{D>/KN]s㹲 ),RC=0tbxkl0&̷U01wW/JY YN>ޒx3 M6 Z #Үrk> &6N`ch2S,`"<N:[Tg2bVtZFM> D{ހ IX*!MhQ{GI{:mի 4B[*Dg$dXAHR XLNI%)7LlƃzD\{ԫ`mChr,AMujd\cՄᦍ V(#Ti梃/:E\Cچ!ddGIUa6i<xGmwG3=ZMr/we'zZ>Ȩh?C<&^TMlubX:p&3)2%$SA:h;c_@eeG'+H'W1$XEHh|ǒJOmp6 '  :X#J#>$Z?uZ0cUE)%&t :FI} 22D3`[1[{50s1sFge3Dz=(Gs+j|k\l409j(#Q!uHjb({ 3^8J9-r hmF`1of/k‘b9Gsebˢ*Kàڔgl5Z aR&@Op2XAHƬDyV)2XƵ,Vg=CByqWn{@'Lyv[L5E2% /vslrTϞ<opRS.hL*Ɍ>>@Ud D)5h3wr<no*mvW7!ΕҎ' 2Ro qzC.8F3o$HL]= |IN[N&.3SZVUi\(h&ʖrhV L5NcJx1<ޑ/V[c1ZvE8}\}OӮ)5ؿ7oEUI7VDr^P'.Z~|yrO 9KrX7w6G=]<-kg\ aE5s7<9A+KdƑ;ŅJʁwAz-Tҳ+'LQLWOM+,v>Fu7%@9= "![ f-ɠc}zYD<7{LHJhBmyץ3Yl(3".=' 8_&Dk)3P9LsF hySpEŶeU<*^&-Te< Ԯ\S:M } 慣j@^m{/G`+7U\QWXcD +^JYtٳ*>dQj9$yf]7,0v1 ׶۬%[&2N_;c:PY`h,-ɽ>ԧVsOvu|y;O"R@H/u(V> Wub/g1to牼}z})+OPE67pddW> aEs?å}ǡ *BOͽH?OpoN>_l|bgy>+P%GvNmNpy^iYlrz]oo[Q:nP4LʄΓזFfjgzXA>BW)=k)tJq֢BfQ>eFv,jbJqtnL t_G5%!ıI|QS1ٗ3 vi s׸Uxf@1Y)-VL)xl[6{ bahnS"ʩЈl/^i rI&qC,[Gc<T4bHEzm#ζZu-"Iev:_|mt6 Z~`~9U#xQfX*^)SúBK؛nɚ6}KtI)e4tҋJw2 {g ybbxE5)Hw=kj {經dxRj/@LuTLvZ> -}G.JM>hԲ&_z %3mYoX]>qŷ\X6i:|WE|(ņreN93J*Q]e d1  v[t&2 Q,x f |gc*s)}چ=j,6  k>6@zZl{Rٴ45Vp GvЍ&#!Ǒ Ɇ]{D:{)-7G˥;l)ÈБn O̐?V4tO׻+on)L x ;Rl)MH(y.CɖfmY2mie&s\4  a M!$2 JfbipHRںg , -)+~orZk*dS.+,06Q7o[x9ͦIuTaW3(˵Rn'@V QSSg=7xՀWe-KЦL47=v%{Ӭ?꒽庌~Y?-)u5e|Oգz<*Y.R 9Q×SdvUBU*{圦E,=Fot*W mZ*8i+w@:dH&%O% o&I7 tYeq<=7lM\K3y$s{|hZ,?rbId+}]l-h$u,R7d3^ a" |'h .n]hi(jAFi'O1tLA YD. QJC?,B2=u|iJw3Ak4o{K^ d3[rS -AQWTuxU6P{3twYs }ZԴk%f,]F۰ݴ&'/(jя?-]U/Pof):?^hOwtԇik!xBVr./cQ<աbR%{&ԴZU0ȧ|YR {^!(ڬ)(f}0UO~Ù^ 񔙁'|4 v;eဳՄ98p/CyɿycϏ١?YWO'Ic?>'ڮc%lk0SgM ~ww=kf&R>[37$Ĝ/?=C> stream x\KG#9eQE;B7AF5i]n1o_DFxDevt[ӁTvT痤;C|!@` bzV ZYX M&l`W1i M6i Q [RAi_4q7pJ02 F ZugǨ5GL~q^a`-#N().4xYy{Fۻ/ x3eF˥ tb1(/; [4l7`Z]ֶvuA#*R^#*s>]7?Mtޣqsp@25|Lɻ+mV!ke6& rx-)!EJ | PkR8j _gErc'h97Fn\9-B{ Il'[ {L R@+-| 7V&mOLm77>uVy4/CO|Q4 [ɩ?%gRu8!jn!b[SC .y L9r!BӞq & StM@>b7MH !bIQ JY{,o9Vؖ{0bm3IP 2K} 72!L'jz4)AEzk/':^U)8a~%Rq(?w7y`SxLd&4[ ]A<<V+n07$Ow߻ί#lݪ{gSL`lAZ4"Ր `n)c]-"Af>P*Gi(80l y'O2 Za`EYJ;iG |!j?M4zx9/kqNP1Ҿhմ/!djaW؈ej{\5Mzo0 (W6UܬvB,O4Mm@rH@"r!$imT_ %w%B s*WИ$<+(_cI>$cc")E 1980s ˠJg[k3d߫2:6IbD nv)]mtk~Lo;'Ի!#WWPd7ƤC>㳉h?T?4CNf𜯚pSy FD>(iۉlEv>k-u7ڊAf.dmrdBc:~,O ." ^'; ΢L 9!.fHl$rHd e$%ig/=;kPg1Ά (]i+P~T"BdCR头,a2ΡZ6`w ab< :}P݄a'BgV%` &Hx sD1}Gj5h2HE Z.VwqDP%-gҏh;J# =k L ܽ.:#s4 +C~`C`Enku#Ш-:4q6?!oN{<͵^ --(&SO OG5Q2QA%3G'qw@fz.i1 8u^KC^\0bUMW=]4iSB(U&X674>JkYBB؏]0DA ޾;8d?)/^Q>$w4 @ I;Pcq'ϑr)*o/hUQJ jSmdi5oV:E(:`<)Rт r^[8,IZyΎ9 ?u;C1˃sb#Z=-v9 Mo+7( :8*mF:82Gz8k8S+WO_Rs>bG`;v6H1, [Ywh_#e|]8q̣Xoqq/n䀁4`}1&=yב8-INM*a'S2TjTRZK K 'ғm[` X䊥ȥU ۲u3(GhYw2MUJ$j2U֚61jyӺ{p*3 VSbA.4^8+- &oYDcI &x?Ztއh>7[]Lb]g&&(A^J}V[9uxO]>l6 Ӳ <%_Z68 xD *)M煵{6n-n# ja6?'9."$$IU*H}ƚƛrQ*#2L˻ 81jrj)VbғZFkNe;ɋ$ZcL ٫kZ%s8`tj)rr0:JzVvP͋|ŸG6q6# }f lg2noYM.\P.S,0^j{;ީ1i柖) Rc>~fm9jo_s(fڳW4}Yf:t\]{UNbF9.aI*Ջ+9^T|i]11K}C$OMXwuurSl"1udSdž8?`P"HfļE1`&: 843{ QV ŒKU3K% zM]I^Ȫϟ|# U9b߭YrٯJ[tܞ\4#Qm}: pO|ȓRE4/JϱӟqPE7"퉓N}[&:znU`j}f(@X4wφREW!nRWѾy`)86vpYօf>p;vr"gfc-Uzf1PfSSsyI?qEEJ(! 0;1މVs#7ğ뭉,%%qE%KRv!:gIM-(%X¼ͰּԌ`:?Ԍht(͍IxώP3ސ[ex\P`xp!4+cMpe&5aVhp-M 5L& /+~ɜ8D(Cy8h"~AM>Rlͅ^L$t4Ee"$< /~'=/umnj qź :nqh8,|c[1}zUW3r}K#]T,!%Yr$ΙнAQr^K~ XQ\$qS^ƅA~)tUlqV܅ O2Jmd UWa |/|4P>⟡t>H Zok.>1ƻrʦ1"pIFD9x 0ToS!_6Ulw _9,&z*W69߹L&u%y;NEMhz{d^0QmQהwQ^ZUq ŀݔ؅zZmjS42$y.DLsYΚd\4 XHKuuNɔ+(&]s ~AbnqB٦2x! &P5&*nme ㎈, dĥsoŊ:O1EU\Dk!L[=3QdO|}w=mLFH 8|k'o`)5/۰enpi(38 $N_m$)з &?UnKڜgQrl?oFi|͇C,ȌqSUG5&'а ?tR ^>\j! 4l{] yJxC둿~g@VUÇ@,(x64}TbჵtwW|Lُfwm Kfу$6̰`fQEx0:݂3MQ4]@*k>H6K j|mQO1Žr#-nL噶H&n rtb{x+FFSkߏS`0]!])?^*ҳ |MxSM _gbU}jӯ@> ykS~μqSG bVU}>?q}<f=bᙚ>z:Fڡ#i]:2_'L2;ky !V=ls{id~ F{7/-, KXtQeLJy«z Nڒr3Q@7Uu!"\vHח>ώvcvofߊ/>=wP/] ~߮#/endstream endobj 364 0 obj << /Filter /FlateDecode /Length 4493 >> stream x[[s~go`i6~QUb[>R+Ê"))1XJ> hL_y/F//> njOړ_zRD<rx/VKF+~~ GͰPEVk1N"C#a8ZN8\ʏB*IĨc 1CD6G1e" iV3ܡ&%> X6Wyzvv"H8ʘbt鱷 g彟ь2O}<"qz*h,!-m6&&`1X5U*֛ii1>%Šװ}FW?km=~:o!Z0bt(ZGU;SwCY հk5p _W!ƣ q^#Bas=B5Si-o ? k(թYO+_$dEg߮H1dt2nȻ[l#$Qz(mEG .# d$"Ǥf5L|>M T8>MNXY!J:M֛2!e`pc䘭qTbUzU,V:ԣ5QeŧA;c)ß+ygHG=;Ak<LmI -ؘ{o{鄞5 ,72O (mXM 3zp, 36p3fim+^tzneT&(=p>Zmw7@:D؜Tӈ JrUzJy2L,<= 8x .*57+{b)o_ސyڇϏV4<;b,&,oA*T1 :|T:s^ 5 Ë:_si)n5S܆0-sI:[/pSuSw[_OmW:óώPƮ(F>q^f7i#m-MsO0˹}T×k4݌%߷iWFL:O6>!fyrv5fԽ#4w;jHS`xi}/Rk`^)#S?iy5T'ƶu IITGh}:g޷d}lf,-Cs0䣥=IJuey P˰2٢xnWL,PlH!GcJa*2 aR03bd)S~g2%)Mf){5vM3(PIņ@ v=q[o/"E%K1eRs<'[WS}FΕ*cȧ64D HrD0 Dvc$k)̯HUmsMV9f8TDhb8Dd-dl~Zӌ5,mRW(Ea*S4+ѯ@uޱCۺb5pfrڍFk7WՂ/ 5Snpl vNI -D?Q3pI$"6N~wzھ7fh5I9zMIBP`eNz ݥz *QyN+E:aYS^D靦v@6顏nJ4cј]ȟ- (X(R\Tn**݌Oę8a 11/oвWI?H÷)`fgr#'Vg}s/iYJOe)[ls6}U;"@MD&0X="yv(jyazaGYŴ1 7ȌPj] J 6psKRv qNE<,?[q-,2pJoW 7(yUeEJ*hiZd$b yt[L΃hɩ*)#r !&b~Q` Ă,3SCn1Y8VHƉra8ZJ^:Β|pt%ڀY9-Gn/Jp@J6vrX#yxexDHjUD͒5?o8%&"X&{zC s3!{ZbUQ @$"[G.uEn~ɝxZBAk!: B! 3LeFPQ"AI Ỽpr`Vh]lp'(WNTj~I C##d)x?zclQE9H֭ɠ^H4"(:Ltr: N.;5F/Ӻ$'e@J·7`jjoh_w,if4[x{2L$-,*)JrmүOΗq\(wNFZ]SzV +:j&5BC)!9 [D%:M :(M2r!%hm6=.h%\4=^݆Ô8~ ބtvB;*DfB!~ʐ Imh`9ZWc:#7xA)?3'yDE> NmHyʹ5wzK=7*ݙ@ !?/,Syd8Ӓ+ZӹP :mCc\>e~F+PYXW=O]j윀7˄ސ374] Pnˮ6/VIS'FFhxޭZ6G.z@w)2i7}QaS[֥SNŚ"¹J -w*CLaLkRΚ4?a_ξ:DS=SZ_k",YkJYNҞ/2[=ݲ mC:r7f8q㠬QFtAY̒$ݮSgPN`;X* 2j@dokA)*DŮg?;4sY͵L.jM!;fʴWq3tH 7hPC@u&qt)C}:(; fzhDYl&iyJHBe$ةH߫>wnS≬[m1)FY-w*n R.] ř(m9_RΤk!yq9 F9j)+7լl\8јz+M%lT{?aoZ+?o,NMCvѓw-h2No8[=dk;[K nt.ߕXht_ W>qv{gU -uHeRc\@x>C7+Υuzl65`t-9|Y `Sk._ >c)Hfφ)g+W7<<Ⱥ5 PrD ;/(9z^//{B6ٶpG%l~U73HqZ y۽kgG@q2.MEi|6pOpchM5AgM>XZ,i= ٵ{ux;}ñkӮo]:zT|=w>(yzξbA5.Pagh%BM~%:D ʨ|b3u)%Uyf@Kw.|GoӒ3 .ֆ_?`*8al(C|Gűa<Ȭ1fxXB7i5]6p~ d-wYqЖU[(zx'Fnt"Vo.mcmN [NLmTnK mҵWkR?n37R3GfgJxض(_: M|Z jǷ[ !D+juIsJGx s  +bӝn1z!)ݹ0endstream endobj 365 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 5602 >> stream xY XUgoqj+d9i9㈢8pdGs<,"EDe9vLӬ4-֦ Xt{|s[û1d2v_8B&O)Lvbeo<xO[̌2r0V DA\&IZ7"#e9sfMzf"_@O'?+;`7_`[pQjqo;lGn6yWG t6(1E5a+%I$SX82h,IIrzt|9{B)~/$k# `%apH*BqpǻP gpp>ZЇ*{6[AuBzL ȨR+iw\P.Bp@ű<11X;Z[q^_zvԭ[^:+}|*9- zr-]A] ?-M9)%77:HPדQxo K&k}sq-"[_ZsF,VK~?W_/ B \36vIpL)ђ"ixƁFz<83{EGH6j@ =O-"=~Jdbhgef_ {A zV$i@$I."Xz1!9ڔ*,lmN9G'W ]>$#}?u M3 1x嫤dAl~ld3d&d$A Ӓ4i z `d^N|qJଈ̤J̣H.IqNe%dJX0$ѹgeivd1IQ{,42OTCpwtakdn"A.Z6EE6TV$>t(*SfExow֟SH6,䢧& /'XuC`o*Zs Ӱ&1/> H6-3R-CbP<͵&H_( K-P#P>E˼/%W*"%Z9(/l곹¢ @9p|쾤`biPOP eY鐞|('#Tj%:AGղvzY <\VdZؒg); oX9>i#Yߑ?r~7Е`CxoX{NzCRD8ff_ NM~ bҒ5iR'/!Ihi"vcSbZ] q:m|hA>A;Zzzk`.GXD.z`>?4!)|iOFN>љqxV:EѨ5ʴhGT4EX&b 4ˢ8lS3C8'IPʊWF4UzX>RF225PɉgYy.,K@?uH@><^' J)UTFt\Y< 䟊8иEWn6!zdh(NQ!dp6?'蛹ؐu4AoSec-,>EȺNkPV$~D\el Ck~7 "7^e@.nJ5n!B9E[ᄱT/-FrӋW)a$4 j{`Ŷc`:hQOپ`'!Ђ:ʩBDy% R{!{rzzNSPS[1~e'C.DMјh .... Ys TBb5+1aFy1<<֟zHSQEQU ?t+]#t,$)pW\NRY9]d^ t8[wPsr>$E: @8@p/W%&RIAVqƢ3'e8D.> QSA!j(}qTHߴDeWz.򇶸PeJG 2sWbP@"/"p0.eq >b7zQj'XiNXXϹS2.vwݡ}۱;Jh5L-v~!ʐ k7ԋJے2F*yCP_)}P&(ɼ dc4>06{0dd7ClF6Soܗ,&"3$9O{NIi* hѲ ;h/E-z<-4>:>1i>D=MEy(6xȡ:i']UXqŧ'Sh>ّY܃օKo^R_@!a)Ζ^6C/4>~h'V!ަ{v2㰣ҐSTO_Ӵ'p 'o~G _~p>n,@hێE;Rv*,ǠZ63@ՄiRi\$IN !2?2L)j4jȣu* 4D*sD\!S?q>}(ssXN Z e'ʳc5jHvFmspQMӦ JJ^\y6=7[/llC S-d5y*; +jzE,4ũ 4}tqLV){CM6N!8T<3[vCJiՁnQs n8/i=d0?RhgTYMNLV.9~5O7!Á흏axk;ZslX&RJ$9TRrW$?VSrN /t҈/辤!+T'\tέh‚,S 'Z &)19p(|=Jdr邉j]wp[B@7&'{փayUś?k޵9BK _Q7V˹sX;t|~ӵ=6W=SJPzk8YCl|ܳC:]E4p{"w/;)5%], QD0 RÅhNѕ(6..VmTj[g=K&46n9\ûz8;}2|џ>b.ř;˼zîD6JB~h{\kOՕeg =: if;7tDȧ1OX65B!'>&=Azɞd0wo2FP8ޓ/KO=gYR2)=> stream xe}PwwIVBl|/zh+j5! H 6ޒ' ^Di!uѳgw^tN]멽r=ћD{3|y!ML6.&:-ΤY!lX$l*,x<:[2bO?MS{P26Vƛs ͢ŚUV.ռJ._oH7jl}~Ezl5e-Ek-JJJ.3 XTScּ/ԛ &Ee. M,zFkԛEMYg_PXߒ5o[$EͥEmj;J6PT R+)5US]z}6$$=d\vL>E+B cMSkAN'-s=R(+TkuƺAcO;}spڻWB -8.w3?2Tc  ’k[]AXW }8t&~O^ \dp5NߢFM  E`m>2t99yT,*U-aއJʦNٖqM ;HNI!Df`*|3Y,;\ e/ټC™7;<n^m#5|"/zSA/h*.8:Q,hpy'sƉdooޤ=M)@d0׶0-wddӀ-:'2?)&ϗ,!A9N0է똸ڴhu`:FJjIʟ%)%Ճ̳6joZl%֪S9;{ ǟ]2ywx2uQ( =P7mnpL(1l֝yg&];-pY9vbYe74Ubwm8Eō$q kfȅ4!*:Q[/'/[q]`D{>vWNSOh)hom<.h<+׉k8LFm_K|{#6dTՂpf@t@v,1;~ E` H4 גFa@ݷ #0 #: **UUɗ郘rJ ##Kz 'BPI אEd^Gᶾ~~/ V0/%b2,0 |xds`y^U^\ G2q Ajbb,q>GW) R3$=r7xk7@NU5 gq'.ͯt<9M6h;7 Rჿ )7q$x+tYkD%{po`_?\<ƯY{.S:_"6N։C LCY) }n+UxЭ!=!KXULn]- ID&'WvNyBC UQJendstream endobj 367 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1472 >> stream xukPgwIHVݎ1^AxvAh#D!$$p-//("jZ38NH3jǞe>~Ca?۝9eA ˲ⓒbS"&"wYI$I[EXfdܱ ԫ D!j #q댌e79LU;>}6"&&*T9yrv`JgkVm9=`׎eZsf0)7lɜ3!Tkϲ\f~fζj?כ ڡQÆ^̦<7g, è9~Mz!1iY$0K$f91gf*3gFRIcoil[Ġ2FfݒJ.t n2qe oOWUlєw)*_Rd9 refuQ渢Ϳ/oMѐfM'~3=D (\y2}g0x$n̼Pc+.uJ/ۼUT>?M4:7Zn:#_8789Q?B9 U͢@?F}K;{XSL$ 14gIwl1ϝDuPf43mi]P㨀JCH5(,L a H3?Yl.4׉"q\*{b]]WY d4 pvame([D}(ζ[6YE} ܼ P~`|٤X 3P&pߴW<2LABItLh{G!P]r(* p&,.Y$ry}pxfsDnad69ҐW\z)1ͭN@ 3m%ri6/##*Xb%&)7ܽ{-啰O]U_h9H7Hn#緦}i-?㼝qK4`;m`&Msm9ո)mPrNJw}{MG1w5 t/c8N] Sr)@S>@x*S@F>h{ajm^@Z YS|4#4Q !P]bG!endstream endobj 368 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 8413 >> stream xzta X`SFN%PCｺ7p/ݖr$"˖llm:B G r\'ￒmki!i=>GΝ(@ |q BW{#o@;{[Cw!t［U6Ooy: ~yA;бξctG`]n BW8[6::7@d=oO3EQ)'ՋCljAWA7j#9V3 ~v _w+VgEDh} awE]wҽW+=h^j&j=wtg6ijħKx>ŶۧgMmu;wf{xKHIc1@ǁMtsb?kh萡Ӈ3l>88ӰsJx0&~^P2GjY&"!hm&רjƇ.ց UA2&SD}1V ;ߵu+Auʼ$^ iLYVX*[5I 6e~^v"rZ1m9gn{"eWO^8~ !U ZK#0Eԯ9# ʬ|h+[$-HV.^ <@_}G̣ t6z^NٰtT,Db+eF~APU=h'GbٟG.Ǐ#16 sP{D򃇊`?쓖99jpOX/u:8mr-=|$$Wc}T@ ɞݘ*(<pb&h!Ůؘ|3ўʹΰ]5/(/A,?yomF=~Q*^ uJП(3JzںCjjc9 2??e+ǣhHLHh6ߝH!fd\M;JZ: [Ӭ-r8}3 :%iM`PG,w_gP)y, +<̵s9It1h@XvrҟM"_1rZ׉dXje!{hyxQ]+N"REHo$J1x90xȺ%عGeSJw`Dhp xĐ x hm]Ѩە6M@X< #em#&ERdžųI B"1 dHn m` 0:s穯8e:9H `[:R4"Nma~b]߾<[-YNym֢}kN)}&>H)E-NRAl T+.EN}Z|rD:Be4ɏQjף ?Ԣ/S{GOγ9,`2 =O{S r^W:UOt2RZ|wx%xK-:Fgs_xW?1 <OM8-}pVfD߄?_F} JCX4؄eA"t_ FquW+^NXO R 6YpXȷ?uڬ[\I䥜CJ;/KT1q@s=pj- ?65㼿H m"y[~w4ee?MH;B ^@OںpTšf}mPNLFsⰓs֮o .Wfl fGVFѵG{Cv9TV5 h!? =b3J ]ԐJS@0lFUzuVAJ 鶸3jB!z*UkyH!٦Fkr 33 *2Ө3$hDшGB~yB85gW;\]kWndI4q~ݘ Um:OwKuEѣ-Bz5ԚÒڰԆp^q8v8Vd|/3ԛT ~QC*3&E6'َFlmyPgۊF6W۔h]9ԔQO>Yf.tmQ &m({2AMӭ׈q=d]˝S|.dZzu\Sq Chhn{7ofm}e줚Iy,⃎r oR~\;{GFpd>zt#1h;=oڣ5=@S  !?ʢEhNzc4v&:PM k`@ujCd\\B"mBΣC״z6,"<E"@gpK\tk]ݐ-Wcy*Ǒ['/N/m!/%rPO$-;Lo(imcRG'NJmd²z((]5:LbB#[I1;1u BY+4% )  :4y=xT)gͯ"Y6>6ۥ.ȏES78\r_a C+UfS'p׾ը{ff(U% 7ye_"y6ޠ$c̷^GI!6jH%|F:Ĥe.=9 [zjZ:XUdUﲊ/`&) P'cֳ$`3sr}lFY5'ǞSQ=DLH[{@Ivi8bW7r bY@^i4쏚y]cگΩlF`ȾvT;,*YVe{9מ<Ы%J˜֢8:%IN[_fjiBZ?BáW^-h@ HZgm-Fs 6Od]g¦yIp.U :(a >!`/#I`} 2I*y2`3VPG.L-J⎞ " uc8-AD7(|-0 @/>ZX>_y\"<<}iG͆Olaz|zHdڠ=e輹{PtE3E;~7x~gdE XT>0p6 Dh\`%6͡7͎ 4/K5yFIzvIE0_ðwT$!6ߕqc!J {E<|V}d}Pnw]Jy:L$X&"'6?( -Q98]Gq$&*|'x1 |rM+#:d|vmM܆հ$jwd~{$gDPg~6/+DnUSqe;^sqj6ِլWߕA!5i(l.S[ z` k{g*`nܯH'%^AE?k~aKͺ"֫,2O/?G+Xlo 92CG5'Dj;ҴXW"1VH cq5HRS˸ eХ HBx[gZvN]9q6؀9r9ȳKҿ%ձJ N8p$YcW"Ī LPJ9[}ByA]LeGiYiht<:D| ^.?UORrTo`KV\50=ym˭ '/M @./Y LY?<4pIS7>Ֆ+KJ++KK+= Y^ (1J7 [ƶLg[(2WEj(($T+@! Ĺu?A -pAnsu$-L".rxehf.Q`ED!U UРnPAWn lZ va0r]挶xJueu XڪIw%_=~X=1O\rmt[(Rg BcmfR}Ԛ]ۧfn_~dso_q;{^![pڣ+n, /JPZɕ|q40O}43-uxlLĿ%471.*1a1!Ҋı)A]hӄ:O }l֫>bL}~+p?fVi*n(tbN0IǪV:J|PDHP'!diPݯ_8_46d=L]/;qH>#n.dńxg%Dtvv&8.`뗦aVZJmA&+EHw:}P6GjBaף,6%:Ezyrh#$VyiN2%Qe$4~K"piۊt*i&"% iZ]j2_4q{zx 637D9V;yn'p^s<⌎TciiqgWɗG;$62^R 5|mSK /}Ŀ1#l':}nf*ZFމ-ƒ*EJփ+6,dTilɓ>Vd41ꎕ6w(Wp)2We=xx~#MLD39~wN<;,ĭ cSVu7e{V~Nv'a+MĀl+iq1-Iτ|0akP( NBJ.?|NvZm!*EN,1>}~"$ۘv GeC^ogW)vCs.lmJ/~Y.2&79cõM۸ #VM^;}k{V̢3+ 97N</|u-uC_ =1V4}uznze)8OW%>?&GL_nK 3'46fpOH>(p螜Zjv8d{'/̴#'rqMr#_>g@yq#zIՙ}5g"M8JiuGl]% յgajG9Yö<}ˋ6{,]<i!/N]w8Bd׀6NCwټ" Z(: BC O7mDIZ.j&lPjȣ6)fA^D͡z4 Eݯ_̊dײe垡qr9Vj`T\%fz꘴$ٴYR}efEoYXWf^i!zY#7F4wz97Qqb*nb=>VgqGK2IM֥姗 6'^b|F, WkuĜvG`j%;JK͙̓k"Z#n"%I?(Ŀ5ą"I`MHmYD='\+AU.~)<;Yx>mbNLH|r pPl$f9C_'guTGgG=oMQ(ut`r<"\,HNlY^d 9,>ʋɌ`N+p'Y*],*FP AcxE"ک C?FOrrs2c2XAftumtcF=&LV4zo Ǡt(Ոr(4¢9\k N az=ZP|/ȑ[Z/URBj VU \t1C:h3sw=b\$~^HcHvj JãϫBJβ36aE4> stream xW TgRU:Dc5EqI|Ƹ}]ؤٛUDl"4" -PFܢfqyQϘq_t-{?ɜΙSnwK~D"a\9յr8\"~O!]kd#A X]pJ֦LDypQHhlxV4gYfNr:iA_xWJ//KGqZোuV dʔ^ACN: uZsZԷ}E!A:p!~ 8/ EFE{xl4mgNv0#f-ld61',b07f Y|,g>bV2%bL33#)h ϼ|&ߴ~N$3lU*cyH,=en]Q1KQx&)@Xu\*wP%V8䃱P}|Z<4:S "N;k;J` 3 ߔk2Ϣ -dl5LOC<U('U2#WtS;(N;([腨"זh:ᄱ%ǢQSy<)] oi!*(2 gw*bO<|0A7ǦY{@#pjtt}NFߴ'VVlg[O4 ?uBgb3GmsU2|^pkM-V` \**G+h wutee |69YoW5yˁ쏂jW pמAWu2yS)\dANlb||mpAd28uN|jf)vy?RNM$l $6 o#P \N]=V ̚OW^߀#bI'A):qq{-k<٥!kF)X\a㶌4z甥hjnY2]y2m/ggynZ87sg0{^Sw]egE,H*sR1]UeddN` p(͑-LK6 Ij‘t A0hkvEݶyk]wY]Kf~ơ+=^t c%ݘ7G"EAh0xZ]a-FHl:zްv~2Dq2r bз$7Q.A>.Vj?U{`|8J AD+0}K2aQNQst20̟Ȫ6UeFCB 58z}TpDi/=N2{8/~ܬ⊟K^|kl쑵{8;r:q&C6 S|rېt6!{mDhw .Tԫ+* %2*Y5I_J~!i*ɅUϪwY7[B0ch2 {!~Ӛ8C^:jو56zS!?I)^~cUByb>l2@υVTnפiwy^4y{WvńhA|ƖQyvG =rde'VDmbڑX 7H!H]^2XﻑOl^ޑw@rAEwϵ>:_Q ;=EWT6 |:q,챺s/2$3X{_UoکYmn:CF%Mđ,Ht]3Uٔt?stVy\l7.BйN\ѸyX*<-:ižo\?R"`rꚶꆒ罎geu=j]:Rjx%짭41V\@;育;8޾ ]kGг0ߨd{ q]~Y1{gUh]KygUM F0J6)FZF\8Ɵ&xj`̨0[59ȵV҆zN}Uoy:1U\.JѭXwkURP%?n 2ݟ4H$F֥ۻxf@N" G޸چ+zqq/TE,Ҝ}L`ꩴRJl(q!eu׼;ȬH&>͙ݸDw/w_0t{ةݑqou'[ wC./``l%Z,"!|eL{̴3rq229\N#גlZB3̇B!u;GaDb 2"d2Жޖ-ܴ\mvB TY{w\zJӡ, j+&q"KiK5Q _oR>N>oetey7H?2%q?i?;ٞFWCtfmwR\[܋U*im*g'UwT/LDo$Iƛ^A3ƽI T$ny:yOoih)Q aMA}ADpl?? K4$~\X~:LWְgB;=™>rb59ݒ{XNe,ߐmkv&[/J6endstream endobj 370 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1022 >> stream x5}L[Us{ 8h"蠼l2F0& B)Z h#Ƒ0lft8G"D ! N14s9>ϗAJbFWRQk O1dİ8CH9Ř&yeV=û[q3TE!acyVGSNS23wə~QWmnKNfvʣAWYb|l2nwv48Kt9bl NlI<8{ш؟WPz”Xm缃k==#ݸţ#tDin A^|xЫ]C :=Ѫ~u b)RLi j 9endstream endobj 371 0 obj << /Filter /FlateDecode /Length 182 >> stream x]M MݸEPƸH3o Χw[ [M%Iar1g.*>_髚Ew_t0D!)?)7% ,pθ$ :vEZYᔗ*Q$b>׳jy^C,. \endstream endobj 372 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 556 >> stream x5kRaǟg̴7ԧ4a8g07!"؈VN*9vу6|IӚhnz H.i{qCn>M'!;3%<bbD:bt!G\m5BӟVe ojjuVF2[Δr> stream xYtTea(FI` EuiRDP!$LʤɴL{3wzK/ i 1E{ea]v'ryl_ns|L21RY=/˖*")h]Dz\LbD:CBЦťbVVĴɩϘ1&-&53&:1A=myr8#=&5h]rtLjÙ4iYr)+RJ[:sMVȷsE 1~fі/h3g͞;Ù Lpr6plLl<̙yy33&g6gE[9U՜9k8p~y33y333yyYynzXOcV?/O89QGe7gxb}qLԘstnv성ߎkO ;ṉ۷ ZrUǭAo? hGhʢ=`\l1q-{ڱ͈WuB<&w0NV%KHyCJ;@ܾ5m7\`4`$r1!X2n 2>C׻n/%b!OD^6,{Hc1Hh9/Q`9t$DB9`|77`nq؉=U ̇]oxtAz!2Un#>T9EܣH,ѿ{|+6ը:Li*̤C''_{^4D ɆL[WDž'k?~N˭?ىbwצ5%wҥ6/޽_|>5^܇fC7ChrndF(] K:8Cڏg$vZM{7z~zZіqw<4u"u@v&<,TgprQ$ vTu6t8T7h\e ?zͪ*62B)aYd&1x_52V8 VPŜ'߳]㯡+&,+PVT D)CyzX6is4Y˨4QMEG 5.W+a.ݵwV#60Fk-RΑGk6vĿwTC!6q4~/I -coua`/QqǬdlj [RUWi?޶~~zoS_تrtRE..-=uZk֩/$=5ؠƻ7a'|5bg 371=zҰ ݞ/n*!g97B룢<^6ʩ&}-KA 2L.a!X673N?)jcx趟Nx0cNA|ӇPϧb[5R˂>qyy} AɹS#a.0=m ޜ໺v # x^W׎gRM]);nOzZ3ytnٻ[`<߱E .h-؃^x_BvR!._k`'v[;2]1ȼo5:u#8|gvJ?]{03jr[&D<6`X%Ǿp'MD;n)5dso l*BA?}뫷`cY9RY4)d{Ѭ_Wz7`i_eŗmVJ}$Q+M,"LYRSSr0*rF*;6 ;oYeuHMP/ %dō֢j <9.IjjV\̶hwoˋ,cC%zЄ7Wc/)@|y%Yy3bvQq۳q 2v;߃}@Mqߣ5¨Q#  GA%itT[?rq5bl,6@Jґ6HtvҼ+ 8(( Σ"AF%Zۀ-OGшTC9_pTY/BvzmGbP+,,uIKqk\9[g//rp3<ter+rb0Wq0Ke =}%(X*@[/ކĵ7.cHgp! r)/D)vꤐM,îd&s7%HjZ\e=p*2l Dx#=u{ dM4EP/*ƺ½m9w\^LY )uf@Ji$u6@G7":ĝy [-.rH3YɩlfOgxs;Ѯ 8nm1 S,#lGS;*"A渥 %,~%KZVYnLF;4rl^mXu6r&Waۖsy'SCOuGJꕛgg[ZS|qnt[wW.M1uAВoxۧh1Gq!atUu8(C(K=!d.3hVYߋG2GTPp`% `[X>&ُ^|FOqsCwJ$UB vνܡDߛλ`.T'#d:iqfCN5X|( eR[y#CT4nwb>1J:`(μ FJH Ff>J3R7ft8G`juz{lД\Ì#݃ &6Ǜs.=D@%^ !!: $7 s:=9{w\ *Jz~y~QN`*90A1Q(IߦYy$r7ZȻ-=_çĭ5GMWr\nNf i4eGċ4e׾#9%J6]i4@~rVzVT&$I)˭mm${o_ $ fo L\yoSSPSd[cee? ;e|uMC:nD'&UKYł׷%ǧA2z+E%%n~l> ʱ0l6Z ŞC:^}<䀲A q}=6xI"n ܗ*Ƣ yr+I'Wv#⣶$;?I%R)P5Xei>>Z JŗAQf0kبLNwAZ3noi7yG7W]7/UtrߏN-k!u 3VזU;̌THR^Qb/jj6bsh endstream endobj 374 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 3847 >> stream xWytTe"P>Smh=EVŨQ5+IT*ZڗWu_kTeOF6b 0*ultڞnq_K۞sf}~|I<>GvNΫO{K>$4<߶{cǛ̿I_ɟO&;5oܹq=f>%TՌ쌋wmb9I<:_ 3aꉨh2ѹ Oi3ؐT4Ω k6" &\` }{D8)3S6ƾF52.p8. !^ .xڠޣN D!5Z8=ځ/s41!8@XO."(l^* Pm[D:m4d55;Dk!e bώa/Tj2⪸7 Հt5aHD0,`,fpghho.zP[ߢ& hKtm3jpk)(B=P/x!"}d twG F2^D*rt\.mnys^ѐ;qhڑa44O0z)rTh e&`"e2^O7]=1[ }#>KC|$48-AmAB PZrгh2k!PO5\QM߻g/%'k *gIh\:EP N1&f p0 A':Љwq+Nb—w[< >*Dp<"3d2:\< \1f B/QRN=Kv5ظZirF ߸ 48]Cq-pሂj˞v ;*$28AsK<b8=HGe'gN<ᗂL} \zCXKd̔'R >4w>~ [avF;m暊 &w[Oq'|;JC #y=T]W}o=pa3&~K,wd@jC/gw_Lgշ LcYBN#U}lTd}pS)zo2Pc' .n_ځIjP[9Bn?Zt}zLCCC_A+qȠ}M2)ݒHA*@&wU45n};OWcwa:75m6e3&c7PX~>CDŽ &hԗUr tukaʚ7( |xuXUP>jo,./(]NqVa*c;d#2lê ~-- $l:)qֲ@躺$x:tPT`/!±Yx┑х%`Ad5ؕ|czE\FPz=5nΓ%BܡȡնZbCSHoގT"nxiM'jfB ӤUIR`zJm-xV8*댃}Ou_v{#cG}~9NdV5fl">]6Rְ!PaGh8auJ&Xa`ѩ[aEdLIHE%᧫uUN-XciЦ_r"n&S'ٝN\4ץv'>Eu8tCFJebx}4{Ku wV-n叞\̞SN{_ܽLSv<(.O.A{'/#Jb HAy"vO&#m`EY#3 ?%mpݰ=bfc#x6Dd,>sSG{{A,G`vdF*P[UNib ^H1Ro-IH&R&ۜ鵁gBkg%ո'įN荆$MtfMŵLzNЈƚ(m/.w\a**B`'oN啼UFڔxiĩa ڹkAIݰZ"e- @vNLg'EZ}8R!d%&.wȬV^zHb\ʧ yxpKf=j3塎P8uƸr&?OGtjI5Z+JRSb}ՑhZC{1\nwP Z^lFu T&UhRh;??Ja,-fŠ$6u=*UvRuT[éfM=~#8W[Al i :Ѫ;dC^Q-&F7|j2 me]b\Ƽ0q3 øV,q\M%) 7i&B"ihoojjǭ<߾gKcWlbRCF$szpKd #1Oޏoeih~ D2 @$at^SVkMpLձM{3-A'CâyW\s&ε 6EC]](8go'ơ4N)17˼ CH%p  ?m5ww"G$zI j.Bغ@x3GnoO$/qB;Ra:K#%k;v+]~?លz%ǖt*bx^-^s9PJ rB濢h&zfΟ /ʫʎRБ/q{ZNX`[\@q&­(k5pP)(dU CW&H$ʒ.7rGKw&KL>oIendstream endobj 375 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 4095 >> stream xX tS>!4E hN W (2b І64O&<mҖZP*E* ȽK}Կ->]ȺoVVVη?j0J"X.fYʼnaCRF}.y7&F@‡8Iμ4-=/Sz4~j짞7=YZTJZKJ٥%4Q1ij6/хIZm3srrfJɚQ9jmRT*KJZZ+E5Xi):*3j]Z*3GRӞXխٵ&^ڐ٘Mټ`LESSj#Q-j:<2ZNͦVR9jj.ZGͣSjd5F :%0at+BػtwceȖ4ދRʑtї`ŤH(MV2lW*а̱5@_*õ&L%b45sBO=qC=+j* y@fț#mYlq5UCN AhX-{ͺL6 FReo("HM3eu^,G=bXO3x4ƢU Y6O'DrF{mvJ]Pߠt*+\uhJy5Lj õ)W}u`VWeAj$#3>KPo;9$BOZҮ?>6eu_p G(RLd  ;kA{Eŗtx WXa*&e8V&8RktJ( xW-؁ޘ-j6,;%|wK[;txMXTȥwp?J/P%aw6fl(vC@98խ<)(CjthM"c$9)ƧQa9{`ڙ9ֽӠ qyϒVi/2% ℠htU^o> FjT^ ^(`KJK*M ]P\CPjP*"dHg Di͓,̕&gʗIk7: Cyt\ o_( &2Lk7r jl-CP$P[ f!>PF34XQjvi9xFnEe$;(_1* RGquXAQN="OgX*g57?G܇RM2̻X)%h_W0F4g+ϛbuާ 56Ud Se l{`dcOY0~׎(24\[{AxRԁ$GOt 4D(wu\]M_TȪ LIH?$`FW(ľNqW*z%r+!P@x *}->KGBN}Zi[?zUUzdRFPWiW~_nA7У `LUR}3Kgt[+f}#s0Tp\_IS7i#pm6MJ%(# =G+::}ue _߀%Lfn[BnYtrG-8'cQ[ow_A !I:"'&T,Fܠ2~Pτ܅]6G kZ,⩊߰){\zq9"&yGHuYĜCe1bI3qۻ NxL#xξkb}1; * WΚ>eq$pBl oճJ50~zJQ~ۯ|A7Td U*_dkl[7}~I=/|L`'o "AҾYR)ޒb굷B-ؑ]ߧsYlu!?dXG$;B4o\,iiMfZEk)n {x =|_,dHff*EQ[} /yC)Ua]7Q*ˍE9Z?uQgBk,5H7?cUM>tN)lİ}BA;#I%B}ܡW:ua&4ŋ_;[a/D>DeqWgGx8Br<h?QO8`rd.#-QNa}%oCW8M+H2[-%xW+p= cq? 즊v\>]+X~J%N+&޴]uV5Pn확m6lT0=Gp)ZS#7> stream x}mL[eǟK_(lȠf8&FL&d3 ]Jk P mO P:+o[[uD6: Lc`6bF{n}5q_t?9' ɳEQ9 5-eNJ,e0y:Ӡ(Fy5/|52ځc{6oC2:.r,{:K}KيJNc`̜(HmuZ89`{UY?yuZ3983u}hǏ76WxfgZjDG!TG ([Drd@#,s֒U%Ë~N^W*"މ og%pvbYXp$GR%miJ+ҚDDMa"|?͐ 2Q*' 8t^ J,P8XdJ'Si[e+rֿ 3^1yvւӠ"$Ф0uzׇ̈z$$CЊf?ß=k֪?EfyY};y 3Is\R]2ч{4Qg$JҪ#VE Wl<'\0aP}MzC)[˚Хy\P}hn3`Z{Ce{Qs"]kXuFg!^M( P8a=m;+PHTm1n`eV)7s=sХ#fRrϏCH;=C1W{P F@`2ML'gu<I lgwsIF7!-N'Gk#zB`#š_ ^ NlHFcJr<ނ\wTendstream endobj 377 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 340 >> stream xcd`ab`ddp 44H3a!3,|<<,+-={3#cAys~AeQfzFFcnjQfrbobIFjnb ZRaQRR`_^^[_nPYZZTWuv-(-I-ROI-c``` b`0f`bdd S{='85o~Wte '~ ne׋!۹Y}} ?D+}gb[Q*_s/wt\Xpa`K{endstream endobj 378 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 3689 >> stream xW TSw!Ҧc^f[[lXǶ[]7TpȮ`B[|@ ;::mnNg{k_C/oc;===a;IO@`چ+? |/ eoǢ֯s9!,.F%P³P flr)K|ׯ\Ͱߦ'SNE)R=DEn) l9993Io/y5,'U;13QYzR69o,E<,R(?IuR*ۘ!ߜʎSLHܙ':-}epA$v bM%D,H,#6pb FN""(9"!B $Z^ )8+ :-Z(5o髧6c݌9l2-$wg?뛽|g ݾn/xAlȳw &=nCKJ0J* dipt yAqCGSà uQeR`HmcwBU]d#,R z~P&0HlE.USJC[ЧCm~e‡{棅|8. (eHK#vND6S rSbmZ.b5(Vn/-xa8x\Nfe@!?2$ihZۛ#o/Ӛ?ɳ Ķ^6iߞT~vN4 Hݿf萱lyc cqj+Ԟj獟ӤQ i4$BhJAJ/ߴEl+ ]R~U+tۿٳ ȗD'M8+M!ЧJ2C^]4~)pPv5PGI Dr@)\+A;Zt)Kd;Vr| ͨo e6Vн+1K QѬϠ ߠ9]r5UtkNڟDiY[9 ^4Zz(Ltӑ/UdbF߲eN\i X<JN%_ ZmTiﰲm ADՐܘkTL0`xy9]fm0KZȣƷZ<$?wik^ _ -h(! ܥVb_R^5|m?/& dq,8TmWS5Z)HDʡb?#rmCtQ^NJfI X>o +`E1f\"o&D kE(X;p{IR!D>}a7]j-.{U)SEi Ka**VG2kG> qi%pUEBV^`6r5%f/<vLONrQ,/?hϽs*4ZeũG@Y[Y-pedr{ښ)[fk7G=@wEcӝuӖzG5lDu* R[H4d7hd51gexVeZS`Ҙ ĬZϔ%dȀbɫo@V=RQ3#{Bp\"ebwh2V}}rS2Iy貌uE=Iwzӯ+Zh2iԾ 1@Nmg  1Vv5)IE`<9{}7zi4S¸;oA&զ\TJ7C+:ZVGR+5;2簢+pJXle ߴ@gW+t;tr ]L]^lvEL@Əp?dv6QJEY)XFoaE7]P:Խs>O/7.JOUm-nq/z+ ^45_'py'_HhFsF3f'.ogr붧NsUAho+sѧ=wj #T(G;_} GRf1I۱'û~aJ_(NK|g H!2v* M"Gw"Guwo?tShX{<@ekAA)lTU:Ƥg4Éz=t #L10j~#c ^Tlir Z<s_gWqIR&'>FGΘP\[PI\1nk4䮞eƕuް5%9ޔ8XT5>ơS ]^I.Pw,I@qׅc[bvv-0F#k#;>-bL0tYܱNSn+18Bxook4P-1 ~>ddx.=,[5<WRG/<ܦ:P%%P0ig8I1:\L$ɱ-p'v:]Ngmڌ >tmQo%6WQmZV,!R&l UQ|REhmhUL\dC=r!dSZȿ>`Y\>//.] DpAGO5n?z^oc*uѝ T_$uN+nP4Zd]xjOċ m(咠oh,6`2@-`n E.Eߣ!Vb{T'B4܍ Y,`[㿼N :?'oF?&~r-%zHC튎]_R0Ō o?3MhF4>Ƹ~8LI6Qh#Y[voer5u"cwgvOwۃ gendstream endobj 379 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 7089 >> stream xY\SW1zQUP{/BźWuOޣ.! !$!@ a$lPVVVQ[mkgkg?I?%s'۳~DX .j |?@yarNj\LlzsQc̞=s|ɓg/JNL ^I$N ~nnlzzI&F&M3>8+.=6xctZtjf¤൑M?KѩkSظ(ib%/-MY\/1G,  @b1؄_ x*ރsz =N#3z JT{ V!(}}?jSJ]F =Ago}It0]6nz*0+aa)þ8sU {C/]w E##o, ) 9r=Og8g? \ySZ[FJN@ȋGHq 62Y5!{7NC8Lj6 zNj(A Q9^qW\O}z@)@'["Ptkסf 0`0^,v5܎. ^iNupZkC3'\z8;I)Y-ۢN ^+¶0A]MP27*S A߼ n3skT69V t=؆uWp:G^99]A?$_\icjoޠs bp e]֎]KQN2}f 3䷦Y՛WNvt[.ם 3B {ο> D}"o` t^׍?m^:a~A'm "m]kR" t֡$ VJ] @*AhJYd \厓x_`|ݢz30P,@`TJH;Q Ph"֢mHNȗ˪'ɳAMFq@~8:踔j`VGiQ}!OD.8 =85OԖO0=ޘqwJv [?i]`8 a(Lc@vBT4`(o.띎uض%2u_rj@.F2F"P#ZҪTfEKȮI]R&ȃҜ@< &iC*(jMDMP(59L 5C:p?"+<\)aW(oe^!u*MPQuY GC 6dTLJ" B!5@퍯^Ŧju\ P/@0eNPDQ2Ëش.z>IZ?ί?G5KU_?7HDžHXCyaC^D=|> ÃIuJjfݎݿo(6Vbp ??F~+#]0¹ts+ό}׹?䲯(v(&c-$m|6O((UZYi,jf^8pU.8ɣY A4ϺòQ5' >Agt*W@ q$0R%tXa< 3~-4[(|ǤZ&$RHq?վgYmfpIВR^bt:IF|8@^4sv:Fj@r;*PT793Kwsij\GphY~b ;I0ٗOH! iМKK^;ٙT5#YTՠV Ty󨏏xGbZkܠ ~&=M*<2z 3#>Wcv_ ZGzXhj^ĉoCzOdAcƶW3$'?y1 |TWHW =E.26o蒀E>UCC!=snQlAՠ[G|޼ Y9IFot$~L~C~]gq@rKe}C0c9Q!]AnX V.c6;3%% mi"䃬[Fy:!NkpAA)ιKˀ_ dV+ -P{NDo'kp5]p[]L3`uwOa\*eVm Ȇ߿< m$QTFS Ơ- yt<5C̕3{5g煫@XZ=D +Nh|sצ`| IiKeQғ"~L6'T3I3]I$ԜjJr!;O#N(ГƄ; S⍙X[ wG֒bP׭^$@Zw`! - ]zG_\,C5'0s[\~6"B5?b.-"Mϭ:дᩧ/BQ=urթt ܮ2>ڡ79u7VdU;Ye+LOJ#\!9S+Zdt c. G.)$= $ 0.ޝ7611m) DDBrN(Mٷ3;Pk-@vv4)죱k|ٱZ>1CrŃ z/LP Qk+"ov} mgٺo+~ԗE+< B7MYЗV7vƈ6P([ۋh(Ŋ]; %;υ_aoqݢx jp²4@¡waϟon`QxxTw^ê懱!ɹs}W~P}]t ,vU],>|uVW6LoJuXpT4TH6Gw)8A@z~{AfK.V4[ Zv{v$؋ޕ~ W^aZ6 H]qqm[5@ݽ 5ѝy:~&:|:{t8M_˪Z'NUj=g>M/QvKY&i- 7sgk{;SD4/E-*Pi3O楃 -$cˢ/7Df; Gf}S]]&th4/}5| ;|D$pefpR:ul5jՙlcrwsOJ1 Znɴ,`3q@\h*xfB*xeX_BwcкlSYiHՁ#݂I \d6oXw>V 3Rbq_AQ@ ۔V#JȋZ~ '13s[UXݑ)f.{q&ۅE>,%8C!SAH{~>XW3`5:O { {Д܍[98=< a?/oD?Hf._l{}AǍ_Bא'SN|J}8t6R%Wt*ݖ/{ŽCK("[ !nu[/ѫ$Y2NYǪPhxdz ֺ5KNY2דnw3՚SaTbQ!7ڍL\'!% [`,,%4 D$M&G+UD1Npwx: `}y pe 39?ƛi+ja31g35[>y[ݻ~ɖ9/ы6xGW~}lK_X* v",@Pq.Zo4XȫMPGtLzI+hArKn/d`:ϫ̾q`߫3zcf=-Z"۵Je8΁S .6v$6Iz#VL?q~NԬN $:Uުex a0ws c]Oa|$- f`Wd(3jzZWfX2 >8D *JPQWQgv1TpIŸ-<K@7M77%F':5eWôjϋۨW:7Fr@$Scʲ+!y>%{XZuo9" 5aEo_>wtq90#Uk,KLWП+ $8^Zj530v%زmeGΟfd] ?z^^xPv*EnxiάmqGϟSf(Z^PUNq[)I7jvp{15rtIQy 9e"eVǠ.-SpW9erFс|w#TeEyueYab$i'& 8 m ne[1|v7NO)O'>[a ]Uj.2DeDatD0-MϱU,,|t WJAَ?p%&_ER˨[ٰn70)*A9e-gD2iv~u~]#ꊪYV&p}i KX*UU )VZ/P D;PTcP#nvpêyq7pm-V-)5ZA}V~LAe9X7Ϣ*-(C#)R)؟֣>J dM5%Bd J#B$*˷֘Md>X.~ xˋ&vG yOpX wi*Q ]yp~544!z ADURIEh2 TAG&{{ 2[pNHe+A%-r{~˫Ž=)1c3[ @od|M#Dwx d?1wk;ys\5xwq[|n -5 {1P@3F7LrIs5Xrz >s5ۜIҚY?ҫys5|]3&sO7d+g6R!ո 3U֒"pz| k➦! FF/>p/l+ W ~d4v"Z>&4%y.1 YUZoq76,uMFs4(D$O%kuߴ9> stream xY@SW1T\W@{]WU* :@Td+l7aD)֭8qq~Zm=o@nͽ;;7ʤ%DL9E;TKp7{ko!5`r"?2"3a#̵9  $R;>2{Nʄ DWp0QSJS4:S4X(ƃ{`o'o}9_Ss:`CinjW[|plo֓m`o-vZh-],۬tޡ&CC K͇V7 :Y|<eӺGH4uZ/!hظ4"Pס#)JLILEQo-*^eըa ULj V25]Z Č`H̦W[ҝBQm\ 7`6B:BBEEQb4G"xXBԙ"UuΫ͛hc툙<?ҹ6E|FxzDbBw.,Q'jօL =R3o_X8}%y<>&]5"1 G|RpaE"®]t߂F(ba^ۇdA{EvNt7TCGm!~ f2$Y~=?_JH{A )ϑvMS9/~]Ԇ!vyM޲.K*۝]Dq$i-Ik.ZϤHLm/~~Ǭ;Lv#5PK`jv:hli ~tYR>=\]e26$xFr ;]f#PlWC U|0=w5o]Ч`H4 >ij=H=]_xt '㯹ߺ}p{RzxskcNF/xrB;B5Fk;cp~iOK w3FʈbUnsr*ҋ Q.byg1/>$_kNҌڲabe~*"2dg{3G}_ͣ\^jei/XMf?sZhP BMkMh8D?ǧAA"ZY?5rwHaw^Q9BE|AB*DE99E@QpIfQمuJ2=@nUVe.!L/\-U"KMFz!@W*P*f.uN~ пNH~3m=={m/6 w ' 8mET x,s5o\zJ:GNBZM6zodFb>7TZ3èhhXё\QZ 2ZEgG?K Ղs& Xe9jzw"C ,XRVX|rhq}?ZxȤ]bn]f]`TԃDz#!(tڡQj?N5psw6UT.Asmmcph"Xm( 5:EX*p F`n=y Xj$d;FbXbVn6l[:B"aKyP@š?c@Ϝ?rC[6uqqx)-yzf{C\}WTg)SZUP_g}̦Tϭ|DGVL\`RP^`!ȣHm>G1̌7+a0 ~Csɍu\Tk,QOu>E1E(ee1_f,8|,)Eh˂mc:^1`-.E ٗ1||aؾ#eeMgw6|NufL|TB`XzSL{6΢VMމsOQ;Rn$ZLe\qj 11< &%g$uQ\gz :P;e V1'N㪩 IMI?=z&5E48zh.Wq/ R/Z|. ѿ2#Wd|˽K}UsINo*+;sUqR<'4K}ϠM;7[Í~F?apZJb  V*+U\77 %Wݮo:V Mg)nZPjYjijwW_-;JEQc.wWq46WEdVƈ_ٔ5VZN܀>}\Fp~bEwbo}M \v \e>%3=u8D;Xt֤S:&(z懢#IIJGٌJZ" +:+zG_j5`n o&t{.+:NFmtzK(WN0DMFL<77&Ǩt6OWcXއw4+!Y#6?vNNOO "fG|) XuawgZ[w5%ЎbSd( 1ݕKC!ȝEVsX. f;L?$ TQ;}e^F`@@jA6U'ֵsvW&8!xe lJUUIQ|d(t>[$"PVjyY'JW*˧7;*pf3wbJU¸l=sӖlZc/5/.zjϵBxĶ~:2~El^5 bEyܞ=7tյξw$=eHo:sYnYYD>S!dg9]h0j~-,ILJL|#$QQ2' @pY_0 c"#JYlAU[RMFFUCuHURUZQ\_ʺ(Rk{WꯃUٸ(J܄=daf,3Dg̈́OΟBIQ2`XkSZa! H%NVrIZH0N\I{%y\eYy9\] ?~U/9Oh#4pey_K ǠGagmt޲y\sAM{E-lQS0ׇn6o×:q@[.JKU;YR]ʙЂ89qQ( E%CfYJ`gÊBd ]5&uY yxE<آf E/:ڋKMNf:ńD FRT\~Pa3Yd' Lk|e}4}>&afff~ߺendstream endobj 381 0 obj << /Filter /FlateDecode /Length 259264 >> stream xdK˶Y$amp^T Ė7h`cRz< {{]O[% pty?˿%ޓ5_{\ZG;[\Q?G3Z{gw a+wǭ;j|;{ pFߩљo/+g~_c9Z_??x/{U߼Oo_IVZ" *E6i#w+qVrF"yCg/|&n~W'bc|~Cv"}XocUq⧷?}[J}{8->1r1^: N,g&cg%P_!=wON5kd0%7:~['}v @ oM&[=,o_@pc`bYn}ocƻG뭳}/O{9 1w^o7;z0}{*W^0[~/Q6gk"5CT[5gyo b>1Ľ &n/F0q2?hsM%o#0q}5H@p\~Xjx*7'L\oKD0q_s$}z\O>: e%299`z?䦠x|3S猚WB~s|E @Ӄbq=dbOﻇ 2H &rpnas1L27fou1lΉfoP/K7Eœi]gNu 9{9ښ.$.D{ N^T9bvt"B9gYFo 4þLNH&/yh?[:DjRJ6 oo?7tS$$L I(-L84`|qp b +ĤOHLNo' %br(y>,W+t_wmIIF(%oVSz$d;'9 G'@3t'{'YAx½T`pO;;йDbMs7Ԗn<4kT!~i? dƌ GP>V+$fp$j|CNPS4E J x+{9' Y=:&KlF mPD~LoSMߵ|)Kɷ,:}6Z`oY?Sx=qrH;Mma)O1C;Y);D5!ǖN^, ߆CǿCnSmvrS!BhWNRے05utڔcJɧ&!#l˫HJV+f02\_eJև@JBlucpu=$%OZ%9W'J'\y4MKY#*CЋ8adj nj~ ۩+Xo Jo;؋&FIK8uǚC8ub¹#B9F:x @'aI{[~[lLL_sBȟer2ɱ} ڛȝ9CJʜ\Ws 'B׌ 7zrhjXv9wz8woVgj -8?Bwy70~ O8~ $4CnU߿.&T+gjuj@/hd6mK %X`_mZ[ %X75OR)=g\3 Ȉ) ] %%%GpuIId?PJV~r]7JDMb:a%L1̛'8*/zR=3A\Vu  ~4_B?*wBb{~;ϠÆ^f !ƻjCw/- `3l˗dL1Jq!B۲~;bɶ|S_`SXbV S)PNooR[H򝱡PtOacJ<蘫&gcO)4ƐH)FL u!dNtX|R@"N 7-=6\6t-4 V{&7$=N˃>%s>'6,QF{b13xz={Ǵ ?!V(5L"ᨚ +GbPP,ֻCVZa+7OFlE5 %CS~7S!ՎGjf"Gj9F+f&KMt?c=]+sI1%U){\S\7M9qP[ɱq~ g.j&ی {4j浘 {6oé%# G$كIg5r&!:/=8hdRչFչ63b^Q<ڏ :ֺ2]a¯"ƴTf|E#ܼ3 F|"vP4Bx)IJ:cڎC2quIl]iiN*Vϙk_}T*W|Ń$D8{j=Fxkd+SZx0rz xyG1"nX]JI멷,XՏ!a:k!醥i>n w#v%4H+?_fƏ!_zwZ[]G@sɗ^0> %gwOѥC?tfsS~ȩd?6;DLM$\eq*%! 'B!٬%cΟU*ӹ+Z:Z:޶s-CeNS(ևH7s@'O&[_tDZ SW,1D;;%;I1a!TJN*K$w;Y$qE>W$7^= ABٱDr!JpKm]JXr]"* ,wO"8 \Iy;&wA*[,%%N&B*;zw7 bj$Bow* U:!Iyd(gICnχ؉ߌ}]wA:N?BqdEqRU)i˝މȝRE1yI8Ϡl=Չ`@s@fi "4#!Ő;N,bqCnDj9g#\3[7.c-E 7)n?RK^j[w?`Ywj z V]TKv#~n@npT[ 7DP-Gs{kLqf3Lr&j'gÜDLʩ;q4WB@6! h@h)ׯf`H͙xsRO_'$@m@L>Y3mj+H,Cj x!U'6ɚҍN:Ҩm_;9S Uvu21} sފS(Su}G6X8m8quZmG6MȌ#7уPO pynp! m8mG6FG62K%;+!|l+.baED qIc&3|cС.}N/ԣh!x;7"=aV"ؚCEpfxsm~9)6|D9Ű@j(%9g} n%o0^;rnn4lVbu^R׺GTV " lwhqDlC<"ũeR<GOlj{;P6.~`S7ꢶm?vLJ=F"ג"'-KH`o7рx"|H˺CCr]s)HVH I*Jϧl10!}Ɉ㌻[N'\ 5gFрp>bJߵtA^["'F'ݾD)Oo) \pr$o\:yXF_܍#`ڰn#5fMB07RI!za[[0|7Ͱi9>@"pd&=O.,_.(U"#'#In O֊YE$7&Bb%HP nmv?rS 9BӔ tnj7Fbmy/D)YWNuā R0?;@HTaNE 5t$u?Gt[[z!M s5t$ɲq--423$BWD>pvo)\JP1PVM\.g㹟 RLF\@H:6iP3Ix=z-nnvQp'L]kӣ2`ՒLZS"vn[КCvcMg  7R—)eS͡0zjMdDP {FB൜ k9bh#Ѣ<,-H?2p*V0ѕ[L`Ɖ4B?SRzWCgԨ~SV"IUPx~sԌ _؜ZiK&N^\& kdEMD%7BB .>ݿZ TcF*zKw[`j$v!mQCC=hq4"d #B7w We<@M'@\r(!>ޫ_C/R)/RApp ]<-cjT{ͯ^aBN"Iq[@F8/-@-Td '$PnZfo 0j:&"J&{ˍXS t#j떋5s)`4KM^a9@YPL,/bӵ<`:@ONtnc2 aB 5,%YV&=QiFa{wD;J7 &=@4w>g[}yq*5E!1"9H7jD~F}-6:uM['-R#TIGB7Rݔ!F2M5T!b}8 tOMx<Dbz]>8śaL[+=% txN WR4  BrBҞ9 F-7W(=$7( s FzJ.i.?A$7N.`Y 3 M$lӿ$7̠㛤Xn"!OrӈrBP:Cބfo!eق|2d+ɞB1DkN}?ºHS;Ȥ"8DO.Z%uYH?  #m e]-ދɉ=%9,}Ixz|IvxM tDj_7|I+*eGڼF/9Y|II+JS]Xv]Mz"t%}SA!""bc>;tf\jL x2f5;u97@Xx<SWG3 5Rwe볿+.=m+ = @hGNon)2,Υ#IT$PD]hSd+ɞ~XH ub:JFmƞ)#\u)ْ-9|v7㝷 d#_t9P$*l7"ˆ٧SrYP"v94phn O )7HdRpbmdIvL#7==j)%_DzB @S"\Q_ 1v]y~t1t@DZb 㡋ndW{Su Gfcn(9CEp׻(O';N:."/*'<W:2f}9{g6^Yf/;ϭdp)k0t&ϿwjT}͝ yRdz4Jkt0fdU0#M^|kZ=$ lHh {( a@J5$J2"96,$u zJ\ʍ49 oZ)a7p[)ZV)z Ae2տAs.}|U:C/#(t"ҚTu ^t"z+c"K5pf\ifƈ3#(Q@>F~8@FҮDHLl@H5!R)?RI9&'כ)2/tNE#+4CLhCbcm_Q1^2Cq^)@pS- YG]a.M­\o+!5e`(Cl08?ُg!4"~ d5}: Xy djum(H,@h&n DR;4_["KgxGFKVسDgB4*#B\R11&-!3LO">fRMsV ȢUHNq0{ 5\3PN6o%KLNe7(v0l}%r2&E(tN_5%Yi~N:%8m8USOI ЧԶnHLOV< 5ht [uZjO{2NkȕsJJִB!bLns")'+熘-3S]J09K)r܋L@0mbK9*"Ktq 0&K5?EtgǠx%OƼ|Aq(d_Y+w. V])BOj9R`]-Uy4k7 !!Sڻ_v0a21&Gl+y,QG"qMR@$(Ƒi,@(dc9Juw V.Ңnf#]@г?/T^Pl'}#iMmPY"Y~@Ȳ ȫ򱪤ͨ) i|G&&t9(Z|@Ho?Ya//«E;++}o/+E՗3tKSVz;\~A,1`c,1ܭZB5$_(~rm!n3j$YpbѾpC=Ofۺ>Xn?ϡp\5ΐlvȥ wH>ơR`/ Ej\!:@-jx#;v3%"4Ͽ8D QNؿqy;(R-=Tb@J_O5,YJع D%-㬛*HCʄf !/ EVjCV))锔yBW1\;U_ֳ$'ͥf.!_%ٶw犒6R{*mGT@=?W}DmNQ+{Vls#;|Q儰}XUk~JQ r=g tlpDl \|"G"c!3ږ'rfD2}"}MO܍rYەq򚾪"x@X$m=WխU įD^|-Jrgp{xўv-:?EF^ KUβ+@J@8lo/MEn]ky.g' wiX~ʾ?lHTڮ˲*ɽ]wu^-_]v9Yf,Onr9WJs/-]]休^a_0:W6hw)B@!T;Yɫ4wȥ=C;>e8]r\oP U&5v"dW Ǯ&e+绂>xv%jP3DMR2>C7b\͞1P>oϫAzb!ɐ =zB/R|S"LU=챪+]0s|WDjH3W\Ȩ0s6,n3+6=4KH*n: (TȎVY*)UeuoTjykNmy^NnZ@6EOy0d#+D(krGEHbv nVZ.i((]cRH")"IZUK2'@g@(kjPK2ׇ ObONQLQD(gUKA/Vڪ"C1.@z.#}AzmFѮ"VJP@%vGvoN/buT eC2pݮ 00ώlF6rS_'Jr3`&p)D H=(3$(k<#k#[O?Oƹ~K0#aN|\@RU@۞g"g8 i'z *f)[!IToV*Ң/{7үː<$Yx- >=s䇏%_þ5_dFƘ|:ʍpڐ}f+$lv,eQm7fvOـ.;%0 "z@Ek-U2mc2ӆsv>.9(l_Vlh ˞9ۉ\?\gISj; D?2֭?w-E!Z}@NFHn{(NKz2((p]찳"pӏg;ZO|b~09zea t;HN?ʝp3G|%{G1]Q 4 lW%ߴB㑋!%F8ھwٮ#@xޕzRDv'.^{rY+ի)s{ RlmQ-&âhͯ%IiXװ(6i@^}G];S;]6\Uqp> ?BfBG@T ]|  NȔ4]v$xڮwچG;ױm& 5lwRt?!?mPq, 9Hte ,[{P&J2)vF {Oa(T{,+fݼпf>3R]H3@BV"[A%Pr;ZQGVq3*@3Nf UIb( 'rIooP*}=crܱ0=bgq bP34N1֖ 317y3VyЅSC䝡~dTC~d@C:~AUnRtD_H"ϬP^;vxCH zJd㤩9ԋ 0a F⟾D!{"Gc}4}B]?3h 5#C~?zjFVNa<$'AȊ!A/@b ]Kafdezm] _™+J; 'nl/dGh8Cv+:")6,Q@rb㊁̴* lZ3 ݗ(eA:ElC Jkx/L+71^S@0oj##9L ߛ`Hc "[Z;Bc3S<[d^C~BRwNڐ!!T Y\` p VS8.8#sUڐ,FTy ]Z\.Զ{FjCr:(axg29Շ Tf-6]RK2T近C㼧nt#t~TÍ`` y.3+18fO$)>\Jk/5J@`XRzN2Γܸz 0>@H~ldR#rl#ŒpDkYœvf`m5#$L.yb2!;&a F׼PR!^ `2dknaV|\,"9$mCO%|Q,`8 `q -EYEg4 ԍ 5"nR;2؜+z6Er"Fگ6WZ8QHVdȶiE+2VdHT~w_gm*kӘyP_I.u"ʏBJz~\5;K`S"-m.ôū3)dR'XQ7!RR'2}א%mֶ0R$ϙYwu#ѾK4wvj;ORXXHI܈G,QlCt̨g=?" u67ڿjGu߉TfgqO Lmw?!Y(\#ZT(P!33 ;Rۗ][Gp|͊߃Y@0}gC}ͱR72cTAҭY[w#Z ȲHu,Ɏ~d_$~d]i^mj?DXߎ~dվϭ~d_ٜ,4qHmw<%@ݑ>'c[z6RB3٫p?7ˆk[fہ[l\ؾ|VHl_c6T8mXg+_!j[a(͑?[vQCf7CoMrŗlZnj @~ >Vd csѨOޒyiV+2BYZ}l(gIl DTR[as6m". o;~ՍP8Z]K.Ss7wĸ#o K}|ρd[䵓_4G"HQ]"dՉu Lکpy} #Q'Z,Dԉ 9o\(4GȾEAu؆:. z㚩7<`T0yǷDYD؟ {T}ͪ@. R^𐤇_6GR6>rȳt>9n/}:qra Kg+>锔r9ax+Ggo+</-#ښ9}stdg' d#)og{1zq?PnT \w罹e* j"MɁPB&&o(}gRs!'ۑ j k #{'5xO[MT4N.d?譊X6}o(ߠ.dޠ]NK{[#,k B1W]BB¸Gj#W7['s?W_wN (} #2*H8\%CFR3ȉ T!nd_lɍP /InEϿU7rۧc8n u#ޭșhxnܱ1o0.D)d#C^"o)ky Ub;{؎p\7Qd+~fz ZD? ;ߌw +jK{>GU'2tɅNdxՉ DMK##VG3_cV- "OݠU6+.F۷i~d:* p}8WU[׫3מJFh7N穬n'+&%#vKQ rmh[p qI8PXR]aOp IҊOr#N*4yK'Vtm 9ӯs=Ї kZaj[FalKF&Boڬ.Qiý_Ў'. su+#tKaesW9`%FTȘVl,3/t6 W'2A7F,,wu2uxG|ch@Ȓ:H Ȋ*Kߓ) w:(,RKomF;xpcvމ0 xf>zo?׶ב7N"j8lE66sFۨY+TY%k7P fL¨%"uRh* gd巋^#9 5H+#R&w {{I!ZqrKRЭLUFW72D u\K`fZԬ]UZOU[ȑl l?8H1Ռ 'x 1"EL"i ԢvR@FlUP'vGU3r=k!G2'FKP1w/&B/Z@1IU#}\U6…br&m*@hsh&@cރ&ݡA` ΂@~s8w H9 #NLTjtpE'C< *@+ JT7 HD`6/q_r5!ۥ\sQ&dh% MlZai:VGMI'JBM&UՄ̱ٷF=;G'h@("\uJ|2 DJMR;ze[ՎƋ@HBФ[vJrG^!0 3A ۮ2U %Bm!ɭ-?ni[76!Պё/< h#g]̓p[d2-Oo-5#,3-j*Q?*o6s4[쿬ZjYX^\=4@g# #'o7P%Yi7k#/k60'y9]gW"F /367h_9ChOf6{Ȏ<rOhI#L4]ۀMq=S Kc9Aj nSWaA76rî%zאVڏ!-S.m%yy=l^ ba,FH ce%9"HcCqPum9tXر6n.fG 8&Z,'>makqFP 2wɉ-/=w|"n-6q3Pf0c6"}ڦ!u~l&rmⶇ'jGN,qk0u_H S7JƁ:g9NqpjgPXRPv"!V9]WE/{[d*o1u![#"0eda ]џa4>LBfE-{adWFS䈪 B!d$|&I7Յltaʕ }Щ?S= S|.~ p+#hmfR^BUJn䐪 n8#r2n"LlKJ"av"@زͫN}l0eyse`SgrtFы\+2\ִ{F#ɛqvN1܈n,4ivAc`^5ˈ͊Hp?<),WG8sM?Ig=2@y8DɴV콝G-#!9JU ?9.cR@&~(3ds|kD=~,U ؿlp- [R u()Vt Y  T %hٚ D,RsPP8U\5\Sί"e{V@0q(4r&~ bz;c(/C+N"lԲX-\j@xoK_<;2ƎoqRz;wkGl-\ˌ,k0lX+S60p:d)>㻔C| g ؈z~9KyP_9vN-e3"<Nd(VȚ;L,u"C̞7Mn6"CU+Q)VG0=fTa3}uFdWVZʏ>qP,Ei>dr#]X˜1K& hcIq~(gm[_٫=FK7EKX⸫;=!I:>A'9;+ +l/E}sEF)2=qL%Ҧ(nلVDqVv:R:HtƦݲHG$0m( Ղl][=rS.9Ձ YUfձՂ .> Ct[a5-‹rCLn5!C+Pl`/ZFTD2ebA39t6CjAFt ZEnj Vu!n$ʙ5{0Po Ƕl5!- #{#8o&'3Ȉ101sr˙ױAg|(]jst"G8r/RCvDj{}V$'R]ڱ n|<"g?{|ϯtDnY3F$]C5|&>;Cpc %NvH nqȶirX| _σm4jfQfsƹsIdQ|$v+6鈔RL?.FH~A8WMvلl\Du["elپxf{w x 5r47ۗ-wܶ/N FZiHkHdhF$CMg"u@b cb+ \j@B7jGZY9J$j@Pj@6UE6 .kǾ:p( gnV^m^'n{O({ZIXFmiQ[j9jG}K?v2)*%= D~PH }&(wN?WDXsL?[Bj*YtQ?wƚ ~Z*t-]۰T3P"*y7Wl;m#"3*Օs}pxFLQ&hD(J0:fZiM(>n %jB&5֏L ]C~[sjU2uv"AʦDH(Ҡ {(Dj0(״!Df`--FbHlPށ{QfxA`O^sGV!r43I^'(}h:Oi-r"WI#gK$=(@! 0&:rl?CvY" 'q"=[j-7V#ߤA3>^}\*+SBD[.Hvv|Qa EJ{8 )ɏbk7F"L+m3Ўf?' T?WŵzfM6ka ٮO%UJypoa:s7Cۦ?ؖLE#BRi%5EORk72⻔X<}jCeQֶ n#*y,a8Ȋ[zSwh*Cr n ("ȲDZ(&H~ G*Dv0/gyjC۷Շ ։~~Xb(\pmFDXeĆG*n|3&IDsGUѲ=߮mw5܆hGfU?#hJ39%.zAauЂobe>WH>z&IMqD$IADZH>9\-j$TmD7a9L!UOijC=J$[4%gޣ[ƮFd.#CD Շ1DMja]})摈>dRec"34?r[u$GDO 4"PPF0.?>ÍR9c@63ӌ-׮`m@b2c9ܫ#Մ,wH[ȕvZ_`"ѕ>Rg;VEpSrŊF8UHwQ #MIbAQ^,uk)RQ2ۻ.~ź܈ODudr]6\a~9m? :J;r!ex"7w帻C%r%У YX}ȪI}HV+MDA%~:N 600ԈwO >؈cjD.-(r"Ǘ:yӍ(8`ţiUUN)UNpT9FONgT9γuT2UHhܚ944-An 50&4$MM7}]$@2.?kG\Ld}|y pzޟl77PEbC .GII簌)ɆHDK)z^~r#j5'\;kgE~F~0d);U SVdh#,VRGC:F#jcED'P/U;%;/vH~VmDrvIP6q1ȇF3]w6#>1:۠7EFMI^ "ۿXF{DOj(ѽޒ ]!&po\%pN#Gj#3A5dD9W3A@$E/C>3ɧXnrbQγQНbjQ5"ͥa''oF{9\!` TP %BgR=}RwT`V$f*ܢL&Q#l׳&2#fKKy%Yc$ԛ!$jH6%7i E=娕 #dVMr!jW#ijkk*lUysm֔sHF.rSQkS ֧O5$C\\jHd'yp*}^ݩPD7JN#Jo7DtCG~Q|M|On5y5zTɎ,ܻZ[\⹡]JnG7'ZZpu1iCۊ*ua #ɦ?YsLZJnuzHGIZ!K5Rr;d|ZBȚVd5 ifF= h2j:dҤbR%G`6$)XPBw6!)=3@JP`yKO!Ua>B+J6o5Ayc6=Bs 0Y_[ҧzl'KrBA2dϥ0[p؇ֽO۱`XGôV Ҁ;B3bnI֎fd[  'O.V{Yx^psxQ;|J4AsO0pJz幣bc8,ae k\GymzkaWõJsS]%ϡSUpkyٜZi{kD#뺮%G+cA2u6Xo⭢Hqf;M$mMO zoyFF"~[#x?t$_YGadcn8?su929 ˤ#{EkeҞY0lQ]YsBm_J=5D,<Δ_;2:춲?O*lXJ;~NC-zb8"m|TN9"R[.R6T 8;KmYj~Ezvտ`Vby{T[!p9˷ )VlN`"ގyG@p+jrTWˇH;)Li1֞GC=,p4s.& J5#/Џ|$rRSqJ>HC>h8WJ~X 0e42Uogٿ{ާ$3 $[dV"NXh;i\%DrmmR\qTSU$ٰ։6O-Wd =mC@!6u[iݟ#.Ve(M. +;jst]*RU{%l݊QWUv]~Xrv#["I=P5׺$"ϨsUFf"7]jǯ=F"7+=JqkF`Ķ5:\撑rCxWd?W) Īa^)_]-\yH"?(,9D4r G5\ؒ#>rF̗)t(Wt@$EԀ{Us1b\!,;x+"W߷H0. 'i2ƨ=G7r$Wrw4ޜK5Zs8d#PLdX ơUDȽS2 _ l('jXMoCi^)F*gMYs@UMS 6.]ro!̕@NLѓCFQKa=FM %chDFnBd0+]o"_d,{)kBE' o/ s%&8+RF@h* -{{ws棁嘞I!s&Kx@( ^*|MogDc7b>IJ9C`~ |v# zx4ƍ~Ԯ: lN`"@89u57 ԕ#THvhY8yr ]%w,?_h2OHrUz)M^AU8ټ|+j4 G9 vF?\|}J};rT ҷ3 [ d5W޽vO~?T,D4{%ua'??vRɔݖlrʸ `;^+_xȍ7SΜ} wڠ.pevk '{= 4\^ Ch?.pڬd@V퉧U{'r]ȃR:KiQa0Sp[o oM!eX? S:412IWDuz)\]T7}e{W闯HEauA;1.!B ^E4'\\S6CÀ IR@O̢1!2b ~lPʀ_2-MFz+S3FIF[ ;T~CBOжt@ j1:m3pڢg3tޡq VCUFS_W;1D[*Bw{Ud jzO[`; ,s_ lzJ*zDY1D,Rc逬۽AjAdk/L"jɽ8Ӑz7e%#ֻ~*fy~Wp6+ 9Q{֧ZJ7_Pm;Ƴ~XNySfD1h@S0pd蒽 |krfe@%Cc6l*n`ήPsBO]֒fRdMIXQؽOr?4V-Y4rS=LgNCU`O-IˆEw\Al4}.;\N2ʞ_^ef'v.2kZem^Q&x4N>)jAZѨ{` \;ơ24矜 Q ҭ|N-N(%/31@oq8Azs:aLYٔegRTFuUkHBƂi@hMҹS6ÔU!O5Ȩ}h}ҽ±Z7e>sպ̐9nH޿WbX޽#i*v'Ȩ~ a?m!mp$]ҬHՔ:SHxkSֶqbެGŔ=omɛ;brJ9%2dGVPFEۑ,oQ%==wsK~oؑ'Ֆv<޲-tF]]i_1|ΑvTECg#~)x$AH >pcD8_rpAAp C` +߆E⿈[@`zsMoқ)(Ao93⒆޼ p໵s'| s;?9"'JhJ@p0ICD^;S}"2H? _Zy plSb\.&1\TD臘F:.^aMv$>[q!E3<9 U`˷(`H@/Rr@Qʆ#2'=2l0aNiЫ<@@)Le}d"pyĘ'dx>倓T&U9Lw 0,EL@dzAv9hVf b d`#40 -W]1Rw \Kdx\EK !Ƶ[-R`K|ΜĘ/mJZ]L?nmL2?j^LCjR9_ lh#K޸LEZ-E.ä2&-w#,pUWitiO~^FN]0Gk=8j%URTנ\*#=lb7r[4XFbI>bc;S 乤$yi/Y|^1}IN1Vb7Kn, ~ Y}r~9Q3Ӫ䓨 N3kZJzt^ x^#fM AaaGݖl);{JkX2fm@d4d) SWߖRR)ۈ"8e:`htdnʮ谦?EF|)eMgJ3|Iu꺯ܻ.Ks~N|DǺJİ2,KgBR@VF!VK@4 H_'e*,պy L g^m0XЖjRԀ6%8uJ' [s'Ū,lH@vJwoM|Tul[Ie@^S.ಗ=<8 Sv}_oK r9VN37_#,^iW"3ĿLMs+lJv~Rl'4:pqe\sv^iJz%-O7mvΫ^R bpO :Pzz]^Z\^ ljcfnոA)ΉyGnc/oɬֶJyK&H+_B˱ x\lmIޓKHyjSUޮrDhD|%7Vk)YYjf޻FgT*kЙ_.;ZU ي)C1TM|̛͘;"p\&b%zRC3 ($؝o4@Ÿa)msSߊ)']1eҝi-Ho*9~*lfFVNȀarQmϟ{2&xl|հ(b ZoŔ@[YZ|.66@5w#@n<پwO?By4=f#)U5Z0v-?Gn,n+T#QF1 o L6I__c2`~ 8|['4HOJ>G6%h^#ij%-{*ѥ *`V2ʖU@h0O8T ާo:G!e|#1w do@ gHY{5 {R u3k98̫ #Q >U#`#YE2HUzP3=\_>SDqB;h.V2N&]]߰ڏ0H;23ZI޿QqKZ(!L}ϫM;OkX⫽)I<' D+gG+{;';ƕH+*Vm)Q`&#~QNV<<#&`dlX΍[9i\I1) چch>̝'逶$-5#-huro_eТsUFH8GɖY*A_'H׉kv_a޷&D]%/ 9]cZJNLFK,Z}HKEwO5#*H=ƕq!ո1%z) ]ո% dGyDTj'3c3e}\ ܫ|;a,XU{w WI>#.v9X##qR"UT7[6%z﶑^%׼s 'vc_f M܌,mЬGf߫v>U+2hj\CAemusWeبAHkWKԮ"~0wC{1D"Jܣˈ2mOb]oiWT7rq  &=0׽q'N޼Om?>JNOCݪmӂb!Duv%y4BXERC[޺@hToM2+ǬZn!ݽ4 l[BlK -@C IZ"Ԕej esʶo&Y^JF5kˋtTzotap::<+iK 5>cc9S/,*nOe<9te+3'H"8OQhAC\:%w?+wZN oSej8y(w; }GN\󳪾LMeYl|cӡ@v˴? TTf[ZRzrPuK@n9'O WL̀t(ϚYc;Ach:\)rE[t*bz,`H۲[ %@SD8'SbO (|D?J,CǻB?J,{bBq#Ж%W_I݇Vtn]#JRr WѦ-!n=y3V 4, + `e@&N_?%(s3ȗ/w$SX|o8 3Tc.Ql d(CeDIr]&\&[/#TUjxԵy:?)GsuE4MieOX7]ҋZsAp (ᙨMZ[ ߏuw8no(̽TS*g,٣2!Mw%mvda-%lKv@Pqۧ"3lݯרMDIӲ'$R@זp;nO2 Ƭ륏Ε+L Mn@T5@t16+YJyM#ZDܷk@M fL\Y7R~_p.Q=n|U@7 i`I]ec#&3ҿz-JNab!\eC Bd +fRf†Mr6\ TDj!l)o 8˥{OypYOgz~h@hԀ]OƊrw'Źߡڥ=T3;̮:7r;H PKWOߟP]BUv X-KbL'jv!Ȟ9ͬN ϽEMZ, 홳"̜Gw֝MxJ@{zِ&U`kt_<]w $| AH<6!bzp"mN5+g>1zFpk' J,TwpQU64U!sS0O>uj[CqW`٧ '.* L{(&Fiw}&Z>rTfNiޑ]÷H `8Ӆ # M7c_57 e RPuki?YwcmX';sn͐Y%{dQdṳK k)jyr*#aC)>@nk\3אe?fC8J߉Xf]ef[XXO]mBD^4ט#D[ UQ=j0CedO9Y@xOSlg?.6uy"@_6Cp!d$J~0FZDVJZ5R1@Ӓfzg.A&ǏIPx T͉:+Cw>ˈA `JZzA9f W--G z=CwzcN#C 4,n `L3smuD dfe:1b8*vaiei6kΈ̧cYK|<5PxJ苾T.hm6RuTgd)%V@"FN30T(Nߚ,Jc+Hu臖z{HdݤS$WZұsj(?TA2B y3HP>E˴,c]ˢϷRqJFQq<\'Uǐ VһCsmT޳g}J7NFTK!PSr!TÁPSvLW<@ SeTt#M3 fʜ,celXÛzwY:nZGe+Se0NI\fn yHу2d"@hr%Q?8 (7(L=Zj]7{坽l gR2 a=5$g&CY08chI$5UfJ&Q o*tß*rG0'-:)t:`N`Ox @e89,A=YB9ZnI5DenʈwmD /thF5b-)iHx* -LE$pt\"e$B 9^PP!{#<:$5TOE1n~SOIDb"HewY;=4ȦI8F߿2^nݿp+&jrO1gLt0 !aPUrl@-EpPus}?+%W8@waؽ);?rU8*(nV1X8WLoy^1c 2r$. Bv:,kE))cm ^+^xS=xӠ;r)>k?QhX[2 %Ѭ S Lk,֟|CѸG:J-cU"0h7US4'ϺRW9fwǜ|ʇ3Zj)ȭ/QΪpgEقRҾ9gIڹT3y<&Oc ;~E @Z4CNM}]?*wXA0tv%cHHbZ>$M "NS擩#vҿ#?T@zYq-KuYQ.Ct*b[.[5J fo |]F7cp.'PSߤ24y]jЪc%Wϟ#q@H[e$ iZ~-t.Y:A7sW=㻫Uxh1l_WBVLO2d'X,S H9f5I1r:C7ObaO3׈O{}%~+d3BK$@X5õ{ju-{_^JIiwfܺ7Q Bv%~abp{9>1Q4X@T"RZ23[$-#0|p{ƬjZ%]xzΡ2 Ua@Hx%r߇ȹ=U:MD[ߘ1<./]>!WPԼQK#)G񽍰tߚ<~`q8]qQ{V5EtQ#nY,:{lx*mzϧeC^kg6@8챝 + O{ouٛ$F8HvKؕhfd).iSrNI ŁPv`7G&S}6p?<0m [own\"y%ܹ:?{zXlvWQΖGyJ826sVl6>p|-s#e-@za+MK&B%˚?'kF?if}MS/?nT)ݷ] Xo-o^-5BR dv<#CNlH'o@TMA(n ɲ:/33F-`,伀"@x!^Vt:u ¹Ί1o{~N{wUh_??wm d"'~@nA]Fo+SH&ȁ3y@X,=kB7FfrE{K15C h*fY82^G# A\MQYo}ߟg:N~3׵+ uvy `|Ŏ9MOWrAʽ9M?v7 륣uʔep0ٝ WcWp}Icˇ`ٍa^G1'N.r˾&5bĖW<ߗW}%^51lўj(7R,ǻF}w DSIb:yX1ͳ{W LBgY]xl#MwFnƗ'\*?Ӗ?uZx +KO 5b*UL h5I*Kmi$c|cUmܯB`^cs,!%u@X5;4[ܼ>M_dy>?G@8P^ePS^ @˺Y +L6"2W$;,O>z@,#0gbzDcNnHtlRR3!-kk+Nqg䇋Hvg}JJ K\ U{:/v{QȒw *!]nA>Jo9J?R'WeoΣpX~ q@7a8D#/r,ٝ~YM95D[𲯁E9֟=a39^"(PF݈yvUJ\˄24W~h{Se@.{׊@l!G>>yL^uH-ǖ7$yh' }+|nM 'GtM"I,]w|U<-ªTGY(j|=VT~>âzđtLp KEp(ǭCn,bkGNҿ#Y~((lKxv~|h:#j^-*ӫH^Bșإ"M JzSe_#滬|2rdz}a9h*mKX129e ; Ĉ#rlek>?M].=U2MF--d꟤')s@3UQhfkXY2y uL]9|UV>5tJ5*w8?Y~͉UfHkDTj#4 HDMMnǁ@dTFQj7L/jyZYTd?*wϞTa2K2TL o%ŷGg$j ozSeΨTz O-ipyWnET|,Iy§21_n* YZ~?_6u@ 2MMg_P~ٛh dMo!*L/n4 bںOg^sZBs9côXfbdJG򜄄3]D Hy(H!eT4.M>zo֥z7 êTF%g'*mKbG'yIHBKVR ,ջQ֬yWJITg{ 5Ć-UZR KWWteoTZo T NS~t+,ٸ\'G+QCPf̰uC2= KAV>{)ČM9p~UId!;9d]0 9q%nUfyaͬ=,$[_ql"h):,Ž/^w̑An|g>X&RR7?T˫%<<6|bwo?B`?6JhVDW 65o)T![isKm:&ؔ/Pl>x@FIk]{yT)sxt:Z)ba8 aNwmd Ƶ:E NB_ SPcֿ9+Y5LM}_nҞrko*<]8@> 3jDavnKg/2#`YYN2@H/M U ]])nQ]C enVY7C2EzC3OWe%ŎWjSmwSYBܑ1ld?O;{UFϓ[?*7Z3Y)}*V ֕PׅJ$7;)iیLm9ԦL 1y>-7pRZ<$I{${ݼ~ Վ@hPqٲȪ1rT<?f@:iCi&O<բfbϑ=FU|qp'@h61$:,4Vbv9%gÿ{ 2̥Yyk<1Lz mK޵ {ulW&LQLWRfziTRA<@k<*vHNMSy=~ݣvThBpy$_J[p.ڵeu~XiZպBHzi݂ZiZy ׻#n 諂 v &_]]ɔL@''y~>E[]J&|N*g94UnoS"3w)Wp)WlSdj1rU./ÎTq#T{ϖ;2Md>D)u#QrD"GVkTM]eRc6m`=~s~{W9fXz !Q :a<|̝lK "ZBo,{3E -cG ZEҼ5͋;YUB:^{պ Iߩʍ%P͐WUr4^Vn#oz}VAQ 3w_WT@4 PΏu1'2V8K11/[~xBY{a6z=8A2zN!\AĬ%ˠ%Uzơ^Gˮ.uڟ$Qa.\ŗt3_1'̺bpSce]"HeUƎd4q p3#;x ;^mN CPn*@dWnDYuU\FXyU~MT\ޟ N?H{-tM0p@ DM$a鸀f~hQks oU3 D??j/ڱ,^ ʪ`vhS%j t*/ଚʀNi>}.@=F( ҳRj 2f%]^鋦~%GՎaqFGf"G"$٥j!11ٮU%"ron'g=~づ"(T߯9P  R=RrȻҦLeuߣ*j?+OpRQeH+Õ9{ rk@fgμ31GN'Gul>L# ys) yrg)-gV֨9JX.vv]B-;G{:GQO 19_pX|\ vU ;GUyewl0k_jS|s;4IϓR/qK=Q_յfCquL aoZFZZӺ}کpЌhǜ`U523ݚٟ'i֢{/-{T;˺6;'fntC"ER>`bl#ض 0{͏~ަ\[3yx{K~B{utJnZ0*B  U Syxn<) p|!\M"=[i #y`uflѧ N-2e|`;׍.N_. -2k洫j@5ؽu\"B/ƫs6Qմ׈ʢ-VY4Ы6|nH1V*hOs\Ru?Y<@ZL|棺SuQgeћEGK }c׹*ke0s,qHå9co4qUA-1+ۥaʒId3dN0,k 찏呬) }ašv7W~HV(;Y5h?Q#9UZYyguGUP1{VĒ`xӲurT\yk$vHƓJ\‚BwfNP1M| o%1=H^'nygo@B* .`rf6 }SMOUDǕX6eY\x2˛w#dG(g $0r"8,#]t{( 6!Y$'}K>ʵ^ 7467PL<ܳ+?An"!.-|Uzݓ D<7k܏k 5)IsN*ʢ^j5*yHq]M5vɧK>2LONd1H~եuG_#2|H`V@AivۥuG3.. 3"K^ZРHB<4O!Wqs #'@n'_AvՔs(rAZ;_*9JP|Tp(>b.(Lc=O ;({x@vuοcOY߳TmRbH %ғS#Tj٧1Qrt/aG]r lL]SR B}2@(& `o1Z!I<+RF6JYZ\#@6]23PM}lT߳k+LׄJ-~yW=>$C9&Az@U%6=jo Eq6|9/349tRν Ғ^=T4c.+&RoEwj%:UFʧh<= *LlTE-;~.Vee2Wr9khԀZ7g|krkޔ={JQBNyl:fJ4K.[M }x mU7uhʚ }1ff-;#6ʽX,&Q9DÂʿxWcoblNcB0$-ZݔH3C-kdkwZr=e 2nc=BRoR_뭜 7h(K@X͵%gޠa~96+AV @hE*-{UJrvK04Mr #dO3\xˮr9MMLVܣ=25l|S *{TB@8@~쥼2գWz|P(]3pY*o"um.2ŽRR8[S%8`Gi]|(&s3(TK4vkU$g |]|]x DK|evy7I rFk*u#ͷSnF PLKry ( 7% 5`.U:^.UQu}5!*VJC" Rz몣 v}:H%p)lE3s<.}u$/14*Wi`@RWkW\cW l)}V\ղc{WViWVc=` [T- 4UCҞÆRu*{8-i݊+COQ?)e ɭEV oոDc$ GJk*qc Y"*KWJܐ}{ 8q1n&GA[XxJ;Ot-Kaӯ̢c &n=@J̙?sԲRb۹-F1P,„u@۵R?URl޽r""2@}+B ຕS6ۮaN(+\];r eVN}oY9]x_A-uW7y؆E·8B7 y;#s_MyråqǘY|" fcmŕP͎ksyΔp3Q@%7oT0O Lnrܮ-M[s]-9Gd@sN @,I1Jђ77x LяѱVHH޾~73}[^đcj%;;9\Z|=%\^xhQB) 6=b##8uP6{J`|110vP4B5~UXCjME~шtr $2 Ƞ}[&i[R+ym2qEVZƷ6ص'Й~,dZcsfַ?O@2K69lho@/RU}7hGnp{'n u$ſ9=vVi'|{Mli@9]?@!eDU* 4U\ئ̬S1 e 6ipGp{p+l+6&ľAfIkIwQuF SH~R%bayuiPJeB=pE2)ۿL" \%l=u SsN%][_,?#yIl\9vvT ~O-Ey@F46*wZq_ڿ'EK Sjr i>MrԶo~a\%~G.SF^S)S-6ƾD!\L PUgLd =HWo]b}xSߙ^|G>Rr}L]j T 񖲽ZQ0@X}LB(:`7ls}LBEϹ=@Kv\hs+:=J12'Hc@:,q߇U'C%/ 26ug.y)p(@jUyU"بg> Dk]8y$U"Yށ@2W6$ved_w#Ega۫%S&վQ#@6-XgzGͣW=wqd'iu;#UYOR 6B|{We<,jCVûڽ1rn#4o5'ϢhS*j:fwY-\TQ9!堼4?uTҦ6B_븤Fze$SM:m*>M/!A?l20~S{뚷Z=SazЦ@ekiDXhc:%',#3<Ug=` u;1S~S)n׍t ]%Փc("~&y@vkk*k`JgbI>—B2K C[IUN"O@4L.dP=Qv.8 ==nCUSz^9/i9[km̡ѭ& ~3fSmydogÖ0l> }ĎFũH-6ko"pnAɍkW吁7$m/ b6;ݕg Jgk"A # K!4g/_I@)Gn>DKp PyZ?U?Bd ԕtsflv'wt+mWn VZz 0(8 Xۛ@(oeJ4؞MOWM W"XV/oPk;?I 8] S۵ S ʞ|_{^Id"SF(2)`[Fda+luYsg/@n$Xl+ *i뗞nӯC'^)%HCڛrO+O-QW!2/,1DΔHr +Q=@8MkD7Y ̑;ֺ29l5#hwU;_7+%F 0K1rBf[a NNA \,NMn_-=]cds|4 "wva!{tCSʿIJ\O])d =2E&9]jё;8r1PI4vCdnY=kd]ߜ'zoa2߬L,9Η 5n9/Zg;7jgM J=HO6; gfe:k'Re"R`y9Wip}4~D :o;ZݼF[1yג9\Uoq#eRm>^ұ%GxGڏCrerbzm" !QcHюhR+}4J!;/x9@08=J!C*s6SѢi9F5|2_ ,g-=s*s,Iǒ:N2C0!}2v]Ԅd<|vmRykkȵ5Qaa_H@vYn29ݯQm 8B֪ۏMitMm4T@ȯͫc-0%9ԮGշtϏϳFF[#~da/ &Uoa5;9H֨1jǐP,{ ?cŅCn"UM)DžqR T8Ms|ߌ%JS=S?(P[v@Ac|;+y06IhܫS? &̮k+\ [1t ԌHWC攮sBaD,]9fڷ PBE\T}۷N G,dp6'X ]ao-~z[8UFVVSmPMj:KU RE۬ @ -4(^* 񨏓ˀP~{ȓTY0^3 : W4O o |#K޷W6oOBSjVs'əhN[Ncz9mDczȷnV~>rRNkz,+nv[o[pN[|^ISUL`xsb۽-#[GR\5k]7Riky,*ېtT"T5Ő87).I3&Lc)yGJ_ߒ'Ȭk`5X缛zh~ ?MSlxHC,iǹYM9YLy< :P~-T#RV^#FeI[K#*CNMKb1|QPS\`hWe,kH ml$\$!>SEƐԎ03Sx2JL:8^mI|iCqt8G.Kݚrה9yJJb lM*é<ѲT?2zr-ڕ߹?6xJ=Y? @^{ľFFZY2-aSj^ Fg\;SٞZ,UIJv #_j?|uZ9ޟJ ٛtKc#_UB򺖐=zJ}jLEp+zKP,з;5:t3{ s쩄Gck9er̽ƛ8lhٌPxXHƖ{s4CVƜJwԜ a\ܸR}K>SS[(I5BJRU|u3AjvAzIk,mTSv/RRJr\fWKm;N5b풳Ϭ]U$ͧX 8CJ(1>^OD{|Jcϛ.%'=Dj2b<ՙߊ9H"8YDZoF}yjDocD\uTVɬ{{KZ\X?#.Up9 #e({SG#jt4cUi[E-M{O]i6}Ni6ߟsR? "<\%jhDjSNM۪v˟}z-G%foi3CҴ)kڏֱ=yUl[TChyS= 6vC|cj┪+ yOeҧBȖmրg:CɥP YHr%Z$gCw*rȞ5Pyz .񵟞*5R:GʷuFqU {-@P>C;SJ ~3/"fVgrOIə% ,n[=F˧A3wEF*VHWenn#4}Nkj|wνY+];Quutm ??>Uȯ0GA?M۪ U_A"p^ȭrdmBܘ UFIEoOI秃]o!^^hpb`~C V* q* '* ёp{ߴ\My:&wM";E&rhQPԲb}PU.Y5>VW/=%\mes_JFG7h?|+6^O]l|UvWz@v;wW= Rngbh Rn+mE1j_s%m__ygˆsI)V\qihyn*ݴ?Ne{jVw"ͧX2mFF Xh<6"O_. E O EKW|&R>sY2vI*k x*lYd@%9O(aa ZqQcAv@(GNB952ENŠisfZfJ#F ݞ/ `w iNj6 ['9w|1\/4# Ё0-i*aUmOo^yFU^F`[&k ? ȜA3I lXw:0Msk=Uʊ\kx$L}X"(86K:`:8@VdO|C7by󖲽vGg^Q)MO12Br'6K$IY0n䰹_;v$K٧x޶ TLLWC0DQr_Bd739,\Őgt)'c-Mw":/Ylm9YcIB۴Zp1Օo&6YH+WRK: Z<%]e ld::pK(,Kd11 ŅyG5)U?rMTg0S C"зO .oKݙ;cCB/2'=_%R NKƟ+wV&6I~Cg+9f&iWD`9,mss"h&W=1{?"SYP@ӭb- O45wJ5+*Je[!!ZjD+uT&ղ~=,/_b9Svi_3t[2w[:4*Fe|SیJA{M9'cr*r0-2vjdNQ?Q~oې>OXK6aIIƎʷA1Ns% V4m6K]uiFP0CDr{v$?˶K;eu7PVˌJQyDa@TڪHx'u$q ^jHV/z\/:e2Mig1`FH֫`"hX(ϡcVE͡ggCt#ce0;, 3o" z-:DG u/J{K@ޥTWqw89K2Q'aY#wÃ~hjÙt#Q 8Kٙ*9GEU>L>lی0x7Lvܣ&dtӛUb U X:DƤ>fSa PnyW(e) $6Yhv%,ѬYMdi! lŜ6RHb,{,9 #Pre6mH^ D};sԽХ$ ͝Smk<(vG0x[joӊ-ur2@ׅCl4S2wߵһw-5؏7i%Y!{f( 0Bګ8k.]nŒ$W-Gvd7Mn[#,ȗ f_s`? w1U!Sfti[؎ K00\/sa=lE'r9󽮳wG@'B=g]bNO T7:}*&- S xMRNk3*&- 0L5^$6D8I>ӭ7Le"IrLP?f5Oߎ/I˙*|rYo]'w&J`+$\܊9cDsL$K%ڗ.,ShaD6l⬙D-&?HtFB*ݮeD=̂-&*f):&Eg=,M(NQ/S'6b`C5 ~6GClWY:Oy/Gqsu["C#%lEAU5S'a]mss K&rO=)ݫ\"}Yg5v7s;CZY%4#LgMmQj*Y:?AXfAh(taۍGj>d % МI( ,K6ـ#KY@wMnD0 8+؇lzQC2@(ͯo",#f'f{l7:IgH~ӥ_o4"˰1HEY%Kf 7 56"vit`(tՖȢevu=Blx @9ަ[vuOZa'DKv%ΪD3Һ(]HQ[t)u[s_i"xz㻳Aog?u<^fQQrw?ݩ(0#.>cJdm.To}˺,\жn&}^(ݻAf"GE!a@@Ĭf'U. kUD(uCY d{*4jLA"Qbb6<&Fdt0B |Gوl &&bvNyd;>or:DGNъM{RpUuRۣD`n{{W%!UXr~%YQKl#E"UNfMr{R"toB)kImm.!fsD p@ȲT2=oR72AW)WLbf# Zl6"5.6eԆqY0ށǣ$*ufgA"ekJD`\hh?ϧXrCEeKY A57܆-6rߟ.{u>O~>="mDtBnudǢ5 6֌ Agס=1w#!rU"HdYGZ"㨓@SlL{itvvds$BE:j69Q Hݘ_1eISY2baֆA^[\w{r*Xx&VfDŠ-W~(8oP$#e޿![b¥n F6 eKĂPzgFkϧŧUQfm @sU`~v:N=䳸T(ӯD) $gT\a!}@Ymx ۙ]&^.p-dG UvfIAUđA잒6ح:؂>H(e`n{pKmց!Exֿ%xN$ҕP4Iq8lI617ڤUkJޗGAGDFz%ȈMR-IlK564ѐ<]6'Îd$:j}ؔ,uiCyД,?]<)u%+["Jv"md#UL$*=StQW2OB/͙*rqԡ={[TJV]IOZRN]Od + `vkn2VzQ &]Jx6F@>WQzwP]Fb GƊ^zV:[z=a "4Ji YxAڒ70/٩$Qc(2HO!݋Z=lM)< A|^ͅJu~؜ pT;앍?NtXYqX.&0R7+{؝,>*)gEew@v\7 p` S:NO^Ϻ0&jA#D%/Y5#͝U: /4wz0{a-nR(:^*mRZ._w?YdtgQ$U!`YVJLKc֥=9PɶmͤӗڿԹ"c4zٗ,"˫dWN$zSd,1YYf'o%cW}>F)`<[2G-d{w1Y5' j@  Zk1vY m! ˾di2иљo9|Օ yFU|q8a@+K; p 6LBOR=*mY+GsL5T]+r MVR8 z-tW[Eqف.6BeKQ\%a7r|$p5G:ii[8(tM*Y*azx,g/ڿ~;ƣUs"ǔh"Dl~kK$_DN?=-g{ATWäe~CbP$—,d4SqdKɉD`t]ݤiEn7#߇ 7x8E͈.N;?mRDpQ_P zgYʠpwI [KGi6AsLp6?ܵ'Q@9y.ktU"1{,lփƽag2Vw#I]3%2]V&ܗO{T0L D-fgZd.:fJ꘥ .Ux ][ 8>N'=b[W>$2M|V3ƍ-!9.%o‰@xvKB{bROן ;jO6Cf<((N@Uީd-z,}L[Ǿ `+VttRI]׆C6Ap3DN#ǫH' n$NAc8B4K6 OeJ?o2]i4ٕmو A4$G[U'"`V#O[D#wa3FUmIiqmߞ9AlH{v&ޝMK»kTlZ `S0}t͚7ÔwL kB9^L6:c+ v=@nk'KE)jא!Orh>V #?VP߲\j&0зVR6JQ̦BkC ^vRݒP'8`wܿY"!v{MAz;SūA0jfI+wd&@.Na2J`a MLMfd~0mυẛ% `LsGVp{ 1T6#OlM6gwiZ◐ɪt*7gJd($Xn=L0)Ry[~<up5'Z%CNj\1+R.pP ꘽FI};: -U~4(oٶ#rzw!`S"dHJ`AE`(p'u\A%Y"XAYIC\\NH|pdE6xlYY? ts:X=<]+V =Ir),*8&?%1$(` &4N]ǠxzK%Ůu$2skIt-r =rW3[~U r,A{eKA;U%FyXqoZUL>-cJУQ"Q)ª\"(6'xd|&`5 4qTjM۠aoV"~dA*4'K{i&YYգd$e&0d C.:&BZtRiC ZGqr͍tQX@&nmoߒC5Ct~Fj{Z#{uDrI*&04`㏚FgqRn,wz:F Uq,w:;99>҄ nԹud2vlA Sa:ճL'J!F$bJPꞈ&C;Dϕd#69O6IɞZ8=b{B \c'Q! ʦEk @22A٬@TbD'A&e,D%-0]pG ʞ9ׇ)Ș!oUQd3DxUL"eue5\*3: u.mdBAK]cGDhs]Ks著}q?-FAY%ǝ}R_Ti=UMۗ230^v1vNdGu&sJdJ׬@厺kO3$J{oҾL!/Z( ;OAݧ&?u)wdM;M97kq!s1Un]Ek'D{wݼ4`A1zNHaGûؚx~B&(Sw+]VgD{ҥ$cn"KFZ Z5TM| OĪҸO"/3Yn8˄^MQDAJa I<=@ySZݣ;o ! 6rN@7qgbdPOL{xcZH=ڮ %^UJTҖ$I )j ,2y. }}<,]jӄ/VJ)l/x"GnJeǡZ]E 冀#]&HNSHP"XXq@P6yX_Z$j,OdSO&Mɪ U>3_CmoӒ_H"2t:HB;ũ$.\,!.\$sGw+L˒G"뇖<,OM|ly OmH>|'c`&>]J˸PCQdWםKujl#Mf! ֢:ˀ&-uj",뢜/3UrA&ަLUi7Qgd/7>F>EI3Yp>,io!l`2Ӊ@&"] C׬22?ײMdZq>QIji<v(V%+q(lB,fw̿Ɖ@486߮]MdGz4[EL7u&aP4B $&99A׺iqr؝m%0y6!׿Zn󛞐+Iٞ?,s ??=jg >H~B;$1=H瘞9I|e9j,{{>s7_?~矬Xq8O˒gƭOY}=-oNmݿ~x{_=ζ$]mx,@Wj܆K(!ߣX?G>߃uw^}sF٬ݼ߿p_(CxG2P>|ߕ8ƺ?-~cG=ZQ)g~}=W =b?ʃ[e5xA<7(ǵ4$m!Z,v\i1O ?@7D_h W1\ PSm (> ~kq>jH 0Uh_ s1CVydyg w9BF2Q $L&}O<&c$fHtƭ[- >-y&4cINw.Θu9|1\?9_+e"oG7BkNp@2ުCu  @=R^J7!YmdYX/038\Zrع|TІ!:ε>CsN'p@aE*V1X,Cd$U@ Pٹ܂~s @SqSF~<:w4@ù ZUt 4 u(ao1=(9zOqSIMJe`Lac. `tРj$ͼ5wV<鼌 $y(ŌX䙷jZgFbW:-6vO]! 3fv.~魳GKh;}ݟtF}}H @4Bn(}uh:K;ec@6<]*Y )xng.i88ۯQپ<ߊN To|S9Q?p89{ Qm~G}Rcb\M1QFV,G7FَduC  O#X,Kr f5SG jv8rE EP;܉ ,]MQ@9rm0[E~$ 瞧94KsE5v3ݥ\N@zRV#l6_ZM_sj i2 p.Lf +ǐ@=̀w^MЊO`+߇u}(z/C+C~TõI>잎p:ǯ &Fl,E +@ğ13>9PxNgA<˜8YPS4ᨈ%*_#I|.!B9J@1tK-c< WEK1^] FK1^VS:d_r7r}R3EZCf2'+-Yx;]iuNq#u |r5gr?Z]*u3Vrx%x7 2Jz BPHf!cb)!\4397TG}>H|=5)eoQD0WQHQ)"at= f;}(+ 6}>T:wkwqYu({\d?o)y zs <Ԭ MYh[" _"s2l: Z%I%!S08D!&CLJ 6][ *wa|hfwj!W2/5zv..O څC sMuh8O;pq4 xxM.@d\Ȕm0@g}Qk[_kI%B _"-J:f|  #E"[u~Jr%)B!B!WHq7&g/ M$3ɖ"Mjo]7  I AY"1,n{2yUg4=3Z]ߏB<,L({ɑD[ 0Q.L*k~S >ndv4;u&rm… 'TUe@ȑK喯 D=PR0FnPsS`+B O/o=4&^f{R< `IGRu ^fU LLԀ¼C`67p&1SdBJk"J]DD"&\zl#C@N}z[! J^8 `54dݨ&=9u#"Q{zZkXaԛ 9X'vyll@MR7N}:KFZ'p],esX$J/QS:=g%ʩM@w]7ea'L%4Ԁ$5!4v$Z}/*A%z-ؐb۴GaBސZH@(7uEyɨS~Krem#Cg4[3M;2VnmlS4RTкtO!U5*v\撖@k xz]26q&8A!Хi6Ȝ]WY:+G%Z(GJZun) )hJX%j Esua}x]4=vtx~~z]iٿy.g/ 5ñ:\m&7%[4nz/cS^\uv)Fh"s)>%I^ n߹% > |L.۹w'e;g% &:dJwt#oheh ށo /Zqv@ !CfuRbj 9_:%kpW8k>xRW|II.x-SUXlO0;jN|GѦI J|,8?˒u;=e>L&epS/_Q~Ks 趧ye8Ex8h7W~@?zO(}|z-[!3r)[?2t{9p~࣫r"zDq?]IK82+JhSutS{',wv^UWM:K45(&$zonTLrHIAb,=Ս8\7 F2KKK(Cs62D3pR䉰yݗDdz=xWD5^NJQtۮcvb=6Id)GK:mpkR¿y*GliԈQ~1`l?Ah;S]Xhʩd_{n RW.sحC@MV'j2EqG Le89pFSlbqxb kj.YީT.oQ)'&v}IƳ );У\ҪvT@*.L$G| kM]8H#ӯ ?uU ҭ=G9L,3^Ҿe+xeffztNeD-}\la-۳%~ێ@^9*]s:Qa7_szK[AВ\9: 謼ֲ6IĆ\w#43ŠD,M/Νڰ.vU)"(f]mVLL`w]&ޭScMM9b,E B [,zn%7U[d1k9eϹq*Y f:$Br `'d#Pp. /ډ?XkBKM`r+t*XZ~k C:7+0ۋc$TРLr!mn,NZmkDSOv:qA}pz?Do碯aӰ ezzDoWr"m%~g]꾳!'-nΠBfqO>*DˈnFT8ޓD'=,dBHzv DpdYB"QڧW{(}_|`T`yTaVk'j$Sd[0e u̹P/{3HbVuD- XV`% $lIz!s)v}lVέ;}"He[32*[gwmNOU:꘣isib0,#=h9!BUcd2@CJsw@l9#:ʪfuBJsIssI[Cdؒ Bs-@@"9g]}NV^+%$=S\kSJܳbt]CUz+C;F Rz˝@\i#R.oBK"3Ȓ\Vgmp Q|PN1\A; R\*Wr`RWˮE7fw:Pd*0fGΣlRxÝ'7zCW^-u\?(FF}O#Y%r9?^geLH-};E/ReG}hu*OuPϊA'GLwe2 hYXӮs ;x'~DtzvtBVLӹlzmY2m?[b'L}>ˍP@ci3k]a]=3r4lXQٱjdr.}4Ze;qnm5fzve;HsmV9_xu:Υ2~n pdm-2Hiz`97tIm֒@SL3 %+r{ q!Kav rhB%W:*sS Xio9R% z:> ?2x_CW=i|lT|.ҧV4isK+ ^q 7Sϝ(nq$ϙ=/tȹ$sYS[@k.n\[|tU `lnSZ\9Εz^95ٕ\&ޛ$"+˹][W5Q'4oSj!b";Ueܯ _~s}ߜ[ /GC_ziԇ5,3X?dZ#ad0WgW-Үz.yFMzMFPu;`)CR]m/uu˚Pxs+qu W`k(kVW4w4TW+|*W4o،ތ}5k?ϷVn K)Z_>%ѝ~It۶9 .\LZ`̂sQC*uzQ2CJpcdlQ\5,`SϬ e਍=vDe){ <=(bj_ u9*9D#˝k I~2$# w]uJʹl"+RjdQ2[U\.j4qzqpE]7n%C?۞.>iu2u:uMXΕZs,aKSv֕,!`ݕ{:|O6%uT-dU$#7SV+?&W=~Tk{S;cgw^1RG16rw&E+.3GD:$ K"P]7cc . WHRmqJ  ڲ@tAA"k}+fIaqrpzr'c#PۥHZ=T{1- uuB-o}mDZI羷 uـCe>Zt}s^5uG!ݣ62Rx~:L3\=:ku 27j`׵ZFoAs!p~T̮S R QÑg T[^j_%SSLg=w]8eWWgG-MdEuv h2~>뢅)5zv gפ= ]c/ nD\&R5e2(K6[~"#C0rO'5xd#QWFO̻>'ֵb ͽ6 5HspIH"SJMݩ|~{(|~wuE=Vv#X@>3*!wXϛ@>d>:_ ڦ ݳ0;ۿ$diGAj-Z) 1.tcXGQ쾣lnYZnSnB $#dvSPHYX#=u IDH< vuv嬉 BΨγԒsk[xLT<tGoNGB f7٭pvkwLdc8F{CC*ݓ#uȼHGC2)H!<ꬿ@ xKG) p]r**[5eO]8+hM]{fj#m*HKFk6U ~dfUR#h6GꖪM- qޚg׭cLt2efhMcY?8{*G1ZUAt2a2"שy2dHt/mnL[eҹM2YXތ؎1t=ލIm GY:f|n ,5sMϢs#)s.o" URI5x,o\La46=-9&CdH#jKzقjWj?s@ǹo%{\b}{G9s5vZj?Ԫm ܟ΋Kgܖ \Q1o+r]( $OSjDH>^/͎MKGj d7_6de&k&˓F/&KĿg[0,v&sQh]m>~3Ok3TŲ\iqؘ,oVKeŃ T6H1+#gBԻU+;ܭb"]E (_$K("8ZH|nas}*7u^q-؝ ,^7E hnT~?dE.Liuɔ(6ȧҭ*bvW%2ޏ~A|ܵsH[bkKzv+1.lMْdj.ݣDC$i9Ijf"2.ZVIBؓ$**320w߫"0kpԽ3J"d{IggBU&??u 5y?5enܹSWT${/w׭|?ܚOs{.u9FZV@H:GzS{>L]ZEmt&$6;AOsP"DGVg% kﶃiY)-k>|Ԙ)*7F:dW9J#"jb>ʰ?uo㻞,e5a&f\S#z'"UjoH\b~Pl?:oڸfI0%ߘ@G~}aeR<ţ}0[T$|!#[9kWrShjd cx*=&n7B,jІDQɕȽvTv&5E7>Pחk5'Egx<dmH(GY3ۢ-P>ZՃU>_h rk ['I1\^ԦMk+HM ,?XV,B@Z]ecߏ ƮSS &HaDD:-wkp6BBoCA$"Z~eYdJU6s'En{Ѡ+wH>;YΕL>:PuR>O#nN nMAvm9HnW"(Ͻn^KdcVȿvY"OOv; @+O!N[cȇ$ S* 2v_|dgb=Νfʝ5N gѴ3 9gƟHnDr- $φW3rAY)u`c Țs}.rZ2m?V7Uu:3OM3sX:2OM+EgꇸT"S}r? p>-E%^39b0>ء8XL9ƓGd qH2p>Z'o%a)N6H  ӱ^npM:#j7w#Vщ rsl D׭t_ [ $veS5(3 1jdzE5D-C9,mk/zm]SEΟ,/'AK 53XV%O9 gfcvH$I(1"k8z$RhOOt*yOYKz;z_Y0ꘁ譿_ A"g+zFĵg_"xxՅ4^1&oc& @&)IYrQFd]6)e^҉ LJ_6)7IhnHFn e>JtT,5x~>v cF4@B4eHhPYW0}z]@|>ꪘF/z|~eXG!XFukN %k /(FKO׹ULǽ1.GyIrCf`J s$?Z ,V||n. yJqr~An}x{IsLȧ׬L{xQO.Y}WdP~0F*@śԺ.R'eJu٢,Ce1HcXAGoe `@9 oA5ɎV[j.[aэ$!ds Pp9`uc*<xF[0(F2LHRnsq"xϖgDiz@"rD/G&ϋ,Y65+zהHt|xo^"~f\tV+M5,!j",|g>٭{Nd'κF>9N$eVBR'r/#3` \wa V''WD{&َ$Hrt$XUtG 5ۓ[*K$$c>g%[qlҒk?NZ2x-cO$c.߭MA<'%ID2@F%pd0#~Hd= Dc `,N2Q'!Bӻ B[ 2t4n6u߻G޴2?'4t&FT-Lu٭  [kȇ7`ܴ#kMȾd|xR`m-ٔ"kaESc 5VÏJwtm6Pc`Gyo$1KARHXH?D4S"I $ToWm$'y$PUZ65U=P~t0&5B?sŠ#$#G6'sb283O#*xI:Qs?d%mYPB,phc!hcR= 9f+$Kw4TqG!XYf59;dՏ;>ɿ dCPdS *En2'yH$\ܨq28CQFvȧ%|Z&); m@3cdgGF£fl >/1„b9`h:g.4 MZNdd r|1`xjÞqOZoTq(7Vky?)N 6N7 K$3(1\f|8SX*Eg-YM#˝Hc]Æ4:,w~D:[O!S2a"f"xzfN}[&p}{.fM]4w1XtQ Ї񳣏 oM:}\Tpa2~I~CTpGuHpc_rNHopbEp \# 1xo6N*JEi?L%=fJԬ: *I%r}z9$r Df;1HǨUBrў,@&&X5Jt.Sج!6&2Tf8ǂ=j3H`] IWCa+TfRfeH&W~=[U_]7t4%_KVhtܶJC2a%.vtU=y" x3jܷsM,55uzt ]bH^<7d3m;~|9 OrzaD'YnU(Ԧ O[]D]6eHrhܗ{*w19oV"{NB96?)tUI*qB`r\ޗHW]P橡elB&bUcI ʎ,xe0؝ ^H1L S{/7ؠ f%W`vdWn?1veic!HYt@ Zl`߷>F^w AvQCv&oSEvSc(fA OW}gǓv4vH"&?R-z}9RۍBh2?m@j|GN%B)YoԸfDVZ$6$۵MK1kȕJH%fJrKU.UmȜEI~;Ǭc,7?Iz;WrԸgqoV{%zb5.6I]D3$׉>*>3ӼT,7Y@2% 2y$D. TryJ~jU1 u/,U,?uDPp.BLb(^p{:wy)&K'lV ֪8p)&[.Jj2>D֣Bc=q"*b?Y΋gÄD8Źp#<%3תUݫ4Լ`{9~Q"ǝ{֢v!͎u߿D*.WހZ.>/ٽɦ-5WW9%.!.Əi ͱauYve&Hrq\^Hgil\Jt,e3=GfR@lpfKkJaP'Ҳ/ph]hQ59ɍQCpr# eO`RYye,v跨=djAۙ|woΒEf]J<+D(I]¤Xf_[6Jx a$/nv^kQCHNN7dw(i(w,BF bc =U#Td+UHw@sԄw󩷈zw4(F/ƺARy;JVI<P* H>;xuYx߽_Q-MTWO# yAo˒\u^zS: pJ툰eJI c&Q|,zKfbEus v۲J[ڃv-x\jO$lIS}H+"D{;䓶o(g?&eTRPK$'^P KgmH#va0ʹcX*ѵ=$TYOS(J%J 0ў{>ߜ⺇avAηq9ad~ lu_)c:vV5$̙H)W|Z Z/*0 'f^M)VOHMT$:@hQ8hv_vK>Qa$ŦZ1뾆A|<;ej{hQ'dV k2ҢlA||J"{Bl)Iٶkg"HO}e\ު2Kͭ&eh%֤7gOZ 0dvФ xˎk躯JݎcD-LDJ_%8wѪ@I NCԳȮ: 磋VDP ̒=~H_}Hn'3S }+|ǎ#(,F0]uW%¹,:J:MG涏 h~֫`W\,ImYb lf@ob#RУl*J~py©$aR5Y45漌q$0jզ_@TФlZp%É`!bC$r!t)w,V$m+'Cl܊cy BzWӵ2A{}V>qѹ(NcU@1>~7u$gav{2':qX. ݛ a!dU{ mUxo rݧ}O\7wm{r}k$2QJHNW}N(LFs9y[#p墼Y^tTM(QU9 /CF oD,Kn$wd.3S,?!CMl"<@џX9$IA1lw?!ujOښɢ=?B3!$S+0dD^5e֜Hs@S~H_9Y-[U^rMd <<oc~B qdy/@M;n LK*6#yXhң Z4G}G8u!Q擰U)Dp6jV{90m KN}̬L(YDz&/ B@.%Usۿ!%YV E#Tb@P+.#>$&ң(JFwmU*E&7G L//xljz@lary't5tb-iy o2!129O}I1Մ)D@WDt1 QQq dt"A[x٬m!i- ՖpnZN͜?㦺h#kz}ӳ^"Ƿ4wЏ' +w HigB!dQ*ٱps_fhf8}s3 ԾQvjr 8N!=iڃj5WVs IS( J$B4$BbV9Dn,N0iG/ ]] ] ՝6P?0X)m\2VYIj?6 `SyL\~R>}̩r_$W2DZ5H[%2!44ALgΝL3ޏ]I Sbxk.C@fr+Ds@ c,L-!If۹~zٔ]xfHE|&g߳9t) XSr7$jABJ1hSu/7w L5\i̒Wz2`ےHOT9{jvB^4B P`N.݋upq~jQ (dM:{}{!q#0l$S"|tܒHj;*J{kT^zDU&N"잖}j~ӯ-ХÀUٴM]_Ozw2t+KevML$AR)D"E|j̮?j'A}D#|JΠ+jEU>Pe DUղصm؎-z)\ՋEq 3H%hLv o gi'msio0ZCt*CAY RWdn(]T1%WK|M̧~њs䳻;U$} gwV仯iDe&8{NbA梈E!uYﮬO) C05q3Ǜ+kbTb L"G8QU+E?% AZLe)UǶIt*L4,Kc9j'ٕHܖB͊VzxJdI ٕQM ky[cu4}?R(Tt -}>/Y=vDOB:w3G<|+V:z;}8j/+'Iɫ,%Zݜ|aAdfBx:*үjw:Xgwǘfza;  - dv19YغW,eIQ;\ kjXe_[a"DF}&..5-+C5YkP7eN}gE!ҾMWJgeJB+x?m,050't=֗Rߑ]m"}ODe5I~lvyY܊wۿt3Ϭ]y]gLCwcE{ۼ˘gJ\^m^zSu/?h|^D7eȅ|: y?VI2Qr;4vOA9DgѳlΣea1beY.+@/ZA\ wҥ KIe  (OBҽ3>ij52*[\i<^i%y&( \60M@YZƬz6˸sSWSn>?g2RJdUYYJ6bn٤s( P/N}RKݫS5aͅGHGP8`M+|2gz%+o6\~? ʏYc]z?-hSe/PRMa(%`U!v8nAgyjI|i;? $,͇oX}YZ٫dx=;2^$#OY6-Fά;*gQUݯ^]E,| $kU[[C :ҽh[.*gZQ\ ˟b&.t8_9pdל-d,:]k lBd~0 3 ud-}.=&ԎTunVFz2f|j o._snNs\)]9Iu`aL:HUV0.O9^)]<響8Y8|w{^C7fC:$+ wY!=\$B;,Pşsz9^hSHF&@۵IXfݟMB)Pg X0wrh\6͡s]{`;Ibkp9`2".;S$ZޝphT$XaN | oX|v rɺnB"л @a'}9YqX%Ҵy|wyQ{Zy 6?|uPt6RZO)*yLN cPI!U}u; Po]vcBKyH?R>!Hw'u5IC>~==OZv9h`) 4؇$ 5zK5&Yh2S`a }Q^S<3ױ.O7],|!Dл'.ctiHS'캲9_%ȫ@T|A|MLKкsK)%$`yToPD"d3[$+6m@B]JJ0E'D\6HYϛ]R"ݍSJһLdYˠ=l,_\COCdNIzO>MIBvzREuoFɤ'sk(0 ӕfA?s݌+Ѳ}hdc%ֱ,7Y5#׶Ƞ՞3qZJz+I5%r6jͺ[M˯=K?eiV0PC/VŠdIkRאoqYۖ=>WF$ύ<7CH=ǹ\I7+ /XqFܗkUt^ݢ-9@S-8y> nap~] ;dhB;f5T"|Jq&p|8YkJLmjtஊN_ؖes5t"n5jnIŐtiY6ݫsRǕ:ߣ]Qלt,5g_~ռu%J/P%|+~lՂ(>kTZP{7xe wzYKϲue=` 2N"5^r{H~ [JzS%.9NOPi\ړ|k"2΂Ҕ ]"@>c)Drq'է "u঴M\`N!Խl=kvSkt;z߿*eZhci:^⫇j E[>h՗al-~j3XƠqQ}.D`:ݜ{4-6:Qz!^ɕ'бs%We,^ kْbQt-n"XĂ@W zWe_ѵl~4uX=2+߈SD!SrNF?$F;B6eV*ߝUJ,2ݥH#ygd._+&>]^:<QEj]s4,ZH^‰pA CˠC+*GϲlԀdVՀ0XBfV-#S2j FZ`.|Wõ`eآgj2,C2X_Sg٧XwK-i"o ,ϽBORlHdRRfGӲp{!ȩJ:pB L@: (7?pzSe):Ўje`7g8p"aFSpYjo.V)kU J9'` ;} CƉ.5BXU~">`6ėAf>Tz^f =:jՊXYٴj"S n"C8cO|J]_B]nwt+˪BTfz 8rKrs z$ z.t,Hk9U۶pDP'AqMkr A~Z_euU41@! zIo٤rl!.6 t5nn7|Bڤz߇\YA$3HJ%@P-A!P4/$&ûSv/û[)*JH Eᆔ.}n0ݑ4*[vVvUn"wVuj)J-s0]Z߯_N߲?.]$ne;VH{BdsҫwZ^?-9 ` ۵#|[vCUq@ʸ̅xևhBmw7f .T1u_z#F}DXVl*'2Hd=zjtܙn>4)N @!|xytq/ӤWM_A O16YFL>EniBMhy#7^PIHͱp;ŪݱODYc{ZD*^Uڔȁ+̵s̭)D|Ze$?b (Mn' v#"YI8pY)1e}o4zq܍mUו$wA;e+O7Ir4OVSy"r p Q9lAREJ@ą#D.Yy{=k bO:"nN4/Oj"tj@Nnj2敹k Ū5{ɄV2^=K%TayQ5K^I1nAB1&>bjȣ&e&=\nRʍ&/PaLWȪ:cRMbปYw;~- N;\徢V[thMXCT7HȴjLHE,tM?%{Զ$ USe=jZ!ӞT&2׿E C[y(-%!X+־g 0PO"Kgh,?"N3퉲YMOsj]:Zo VǺ:%CZ,ݩ]sAFsKA`ybACY^ ,pݽGs#Pb3D8U8wHYRo1/ϛDٵ{![lz0/2mtCHtgZmU +jxZ2.Au.1ziT 9z^ FWU؞tmy.[nAzCuIò'K֨cz]Ap2IU]szeEEòc5ŧұ &d}X$0mj5i؟JvB- *E\ʀ ^mmmLNmiZf&1Dnmaj۽qZNw&lD:{hmx^ڏ &Sl{YR]&23ŝwb<'MDSRK.Ln:IrSmOee L jHƍe ;{8:l~gҤH.rn!Rs"z8r`aY}փԚo߈Ij*lkLbOˉWOvsY+.!]ٷGvQCu剀F"R1/LϾ0(8 ^`}| Ҷzϳ  "[fY `r[U my=Pl0IvHY!^>7(׽:޽7(۽)B$5Ɇ,NCI:t- kLе,?e yO(;bX?lwN18 [;xZ{}V`/os_|ͦU|PUBۨ{ J͙JL'ꙴ^ܴBx;݉{θx W\= t+M'7@tcD7ڸUO?);30ĖY0?T'iP7e|/{sY/Ȟc"tLYiF'&SJͶvoRK$&"7*:sءn1ve&ݳ9YmdS@"oqVQ>@on4&7bs-n>g"L>i&m^b˃expv>e?U1RbmVKdMF‰VAӲμh!'M$XCO\=X ],˶z eZ>&S}KdⲨHqNw$J3j$x ɝE.\& *0dQ27*)`{Bz/Wq 8K \^m0rYDPÿ0pѓioK`ZY" aYudG2*b'ٽZ6헶eo^PѦqҀ0hƒ3i>->Ex^m)1D HB }ެ&77%r?%ݭh%#4$Ydq.Iχ.Q07_}8[Z"I+K[_<,K|6%2K3w̘Lknq_u%}oݳ^bŝLn5H y-k2I1r9ppU 8`DpZ=wL#xh~ ص/U:dKzVs}vǕ0<7b7}/%?^9 De?9UjY3Z]M:l?uOXW7>Ď$ܟ  գ[mc{:h֫[֭Pɦae=DSU5WA݀_# x&%z}R+|̬<} : L댑VM1 m˺Gײ} uuEk?pGˣkYޛoT,+p^Gϲ~u-Mofm?~R|o:!Qq]+p/x^Q۵o$]b{lto__cm~K,wd;4ɾsre^?V&4/XzZWr}SOEixdQ' kr6h~%*2Li+'q04/0̰j,ت.-n &/<^f$_Ob>U{imK{ZM(7:Rut+B▂DTew Ӣ/<+DBMɅE^cPe@ m}/?W ^e]H,cHZ%YؖxDD !"5EBR%gKY@ Qy ]j~pauHK$9VGx`V/}"p Iwf*OKY"lYڎo\a)ڔBD0=&I {yj?)O[Da9C<#.Z J<֘]&Gw>xSh'O>SV"Ks=S"xv7H.$^v\1:@Y!rB#A*3<;UZ<;Kiug״/Iɿ!ذqDYѽFnV/E~X#סC$wN6RHOP09N{0.QJS:\Т45z=!A*B2tLֱa"Ż .o!)-GږEǠG<ʥ* xip"XMuM#wWUCz$@DP@J)ݪJ>Zi@&YA25:d5O=u*ρicTD²{YBQvѣ .ͷd?- ɶMX0aӏ;V' !` m&_D26~6( d.QI :P>-HMd"nȋ:5πM+\jP$KimeG5'&w~v$}$}v5%3}]"PHj"Aѯ}u@Dy=IgGE"T\.āX='KlhﳔKO2 _c6~t55"͚&?G# U ,w|ٸ7]oWYLndžt&Im5R5(HN/'ȶ5 ~t:|ҋl=%"ISӤY?GXTUtYWa:->gʤ}4|p?V4%Y @GrN[.Iqɿ+Mɥt\rMNK2^ r,`r^(6/%+=3)VQ>"VL ci ~d[n&r}ONdE"!Dn}(U*3Y+n #J؊H[ 򩝧ڹD`M. MNP>s?nKvl| IW۠)/ Z: %?\*[TKx锺PJd#x7p>k[,Kڐ僫=.;^=',˅l '_"V~twMr?Fz~ubiSR5>t!K JёCK!QܖCishCvB%$X5COyPG6?[٢ʺa}g{H*b;*P cwkoyrf= ;ȏ%?%pvCUA /u6l.Od5hEGZ ` qVd.̲lDH֫2W9w+Ӊ,Sm˵>" W&|Ѷ>fdB}]zaUC#m m8"K!\;5xnyI&?"[w7}$0~f4r4ZLF<#wRebNmW KvOȣx|-! =䣃o낭]d@7?]7 Dn5G 6/HhjUp_Chs"זD!3:ƑN/6GW$x:$>_i"a|x?Ad^!׆ ZF y:eh!<AlN>VMi &&dF lޠMR Y֬**%T}e^De/`Y[_1 l`3c5>ogsӷ, YVzd& Z [[F cw%DmF6l-)Td?D`ڥ8R B BsV_@LnږD8$d Dֻ>tLz9 r0bTyLf 3HezTߘ`iN@C:eI$ He/ $*|S>@"K?j,b$} tƋ) cdЄ WF=@r3yg-.dp 2Bm[AwOBRP"f  ;~ suz7l@*9 +/Lae" TJwV+{L丗ށ$pא؅uIߊ5?Bƫf;:;* gML͢-Y73|IIE lEZbn;kG@q| ;tGw"iG!T ɳDSt]EOsЃ, A,-ףIӅ,V-N]Ω! Krn/9Z ڐ%}; (0/7]Z`І,mm=+ r0{W{tGs8c4[O`O\S!~y Jc%cKz5w ZCCp2vg̀`|iRY H揊{䲀?Q4h Ypz sҭz&Csdk*AtR AķX.őUn_' 8ao{vCRo0j:iBp]*%G`~ 49p‚~SŤ $#$DX|?Ǔd__d{B2H^)ɍ=^MzGd%LzaW y1Y&F0dۚ z2!9Չt@ .=SK{YD|Etw-R0kTyH~eFk3ݞ2G[@NgpHj ~YZz/q"bInKm,0a+SҬ1}I &d*2 dLؚW-U.d+ʅlt"W #~Fa{' y )oZNՕoSEN޵]-I C eߦ?h~\%[HG@=v \ck@AgBkO&mVӢsM8iw^N *!Zunm0HmH6.d87 Z/bc{:_1@ѬU^,>9B9B݇wv+G%FhmFNQHŭrWT[t#JY ~0ԣ~Dd[!~Zf`^uXt߄h?f= GXOo8n~zyH,LS)`r~t> r/QzaiA,l :.QhwR=l^GKqZ縶EG^L!7xqA3ލ 6jB"ڍuI n׺ 5v+OSۻ[۽uQHgK*g !;Ѯ6 67j,tYr(5L% B<}[`btE?p8zGsrtBkW_ߚ v*4m v|<]sOM{^s/ {ѡE@`ѲF^ e$T eozha1;w,M1̯RC`V2_߿ Ukѱ.n܇3֒r7mГO|},y;~, Ow:lmiv:nwРu (΀PIp'Mc:׿%BGkgBU>xdOA,DK0/-/x=1u%d(Mc~e@v¯ Ȝ"A?}+x9\u39 ei>QmOfLtZyәG[1yz呚ê W ݯiydu.1Bmk pG9\Vb*!(>Ɗ -WH In8}7'#hԷJ?nvYVgʦA,]_U[0v}=vۀӮ nL[f-z8*Ω"9=(h@6{Bbv|Y4!rR5ix>Ic EȧHя&-:nN@j.9\4/r{T5#x;[=#m.}};{)myG̓_wtD;sil'<z=Ke c77w"ee U꘢XЫy'c'W)k3k7+‹ߤsWuN-M.]R7.dY}| >5U6duOB߈\4H^Sܲ!$QFýrK2H:+¥ 槵,Lr&ղ➊S9ras-:t;.iذNW>sGn=#/ 'z|$\;.Ǘ$3 Y п񟢗0lKv!םu]R?%ऱI,l> F;iR$ ] %o5S_2aWFc}onH}X/ꐍGnXs Ubݳ~0zv9}lwrьlYBUыlʋ\`\V9dXG/\[E6ܦ_l^dud{~,N=:k,S*оAbG'2H -^!ugH32F@ ])~%p-}ZyS\P2VNfGȪ$b!$^/*cr}sw;oHvk}AˍM-Ɇ]|z0KUc+Ή8wq+:NdPD@[pJw\F4"K9Z>2J#%= s.΢3: N*>ze'a3r~~AW @3JWnd3V5fo޳"[f_y)3+3j< ):5Og g!{6e\s]ti|D\6']^רu٫L"Kj |O.Z${NPMN12$v^UN?'N@v$PB"K]H3Vk]?jt鞾twRjk($fA.X%SZw]@!tS6.m>1ȟ#/[+nMfaNi['ܘB@J0~?z/Pg/r!ēx4#CaVY"pj ܻ=T NLX}VJ&iHl[ɤ*M=ݪt'PnNqZ$$Byp1WL 6;ݒqЫU>wڕ򅭔+߲%[:dYL|LI .RTHbiuӔ %G!jO hZYMS2(Y!P(Id[ːXҩND(npCP.*)ɭJIҩͽ*>|Ve׏ȪJWyʮU} G+_d5 `r]*:@n ,]_oPv}0BHWZ|p(Be% nȧ$m_9 IۨNPF%MۙzP@wd'@sң[#$Hޡ+'׌DPj鳃ݫv| t.HOZe0Tr_&j-N5[%!2J~'^jc/6O'w5ogc/ޯ#.Bh;nd9t#klKmHWEtnAro*4#Ro.̚υ8^nڑ}0 ne<$ҟTLL2t\s݊.v96mi"գ;oO2AI5Y4|JAvgX.|+!`ﰲTո?~;!+S_qQ4A|Eǟjp^?<kg1$>$k+ܳ$D}YizaܛEAplj%v&{3ҮYBq6G(vhB#^䠖}?Zߣ<M l$9ABc~L8\q٣rϫ̰ 7<Ԃ٣v=F:uj:lm=}"rV;׏Mg@#6 }޿=OU_$mS~c@_8T4S4RCBNFchz0FchJs ڡA\ KKgEeH)[gGkF-ٖcR:>W]K0{;F'ʍ>1ʍw-9cTfЍI,}E]V/^)GlB;!f54#:nf0sNF;v,GP؞IAHÄz6_VѰG_n"GЌ E*TQ e*D^>؉,Snz#6`W׹:j~Б3;LgYf؊_i(Ah$pY3k,/$(iFU˩ҭ}N?)T8

 @پHD`Æd`"Id{f v ?\ů5+289ߡaW8qv%CI@n)KfNN8Fh}c6%C1n;g9ڙu} f{̞Ǭ߄ħAٞ'*goPؾY +lKk,a9נ-{Ֆltfn%iՖlZmɖSo%[An%3x%a_22n%/X}bzS&WV L˸ L]nMoC&: Nʗ\|3K{qE$žI|D~Pr"`bB,V5q2ADY90v[~M"u̘ 26sUg`!OÏ Vr2qBzU}_ǵ dXmK\"E:A෣Ş9&z,݄ZAՒ%jz: VK'b}'I>b,)%wBAE] 'Gt}" ,~[%FCD.@\$Wd h)7Aswdtgl^isk/;Z~&J7+&u]?7q`ʿ{4Mr{%P~ I.m ?J^a8)T",Օ)U* eJ$;klKV@i{!8~_ ےeniBVB]D"H2ڦ9}fr$U&¾-:'-) I-_* lSzcC5;}WDзi0F RɱrDeGn$ϓk+4;lu#ٽw֙Җ?3+ޖ%&f"0zT]7$߷3& !ӝ=5,еpٍF;tj52S)Y3. D^ Z +e'7SDOXZDP R&xy֍=־eoD: tJd{'Y=хt?[ݰ'T=.JleG숭EɎdĎdsV~R5+ ݺ[{ Yojd-Lu$ :_LN+ȾmЅ OݧWy(Qa" >Lh%ѝ ѝ6i 5mHt)[FO3r`ܒ&ыwt'4[SOzȴT݂0Eӟ$D"K6xA۷܄TG"DzI ʬqFfe֙jjGS=9f71vr =$=4't<:>'4ֿ| }_:!q9-u=nT}"(s IoI{|bJ36Tr"NS^S}R&"|OAv'K6ƺU!p6D v'˪s t&GU%9 %Bt;Ye %7wPTH%=C":Z]5iiM'rhu \IU] ({W"43NU~((p~a_ʉ˴X]Lr؅ȡm|Py"/Fq Jz#]УWbAg"|)-84V.A+ tDBf:V%KΜ54 ))~_YUFҙR3,Vs궕@OLƎ.x؋l#䇽uvOB b=U^'Gr{ l hs!n囱UT#LOZ$Kޅ 'dNr7XAMT--0 ^/^ˊRs*1mTxmB4BQiYa`{5%^ٚNV9T{$ ;߾O U[ZhjҷwHn?n\ɍmk)hxdHUw.>p97v}v@lW8`ɭA _,U8H%Ƭ4L_@FBPqQA6(N"dˢ0;Fvz$ȟX&ҫdYM5Oy65磐=&#y<ԓ J8Dv Me4n5hxXHyOuD_>UB퉴XFr;7"_6Q>IUID R@675,oɠ&dCBVc*4KZ#c"Qk!%lQ~YuldQ}"Б]%JG#iUR ZՄ-&4d;2H<؍l?j,ȺlQRcO7c.t: SEUOO$C<~lFA*l%ro[d^d1ߟWSHk1Ş$2hQYR l5iGSyRK w|^Z$^5o><ߢFo&E: DȥLurmBt.(\"=}:ZF~0$.KEmkQ96ܟjmFBL ,B_WD#cBΗPL:2{[ҳ_q5'JOv_ZDe;UKK??[}!F/}RD@.рHJ9#x&V$K&|Ml5r@n>:>=ihP:ۑzHZ?+dg~dyُ,-WY~d=J:=b!w8EG*(y%N:%I֚N;]VdN_TvP o"GGl }A@/AGK泼؊, ;[$Vdӕm|]μȦQk%NJn&j4,54͟}mo)}INυ3 !u(fQ+~'_ňA?E-Q; @=(75 BR'yU!`"GAV{BL}E;Iڡ7 UT!DZXDPt+#uH#`#`B@`#8ZJ1<ߚћڽG %l6M (!r1x P)۷=QvFჷY> =}o6ymTB@F;&f[TQ53},ny#8 %ukf=+JVdvadˇSH;ي,Ǐ%x,@d"! IΧ T'WޞHL?V0يlwc"8HU"0Q&R?<]ԉRr5ܽCOfj,{RN!$3$ IaWoά(o9%oWO"+2*f"q*F .x'v .H"uD/ALLIcN~{?n:E=!ݦJP@X"GWY6nM3j`TK>r7~e0mPF(R /"w*w|A=tA~䟤4DmE a$G ATDPtϪ:go[2]Y=1ϧ'tֆ0oGq_2q䚳"|jFZd[*6Ȥ᣺oyTD74XȘM0͈-wo۝SRWKlDHSb]LRЦ}%\d c]`Sux>$W*L"9rFP(]aפ.evM { b]¾U*&ȀcL;/ؤ3}e<#&IAwHFj(8'#|@>*T7&ҰORۑFyS7ZHPbPnK(S%&B#ҸHYKqeWJ8Q\ga#][:HE4c6rA9|QT(PhS ݙ/|>jX>CQٙl ҹ_ǂtWj(` DH),IwC3bUg"V1CnGdHRL%m_RlVQŭ<*f b(PoyA@*"؜ ?6'$4NmK38F͂~wm,upgw*v&P;JCȁ]m9d O&<;-Ch3H'n3؛,tߌPH6*]FT&`/F0_Q/+k ܧi=Ry*ΐtj$[ں*8Cu&: @9&:IE{.,M=>r Af'ezȼ;{Oc=[p[wu?9P_d֧fvn?S=I`ȥ#5ǀoM`Մ%U0H`Xy! PC;/QQI:`Xi?k0dz速`ٙ%IzF<Ӓ$ϧuޒ!jfEe11&AP fnbPi]7Qp!ѝBXyv6C39%Nܔ,Y*q 7ӘDr!ϝdN9C{:|HtLISD hzp`ޟ#<9BrLE2a`#^OfHɎQ]buE5CMO9C@Im~%&&Ɛ#TL̈(->V@P!PE?lR-ٺ>5_%[#\-wzQR>U} Yu:mTLp^nLm>6=R [MDነ\%nʗ>1׮TMD`Mr;R =uB.K{Ko'SJP-{־%wF38@JI~K;UDV}AQd[j#!J!$2IULwK8yK乓N-sKR—I2Ӵ,]$OE~vԛ+.r%+*Zh `_-@M5w]NM3ٜjv]/zwI'f]vRkoR5]hOI4OoReEʤx #>*-%fd۰?YeП<6f⼦ayR`It=F"9zy֗){ \o]:l4t/o pK9!av"HzQ(vΈ?*:rfYDnIz;AyJ>42V13u1*/V{ʚP?fMQW1ma2rCH/q]toDPD+]gFUtu^S"6+HxCHkvm!@@ ]Nh"u^U ,H (:|8pFƻ*wxQ~JX ]']lp@z'7HuZB2'`7lH)|G/U.P^ȇ\}4U(۹ e(be憎 şWQ05V_%:% DyP&pfn`RE/$ p' @n "$ux&\O$&/ϫ QAZԵa%]5Y&U"e&HߍdZ |̳]XUK$;:dy㻲d'ϔt礆@cGGq]7Lyɠk !ln wQ@͵;}Pv~^Kw?{PtLBDNS:X,U#nT(gcL"µdv5`sDv(4hS/aRbRSۧuv){c%Il:۔MNQA`AVʰ1MH+~&ӹr-P^"~&"Dμ۔U)d6VDPp)ŸH ]!pU ߽%{/ RfM3(sCM*}5mWр=oHyL!t,U(ZDz0?4DФF?SA@.JIϝfU]#$EINa‹ЉHaVsW}^ZH.:<,٨lEA#njmvE7C&rWD`(pS,n \'O%wv|J-(ӫ鉔",Ggy畦Y!%ئ,g.2Dـ ݝ_cUeUJPU'۽" mDp˙<$[v Fu!v]Fi\B%7;HviejA;oPݖ&ҪBze5w_oȣn'x&BxNK[ ߽\?0xmW դ8FSD#3h=lSj *ߗ6aT} -U==KVtM?sP94>M, d~OW:Mv(fc ;ӓ}>*n#*jz9&KD%4Qy l>R7VLdW PnfzΊi5&YxL{PʿD^n2KڟYT OY $zYY>WD ʽY(L4m̡~5U&۔eg6eqD &2+-,d7Jo) [GU٥C#۔͗%H4٧,50V:7~L ̦ZlTqIl)HzS}| h}2T>db`lN&%ɕdFua)X];M^k\"78T zgeC;O^ELj෻pVFr#(MM ?/2Iso5JO)sq[`~\_HnWDPH/bS&RMyl_sJSآ>\75VRkJEJVҿrA9&'ä(hv} J(/I T@rzPVe m35xs RiQ(Pvekx-]aqp4Y[WE(t|AękT9c1Ji0d,$’-O`i~"j9Q:ں煠_נ)]Y`]=f7,{!ZEuoOTޞEuݢ> y9Rډ\S]TD)54S 0pՖ)Psxe|^ϿᠺO5i&wϤ _:]At)($X6^{^QAV@P-CuDԡ@вdadd&[+(Sk^ѐrR@ZeΡ[G8mI߄6޳"]Y)ͬ3Eo,[n>7MJu` K,&םumTw &Ս9?Q0 \*2Jr _v{2|p٤ {a=Iu& !On$p*@I!WrmF5VfuH Q6'=F|ͮeӅ`9 ilzq0c_flkr`{M[lZ$ٱ,'Vib3#0Z +?˲~{'+G+cѪpyCG0%]/t,{5&hd5BE fqD Tɫh}^^}5~q;; %qJ}?1]B:Fݏ3Dwa(iĨRZ'~ BQҗ"ᢽuϛb]'1Q5i>ڭC,Z$ޢصml\s+sVKDiJd4G°D8 |K5|e͇9rer]nRw1 m˯ŐխUp0]8I>"Fڢ]\c`5k3 &II QSsDiWlX |7`2$4]!HwiDWA qqlYLYl`2ٷ$ث~:(PF>HteAM 'эZi`_7ܨBPqU,ύ"Gnv Ҏ?^3b Y@URJ߇K+Ofz.o;fBDK"9v4 uUyJ-Mө'WRy:*;TIdGĒPZtTl;L\w{ح,ڔh8酎 J4lxd{rAwԔVM &PI ͵?O,{2Y>eYAߍIuz*Bb([@9ܟC;S? \ܒEoȫ|ҧleQ `P-618o/7P%,(]'JWeNTw@#_Ym"*uPL=F@W?bUK`g&Sq|OS beWPɓ?lU6Fa|]S1Fx`ejW8TMtK6]]Sۖ*%\/T*bͅ@ڟmT*=TTͅPeR ҙ&_fUYƷZ O[܆37BX;8l^U΂^ۙN_+n|-OIzрKvn9vYKr; 2G΂eADyȷEum>ɉ +\pڿW2fɔf*0y!ymNX8A;sMG\'/vOVB.U<0k623\%,3oEL tAGnkXXfrχg}(QnRɪdN @W6T$bd!#Y ?wb*r~ZZcQ y\o ˆ9D!z<. Q5IFђMO_HG_!1<5&Ʃ5&giHLf Zt!-f+ QOkhO@A2x9{il ڪcc@x.HL$*LV#>ρ^bRϟO3DpܷD(PWDfr,sݨyϮ Zڹ6\߄vQ]AR'6RPRaLEpdL"@Bn*֝@_eʾU_%] }l%DH!N]˦Ʈeϒi R"\?QB"GmYAvRؠ\ƮeQkGYR0ûh%WuwUţͿ]Аa6]! L>퉶RQ |ͪs~e)~rkgj%v^%vw!ŝZ)CZ}EL"b%ŝ]?9G.t_ߍvG>F#紝(||J>' <(2m[ -kOBaI?*<LZ!+Z3%FTw/s}* ]偊}"i S_e/U!۟۞pS(`Ywoɶe2T(C&#uwS"SxjH% W%nGDPa0Y`N{(__Ĝ9H>@v?נtzNa:,pMq~uJI~Rz y\0yee;?LU"uؠBjFAS1t.n}v~FYgcbg r:ߟ4Ugyz5fY\ta^U˹L{۹$&ksPe@4r&w^]˚dى lZzu->tx-!(Y~7+ HqW۲DG"JWewU߲+odj hgӴlƺoٰQ߲^}"-SےDF0+ߙ6LdӁ?̑x۫qٰuո馉nYN;' 4;mg÷~,ܯDuhdT@V1D%^@Qڜ~eLYK*bU|&R{4I{1rǜ~Yhc"9vfO!Yaiڎi3tO(0(uφd]z="vzTYD&1|H{XaJݑ,PeHȅeoD $Y<*8  樳eF5,cՃBP2KXvL#%e. IX;[,ȮωFn9ף5/~eҞ3(uG,_wl7[N"9vYi9~Uf/鞡_txunLoINƔx']Hmtk d .nnLFQK,ݴ5.LZ,CU.66EoR] `_ `6A6)v'ڱ/3ح,k>PLHؖvemZ>GSA2 f^J][s$N$iEIx??zlX<&>-(HVR"筵:~>uX'ͳ*lZc?Wj^4dLcgkM+˔b '(+k=n9s*o݆3]SYYXe&'Y,U.լwFj[eξ APT+D -o7ۻ:;"U@o mBNj%XT-I^`0Imx>}P ::.6,C%D 4MjX6U*ŰH*:9)2bx|d t 5'V<{- ɡn>ݵ f10-bMnwJ4$=]e(Pou,&C7%$ Pbh"!b&vr& X= @k_,tG'-M ( I Sa@e%02EGa/!HpD6#$j/6,jz0qf:RB-˹̒JMY{ dtXvB jJ$@j$@l$@>Lo%$>;M)A\ܔg 7Jϑ.t˚lJm7(z~]N`4FmGovgKBDӼT'Tw%Z%[) Q+xKnnR _m*36Һ%F]JtT{"GL#{)4կ,veed(iհlIbIsVòհ{հ ֮eMAòGʿDHfI{p:Cmv,kǬfDzwve*K0>[@6ʻ7 *wH[kO$ǭ}Vo/9lrϻojI$Go$_$Tg?,|j!%N$;o$b0 U^"8IkF<}X39I1}H_24ح5V\neFYXI`ԃGxzO+ʲ7{^eɼ%Qh{uzfЏ $XX=6YO8殪%=H&PKD.lU֦ $4i[[GVe{seK:EmLZbT11`L䀣 r.qi)*X5okȃ7w1Ak@>NވrH̷ 2QIƉQm$fuT!>iY~R(H맀OP枑K}=-BFNen`0 &LlnFڰ2'=G+:ث, *{X8e95ثyyu;soPXg_9G* 㷇ß۟JϿx1o_zWh*+TE|Iu"!Vo%{U9| ?W=|ϟO_o)Ͽ+ f~?3߿{f<㟓P?ϓOݿ7#cM`[߸(%>0ӋOy/z|JbuU!]Us[[I[D 3;x~%F>AD֫zwwę ,d?N\Wׄ"vyZϞb¯?y~N[?뛅ϑӿ5[ VR%"6Y/W8jCߐ=14A}s7}w|@~~h!cs#r.2?$k0F_+ztE| ; ;s*υ>玍O#)[H*-@z!@~C2z ‘$سr~7U}S͹vQ9@`~f C# HAB~߈g}4Rkp8 G*[G=8Bi@~~H>`S8?'\_+:u{ْrʗD~D@5%F}|ou {?뗅<蹕__7G|dw9<',?vy4Z>Z&n@?]O 2AG5D !>f槬o3yCF~~'Ux9/&opb$ϕ?roOÁUn]I9b?9pBRk<^H;ȯ7,,7f@Mf{9ۍлlH!~ʟ8=ݩ9!!rM-sJ^$SrwHҜ ^>W(v,GBhd0j5Qr𝊔JQV19A[p|SnjOk2 !b6$77hF \7e7S3wh3: 1e9>~ݴeoSMۅ?I]{5_C/p)k95Aexd#Bǭy,{B-sۢ]<+'f"f-F1M/5N[2svxL۴Vq҄hڂF5g O]Fqt -h@h9V(-ZX5k:6X`ֱY9=IzPK(5wrNqLȁlbW$^>[QEjwl# V˶ ك6X#3Ի9X?P kF F@v2!Ygz+Vfqj:,טv$8׌Eig[4OhN -oչݩͽnkFpWKGk#/lg8[2K`rW[Mn;r0d)7}m|W80 3N:# `d郈'<*"1 30e)k,/:b3x_Fomϔ]K? MRro{}9%~fѡhj!vh1"j?9nI]CHW=z` #Zp.l";rM0 ˿|/K m~6>ePF=#pL$_PtvMɆ0-Mi^ʒ_[K;y|ʧtIzJm'..[NMx3)׹49.S,2xvGE5m%}BcR(Acw O8'1I fAשCE4AVa$1*t>0Ew4ZG:O:Sltǘ"΢6e3t` )Hh^;CΏ?_o:uĩ":$^$3$ϵ )b.#a fNa͇TaS[0/:hPmv_ PmCt ~N6,kEs/ZEKQ,t`:Q,Pr'+-7i2RY ˭2>[ĽD(6;c371S(Q9ʋ6xcrn 0ܐ2o5$SDEIF,m\G~Vh0\: PksҧLjC؆G%5k?F-2nEŭe_D $]3.IoJTߛ"w0GgnܖyuO 52E"PU;\VXf/zw#K[HՄ)!4z%gȒ#rYҰ LoHY(RQxNɒwR) SS~=$W{v;'Sispu*o>G9Ep |C;)=f? |ICnyvtx&c>Lnl-ʎXGy.ƕ;0 ?D2I~R%+΢elmse" H5qBHL::?.n;Lt皤;L>;]D=]MTzvwlnٕ"R&ŊSY2,eڰ|'ȍy\pW{8)ĉ-|?{8eup$ضr*C.p,1}._Fck?H,y C6sIFq.׆:~@T)όͦE=5?G> }UI&V_׹V_vt[kfSG*gQ)l:_e_FǗ{H$ZB,YvUɩ^h<ϴ.\r 0ru*#@G.ƈE"?$emy!n۳&̑= Hz64R;@HJ ,,i:|i'/2:cԬN")=>z0_Flߪ9v ҥSr|MꌫQ0W}6~ ƍZaG$?Y6TYi~m$`AzYDFX)b=G-MC:&au*7[E+q#KtȒ{kuog_R[%2:r>޸JhѮvYHtˢ/-NCLU$ I^|_{ ~_V %p;j{sKHMNF;0/m ]!@{>P"_}i42i5r:d#E AQv7 !U6ΞN`OC7f#Ki*ح%/!i|rf>3ѝA@6kϫ}]1#-\_]%; $j `^~:D IØd?(xw#iS֕2ƞwn(`L ɈQX~i?/3%qNZ>`ȨQV2r".h ZʂXjC"DW=ny1Jkg >#^7;zCNMp03U4Lv.YN$QNLv2+uW8)EzoK6$e &Y+貌&cQY Z껥<%" JK贍)3<4Y]&dֶDA8]i6ggi$V~red&Kg 3j,n~/Z m:Y՗8闤V1[kZEEFeAP)'?Hi^)X3RRhu$בVZZ0a3lU~$:HjHv)C쥏Vâ5~ԥSrhNdF-h d_d A_$MdQF~}8$խfz^ßPFH&9?dmHd26eh:j:\gG#i; 0vT{=z}aَǸQ2jn)$ Z+C:,Ne}b6Ux'GtU3Uvݼ) X[O MĨzVQ̔9y[I^;³vNb$vGLW$Ekbmx شrHH"DZhȜB~n:8=KI9ɫ5KeOjYލtlqg"KPu6_2湎%@Rt$E!WX _~MɊLZ>މz3MF]8}N/rV(CN$MdJgjdy6[gDfC5mtrm桜^&r'I힖FcCR;֝Ɋl$)HV;3p':$cW#R@=O1EbGfԪF+Y—i 4SV$-U}8t@::QHw?ʯh,2/Vl 'ׅ6ď,([FRR_+v9;{{lPb٪u;\m֨#-nm G|, :N·{'nZº,OEBZ:|!N`6Mo?Eff˿lwwOr:Z`CϽ2ns+ͪ)<z +&vm 4QI/i428kD꺘|fuD@XKeϙ߉ %_t/TjOu*MeE$-si穯>]h뵰O@"jWH 5r>1Wa߇|L&vYLNiwhc$o;\#H\_,l}id}f\/w IY_+ۯffY;z#w#^6讋HQ?Mr;^& *3٪j_bF"k}ђŐ\hUݤM~.&+oMܨ~KMvrٱEL20,kOx[$fy8E׳;ofkg~}ɀ8Fq{8ފ0qؓC`#yRNb?>B֜Zh۶˃ۋqEvE,t7V_#Ր~q$"a/]7 \&ۊTmCɨ Jpa_Q-K%. ɂ2}zw7~e q+[lZUXY_EQUygoW?v ~;łe6ٯZ_6=kg--1D`4@lz.UM[7iGWߓDy$֏N@`Ǯ9 u ZEo]sK"W%YuUV?""G-WJHFPa-ۉIޣhF_FAU\F$7ֽFom5Dr@ ]䰏1"H ?]|9q\pa: ?:VH bHۅ: t{beUA2|)ҹ揥c1a^Yy /H\@"ߤhJhLxr2l̨Cj4 AvV6P4Fo5=Ѹ^ǑdH.)?$lXK$r D9pY~ygˌ ?:O@-;^bCAvf̟\Km~+YY=TD"K61,+!Zv;`]bJTuɭQP-p+D~D*OYTE?A~KiǓFoijY`ƖzdV66-kA~˱̥W|08]Fq%e/3Gu:a=벰v Rd]g)F=.YV~*rغ[$%)~ Y9v[,2^"Vz%e9$M߈ڎa.BQZ#Dz3A`W2X qp dGWSR<_BZYG)8o,)H])0ۍo{ee{>̃Ljv&=&j5}l6NԽ0c |l6!m>9D(Dd7YEAyS咿NHsVHYFxCn'G66Ӫ+$fEK:fl+'Q*+$&C6y8sqq:"I)fv\#A$$IxJG?:dQ ,H(yNZo=tae.&&BS$ྦ#SˏÚ F7z乳C;IS2 *׀.~4 e39[ 涶}`m;&iD,GO1T Qٺ+􇆟2Ipl-mNIF)$pRuIᤒ J8JH7De$pR5>gs|$wvq  10adKd1pH9%FrZ:(yOR3x褸W[u&p"9vɱ[yl4^u/#-H$.D $CDrN$CW4:3!^Ρ;^r8$:;8.O$7kdf>?,<مDrv:H$noSk$ٶK:Qپ8L$2 ^:ZYY>;A(*#%^ϡlm'-~r[,/HSlS S cvR2T@Xr$ި8xDȳ.ѻGhD}C?:5JجS"[:diwuA"(FN%D bydZ6ıك IeJ8nи~d)e,EY1d) Nn#:f})D2$}p1чhI| -1!յT@CSVC wi$:jE W־Q\2ZYi_u\Ex {[oMF4Z2幤90Nf __ #CaŤJOR:o ^oTjP<.;y.r $S@9ܧ2;濿qw"Ȓ(ɘDzYHCjLY?eiBV7:nH>\ &.'M.J9px"C<2kEHBrVy$("cn@܊mݥS Å,U~$˽caS$˽)-$b9v;$w8Q|L};XnYx[.db'[=ܺG%>&>`-nw,H[2mfFn̮sV! V YrJ75lTTVfJ`z64\EiOcDC֫](U#DP tJ$ m\L$ foiDjwR-Y592ON\6gF4/yeI};uߟzX랡?Y{.^%/H_t=?$gE q+LøszQyJLGW"P @4m!pT>ʁ>$SѴ&!X պ^DE%Z8uoHizS m8j[GMΒ䭱\R,ֽ՞ن,lQW3_m Yi{CP0u~J^'<&Gcww,vcP]g C]HauwPFmyDP5Py?ڐ:e1p$eYfN$ԟ'2(uR;S'Ҫ"'#k3/KTAuj+7Pn R/'q@ȇ$(beݑ@Rt6ܭ{9iv} [~ƑcSx2JQ^F=) Y{ zU0!,8 ApwȔX0lSe4 (˹+w/%5ZV J aʽˮa 86d4W=pr⾓P ~SC>*ӝZL*qIpwAz[tu@+` G+iO[U^ֺ"x\Q\T']Q֝նY{dSz2樧ܰ{qR d/QWPvhpe2lMKgYΧ^= ~#ŀ0XArߧl\lU7hװM4tPd˦ޠul Xٰ`qSljuHLl>[]&iRiwN)-W~`+O*-[3Dv6zL%P1`{*HBԋ$Ѷ2X螈ܔ`{nO[E"J2ܣvνY%Ф߆:Hp{￿Iyu r~"Hrw~.R $d$XL^5)D; ^xM f&1%ey?CNy%&scV},q'Ջ%QXQ? U,.ojvĖ$bK = Y~;$PR6>dY=2O"`O7" &mVLٛ&H`#Ivv %(Zoh8]H`k6.咣!Ժ$>CkM%zqq) @ TH}VcҽmǤ@7e@]@0p_P{o,(K |VUNy=eFd3b1;& &G[lB/w0R#TO6j؈,|B)*'Y;bfT/Έ:uۡ}s+Dt=ڂNֲd^gY &H"_:)O> ~h }oc-ڜ ;ɻzͺ GYN>Pl D.o,Ej<2ܓM&M7TK wv27GI-%(U#=K>'Ir$"qC"U\֐, ߗrR~WHq/ XLqK \YRju紏IYS}lGK 2^><3xvd;q|Ye(Km|x5vأ!eiI: )2~ ex^O"aajДo]xdcL"#Ц3+ZQBPߖ)9ʉՈ:u.YF 7i;x11ISǰ%@Ғ7,e:i2UzӬbA6B@lbO _5vA"pyDC:?O1&%X1{ӭؒlUf o5a!HdTǴ9Wg>s 㴉Jq0{@5miKq;҉>wH'^#ædyπ7% %w973x[N7 Avҙ5I+&{?GnU:B8rbc@-s_,e~ɴ|f"9)^eD"R]A˜TU%IR&}"VuJzs-uԕ*itn Eu/]3IUҙՏ;t=T%ەU%u*D: O$s]r͝`?٘,SF&BMIlh0~dL; d)BRI59??wVPTR0pϪB(Z&s! )#DҸuָgLFޝp *1u'a5ᑬW^aK`5,d3;i#9mB6,M$n fd\ju0QiaXf(e䱔vPÎ9hD .qKap :ʡul:Uǡu\ַI#~κ"o]Y 2 t 3Y+K$۵d"VuX2}~mWȗ 8*4Kkȡ_,5xW4G>'c{ |,lG_JO#(}#I@~ %"fSO3/lGYS= !UV!uf:|coo(LGcw2r/m:`upDsǬb ))<[UڮPm_4s&Q"5݈5k Cz (#tT<S[wJSYՉ@rkzol4@5qA}\ n6$ອ"A^;: .qD9<͆_ECM=;@""}\8 .0'xVpF";qg~tHg I> P#r7R8hn-Hi̎,a\F C!@VWXȶ`+$Y"K#U(zT;L:Yǜ|l nuMk^#׺s$3Da/9f9j3ؖYF.G@ ZaSl a;>h=%khb>agWmSB7KMrV 'R͝=V&!ztNQ  7:Dm4D0vU=kj"HNh@%vtYQ%-vs=j&Okd7E=Z=9IKHZIztυAnL1hͨĿ}܈<УB-DyrqKvt9:oS)Ǔv%x' XޮLjDG{z*=DD$ͺ0Q =ZoYJLNdj' @bU`b$Ff$]WvZ5Tni^ay*p?rH# s  ՟$2CZ<%w{N=7Z' ܿtDXGqHmgKk>s6ԅW%CyS5׷0vΧ+>k}F*S_#EZ ։LH"K5XHTs"q L(lE,&Je2 X'vEyMs'"}.mM$-GR-&fG1= H}m#H4CQL>F]+ҖE~;Oh$T똩&+ܫz=#e`'Uf} xuٚ,k} M7B3SfYI+'-|5qT: v2f"I㿇Zn2/4'׺ AF d\.qLNemQȠ-ZI% IQuIW,e4dM,d:7-' "avR񑇭rW54\Iܪva\TEO>Klmg?r3TPbq!(*]" SwoUzP7Qrhag.-$so$ 8+kSG%W ˝㨓U!n ~bE٫bLv>IA;z#诐U[z,r[kZ;Ut&htL^ "(Twn(s >Wv"lV}Tݝߓ6I5H%\?=]msÕ84wJ8?֟Jnֹgkvr_-7*нo|0t߼`^F}L{dW21K|!h*6Nd?6ߔo^$bD 2 yI:EqJ8'ZeslUszP/w1O"Hh FzDK97 I&uo" v,HHTw m@ug_ h!,UW?eI5MA猲1mk@{}a9@`NҀ@Tҩ^@B%9@!1st˜>$ rOKwS%,+O=7!tYCozӸيE7x98cխ~ȔprG\u $PM '6ʓ(g ϭ_PY~F lM (Oz&{+2vO#(Or^b+#PyO JO)l@a ˠLkN:'0BdU gIhӭj#~GI<`jG"1@ fI@`nC.Åj8eT B{c*8ˉrN>`˪*,ta KHYUHuSMMʨDMʎ2 &o 4@V%EE_5LW=zS9`yR9-g.Ӣ77? (Gnz]@Om6@xs͡:o7b͖+-/b.S/;Cwl!շw(:*GཻY8.W-1]|:6]|%f!gL[J'[4Ѹo?/{ڶuf$Mdzٳ΂xZGYެ,iG?@-)GQ}rFy EGȄ۪9D#g-䪇F"^Pzç-m .ccEO+$)9?o8j|aG2uSBa*̩ߎ$1d؋ndvy$o[]d#~<:h3C*F3GA湳6-oW]oޟȀ5?RKI|AP0F}/*yw* #  3 nPp"F#U67$@@ѪܮczW} }] a5OСw'!lS0)j] ;܌n#J˼|J%+Bȕ69c(~ەC%JM6.2|DSaW7Фlt%{Wb2z@o϶AsW= 7,z_¾zKu/4p=UFd=lyQjHj{ yӺA[E|UVd=#9z)|)y!Ț C/DVL/vewb]wB`:rW砼@P) c2h=#&ڑu(ˎ(1Ԣ̥Y@Mϫ:[eV~@`#b1آz!6d&clP6\g:&A< 0TV'[?걹\ih#6>^l^5uSi tܶ`.<&t5장,ewBү7Cdt %u_n|NhtjLr'7Ivg1 dN`vG.f^cy@'nTJY VD&+v4`MzWO!\[EC\6nEp"M]a5UM OT5Qjʕ(b,ӝeuegy.(C5;W;˥eBw 5~MʪH0?a1ZnقmD]ϥJ-Uo^v>$7E e#c,O;vv) },ֽFF؝U"}nq1,yۛEvwG3U2-wnߏa Լ-Ѽ‰Ue~gmk޳_vkEz.bŖBX/Uȶ ԗ<[]/P-ʺlÜ/e}עآ/ov;eTٿBp`eٽ$ d֥|bw"dء,ҞoCYv"Zqonbwo8ȶ%Y?`Y(M }39xٗ=PQ!k~HocgRZrR _]qޟ߮d,&WRQ{/?H5w@@UsI,߶ag] (O6*,zء,šWGjMdƗYۣ7sDj叜 R+¶-i ۊ2Su}Dm'"v.^[#~UZ݊=wOD񟺳' ^RϭEo;HFLn̦폆aY? if mn(99o{Nަ;m7zY>ZmjQY[WݢlünQV$ZinQ (}%5OF:h@P/1誗Ai] nޭw1X0*T녢}fAu+Pb\z># %Y,nZMXIwEɒo }<&-1U2چb4~DrPB0ta(%{@ U9#O=Rh7&0Qr>j؞Z/ɯ%O־ X`6_|c 䩘Vk^Ovv1VragW4jw\ߦڹG96ZA݋q݆F, oX(?K`4n![a g36; ^ ֋* !R7_- m@fGARwȐ`2⫉R{[*`x5ѫe1͋[<yoz7c{tRrG*y - >.驨k$HOI8FC:[( l/}+muVEP@FuQf[3ehSdEI 5WZȷ+a4# cc͉7u/]"P7AEן .O:wk(pLNEd5\7Y JXRvνY{{{M0XMӵN=';W@z!pľ5)@rCPYIvFփ+= s{8n%3Vف:wܿGi|c7[DZ.sL[;zdP9Uv.tNO$y٤s1Cgn˩W7`I~0JHGkE@$iz9lR6QWO1?o(0B(y ȹmtdZG{'pJ1800O2QU_#N. C#z]k}= ƀ28'Bwfrpn̛9t{u{y OUX"7X5P'!LJ= :5;BFÛkWپX8g#Z an v}t Ix? >Nei|v*KFe2.0}s6$<ۺ+٩ C$("FH0*3&(S#WKQ^FXn=,Z@U5]b"Hn.uњE͑2ᒕtrFf)Bhz (leX^]dd ܻ8+l;m, m,']I'm$B](&~;HéfpB?% \~1Wtyi/OֱOGk~TVHҭ-oltgIhTBotL,Qǣ%mo Fg!Jqя+H@2YnjKSd}sb ,\}lGgMesLZȟ[MY^o<~S;1ſk s`U,'l, ^8;~8 U*peYDXD&߇WF)EIG@쐇ܮDpWbq{*+^"끰p:y"GJһ.&k*Eo/ˎ%EجozLu\ЇMo[wuPsSOי q,oG59l`6AͭwQQG-_#%I$6}>oƐ8yrbjg@HmԨ0Զb98\2r,IS3#9di3JHO@<<`ƩԣiX=6#}q/TtHx+qۻw]^6Oj50esBu Twm7<Dt[hyf'($gP_  C=H瞦K6Q ܭ&uٯZb6n9]t!ō/Th,nT#HnJi`߼m'a F Ԯ`}S/&`a Y6;=J lO  hyݱ=YJ =6޴4XyPwW&4 dThigMd{y؝l,ݜ awE[wAv{jQvk "=9ɭө9@E/ .9t< }hŽxWt L?g: *g폎Hvyg'*b \;oC{z[3%LEHk֥d׷h"\.GL2ki #z]2AMIz; '6݋$|ݛ) x_|uFFfP$4.vl/Dyu V7}Fˮd2D?'=6IE^UO2'0M5W-ɢLUKEUlQd12jIez^5$b/4?<^E~?@m fwi'ij e%]lK#fxdHr )wr[eu{HnG%Rn6\I+dfy4Z ]?.!(^1~/FtK9gפ}[cbsC,p߫";{zٖ,[y-ٶd/d@`"w\%۫SJDrDe}{zn2}v_'!eЊ\R]x^CkZ-Y*jpB7U/.R*1uYx}H7lJ6 n7?icytT)Yɞ&B's ƽ*m?a>5,>5|CrU#@)ZG*G:$VzktHVڑEiWjpwSܿ  svr L=V. $Ze;^|# S[F=Xؾ v$[V Q~_*?οa?{Dg`C=* ؐl$sX}ussj ɱS>e#Yy t$. @:'ؑlilJ?(ؔ,5rPU%ؔ ȔikA~<ߚ6Dy\%M۴qkG@AK=psݬlRC9 j@3fJ+&ݖn! R4)0^}.8Io]RZmlˤf6|Sׅ.9?'YO+!3mHd?O__+C[B,m=:G d^d=}[*P^-ܪc/1SKۓEusXY9}E;RH^B?6#KimZ(\c3Ԅe c A#qe O}L~LD|?B0U;]$^d0kpCge{Z?'v[*r9j+ruȶ>XFBߨ_ݪ b!#SZ~qK~MM"9pIsN'$U ,:V[!rt`- i@?4DFǹנj5FFC з>dgx>${@7.diR !1D2R"reynsۘDbaoZ?ܟWf"I$~5 SaiLD?) PCzV^>ȵڨA+˘ A^ٱΛ9'$lWTYSe ce݀&A"U,"@([Bv|M]#9n~rka6 c}BXOi/rv#6{p٦lWJG5* >\#[7{)S#6J^7NjU imeeKu9J!ڽ ]Ύ۵ IB ,[~H_1۟ZFoYuOGl1#'^'{Nm*ɵm8Bmy@$|%leԑߟP%Ѫ4X$^pF1@HgN |%뽆+qo Z9a@_/FpT=ԔodLg{=0Ѹ$jl4Z~enS3>:NhUw=W lU9vMyhAhQkr"9ɉԯBGBוoIrB=};^ۙif*o+D)r5kS!r-Zw& o{~p6OH.ߖA Up\R_~~DNIMp(--ÍWF 7 ٻ|]̩:ҩF~e)4d&lpyޚ4AN{l"Cӏ,}ДE'{m5||8iҙyp']å. #CT #aD?9ȵY3,2 ;\)=j8Q+,do!M3i^SzfN僶T\i& -o!l囦@-F38yf= ]W8j_V?^Up6Ge9/]1A'4tQ=1@ [J]7%+wQe'ur둢xLyo$L㨕~2vr?f#_L3w v#ȱ'kLBbSeo'!Sf6ٻsR]9ErVBU c*)K.nir8IUH JJKeU] r Hղ@C4q9g^I@ԣT@ z˅ 3"aF6H⻘nt!Ӎ_rn];H#"U[ V^{1k6i( U!2JHTI5ת_Q3G>(Nh4z-Wir<)y 'at@Gs`VYE7B'GZבY>W1Gᷧ\~Y!a(Q_f^J!ySRݬbϧ^EcHP6N~еK ʢ rip&YO`8,@ePP/9ӂcFP恀ڼzyP.ýN!ݙBUR/I9ޓ3\2yK}%EY r|+QǓ'_g t%\qJg~薩d6ê9"F"l([= BP'\r[F!y z_̯Xbv␃4~s'IwنC~6wXΐ ysGF/'z<7S=لɤk>.,R8Iℸ\QORgDZZ=P26֖XZZeMXZZnJw$YjķulDll*-͒QUZo6K3 Tm_wmA,-]QɩI N=S7kXyGN) KX KsZAuN'3Nޟ@ .c7I>V^S̀h q.k*F SJ9~RsrN0@XYꥶyMs_ɕR;7\d{A>%t_i^kԞ%CB $%C is͞< 8>'BDe^lkXfSVxT~s'8J쥺W,QLDMg>~z? LIXe{TMVgQ/%; hOk_*}Wfi'dz[vIv:RW[N5KaQP͚FX, , 2veo+"B-&J o!, TjK[]H%|VWU[]]ݑrot\ %!mBɾ< |= qo(rIҋy HKdl#8HZ&zv5[j LވKd_,^Srb 9dy Lk@.)Rnx&!,%cºD/5@Կ7wZ"6r=%߼nm|;%OwR\Һ=- po{\Euy6mA$ve8t,Y"-w_C${!=,zi=wתpېgܷ :)/Q2GhdCymIͲUMp}V8dԯ&۳,/`o趭B aM 6-whx[V`s ܯJwVS ՖF;f_ɬ|v/}%Wk7J|fRE:j _!>--cFva վEv7'&Zç.4[fK|l⺙' a( D(#VsGA&-gb80<,f~R)&R@U8klCKdnXЂأ/W,bOSIAi%q/ཊvl-w/YLOd";2p?O{)dҽ.,7;i#VWb?߽) 4s\&Ϭ6 s_y=X%®cg7Q/o晝fpN&k=OɾWv6L%y;lW0Csrm~ZJ[D7ejX 6lyYSJt߽X T"YW#i+=aR9dDeN7%_G!߳$S^˜l21>.J oV G/w`yEw%w<iM6+YjtM6J|o (8 _}M[%dBt%o+ysg(ys1㑥"Jcbd16 ޼5I;C# yt@@ԑ}HV @86~u",8L1:}H͡Ɲ %.k7Ⱥ [7^ XoMAosm)궯ƨۤUR5rbzI\Mosm#Ȼ4xut7д I.7]m*}NP[3+{X{I䓆h8 p{>${$O בd3r ;mNO{o2,iKbtIdٞU)-*W.+MX?*ٜ>]"z^wƞ Gxǟd JE9չ%hlLϑ׵Sf@xhWͻ⶙\2ύp$nBuf. p@u~+֝&fvMk3*+<=YIA0=G9E@fNt`iF)`:AM z9ʔͨ9o$*mH *1|Wb%`rLI\f9_?8,>}VB8$2^pXLDƉ"\-_Y0lnEgQnV84k j~1T\724-_zr 4\8?Ù3 Y_:>FʕlzG:٢1l#k䪺a(M@V.V*mJD>2Ȝ lyBP2½P$e;-uOUnD(eY {1]>Ϝm-H甬ZE% #(;*@8*rr13r1ӭ6O(08g[R6[S@80>o}l {P-{W9 1E aKLl0R#usUh}5^_윚27}rR;T$ TH*S ʐ+څʈ;/:*;*ƃ+*bB^W^}]2S/ g{.DEyV5d2!24]K=~B>~Ҹ(.~rwQr Ay-/lM/I(,s9d70|dzjSzv:3eg#? 3"rm"1Iofl-6tAzqI7z5 ̏ôEnsT=5lEyⱱ`}V!fr7F Kd;f_6ٞy}> jmccgY<'4i{ O=fcp|^vzgT '.E6ْ {Bh9"axX[ +HS0]omϰu -v H|w1H19d׽u!(݊˷YEo.J{eo[.J{GoݧNN{ =@&6['N]Q黴+i 9V(]vQccrf+AFVb8ls0ES'+]YWfVclqz--[LIEqzPE=zi \ȀORsNH=Ru5MjrBn4}?@X]+χY<֞&hÇr=Nnߍ\[9墵Q񬬋g_ZJSQ@Sfr3Kӹ9da ~%+dxHyWiPgV;5=G,IB!KʫY=fI# X:zGQ-60W{j2$mߙۭ+^`s /ܽ5o3}rp\vV(Cv,=YnK Rpgd7 % -2gK::*V܅߬ =+wkll? c7I,YrPܜwu[~*uqUaRvtIԃ{D2`NUyr #WJ~ mҬBfw!b~kӐ`8vS~Laمt^8'Vi *n,{&%=uHާ EBTG ;!ĐMm?QJ y9 G4u9$wur|r8cH}NhN 6M~ ,[9T=s&m( ] sv.[&I ,F p( rpMv){? %$~6Ykߏ9KB,'SõTf_ p'͍PORoWWlF:{`Yda#%hdY \)RZ"bɞU,-.c̝nr*XWd rop #')7DHQ"M jhG6s6 : `(B5IuQD߷KIhPׄx0ʰuaw|f.MG+R5,/OmƓPr[>}pms3ߟs=~6 }d)T/ʕ 2 a)i˵bptLEG5u.jlﲴVFu8zn_G@T!Iݳ !nͭFo+#d윁t+MÌ ihOҝ0@s}G*d B̀`9iF\'.E 9JS2F6TTÐ=IPGd+ 7ۘrrƭd x!2KwsT h&$)fj[I^@oV}Aa8Fy>ytDUm62i[A]8$Iw1@H&feB)ʍu/Wl,"! . L3|qGl59?l `ڿjA!, R@: VQK)d;?R)dq8?WںBT]U>~SW (#Ai]Ʃ@H|u~5㾟bbd195^ϧysz!Md7Q6t^-Ҙ!S$ }"P P?)‰ 5R a-I`W6qB \N>Y pNjh &nUP0qWEwW8CYd&502z}B^+ɬb8)w8ZPIWvI2+{ 1EFW "{k4@@R A #c\^a 7Eƺ-C䨧U#a@n+o6 "cv#>0rٯrU۬k ki,b9T \ \bޥ"wpk~J{FOc2I c[T' }B(ILZS"=ɶy]LfdJ"s22@ʼ^![xoH46ݛVM`ȀlvEyIa`zlJTI G *#Id?gQd;,I@ JW灐+6~D&jL܉kw6vssiPt# rWFd]iW'MoޟmGæ 힪[M.Cœ-\ ꍝ\%o&'Sm~) hd\G\ӜέA2 1"[2ArGV/=9]s!9e2|* ;nEYh@RR"K$E}ό>vM 6@v!m{ 駻O)V}q7[uw޲=@$89 /oGz[cƁ-߅E)Yi@FMt)% ;{1N; Ws(oaI-Zij|-j.)^%ĕ5/Ps]P ?qUQzQTP*' *(=& Cgk.w דZ(0^@X 4;\P? JɖimuBXP)vkoūVd+(Vv푦g鱢q+KD|o,1ݳw-W[{nڡRTLҕ(-Y-Ƥ0}F6SޒvY9v}ֽܴvY #ۭG@:"CG.}* Zf퓊j)6WvQGh"Q;W  :K>,NY ŒVQ/@Tu 2TcWzvbQSSlS^{Y`}ԍ,Km{xUiӯH꾒~ MpnaQxc8Gi[X߿9±݋ h~!<Z=EW@$ym|kMr^'"ً|/|f]# ->w9K/?Χ;ytw{ƛU NW)pjIir=DN\T+G۔B xҁr򙀰'~{V@OGwzXyiDQi! 3#;ڞ<, B ~${_!]F=z.-ϐпsZx^wޱG<7&Ud#}Nlt&{d/~Q񪛂95ԬCVrȀd4:U,نR2݅Hj@6O3ڊ^rz/8++?~1zT,:FP2<(Nқ_ڬkW-WpPLkdӏA&S1&mT%r%ЂnM=ڽ(MT^ k ϭj8c| رt(lLq[)$ҢgJw--+zjdIl8UrdTw'hBywz@F"1g~~'Q=yWd?\*O7eT&cf*OCl2$Q'i_EIwNS4V!|+۰%S@0HҹE&s@=GQ2 `q]Hg+ |7?T Λγ 䰓?@𠡕>JdsT9Z3'65}6Q&{@UoM՚Hb*V5:;,2s^C`}%~+ODBvsT-Xlkx3S¦@B x S/oMBwFg' v}m|4EM#wҹ;MoV.͵-oڦ) 6V?߭dS]@'íJ߬oY D'r;2TR[Ipj>s[fi@X=~(9+aG1AUlJXpۥ6}X][Ul7Y2 Z-4ʥG}!%%;U]-?V'=Ғ7Yyԥvi2فSJq t1`%3'#'d~ߣs8J [>{Y~ueUM@QA%K:V`,qLKʪ~r2& ͯC'HDve X%7ߎ, ,QaS[gS\7.⺿u Tq!. ) /5Q`BK[i\H2B-?&ǀ­' .~T>W|G^J\jQݴcuW,d>UAi&*#)_IbV\&d;dS edjZ<PNYeTJ`BHua8ftM=NEl^F>R~r&dɛt*]uF39:f'4w{t*->:H*]@PҳK T,8Н`\xj=Ju}mA Bt\r wZ> f's.%B-Y =>SSt^4 \@,W"O]Z6\7x1SBo8-tS~Kl}[N6Wpq&d=jdTl+cF2 *f/ͥQR4J~9L%pdWq [I9e\4yGٹٴGSUzwQTNٌ%|B v rlAA~gBT+FT7Eo&rB}h !kX@˻ZbQhf#bt+~4,E<|/۲+% 6@ʣlc`f(_.e* TbLVfD~iX]Z:7,e]D2lp>vuہFk{v]lJ24t e$1#N\J(k_p 3shpOdjIZRE9"!OM3n~*Eԣ7gtjllec>\(@86Κ.Iܙ ~3'#%d%_;M3lÁ.Q@KneM:nf??[7+jBCYyS?S%eݑb=?EвFp]%ys*6@lRCJR؛%Keq,2g!EB#yIT>9^lOiܝkd?٥f;zʷʾ~Rw TISTVBY+)GcivBs.N(:"A)~ GGg7 -ʢrrkm}W6. R=m{j!λE;\VEל?IlV;._w=H7ǁ }e掬JOi)r0K~Î%'OZ! 3[&\VrMѩ4CYF*O*"s"LTGr?_yn?n+GxEqt_^ Se+#kqy_OyRXGǽM]OKW7B,S~1qp?(LU,3V[wxJ1nWi\*LSUT,]қWwѶBȑF DoR\4JdެT}#C $ngLy_w7iz|OFBtB[_Grcٍ9lC Ax'~nWmBTI*+> Wiw=)͵7]6sMf&^'*b < !)ݶ' nI'9Ҹ~WY@_ܟX̌JLt)poff>|ǡٮI++#W7Ʉ $='g7<GFT}HO2ȏ3@Ȗr2lY!&[l1=%["fpLZӰz^E-@t94| d( I&;f.<|;.Z j/ip|J dj V\ n5QY{ kNDI5oBCЄjQ.xY|I'ܡ돢Ν齅(?̳.='GT7kAhWN_msQ-=.Zřp) $LW|ӣn[TBDp"1u> Wn!+pf MTb} 'OًŤ, eyw!&A6K~,rJ٪  8ɧ )@( L,pso k* +z>Su|ݥG!Y^OAe8n='#e'0 nc_QR5@YgQ?:w}wT{VfsNբw=~ v۪t;חn{.e#twJU DlK7y%{G(Wnt8 pBLȚ)V+ȴ_þɓWF \n)zMw+ a~kUJ+ =FXRЊ˔ґymWyr38U1fp&; ȢzZ ?qXeL)W-ʅ3r:%]& )h d6/{xSZd [k}ﴪ Eɏ"3E˫ D Յ d y 7^*XL.1iYn\Uʋ:ٹQx9A]K2x-|vUf/Q^+J{Wwׯp6ԑ%}˩I߱~Y{_%_W%gg]}YR:պn%wCH 9֐|8KJa1`֫R%"h=2Oo~ڣhJKId+w VIFƎ> qR/Е Tz~޾^U5G#ͨYU!`Ur4i BQ盩nSj~vW .|oグ T$۸<9W"}wHOFJ҇V͛ohLܪriBQS<nhߡ]^zzbLUڧ7 Di6ȨU]q9DJ!r%;0}T%]Ae%@V6Irj0^90G[T'WW6o!M)Uv1aF]]HbցHknK>s'Mi}uݭ?Ibv' jSKȲ/.D@6ǫԝϺUMBh^C{iۥyNB_Hh*0R.Vg+D5?2ǥ3^x2x+';$obDj+osIށ)yG~REu * vŔ|;0[&=Ʌš=wdSPMwWR] d(DQj3Խًaĝ5&n 0(~PTN7 x{ îp@vKa!Kl݀6.`x}+.`j\ OC|78qz<q \PF 0!L6Ktu,ua靺^ 'i2Wy( Fd^*i,YsnZtOd4i!y=sg@|e ݟ~CAeZZjoG2$:lCɷV@5OܺHS;$`7㫿#_ 4vLo~+efm7Q-ujX ̩{nkӆ#>*7B,. ,&ѲZZ5*Bpuow-Kb;? 3]!O6E|W˳DeqSkI;N H! cJ*GiJݝ'pspيx9 3ۙ'@#{13" LNU=:nҶ_377Dn|ځ0zz[ Fs;V90eI[d@<~cj,xȺpp|AQN;Wl mN6~OZ>NیNv.O)1y5t梨zX1!y[r@UL$uG Qwfki}\_ƦF@N<@\|PSBMYEH|}Y$fNHMQm5H&Hh ȰYiT, 7߀6M)A]v hUR2),EAEJM}v`JR4n.π]5l(Q6@ȱ]35ı[?1`Uf> d lЭ>þقjp^,_'re1w-9KFyOѲ=@JWzp+AvٯHNoeAÖM8yJhKѠ!Hw-~ ,yɑi߸Z2rr$!ߏeOBj6 -z׈~l0tcP~Dsm;|U- umjK=c~Ǫ-gN7rč]r4dh;"{%`Z JrL X]hnۊ=V0lr=hSYwFdx 'Cqt`ͺn"CGm]t*E-4N4Jĭ_h Xg9yCl@<G@=SMz%xqj9n;pƈrfFL=f[6f=5( O n[~B!L4o:l}*/x~dJ磠U FcUY z f:m RTo{QPd9  @~>-џ)k_QLf[ T( #0qgEo}#[X@f>ƿ]5l]O+;{+{gn唲 k[]V]j1 ܌BtKKu-䳐( bI[x+4ok{ BJ> -ߛྦྷUnwgKiagKOЯK.]dwÌEϴOtF]ZuwJd!˴Lڿþ{_QP;ΖK :x*}u潊)P}tS=4iFظJ)iϺ&7WwxGpRV^WFp99 '%3+4nIIw"Į8&+szB) ylɕv? +{S L]0dNLz#cqp2QXϮ|3tvǻa*p h]Ŕa%P \V[~/} @8-te\i0|ۻD9@8٬Z42mM{ZrYPAt^d3=4SܭZwk,z rRIud ݣB{JI@OZ4J%bRjpmqݤ۽~zÁO/Tg;;] 䪑K ÇR {!^;ȶɁe/Yn fKܤ_H_!e+uHٚ%%˹ƴh]];g %P(13l6LeBFV~!e l4\2l0vX9e)칥(5s<`KH/FgMDvjbXc7f.[+$l `8{!)l1 D%EF\g٘}3pvZ}^ߥk{?n3_w X{Z'խZP/1}כV,+MŪVwarw[VNcVk]SugL1OeU fj`?Qh9jO }fm9nRp[eO d0NT,jQg }{kW ";GI ya{gG}^ҁ4-ޗLuǙgگOpZ 57f_n;"}jz=H/s\t>zkr+lLFdbWb\Ŕee!az˞,l磘nzi:q0s_G2BtŔQ FA?!{+1.+4Y< e*I] HnP5Vw֑h~;.me8-iF5/GlVSw# YR%~VQ=ţD|қ#3L₎u8 l/03J1BEF 8'6nj!{_)06ݎjo!;dqGGgڋ!ݨwi@w;"wwd Y.moG?"XxDHYp(#!eA ߊ(F'DDp5 etȍe f1?ݘnj gƑ5?qcIn5N5V˭kD+p#}˦!{bR9SN#l~^86/x=&(r~tۼ/cN=CKN{%qwܖSpBLCp7U.=¹z|ߑd! {[4U?|(ݸP!YKиt+2Pd5Wn \}pvl G:3$jr[%/kG>~d췯6QsVSeu 2Jh|;~71,o0S-{"mla*!*J~PF{oDLڹ@L3з׭Gotc޿1T^c8BN{Y'_vkN%ykKݓ64J| {R|2YuR~-2ٛ-ɳ 9eϮ[/lkA2qlRmjL޶Z=WIK#L?J]#Wk\1nS wi_%5r AKfdI"䮯<¤췠T_q=+^U8^*5s‘D5ooBxAuQQ3Dl|oɐHD#k ?A:%[ҹcWo3)^ec⊈vP8XWu#%"lƼ8V|p[.FDד G ŐWDWЏ#lNKe?e?-ȇ +tNrMKAe$5Iu~Iee**5DD ^*[Uv=S{'y Vycq7$ _ ?d%;3{\/ Gwann~_¿5Ls#v$ibM 7fYb]Rd>Ko *Â#&gF7a =Q;}qe|ָk?B{}p{RdH3n ЕݢuT?8U[Po{-{DP7+#u~H;ˆ߇V@7W{dv˵ f6ߟ}dGZSo Ik#3!;(CI`?)+NC<)C=#˭)flwx,I|cdaNf?XdE[rp;2X@[8pb-$UηpkxlE='  n6ۇ#w kۆW^F.RZ~c+E'vq86`} qDsA`Q8@EH  ;]Ixi Eu^ApZ|[oG<+WmWRw6Dgۿmcf~bYF󱰯"@eO!+ k:~ayK7Ga0&r69cޏ~O 6~oO>"J'CscV;57Wd`v2J'ȏ8R9yw}{ pw;8;2YGjԥ^ũҹ>jҹS w#lwLJwF~J%({6EW޼e3%-;BJWFݐqEr|]{Jfb@A Wj}ڽܯ*➲~G0?"YRپ#CzOܽ7$씢?`r߶4f+H:nUS_+q;rb묇GJ%֗SPV>Ba+鼽Ma+8VQ.{+^ya/̑e7(_wŔQVKKj@#$lf+غ3~(394nߍ;7(xos967F}/tx>+#C@C_59u*ޟX850<=r|zi7B *鞲L=R>3pzzϟVB{QvW"ʮ 8€·Ao8I~}$YB"?Kmza ɜ_c_ӯ/9?%կ/׿RZ,i:ocmR{Q]Vz> (?}Կ=F__ ׿q/6`@>穯_.(C7ܿߎ8x-s;+tfXGsxu?܌GaG~ s7~FGa\~~:v5p+# 6tK q=[\.o#_qpK TnOG~[X7&Ԯϫo䟟ڇ9n/ +WoSM0s??b5EKF7ohg/`E]'ǿ' fL6ij1縥Ԁ)#̀~83 ,C?3)K 6YkDep+40/{V߇6nX1`3I-ߵ=}fr'nN}z`]EwFt : &?V@ ;6s#R/.Pfj`)ha(ֽτQ}9H6(䏸o؊R($C-](ƆԏS~ek! \~5[{`eܬ$>UE`)o2zri>?Q[Gy98U?mMd4I 91i-"1+7HX?79j^IPvkSPޛ{J v!x> ]yixց+`Snsy!Jq?/y/ݭz>)fIn)yq8^n.n_r.v D@Nx9lQ d<~I=KV=s<t|;5.n70et>[7Il=|b_FW"~8Ehe`L>01vS > ȷ h2nmxx .8ܴC ?|C2uʠ M*Lphǀ|ÑUJ-$ x1lTvhlU3@Mu)=(4=¡q OaȄl$Leϱ[<8o| dstg湪U  UIAL%W=l7U&<h2 .Pc-V+`jP3ާ7QR[߫?#LjRK+#3iegfԦa(%/"e P[[ ;2DH`?n^.$@/.YY7csc)%[6Kr ߡsAU8~oW 갏SQ.*'r6C3//XYSRpE'ދg Ҹ\qQ#CZw:7wZ^M PM*_*sWJ'.VOjIZ>1hjm̖@N>瓰9|er;o׀_sEskoJX.~^KV讴j/*_$ż-Eru0JO]g,vR+= Wz{5MUU}&S@@ҚkɕQ_t$R~sVn'C>oHSg6Y+0uy~WVCb^IB lڪFuWY^'EZ!:/\$Db~)ͷ+.CV//ؔ=1~2C#C'u8,UFHmo *ZOqUD[^w $Ʋ}5ꚖٳPsڳwUʽ\:;VLxoHNm9Qk!7]$%o0]BHjJ^ڲ(VRE4OB*'LEт\$}E'YT0MA%P~qh!*)+0,J@E5+;~% xv4 RTmGoIgbO.$l_P!a LH=%fB.pD+aK 1k}\e oNwR}FΞ5A_U|Q(O\J ]Qz k~~ӿԦ(Nk^*<*pw'^$0~TO<)ף#X `*#pgL=ţ׵+nLX7E{A4{P8AO nI8^s6NV \V pq.1$ ˬ \e}% x/niߺie2O[[O\|v͟y{q+ѷr#A& <9[$xjK<иb#ګ(-Ziu9\VvdS~ZyC Z~m= jRM&@&oW1e6+O&W}DWƛMC=.@&jzjyba}Sn97-Vso7$Lu ǰs|8E;jKbLQ"@XGeA;b1' pU7@j*-x]`_blt䢵i[/S*$k՜oˬjϧkإuɧNPL 0cH֐6RZ"֯W#edׂ {W/HH{8=odQFem(`Dj߆A Kä̌R܂d^jS.ge@/| ڈbOfn}X7DN:mIضg?Gf߭*'!Q ~?= Ev %%bk1z Z&'gNE>Q¯y-8 BlC²fZ=]ό5ajL>0\wPBtlϋǎ$esHê~ TAJw3OHzQ%]ɮ~lLu7}T!#X~?z~L.*&L:Ji- 2((kaxO70BU%#3[ 3ޓ;|J#vp^zuP#jka/=WR(,D7idLreB!h?X;d mdkmЕM`v>֎5 5 _츺k9224W%s/jQЪy"Q!i\R[U^r2 -~'WjBj&(π gyo/l@mI*X7Z%^2D.lUXY,ddzXS3buX85>p';Xgǽ4s$n,Ixzs|?fV]kޱN%L Ka\oMI=TDC3ۤ~$p3ބ=\ɰՏݹtGjgIl-A<d St^(x| ;*=N@ &gR DYlCy[wa Tv:fEeC%X=OB?]%Ay]A俞ݱ?`π.;B{V!$sfo`lzg-zZuWU5zm!˲Ĩc`˘'^ЍԳpҕgzT@:3dfJexZ iپi=$`%&oTxa?0'_=h3[MoJψMIA1N>]:#L C[AZ3x%vk _3 }G\xQ<5i$B?YؔΞ'W$!o3፣Gtg`-uzn^lG !kŠlT} 4Bզޟe8g ++u s"qG+-I,Cū4DzV:#a MFIPVKd-_Q=m/ x$Ee^ջwUڐ#? =.s<?zY}[x"s V?ϛp[(-t`_r z;㫏 >b,y8G(aZ?%Il#x ޺gn ˔BPp[X`|1J#N ʹ֖qm9@zl-28pBo#XS #8,U H`QNvTL6x:ȫHv. qz YZ)owhK֐t:ޮ(g|cD?D^~B,ѥ,O gD~J>HYjdW(/yW? _ q%򝂍<@+qUf`v)&V"U!f,gTB0=ij m5k* 3bF͖Gl$TPBb˷9 K|MaL=Gc'$i=ʈoUrKz_b&'Zl XlU_ XU]=ɚ )¼g?];&BKh X U KU}QR3  ¼Fd۴*'AұMo-qs'։NgoauϯT|#RĽP$nek8Dh7 Z³>yˡYR3-sd&2"e6({mLB*~KL08nż"=H/}^ez0~hq=&h2o>l:Y ‡'q,BJʎ+GՄvh$FvΧ\*|IJ0f^Ԝn; _-,naarƒW`|=cILi?IkoowR/i0?^!K ]-$e4,0T?` Oͦu#=3i<›\{x-K؞['R#U БoJ?n|zZCGɍܮpi^i0eK¶L2wI3 1GDL7㙮lQ=afXM6 AqfBg{=zB"ƎpbjCęޤ@=G̔vxg7;dD2#ssm }ꁽsӟҳdh>,2肕K`ÙxTeK >ɬjo Kq`Xl;, v|/@x荩6Tπ}]Fժqˈ'Ly I7[pZmI6pBPo5jbHp+Iy-dhs{6Oܱ~߷ R8c'J%W+'D;@]a^!s`Q(π eĀGԧǦV l 5o ؗv|%uXh{g@R,gھ*Mc;6YEۘîBޒ4>/ƽ%UQwrẈ`6hنm%bs%Se7@.@u&[g19EhxJ;x3V>K9L8a%L)Jx;=Dܜbx)os*Du$ b.Fc{aW~䨉0l$$9CFjwu 79`zH<߬ ؘ y[s$ / o_(Q ރ{[9ӲMNNW.RG5aMRop7,ʔ @ƈj;gf2cb\SelBm,Đq(xfX9{ g9M1L͛Dcnfyn^Xdet=aY蛑wutffM4*hH8IodGDDM%N%:vs2=g߀YcfUOx,8-+]!Q~003Ɲ4NkDqoMٖ1o(6fMacr"paµ*ԗI@ΚJl X"RvP0P'}nX7_Jnud`-O1Z%Ytxd|;[ˆFfxBʂ`ERA?;WŤH5KN{K~f@!+i ie*{,:6O)@ ݣ0!љBAbyWdp&q&ggnd>S}-_=!dCUM~"7Ewq}U'BV.nZIJ"y_]gнHd'Du]vDnD|"ǚM. egZ.ҖV=JG4/VEO ̦VZTF.v>U?.w,۟&xWy'R88Vp=d:I'ek }&^ \+ᩪPoft87 PQe`$i</| !LAD)D1d&FKW&Bɧ]@—cfqgƔe,Aϕɋ"^_?VU}y^ҦkF^ ]w|)9JPY#@^a+<3; /FD/C]N-a''7bVxhu!Z{^@KLiKuͲw ҞӢ_j3yH#}"PQ̊o5Lc,RrD1 QQmi zؗ"@z [2|4 ϩ=*]>?Ƿ({%YoN.K7=ӪGPe秴 H}JiF$Fkqhi>= c͞[dV/13#}uFI­؀ $D<#8fg<3ߑ:yI"mJ Ȃ6D',_3 D୯]ÀDn]9xeXf `]NRѤrWlb/AՀ${:i`Wwfѡ`o}*9T%l_C@_D)`cܒYg9ޱgIyބoh Ԡ{ Cfl7фW{Q6G$F#H,1[_#VۖZ{D~ )Dl?eU&}^m,%ՓdyP&^1`&롸Ǒ9vF'|jeB|C_\v9nC|ێ '(趮9cdJ2FXFOAd<땵b~ fnݽzSYEpW"Zcϻ<󦮭xXqk|Iݙ:BDS˲g6d+"ewsG`+)wXFdf\'aoVY {'<]^Dl n [[E6fE]c I&``ͤ@&9fVQ[)5p#n/wh>6vaۅ)&.5Ĕ=Lt$m׎c%%B ?%3"4~]BX-&3lX=j9noX5_[9o0*zk&cwSm^LYYfR 9w 8Tv"=~p M)a5߾7m JwV`65;ҔbIsb>ҙd3 ~ SR:J{"6tusGN&eKY0<%{!I ˟d Sud]U[IU2{bt ^*|(Ϥ< ЕXbgHd}`X{>YƦLѦٓ_@sm>{ ;Z'A_QxGtAr77+E87>;iſ~l[*> (WIw=)5z|m]UDʕc"2=lȵPx?Z$P6rH *ʣ/xc֊w oR%qL@hf|JgsG`2` 7WJPȰt @S>ii샹]U κ2r,!yCv١&[ ۔ =MTC"qNxC4U?OpU?kIw*XioB88bi79SeG=iKm s/S^7_WN4uW|Vؗ9>_co(iN`P"WƧ6ltvot@e#/Q7 n8|L~vewd_NZ`X| ~r֯?N,m7a!Q,[Wsڬդ1g/qHA`zFXPJ*n&MI%gBчlQg)5sLɓhi[w2@ F <:G6q ]f%N[&.o8|BgX2)l}{-Gz]F&smݪ^[)oDƬagHIe4hi6 MQ~g Bx8/vH *ȑ"%B·_N󦻐Eߌ䰃Nڤ / cy q>7I ݆9k/32O} ]|GfZuLD4塚GK/y l= &r5ZAlwnBc9qݳg;@S!{tJq FY28pSZ/26JAÏ4Bv󝐪hRh3 ͞܁ qc YqSW 4Suaڃ˺ߵ*Ӹ$>ª(Id5juщ')DMf`̃9nUr畕ߊxޖcTw|83HJ# ٙ-]%j`|㓮nA {θ !u; yv:\~Uh6wsƓPh髐H+]6 I~K=mT ,q+vb.CSu ̟OI\ڌ*_baSe|QFhRN|) BGRY{ϮGpʕމj :_v~ aG rKk$ Wӏ &t, >lHe09=nETBN9"|oV ];- Jb;-~\&tQ3Ƹ5$Ej&&.4^E(Fn?|g%A7j+kx Wr?w0I ̎׬&NDWߧcJA- ;q`WObۏ= PRne(Sp=}<5<ohU7';ac' &A [øbN@>]ԟ>,=i3B'ϧ-VC]/sʅ'Fw yʽVK~d!!֡;9=fņ𽾼{g@I,+ptHPMڛKjP'wPQDZG[:e1[Me46<hk4ۭ uƞѨ \Do3}–qZ7[Tc$NH eo 6~zmf"5:l_)<"6DbQ DQߡx$%̦'h8舠.¾$L`J Q15M`s2+,K{5``$ ep#=ۈ(S%)˲` wkT!47%m4nCM/)[?х#s(׎Gy$uF֘(OYa=R2Dʅ#ӱG ^ Ozv2Ɇ䣲#cDnc ns7(-+Z^U,C;0AX`yg{kz:T}N.9U&⡪hioP䨭'Srm Y|`Sq,Hv=,[(|e~n#?YKf _4t Tw߀W  /Wa)t)el)NȐa20UO0r@AP:mQp`15h= 𳋲 T>3\Ӆ  w#D3dAk]LoG؀ R }FhK~' :f G1^{4Ֆ-K yeiO} KY((<5ka5ZG! ɟ$[l_gcO:{) la"@dZeDgTPh*Ag5~z9̂MGftgl V =ڕpROYˇmD8'j'ĪɼIT eSDi_9y&.X+#qԄ< Il+iK@ݫ=d{xMv)<:M1&dKGEaBA %{Xxڇa `и& <7|tHhg~DH\>}Z9#YTbQ꧖-zv~H N HMsEqBzny|(XAo5ZO+  cW(\JX1  YOhtw "/5E˺%VZS:p ;tQg{xU/o UG|OV 2q)%o'%IK K38_@1./!g-m ,U_ ejEK/׳%)00XP{IwZykAX CSƿm{-Fc(w-!ⷳ&_ 9tlluK$%%i1<yKdesPQZ~y*">4-ϕq]}̗w:`i#W5xU-rIfIxGd`myNx}XOw@{{b)*>x%2BlϙFC4.d*ğ?3UN4 gƝ[5ZxijDINq?>V:wOy#VRD`K~|:齞& C%",n`_dYYڔ;D$Dz@H܌]=5&`IDTfaH|h a" ^bl /qgJ٤áے|_Х9YSS v)1 ,e(#|^ y+b׸JSْMbkMH - ']\+L(EAc'k9/!iH]a4$O=35V+L*š'>{Ň 6Rb,!u`fYҘ d`LLpP6a _ 'i-ECib-n,B4gaTn %n*QGH s)NF,' @BscxCBCQĎ|PbE _r?Ny91V! v5Szsze-iއKF#BGH‹P5VePy 3װR}g= r+eF' ] 9ĐuE>y01j'!CE,y,+iC$_6Voo 9EyVJY|^#9XDz`d9 dk9ēkѳ-~CEO XEo7_e8npo2[ꅳvKzU.sӤ+ ǥ&p 'R0̀:*#rH f—G38 jwen0-d9gXh^ I@r.C;~ ҿ^wMm*cxg0-?3WTN>_%zu˿w'rJ2J܋-|dc2=b$ߚvaGțd";V3&y*HweO io93R#랤};W.g3WMM/M^AG}zO2OYUQBA;;)ކ}[d.HYD+\8*67K$J%MrB6k' @|A\ )F빟xn$ݣYpA)XSU3 2s WwݤZD^/eNRRռ?wL,57EYQ0ƽmUlϺ}_/*)VS$͜iJhnɚ3aIT)K٪@V1!Il/,rɼoع~v N:ճhT3Vf%{K{ I5 GO7rm. $<%KO+j 89#z jH$oSC<1_qm=Fi@k+9e]-on9:hQx-zw~b .+Z Lp_bHP[.T5/Nq5_E.ZW.&WC|boP9dlzĞk+Z~[RT뾸8pK|ywW8uloصWV1aJ+`7dHgi> DT"qƛ5^>in?a-T,{OR%h#w+~# >&j Q=inC1Tp\F}tf#iq$d7f/QdbR`ֈ1AeM5o{'KڊRx*U %[dCY kv\5#cZ:A^'i#vxk?KcɶdxoHO7j,"IBޜ}A6"-)xJV/)&E`=YXSP󧭳fYChSY63 샄<΋d"n#7`giw ൷P⋲n(J'Jݛq$f;g,HV}`ÄT9nQ@Q2qUfhF`cM_m)eŶXE(Xئ x џJ$DYM72 ٪hy"z8lzfyVOБ#;Pآ{> |=Up>W]o_Ʈv ꒷Zh3c\X֕a >T*NƸW!,R:T3f'|_\yN쯵XuekFϬ3"LCoP#&@'hq7 gb]>TS&Ҕ<+եDEKl aQ!3p y>VFcH {樊ߑZ> pT\d>%Ed.^k CM@o1oKBZnypY>ݕx+ &/Nh|j٩gW0ѠQc6%Eojߩ<Ȏf͇r;"Om՗]2d7.F:aukx<zڞf},p0|>gr=:R ,)<{J'mη +)9d,"R{~}mi$Zm'$}Ԅ$T*!T-D M"YJy1S I2#S ~Vb^.wZ=j+4r+bD}BD' 2J4Ew ̏=[8*oe܁y9 -n{fWp[Yx>;$$Lk&{'}Ju >p)]',Ff܊= CSLa[27zXIaviv#j;ˀ}bwU~dhtgD[zm ްgiIԈqj~[j$,hsVࠁG)KYI 0V?Τp"$׮ T:GGJw\~M|x {/@WKCIZlXt=$nD{Ri,vT@)4Py9-̟KضoURy [S+pƐJ-C1דH@%ؙP}4Q;©n> W8! 2iN=g2)Kw淚XDҒ#j[)ڌG&0My miW`U 9 '>/4|;=odaCL ނI|D,mԐOmx)0 fΥeˢ]CQMxHr?^}N)򄭈+1K 2D4Yb=qZ'B&b+(>vN2d'>Xvݶp<8Yjn¤8J x.QL@x:.Do pS]v3EB&^w/>`,|:\u'kJc1 2J @?#>mٯkD϶n4.<6޸,ex D(*>8?|Z lz`!Zҁ:kX _|_ }MEq# |#zxuew#+o- Ue~$iL$d_# إFTo|[OÒ +q9|MRvb 7#yvjxS`&fy׆3ec`z`%{c Gij\ `7sNo q/(=ݖ8V>Ƨ<ܗEh5/sx^]@չ»hoh_\x:$)˪Y>yoI*pC-= lRk?ۮb Orj~ E5ڃ1 k%hv@37eR׼7~eϳU%3CYT7@!ļe{ꤷ:2C4Ԥwu]IvuR-(]L:&eM[0eؕ;{#u@F4b+mE.aXFAF(FXP o79/y7t 'Mզ7m V \wϣfjEqR*@ Nnw;|:$pb膌0 îTL@ۛJ[B Yop5'1aٚ@L^_8lx1s#D(iA7DY\Q꫕ݵMןj<2Ej)5D; wYz!\g_̵)Y'z H;[亱GyU_}L<W䫍A< {q5/F'{e9Uȃ]vz.s[ﮞab 3jgEc¯$wPϓG.@Y[yPD֥L_j7vK^cq0w.cAneeUB#lʸ鰹ƕ 4aXL^P[Y_ jh @gRd =s pkUybBK0HI#U[_Skp-HRwYcRUT_^HnMCzۚ; Pg$)ۂbIyψU[6=pKh¸@(D[1]AgZ[U[ v;|0kȗqS[HHDO4U7YgsVֵT"ڽ^'5htrrDz˭H|Oanm"Wխ74x@زeX}3bwRdCeP brLhC𘻅ArKk|oV|gpMl?\y=ܟ0,YKC33xx(ذu;L+^@=L](; U_H_K^vv#7{I񪥩am(+9ߜjiZ?-<;b^m-*=yG%;g"A3#۫,3~{5\h[dU@=po#afƿӯ|: h#; M)c(z}VaZ_٤y,^_ay;(z0.U)#d4 C% tf * tim|7*twS&Sw/ IE II/ثKCBBt>ؓ0 5|GuMe5~%eZE2F%-*}w TV!)/3ܩ ӣ*:Y[f#(zt1~ƻ+(#ފq-:O#Ts/eZ$t?c8 O}VȨ()Y4`0%CIˤ'_gȩ[jk4?ģIOW8Fj^1o;Y*Nͥy:!g9.Y?Yak fcwi?jeƺPw7ܤ<$TVzN hl{cn5xAkϐ.|R~jƖ0ג(6/omQ oU[-N^ tH[]ޭvqQx5m i0^o-K1}_؀ЗޭЎ#8DZcwKg>{.4nG3 yV:yI ߖnA`Z2Dٱ9K@ un*FE-J,b;czrKurYB! D Cy&~Ea'K`LcwՏ`zB[+,TMXFNB=&jb>37bj[vT<b""8bNrg-apx$v-Wx "VPez6vx–;*䝏hoWp&~Zy^Iaȱc+~0xZդY W~/%>mI~7DfLĤγ\PqӇ%gCI {7߮=$D^.&p  Dُ읦"_ aޠZo 6*/rbC JŨv*JD q{uw[S d؋ n5>~oAnLap,,;?n؏U'{N sp+ dYβ#vpO<}TC@I{c"m[,`߮Ƶy>q|DeO7szd@صTʬOO,z| C5Wd#7" CzfHE؍VhLJZ )b J.1/fBҌ`"-hՖdu$}NRFG{FL7b~Gث܋skUdHd;)^~\&It`c\<[Y:,J q{t7"-Bxy;tG]cw7^?B)Rgt|:*44~>];K:1з-w54ԣMsR0j.Y!A%D&'J-c 8>z@?!'dϩ3qx[xb%LT{8eϋ,5O߳ 1ԦEaQ,H[Q }qs?@><_iģ\ |gpjU[NoJ#*]C_]Cٝ@#ȣe94P(둚4oN;=>#XVC!^Rh g14zR,FֺolU7]N-K F"\+]yтD~K 9^Q)'] Y ֬7_O;@n3MWӯw/L$h/AƓwyK/ߙ i{< Pb 8< AgѼ^E怗\Uߍ\{5~*K0 zA4kD痪Р?(LخV^̭-=`[O[xJ0p&hmMڛ?[-vq7xhp;`RYc؀qPW0JCo J%C:o2r끉:ɡvör`j4d !CvS,3C?ϒbejI/]f]ݕ>Փp}C3l٥DR}`w@Qhf0\>='+ zyZ)ʦ>Io.Wx.=c(M.(-~1)βcEz(gݨXͳ2@m E&+"^Λ~v~$_*(TvQysЯ: IPF'³J<4lJ 7 uYV4mԄ>!Q*4,9t=T| X KJYUʖ0R5W_het΋Bih(|D+Zd.=vy >3MSEӈ Yt~7n-lWNOsZ sܾImh^uX >oa7c WyDVi<,_( eE|ecKW: n;aĎbka_x‚bUsB5~I֘WYxJ8G`'0r=#? 56j)Gi^n#P{ (OiI|şR䦈ڇ3 O*=>!z^%bpxXk||Ey~JuWm,ȉvSMA‡%,a/s! `&uzDkjˎWa=e'վT )wGJ77*WU }{ {1SM[3"MkGw?ަ^?2еk>۞Z^K ^ᙂ%8>.A/kEM+d%ZB%"wߏ \xK` ;Lɹ7/| a %vBH:ܡ%`}#$p-:9ow␙q}lgÃOg3=lHQ:6t0f%*k~).&O 3<GA={pwпh;xBH4Hq8_xd~n6";Z ϵǻ}pj :! %W=z%` U$/,q;w8fZ9Xkxɏ=.a\v̴ 0OKD+a /翀H=K4zec~ F?g%Ӻ}p|luCGPu%$1O(sl{9a=7]aXsew̸zsɽlS@`wlKo58q Ӄ.5ҟ%[qgy+`I/ a_sl_5yS)ĺ%owQȰNY512o#$?xK VX]WCS,Y*T᮷eGDXFbq"@q'Dux>g%JPh%y}dzMK-ynWiNRU<(~M#.|8%Rz ۋ-Z/ kh;7#w"!bj/vA P FRWt-1ϳ`>a=m{ԅJx=Ejd߁)-Sp/Y r0_ ib7P),O{IS0$wyFԢX 9H k =T|Sm`KdSEf8ߢX)WS#4_1.pb 'Dr=OP냖Ptd~) ^|TDp')"`[XyxNm0+6h=F6uh|V* ධ54XBxow}+`I ˩d{w)0#߅KMUjP={壕Նo*PJ_L^+Rz+סPJ%y72'P:Zy)dg!wU NT@)2ʊ}7tFn>zZ``mHbVlJFj{3îa2+ OLV6Uf>FfFUvbbat-1JPdM aqVW\ @:A.#;L6rxܸn =ԯB6)htł>k @1FWImG~AɤYRH*4zahd"߀O^ZQ5bt6oHUn&VQce,GeugyoW=$2*ج8\F$; >꾁-jA` աͤijk)20Rgz[F~0|~c.&Fjh% " J(8-X^ TXFM狒g etgSSW`In}40oig7<.) X|:ʷ~X;PfXBht:,S{Fmv(lxb \x,.ДM/eP6g3̇I6%Q|+z<D' mS|=>r ɭBد9l|I6mK.{靭0?ӆlN,f q#ԘVo"{ DVO3duZj^{M`Pqi6*L;YǃQmkٙ[+B;Χ=Kj3dLNJϸy?SfwUXg<|Pާ>^/`hT®wS@e %Ua,rȻUՕqWzq<|3h˽Nmgp{+(lQQq1͓N<˃4Cg"SGZg=uC߯% E(륎[/TNh.jGqGO(d;|0zN{Ă%c},_mGqXDgOȦPl/ݙ k:]R%ض1YXEG14X%R~-HpD^-f[=gH7Bω7NΣ~4Ǘ5dB&.cLޡ+vXpoɷ7nJFR`3{* tF)6 \={jn" ?@sYVB`"@O"TӾ',Ew&R>QڍyԕM'/"yWQ &&3@7 -,V}z)DߥPPc+~ .h!p&8=Do|?a*’,mˋwK" o&N [c (cH{Bo@@d%3h5ĤP艃Ȉ# C>ui8" 獍[Cݖ%XPrs.O{,ȞC)"w@5c [Z-, gW2;xfevpͣ#y>@ xY z)~%`B bcHl 0YrBx?xUx,.eRjӴޓw:JPŒ7{ tâNiZ =J.^/3s|<>LWLC8xLtp2*hW;R_ epbޡ紛૚#?Qb|4e8`i?e:G2|H/[xg+]@f$KDJo֕_dؓP(NaKv|=j3_yuc{}o6y.Kv囚ױGxxwE<0:Ko:)UNvJmCddY{uӁO@N̸5<'<%L59zw -S$ІZӮ2xvWV/Y2![St+7TUכzw]HwVoO$7N~DBF+GB磳|EhTh5;8!#5}w.8p5 (v))WgWOmB#oKnjACO K5( 36POO59v ]b귭wyQ$ )o`d{T10bAHjMة&tF?s ]\LET#,xx֤J'g iNm_@/w5M;sJWp=EmB-Ho/eOi~G! 8~s%rZ>}F8Gy^0"]"~ߊܶ_%ΤOb翟"ed{mo=ByVWpP=s"|(_vaq c%&C#2E-4*Up5-ᡞXԄZϖ w r&\;F/Pe }sn:F#dzDNVcThqg( _T&;5~+LzH@ׄԄ2C/{5Btm5ӬnF2/3A >a}H"I0Tk<:JĦߥJZ'kӋΘʅbz5?l O!o}v(Q+[$x5VU=vm ltH带qWGCϐxEaĉ -=K pPEv/V+ p5{j߄ 2K| ˤqw$S[>\Okʓſa1iM] >3L܍[C0."yb iW޶łNY 3v=>dGy{sg1> Ej0gۘhv7?Z̪Y4<3^~^?)hjX >|a|# /ΤCyII HkK'"A珵*aHxÕoc .ˌz%\p0/{}Ӈ0C}'Qh0<s|?z.]k0;Z'<,W𿴦+ TlrQI8Om{jw; ўÿo֧v"r@5\]Jᆾ#2kq>;hBٻkAD,"m?fq عl0n+@z^w׌f$0xсyєg3Cq½ydK8؊2nI%n&b ߠ$2*ok" NZ8oKeYPyzGG,,HAa\~Tgߺ@x`ڽ~><fۓGmdonyU]Tnʒv&*_YC)Uĩx .C5ו%}_+ܾyVcha/w-?> $Cvv?`T"/mg:~_R1=;SiSRh aؽv0JE]KM\~r+@}1~䘠jKKgIv)Keyr"u :5'arY;L6Jf[_4 \&| zΫa_ ۜ PԻ #RyR.w25ȣ*ؗKdb;+$c@ le;ѤX>]f^?iAY"‹wD{|gg˭ )\73 =aٴ -S,J`WB_5;ÛJ I=(u_Q%hg}˃A!YUMX}&¾ ϶ƛvs|e ]ͦ5%Pǎ. \_}<'IUsbO ~?lm;8qP.]H(xJ(ӧ^:?Xzt#;uWn)os}m70Csw OD#}>ˠo֪MRE *ݗfvyPboF^2 Bægr;lu?  V"8AΑ<[!㜯Y%P\bO7{\s Pxqyܕ~(BeW lfvЈ '|++j}[Z;Hog>dp;2ܳ0ꃗFpH{-F>m!io0ke ԠOB#]k9{oCPSHWB GuSYUnτz mH,3d+@4aZ\;A ^s@+H!0,_͢ ~%U9PZ^v[|-VuPaRCʽ #HJ-,jh({St<Tيau'{=ZUin+M5+t'tb~Sl OghNpt1_EnytSxݍij5ѾD9P}NG4C0A;҇T,a>V/OV[Kt|Z6bfz?LY4=W+v O*iRq"z>!hchW 3<:HAfqt1Ynw{?Hz |mS$( ~زRٲsvK+m| d}*XEy\CVe,EgdX{X$q5ГyM:|]-i+IJޜbk_þjpJ_G7al[M3Wpd&[ޗ@wZmװ3'~"_HM}K1$ Njx| Mr| L:MyڥRN<}}_ ^^UGj ܿQ(|< 8m 'v7:8@W%DS4r[-=U{-:Aȋd|M#3BD=͖;@ע+`}v%L )3p;~[ENPPw!B2?BirjRDI-?&Uel02F2 p;`c< OCZ%jmOdR$,-;cΐe >W^/qR$E/xˢw%H3΂|T{}j6e72=c^Lo/R?Wș=ab+vh߻[GENki%}RШ:s1u߭(֥+2T]fZH^N"1&PY"5_7&vl_ ~T?= j*l ~_caCkI@5Q{ЋLHJaluL휅5_>KFx~+;3<,cMW-%ߴYOh ҭ)%L#qXr+1ńz~ОÊcM6CyA#4'ͮY%;K`tJzɶ'(yXzRKF~Οl\krberY녥Mo<9BUL x vnݘU>*ܷ#"Am5uʺ4wA/ЃR][,?LzGp#ood-jH1VMq)ꘃ_W7d/(^R[ܥp}K a>mx5 Eng>+ (؈!NJT˓2x;ƾ(dB7Ka J ,$>)YʣǾ盪 Hop}@q4 k]p~h ў^o]ER([{ 1=uZCƾޔk=c-; ߱pi q? &E3&45T\ Pmu`μ )q,#Ŗn&AP"z,(-;T<9HQ!]I\m11T܃}(6v &T{bMaQڢkhRD463g VvAvQ0ypׯv};L ~)\𧄧@h3PS:ӾZHb0xlD |4z48R>X!8/yEC kn{DB(ػ{gؔ.dr];A&!OT\s ^@5.~Ȣ澁e~0#:zV2b@GƶP!/kAeLt8z;YQxߕ| %}j|/h3Ի_J- ?>d1=KvO'{&C~6̹=̦+!ʵNrer3#ӁGNQ_إ-!.^z4!qKPBxDa Ls)^&,[WǬO7,~夼+Yȑ;)]'@Re]NA %WwZzPs=9ϷX^COwwde8$砬=U`)ڠA 4;>T.v$K }Ft[ɷd]1࣐TP 0*(z$[9u|PcӞH\ ERe/ ݇sJDa*|O8FsddUEwHZ5Q=3EMMcupʧCWnvGErDJp-G`_-\yJSdϦXXo`4E}7#ОH`N&T{8؉P_A~ Ff3F^ZR~ bHujR@%(+h ;.KD; 8:QPn^3E W6ނt?yROsd'ķŢcF , +j l'i,>M*75RV4u& h|Pf"^WRvW@G;m}~k|=𲬰S bH(q4/5=㖶Ou4OOUn8UiÄOK3;ۯ0,W#VY 7Qכ'5CZ xw'T+ Ą vLA5AAH5[ӝ4̀O_NfT 'зv s=º9lPB6U,X쐋~ P̦W0Oo!>NɗUAiz@ tu,# hn{!Oj G3kk!kS~Wht_N\@?~/`t/Pq‰fIoQbxN94-;",p栩p>} ;ZnSO(UCE'䶇>)s?l `G1ޘ=X~cR-ststE9TM7f[0 cP,Mk2_`Os/3J=4Y g$gy[Mr>Y4 TC'hiwp~M?.Άrq²ǻ6޿*G /ܸf^W2 io0RW5}̑eK{]G}}",{@4,RoيE/.׵*Q bhP g#i 3DUOYkX+}Љ-I!xo$~ƹrȥkBדBM? ?=o0{zyIqa^/PFu怡u ?/2}x/P"_r)<[ W'CǬ7 /p~9QɖlöOnQ|v~db4?)<=bBqawoٳlkXG~a3ǻjt)|f.섳i"Z?Kx iL%9v꘵P5Y.F;b| [lxO Cg;I ͣ~{a_*u('*bt6wڦu(V^5ȕvw%4Ȓ}<نty!6d'Nɘv4T, #b S4sgO 0YkяtTo,CNI<>`q3~2Ka!X~y#7ʞs@7ʽ:,-\/Je| opߓӗWDS"o;oWhwu^CZnq(ֳ7\KMh}tPmB7aӷo~BQJhd;;WnM7t5TM!}U񪾥Tm_B2|\j@!XA2@5! kxc^!a֟/܏Ϻ&'$>ز Ok~V[&ãϧh;xj!>T9} no]tnTd4d(H;;ZT0 mo5`./n9^ZB "AꭻVDwL~cYX-ڗA^odKu\ lx0YXYC^l@ڿ4 eԗ{5Ε7̠.e^?&ĵuAPTXl?(sCp ˩\zpkXGO&3\[Ժ_pq}Y1--U<^3VV+>\E{ N/ J8[Y,Z@0R;E[(}c!ܱ?SD(5o!< 5{BqiG\ˋ!W d+6Uup߯p Zp4C+\Y%~?hޛN-|ry; KMC?cD gh}gfL)yQ^Ѝb=}X@!@v#dJJCu0 Nxo6}/A} ?*knyIw0Q)z*r!*>ހ;ՖUoɑ~C %"!zزIK N}t+"El^p^i+4.E>?`HEu fd ߒJ|r<AoZ]  T]%GkumȻ 2 l=HG-8W1 ((<;{V2{h^3-KN EY;&[@'dzcOJ@ uydtE{qCD=ug ^y{ B"ö N%D ݏ:fz&_qmڃxh@E}N 8 rtI'LrrxY+'d#\M+2_Sy6֒CD\n<#%փF[LyW+ޡHUbt X {^"s>[Rq!z~lwl|0dk2K'&akI]? v a∪V4yS>_Bx:(: ᕉ&ऱdnxßrfh=pj-y}"#aM`=ϟ4-au X\pvQp<&P xĖ8!˚$q'iYAI}G\6jq@T 8;_(<JQ.Ob(Ẽ kH$uP}D+%,i$v1!Kq1yԅDw %`2;w ]ܭe'ǨO'RSI #r槌O*/9" nf NUb3)c !T=i V+%SRvZ ~4jڂªFH9u]#)GPUCā~e%KYlko YpχKww-¡XM" l5.E oE0o}N̷IJf!}>O0h*V aާ6ye#k Fؕ( on~Uw?^>؝R{I=~33w?Ax~m'VSbt#pcvHx>El#k*û}~[L:˔[lG2Zk^Yć ȷ ir΃*׈. `I6/;Y((J5ï[=IzJaJ Bﰃ@%ihoq*9gP2<(c{ zu͝*|#>}>inbhk~] kTs3|?=<.mGsj30q?z%k1RP$ÓzcO#¶92Mc]R-$]G㱛*qp\MjR]ҿv4 c|:W~=z⧸[.S4\'=S#2<\}飶0cS\KIWȅ;?Z~BFyXB J||G|WS`0HjuLUj)I2ĥ'+qSj;>;\[-^D#9^93a[5ӖN"lbu(rHb[SU=;A%dG SW}Q;ʕ=}X IGOlm Dؚ >av ge_:t{~EZwx;7[:#es*.weed׫;8 P0r\b``|;QC >#> @F$}X!0?!f?p]M|9Ҽ.r5+E *%/x!.}d!s{Dq=/s1|xJ ;h;kֵ+,mm!0l= \xk=-G~!Q&=lT8FMՌƓ!QFL۞|leY~mVsα^'^R` {LT)bGR`̪'jt@ÀDỳ*ǢZ'7{/0DcCi.2$ewRunޫbAW^,77 ESc j#Ub2Il;OW}U;B" TEN͐" H T=Ym}_)/yQ8© >yPcޞV kwOsk?U~1_MZ;p+T| cGjVSmj);fUE&vLaܢ셓tѦk[)#T,iz;g\׋:ˆM{$wQf(MӮS> OgǤkܰA_>Yt}³뾋B4m3zaA oq' Bt( 9Kt/я$뤊=<9ee!wOG*Uh'mGPBgp?"6˯_bmU鱧o\Ύ?]>%uB}Z|&4=&=ӊmRI?(-4Fq67x[Pn=LIjf$/H_T[H H4@JEC3x6 M޽[ӻGa{XyclvAgo >dF QQ^Vu*8 r#H\Z->`!z';>4-Y]R<#H &CјT~dޠE`Kk+_JewVSlx~5ίmK@^l "jSfhGFa&47kr<.}qtx V:?G'ee𹹅R'b2 ڿku{),,o,ʑc_yJ_!1]\{qH{H/דxAQw liSL=<@.a0c$vEToMf˪@'^ı(}æҨ1K$So.%ޜFzԵ^1f:)[bY(2cҦN|A'S. ٽNBj2 kz!>48cIm]U},]*)h?}{}-щK?-ȃͦ7O=Nq ,Rs(y#, dz8kmk$^]%rJy[rqq!,{z>KPns8G Sh (|Ij}߿ho[ Ҧ%5-4`;ثmasdjv$&oz~gu7Q 骡Ȃ՞ᆡ݂.%LtPS'1 QtA`efqEP"&CGAN3C9O}D`cK(;{@[a^cﳦv*eM:7AAO,UU6RfuP"7q܁|5B@NlU|Aޔ{4dy'hwhO{}O.g{>,Rtz$wYlsd3Z 蹜 );t6X& caLtt;c`f [r|Zad6G?`2C~''(>K=7Xyr[|0zH 帷t +TW/GBAވk!"= zògRO `d}*B[&ƎQ$)pt|G7jvg yfKCLO>ԇ rgz2) UK`=-PGtB t=~mD=_Se^oT)P`t Jsc?fk Gp)]£*zW$s?mvw3;@Dh$TωUƏV[ŷI:"ە QT]48cM/@oʬOcÊڝ桵4}Do-ʗYhI*-$1mGk=2.^ V"TZ為Q}!3v*^$¬fߒHJ䇣aėDG+-h'4|2c32`^29XBaoIh$*HߕAixڣރRi m{Y!v=P^Fͯha'M!;W@oMĸAз³?s$)Hi1@:M%m_u^=Hŷ⩑?!~ҧ/,aP`RuolA~tM0PÆpvL;}R|lB(z}d2k@e1#ieȤg#kHi/K$%ǒok3#gDi T3A9(|?n>1)Uﴐ: GalX@Ìn<dOG\9\MvG /?V{ (t?D5z x&5穓;/[;T;U:.z.}h~UJ0˛woSJL sEc&kdawC6W]]Xy˙F붮Gs7Zԩܳ"6 [Ŗܟ@߀*O{ss; Mghq ӧ 3j$YJwn$-E"ov0xi^ߺBs2?yZo)'h/Dwf-j 7Oi|J..׎TV9~j/U-? bC9g^x,^}ZblfJaj`5,i/Y{Xʙ<{˥ة>##aG <|N;V8p+.1O zz`ep 08~An?E<Xݳ3 Dr]yYDEsZU#~LP[*Lg* 15F b%.`F69N`A3#].h5e<4Sa[%$m&Տٶ&{i[< a@G1p] (D ^(̶̵GÀi#<0+KV.qL8xąCB$-ɿ"eQiق#fMgHe`U#; *Mg4/0tf^@w. +WW*4iS:jDlQLA`Z@ ֧a\pPyH7(_~̎ҟa\Mӯb7~^Dx16d ,D@Ͼs{j@_vh'15daPWh挦aP@YÎ U+,8Dm3͗.ji@cbBjBiS&PzCR=QeR,Y?HGFtGp!,)IҩfuIVSd%_DP6T,3;ac"C @BRgBPE9xq6a6si1Ʋ\^*_8C{xłrPՀ#S64O!Vm{!JWfAڵϪQavЍBeAI=I 4Y!w5A&cFRmwaf)nчv@k7u> 69P! k>WH-öUF ~^ PTx{5ɲdM&Jl:-~9MTv] PxN1 'WM GgIzVfiQ.C]MՖc -Q7}`*jRA3>n9Two^/bX';,MNMAY!D D|˘wл*3Fzn dB6%Qp$74Yy) U:@!AnJ$qU~;|dh/{`fhlE{/z:|Rf3VE^7| $ՙ)4wd t@Bk{wCjq*- 9}r)$%hA(]MK}HJl^#ɧ%V\ENz'<'n *RL+vĽ~8gT$5t}n87:k8VV_M"h/V|=j˶D+!J }[(L9*W⽾jK^Rq`Crf߄/=/._n;1I Yk؍>`ey扒@oPhHm=$7@[$ոːٜv7PA\?-]'3G$:D!TbίwFΪxQKV8fFףWpgNvX 6?MƱrqX%S#iJok_0~)* 3Wbhjˁ@9ůŽ]OؿhAlrYНX𻧦bOՄJÈRp0BN={j;:uz1 8WPwq2({+0lrn4J WM%ж%.R!4+A%d%'gy&c}gg wlW|Av.=B4Wソ#ɾ(•o9kJ` )h6*{.Qڄc_]nKZlj۴%.zgBY33I(`cC`dN1oڮ̫!.TP6Ym3V耱9B~<+܄d:0b'sBT-L]ˡ]Y/ *ȋD9ХF[7Xeaxe_ Ԑ'[|r؝xb?Qk:Ls`<7pϫw}56^*|AWѾ==46|WUOw1tu`q0T;|O̎-&\tE¾ޟkҋA0n8i("{bM/Jqڭ#4^ӔgǷ*FD"Pu*eruq'deИ;Z_&o9e4qLyPL.ՈQ:뭈AÞQ_1x$#D)ʃKDvD& v)N`J`@S%:wXx@(Ѕ189匦SjXbo,H2+'/>.$mM#<$Oq1CmsdGi, \!uC"|xO`= 1̤4׸oj=Zɖ b}6/&o.L҇ɽHb`^o2 '`%B}Dy]AV٪PPlan2 gȓD/ '~(٦8YC.Š0l&qʽNf,Pix}Mi[0)?>:8J퐴/.X|DY7L`]Fz{x~U*/r]O98<(O6kʞ(|x]gcX ڤհdݬ(pJMtg.F4!mMHkO)i»0g ^>S~tqVo7nU%AVo }&k/k"7J< 9txƓ{o>[iagC\zhۙ;K~))%%9c,WIKߦ/53nڋ*a$i"hK'xl۷„Iԡ>h#ڳT4Ĕ%1*e<1+ӣ \aI$,zϦ[dfDP< lc$"|d0<~;MwLPt θWlctx<ǚL'USjEDЅgg74~VP@k$ևgv Uȥ ȗlyK4Nx 0ʷZϴgx@j7PF䃞"7L£gl&)uK|[_mAfϦxNX#H `H1փZ(O g!- `dHX6 C E85U=] 679vRc;^u%b/-ڗ7C+6jד~$vl>U R=8'a sQ$KA#ih#sJ) =OL?\I▪ zz 9ED'd-sJ7{|L>ܤo3GQ7,yWm) QW`%// `W }qIDqUJ.<Xk`1EYj2\şzS _3F;2+@+ '>3 m֍TeK+rpF34IVFeėTʾ*qGJUYğH)֔UZz (lL~[VpGD[`J&FI1^ ]Ƽʋ|Lg_`;n\eipItݰyj#k@laɔOַ{WB./ eO+2Y|tɏ(}7 ?uN ;"A"B3cτp=x=<%%&A& '3A/Ij0+VNr56|LnǤs(:(z?Y|4endܛ% fi"l9%kPNۻ5 5%6X#-sJH5Jϟ;{j y$47vğx&!(7%I0vVvwgsZx}Z3Y9X@県,d=B:zl jv`=;tsuw&.V5H^u!ciE60{,`t"w wOOfUt\XgOeĊN!Z7F٭ԝ^}hъ;ؾ }!61qnVB}[,R'ڎb1P[ao*vZ-(lr:^d}x7AsLo{2f1S gIpQ0CBX p?'dT+ߘF>p Ob)?OOhh+f9sԮ4fcoliHכ툴zV LN@1O!|=wQZWBZΙ9v$e9y`dܷ#'/揸P5$O pEܒ1*7032dPL7 7ڈSVH/GQЌQYS }l!yaSȞG}@ka^W*gPD;jTVK`%+ 3Bua=B0̢C'p C3.VIDZ| .*큦/ ^M!:j،6ͩ7c, ۫Ǫ; CtjF~  6C;(~&<"mwXQ:L'jDxBbJaܮ4,#"[$ԇP$x󨨟%eʓADaK؉Ksl^p`_Ȳ"Be^BX_* M~@)(P"V|6> w8:T)h a.IVox6W%] Q(PD.߆Ε)K;Q6QM/^D]9kh]xcu=z5Wp8f70,eβSMyCz٨ANK0I6]L[F^8 Hl\I -$SL jᱍJǗpQHGbՔk0.D_kD IPvYG 7G|S̨w 0Z '՞\4w N [6`l E^;xm EP傋/l'9Tt (6AJq=~{"LD]ف8,d%]۵2= 7hw?^cYL%Q[7wZ7v,@gC7P=-+YQ$- _Z~:0ɓiY:2ݡ&t` 6~z[r*[>X0+Tg*f%*"C hN$Ry(tY& NvWxN4A #E XtbmhAZ IM7gWswoS'@%;X&AufXQ`할KBANMĸMHiAJlo9֒V7®|P >jZ2PzeSɚZ] xVO1@.)Qn׹s&-ٶAʪ%n!T5"p}{[{$޴0m$8c'ūT"[ NP|a (;apxtx2bXe5}^dǀ,7ŮMz 8. #I{=a(K-=7~N@*rB,Q, ;rC:c*o*|<( WbSCwz2g}Es{gDYz8T+>GͯUV{ݘ{ OKRJ#Y?>l| ky eF ~OɖNڱliK@6O^Dr7|Ȼ^_pT(Xm47ڮUztxnƭm&a77a<ۥ-'y+G:{ipj2C:6HYq61<ԓ@69' La:GpQv=hJ^qzѬd :5r1L" x3@J r~̎sxa/k@\&*Cѝ`([@]"6Q]] ]eE ljL}'MH ף]1Ê҇,ݸqVOtdm6wYa!1_`U$أ% Vش;GV0WkIӖJт"SnS/%wu}_v2Fx0k:ߙoN,"Xтw ¬$[68)7PY H|g fb:|0{ ➙DŹ프< n'I=IXXCݳX Hm\8>{i Է<0d*}xc++A7bK;VdUp081OH\V"PȺ/5=d Ӗ.E  Jl0i\NV7C?uw~JaUWMeضc{u72lb=Ve?# ?]q81uXOxP$E_I,A>*2'iṼciNjEY}C@NSؒDdM??y#1adUb~4rxI*BRŴ;VJcgq_P` ֒uv %{OėKfud~M:EK>Ėvj. OSb'>vtc$RF5q"&4Pxʯ*(;Ft @~$Sa:+-0,Aiܝݦ{z54(d`HfzL:f[2,aje*aql Gz\E8ɇ|#FCRHwrɇԳ1ǭUz(*&;q k6(H0IUv40b壬Ӏ]PIH`1\_+ȇ0Z2+'擜+輧^.b9IԿtI sMz T6u^ =9ݱ5)U#yNJw{%f=AH[5; Y/([da0r )ތOP3?wuEϘIRT8(JC?f!_m4z0sV";>zfZfnknJ4-XyiOGzp)KODg#%Ԩex9 6ﳪjN=KJy=7~2ĕ h~`E0u3w%I4dQJGS⅙c1񔐞"gmB7 p;7#('$Fc}sB i__(JҦ})NO95{MS|Rpv.-IDKdy`z/^)b8FwLZ؆UΪgOIן7\Ry 'vW9;hظ'L h|m1r YS^c|*DХ(Bɹcf?EWI=MD^ i8֬,meQD!|מ}i*0$d>OWgX"HO5; GHcj'7J: ~3i'F W{V]ywYa.4_55{:HEDh߃ gs ѿ)x`Cvx ?n*6c%sJؽu*-K=C]9BlzwMS7U l[CMl[T"5о0]|XSЫγY-g?O8 ݚ(7A"݀O#Y?%m$ylKB /ȫK 4l(Sݘ|FQZ↎-:VdS/@p=DK |Yc)|G D^e))j-J> Pg i%=QŔ) MV~ɦ.O[čD`pѩi^6[T[Ց6=1^sg6d2xs={dLpB~U}5 fՓX"{@w!ݚO7$tG4~ %EBǏ7~D~3bn44b87'B'XYz]%I.ԯ ( jL%YdIl/#6kz6K.{~ۀcԢ9+ `)j\bpoR[ Jw4QLFa)OLsMXY  jI*,Z:coT!޺6RJh|_CH tG'7%vK] [1 x⳾ 3` !9F `| E0Z) Z&0ֵ?Y4C2Vo%C@ͰU]hByw i _Boeq?ApÎ1\;Tshfc&GZ?9OE6HAyE:M SMS-4445܀&$5b?iY*~puHnLpf6Rʖ+*ʆiՕ  D >cڿ]r/ꂌ⧣,ؙ >=pn=4s o'w|>sOM/†ܾw`$yXzQ6llI?`K,1)'6oZg{Ћp;`=S2pn0% }]X K3XO(ӟ8O\쟨wzJh (ߩ +N8zһ$$+%$EcfazRQ55[ۮ%#[3yې3tVFQ$U%5 b&LH=m3+;QAFG^~!$CsA[VL>H-YMEOl͈ ">Ν|~<即k5Vl؉p4aZ̑Qja$8+s=ÄeaFK&LE瀚xt)>ҏrؘf9~ݕo!H ]+G٨i|΅y񻿦D:JI] cn}#|tk \*LvD Ox ]q:nW(gP{N+9Uׁ'>3nhᵆ`K9l9bC}5,3>(<<9 }u ~K kR6G&+3)qh(N؃>Τ7pEiճo_+ X*{+9j$N xBKu] I2Ԧ4[EU!nR-umz0kd\ d9/y8B]r6dl^ CʀGO h:  p,gF[- &rf#>FXLaDe0|T"C5x_LnH-!Rp(_D;(B^zcٔ 𰶳}kN@4gҕߑ1t3x)xW{$,M!eKJTP VH2fR=TBf nJrb*ÔnDwO<bAL{sV_vO ^KB(ߩ(z8΁ )LWϙzds10 |b[ӊ:||K0V eϗ}8=_ubn@:͒&>pvႛ1;C9ŏlQfA?eK,@8/}^, $IOep'wSc8/PK>iqIHmn[V # x'U[ktNL-k(1M5o)JF5I%lWAf dևaL^N i$"Qb*Ģ%>61X`1(gp쳳XiQkfĹjP;S>Ĺ>NyG١[os!l77[mܴq WjPn!&kg5h!*DO~kD!'mGǴcr^ !Eyg2TT$zkD+!ȋJq Zoڳ )/U|OVGq9/&xHYLB4Qg30ab(NOz0!Vl09ZEb=$T;_ 5"5) 50նS'_-x{NTx;>(G6#pj%h+FOa&wOl_ W`oWk*͂C0HnOq}Qu-5i)dEׂC> DF &4*1d<]q`ϣB;_4c9ORl ? 4DקF["Θ!5/jDDY<8{ oxk|ĺћK$ڸ5sԺP|bu.= 8юV.*%2ox|а @l| t*OL73׏[Oy^nI.$6oڠaec~{=٦']lˮ]wjأ+Oᶒא&OQeMSnxon5 Rj{.l;Svk&C]\+S#$(;M,d'8j}`[z;L*0,] ^(W6-t@rȀrS; ,^͋#6a67&>Pvr hPS{T'S3sqMN X v-O_.ӿ6 ~PWkN/.(Ke~WfP^5{f""<=tޙ(PQE:ozVy ,VJtX/`ϡڈCL&K{gIb25J3yaWND0qPه]5YhKfw$EٺbTk6WxWhF#agӳ5] [l; Փ׋Ɛ18 ArY4~0'εaEcAKҾٷn0x} aɶy=d"|Ia )Jn)7*Э5h:j'7]IaJF;;!tM!+Awom+~S&%L/#:)%0eI?a: a%QwIo؎Rtc9v{' sdqB`Ѵj7i_@m%왫q/V֎|h L\A|[aG9stѡal~=c:|91ZCc<ɬYi[q@Fё#Ƴ9b$ׇ[ .<04K?OSo7}8:^JĒowy3fe1f9A x?vFBuz`hK-<9kgŪ2F5L~v" 47>K͑&ӍL=&Imf7&$E{yvJE:PxH, 7 )@ H7=~(ϯ @ x񾕦$YR_y&}Q 4^1<:Df& z?SaE/)1 aU-'1rz|3P"x@"ewoar9S« <dW*Ft[>{ dه yGXR!k4V?UӘkoA 8n{ۊ&2P{7MzH~12٨ V#x}-uC^'TġWo))/KJ`+œNqO"uISJ kҀ8=94$1hIr[vP:Ԗp,_VZ\RŹOA#&~o01+Zy]Nz>/9rWf}|ݲp}Ӗ䞔V|$bH o`4NRe.=L XD;I*ǵ>rѱ\Qf? R{*UwSrWyjbq43.1 #,E%~@>^lL4z ]G)Q^cWW|pe0$TMIjQ=`BjWJsSgӿL<8 N'LJDvf_?9tEdOѼ{@?ЎK' FYT0a+t=1|8[㻰^-٪x44cjc(ɞ0^ 2@![ãj_cFeQ/5 =5M۲cHkJU swBgJ([hPO"R^5ĺ;B_ʼk7c60Ӽ%N lVj;]'T4lXڸDųI%?C[ͺJ x3clF5v^}S /; ,-lell*$ -}P!gl$ZoгyZѺOWPr [^B UN;P3FHfԚqxs+b4~ _{]qI]io;iR|xRJ,63B~@.| jzkx&}uNHcy9AQ9l!z,C"&)hS2P%usvt$Vd͞f}[YMI3<39  r~8(FYD9cg]BYQ!m5!xa5 6d*S{"C/oK;$?6ݯ}lp|{Q{1l5ݕ ڜ7}&-ހ'"Y^|2M$|it"RNB!TUA.=/<:JEj5smL wdTۿ4&B.d+"`QA3\7{$Fą\;+M x@)|!IggH37cDSc;{{zqۓ(VKO:Ֆυ=}<0_iy{X UbkѷPSOz<4e^_E28о y(RXCI7zS?G#'E%!uD4_ KAE ; P`g! ݛVlƟv_n'b5jNٵHd1yab`[!# M O4=7<@?Z4Txbv&1&^b1؎k=}@ 7}:sxG=aE1)v;]ȵ@A(;]Tv_\pd&d>xKĉB +(fG : NZljSyz? 56S s߯^6 $Yl(?ۛ'R[bc {)rh㎉mP#ɗ* 8QЎÖxWo(Ng${n"$O>: 5e*";KmԟJdD֌`f2~'&zs#2&"]/'[(Fzb䚂U4moyFDpv^n9o`hcx[G8 !3&䤣 hhM~Eݳ R 9_WA1Д&V}Ȟ(ca1/hE)%H;?Oxh~L HkAB;T/ͤ2 skf`D| [?z|g!9-wa,Q*3S@gϑHo>sT)|I.i67{JF ^I1)xݺ! :CyA]$xD(s)w+$5|rm:g1#* <;`zӒ`%6U{=G$Rӷ܉ŎtL vA &Iy<ai3g4wDJP7p[fiaU=r#P1UMf`~R5>IH*G _Vs'rGc46NACVWW[],nKD…/:(Hg7k0LWY6 ȕ\B4X| %Ϭ4w-ߣ]if`ZCt]'K%qad% 2P<' e[ hh}% 4Z``>֖x>0ϽM?Ϩ2dƅTƘOJC"_=-Lb &Z0*z}_UِidOkf_A48Ҍ {>p&n$,JP3F{B~re1'˚ã)T'6,db`Y,g"0li0BAg6C1jGʑy/9G=+1H/sdWs~t/DO7? (2 }W搏OYńo{3|/ENGzۣqVOw/Go3#xwFS;kޱl_+?<|7?w =3-'G:?G])9*ۣ/`~{'o>~FȵSƳ۸8 E<Ɩs9͝HZq|\gk ?|ޥ<|X?=fT?_@CW3ן~=\wϳ~Mw~ްj=wO՛Rut)t_g>y_W{?oz6yG|YC>WVx{{ֿ߼N_> stream xn$]`{Ob{ ;v{}h݊_*,dp=yXj=|vt~3n\Ym[/m{U(7kw^7W-sY5ga|!l˸ก;M;7B;X;#j!)vpS'Y9 {^鄁CnpYxi]:|;(ax8⽵0fѶ%,[-U};ݰw0mڴ\I@56)Z @wZ4,LQMzx= [wBwG{IE/5iAcGFŞuRy8|s ɜ)+CQьz.y6[ V^˰(A"&-{J>ci6-QlB&J 7[=s&+eW\VcSe~b]JM%b̖\ͫ=vmʟǛ*QO26*7ɫ U1,3KY-P0.Zۄ6d,U>?'##zY+7xHdufSUC%^,cq2167lFQ=8܎i_hZPxzEe@Q K"A ]# e͸T5ÿLL9qy{PĤ1eF@] \k.joZ!nҩ2UuC?^_) Jfy5bHp2 %.2w^J}sp (Gb)m,bUWV7?χ 5,lyV ](,sysJ΢VY xtC+XI]Q]{)6B>Shp<=}Pİv(.6j tq7xg.+e]c0r :Zτ-TeM&܁HS$u2݊L NC]p910/H<f| $3"IeT[\Hh#:آpU֌BFd~*O:aDk/" V3LE@fzf QQ9|loa ^*HtCʹ7WRŗdĂzZ.X;/(*41Ʉ=!UnHR e+F"kZWDkT#*vCrTލÐ y*<}Uo]#]bl\x) ;nVwO ٨\[7`is"9<"ux"|^Zdƙ`= hDFh݇ Rs]>~)ayFֺp=ݝ/W!X&VҘsh86>-[wKK4k>CﴵG+8 !o.y?2JpVO1zej!kjZuz#!oT@J5 F_>'#(1С]Z?!2mL: H.@wE$6oxϭ;`{~I^a9U\15D?!i&N#=ڛI]܎!DǞ˜S_N/1'*?񦵌,?)`=GS*pG1{6S3.V#. ꆺ:D?}6'3"zI`FOPWل7PY < BNA3"JMu}<(N{a͆pV"+Y=Θ~RE{fedidpӨWȧi s{h6.m ODFD}Yz7(Z[xv-A/֜ M3 $fEآ[KֻR1:Sc1hVfyA rE_lYE|pEؾ QUƱeIH0Bf{ xn1F'Wv{'Agה35樨\-ZioWM4U4R!Ɓ8$$A+Z!3%PuP9k!E^$T$/XLe]iiMidagND3V#D(^MO& UNT Ww=;"x;ړUc]FQnM_*:viu/S/aT)H[o0wZ> -XU.Fs&мs_hd= 3tf֯oss'xGٸ[Yً]8<)bIMEcEQ'5o<0=5],1 +]N9°q\EBk֖GZ wKrş&{8[3݋yMcMOr~t8"vEE7|R-7Ľ=hcB_{yŌ0.0`dڕ, bHRg rt0_LV 2b$/`/LL)'p:xY&žQj6-e:cW|]f̓PＫ!][xoη9d_|ME3owLgZqendstream endobj 383 0 obj << /Filter /FlateDecode /Length 3902 >> stream x[K# / |j%VۀLîѬfi3zSUd7-Y;>,ab=HRR뇋f!.7埮`(z}҅J{W//0yttGhhTb)zCJ/4kRk 'QS6vR^H%qu ں FV68mLHa`Opf %,x #tPync[ptB9؉aW03 1:뻟[m(GWw8B`|,)b&TR06UݻB% WtFd|ŠpQ(X8EWD󐞏Y#/9b) F-, IțK%>[,ҽ ܍Խ5Q]^}uq[6w/4{Xzw43&vo Oe?eݕus/~_cn18t"yi[=޻|(͛7eV&4y?NS;7Eg<9'jfRMlN 6yOYmiJscT>/AwM`bXoօ0 1u>E!]Ӑ 4r,KS(4/QL3Se4Ň6Yt5 N ,Om,6?_v !i؈ІҩZMHپ"Fԍ@~B02+` $"XJ;h~\<RPm@ଆqSZ)f@j Fn-F~Cg%`mX +FE̗t <8+Z aE M7bVH!r*/((w$% 䥱a %Jy_lcJ&$)0کcD 7Nj'mO f)m?j: ΑY9G;ȑYk%΁t)]"+7C,p;*GD!vM16D>t+D:'~m?="Il_haÀUExW+;%}!Z#&YO8(*t% !QJ?t]b9]yMC(ls3,0t6V8ݶnR_,#B T:uX'N A~yzNVj&7㈛h1C ۪0Ӽ]lLb +qvFZĖtnn(hmC<,VՌCnOPEqmc}XIS rNSQ戾ӮxkzklVx9TpzpW"fcUmo.4#乢Ճv6BaW_p6|4Zu)ş@Y5N<$h=*uA ;>mډ(6͆11}E8§hy_`# <,/ա󠩙:`U6hNЌÆ?*'e!fb)2)ElSNI-hj+N_03ݗ*5AKX.7/=FG(ce4֞5E56u- M! ,}%`R,Ԃ~=^w4]I H" }P&ZZXOPOd CE ;HH\!K~\uʼn "ZР-C <,&udJnV23E -KfsJ0 h}`Xҗ`fRK_Ƈ&abFVi'GvWe{e/ޔUs*۲gLNn3i3f#/R563ӱm9,ۜ~6Y/Si~3GL="#ZqSg\?͏?Ap|Q<kcd}IkW0p |iLJ ηL(.,>Y) =>N\,VIGf"щ%t@^TȖؔRuOs{Xͷ]nipXl 򑍸+#8͕khm?~;;~;sk8g8YMinflk>%rFn^q2D.`#VE䪊{ڰ ׎rxZ"/ ;:GDOnZ_ tmݾ âXT-?GGnpj` ڥN!jntj?EwspxĊ0cV·t#|%Y0(ftFL6m,_Y]" ##Lt*N-8gW~jbT4E'FX?ʺ/6Cgօһ- ءU7űx8#ю9}:-L~)^ͩ IbJ%&<=.+#J7"ױfFƯ2چpLlcNŷ{ endstream endobj 384 0 obj << /Filter /FlateDecode /Length 4323 >> stream x[Ys_iq6NpI*IIJyXJ&%K s%GcLˍG*Ց؜=?nʟ?cDxGQTnx⨓j{ "^F _[{#6(wkmvtxH\s;ي^D/‹}2s`t/Zb2cC+PÄ=̀lޫp koK6lZC}!8 >]o%1is emP} Z'нh#HBZ!Z$>}"s<B:a`۰=LJd|XJ5ru+&T5"嫪@F^hNyÛN>8?i!41_(XX'H^kݷ5Mf7rX^XY QJ(ۼ$C^ލqFy-$);M'|c%.],kLaXU`GG F l% a]+|Cjc4 QPo d+9ܽggW*$@vON4 @ {ZWCL>dl)m|"]0;jӖe " 7Y)}2C`G)b0>!@aY4H3BppژUlle\U{u_6O3^hI[U#Sb\vJLYZB"o0'fe ?MS.7R.:b~Yt7"WMnj̲ש@Ň,d!"(>U/OFP F51tq&8F^Hqfet#k;)-_w kI NJ2b- S9'SVܺ( [ 1 ?n3/2( BRyLKDA=e9.7 rJi)9Ǹ4їG=e7ݷހzM>_/R:5Ky.MDv(D=d) ߷VDL.RБ,ĂEaDevB%Bk=p}kS>9N,:aEɗVF@Ƀ){X24/Sð<'հ6ngfD.J3wy^Y +έ1ɓ&c>o/E./",R55}˅c/RDZdqu$ _UGf K|~\+6zj7 FK~$p46/S+kP[jɴ}9p`"?q {1T 3%JRX?}@(UWZJl}CKFU x.+Ma&+ 7IClۤGZ|볙˞H#h_;ZBdt" nPh"}- "5WcZDy<}}|TKXl"ڶeC1瀁(Y>9⇠ _q{730"nؐ):#r|Sie7u_D_ZG\)mEO5]=t.I5ҞtOPfXν3 *I9Q}~M-rQb7Z|]50dGG$Z ]ݗbSg-E%*?cF%Djtg'`R!Yѓѷd`ȣ,XSp x9ҩ1ks\fSa&*Z'e ([L^1yR/z̔[>v, qiX1Y?ݱHcy3F[n=HG\)eoU**3 'FLtު@~0ps eo tDE!Se$,DK%17{=3$ȏ0dR"LZC~tiT5\wG9^w3H-̀tqZ?!G=L2V^~hRZp7V몒MYJJ. wp0 ٷuֶ]{;`W^oǻqIm `/*O:w&wݿ'pWOn05?_"G?? &%GLj7pdȤa#~בwn;I9=|lKDË1ˇ2%1iܸ;X%$±ы P>XAVte*'G|Qj=7fȧ"UB* qu9yiPt7c4C<NT^.ƛzvM̥`u]av05M3}g5ۨ8a08ZFiVNw vzQԸs~m>i4ztAiPM;'ypN{_aCm|7ӫ[2PZFyw,m嬞'mF#4-UlӚq89DQhg-WD >`#+$Ȕ~c)CVnH,T+O"Ë7ZDiwtcqkW 7pT%,-bKgц.f5Maa;dc죚Y&.6fZ>>nzC?#e&:Wn }R/h0 +B>*wj^'jrQi*$ڌsfM"$Mt$Vo_膲kEHätNQ_P:3Nz㈚FL]@jOgq5.•Rr 魐q\Br%[7Fg[lhSݤ 6] 8F߭eҬre'tf-MC.ur)x'PBj7Q64K_E8̚BHCA~BDOxas-=~{snIVx5endstream endobj 385 0 obj << /Filter /FlateDecode /Length 4424 >> stream x[Yq_Ѓ2CҮd[rXZ>w<FA >A%2_\ W?\ӷ_߮ǕL]N.׿: )"(\ZoZ0Zi1j>\~v7hTf+FC9J/04kVk":ep*? $-A[7aNi50ic&RX%QVG@(Xr䒦U!aw렇?l'6&1z@Ci[mYSZ1Ƭ4R;ǷB`0 rِM F),1X5*TpMhd=K] ʨg5?zmqFNW! kiFm5[mM뭶cp vIf+'?|]ToNaE8տcә;ҀMb[FQ,K VDnK{[fa0d-_'VfAQ D(|{~Id{I2yxͶMy;ң1vqd~X ۀ!^BUrFFe;Ś)FVU۳FIe".hΓIWHG@>yģS'9IX2LA_"iSaƘ+]^n!%MP%~a:^DžL gŻLCioW8gvMeqґn.D. -t2e' fʌɥ d2INeH zd&̇τ~9f_W Ӷ`hRD)`TQeCj#fTMV;7>A1Gmwv mdh7Kp7 3c2%6EV*3sHR2|j$l˪2xrפUBX e3oß Qs*v}s8l bJ'!\;6>;grBa].EIiZxcN/6LdyJ͌h_VzNK娑=Kx[o*aN76oJ7sJXfFgc+&9vg ؛}MM7i7a?"dO'&9 r{9BbC6 ŔqsLaHz ?T]^Lsa8tefC3;C8F~!.kmǝRSז( %DqL% mYČJ<^an ӣbIh"8#0OA"l+q)&^oC /zFl O/)7|38U.c)5!MjӊE=79nܛf|(Yۍgl!WZG\Qi`,<nCQOϳߤ=,*QTƖBoM@cRÔyŬqlxi;<5@; ?ܙ@0k,S58r\. W PtB?~59 Bj|hv4x{).Ϲ|4! MR4y7\kz+˧6S2(%S2h?]Xt(.>g,0&߸nAac I?e\!)\ȟ 6rU]$#n}~EkgΪ&g>Cץ+wOmPF8т.G1fی:4De 8sxjI:ɫѩD0!w6&lL)#5dIOK.JC/EMl&EҵhdҬAfzFy:͖RKɉ<"W 8Euv~Լ:sWC\e ۸D]lLmYMd18Zr$@S{4j'XNP1}祩Ų|,j;u%̾HkAShmŠ{WU>W'}L) !qa'am3>9'۲ N% UgGh La#O'E4lBjmJ>o\NfUnBaUh/n` &_\,v3^0/ohɅ#7\quMyTL+TO;?v٠ Y k.[`7G9½NteMnەrTJ(G=O\^< oP,J)G\r`L1 @2" ˿y|>Q, (yUR ?Ja|ǚͅ A/RKO;?RA\} 9w"F[ힷ:\ Q}lOೈ)%ڔ.V&"r("Du+ _EnF\n|;rw-RsצRf/>mmVSBz(6B+ޥLU$8.S]eY)=o&Ua|^|I$虗5˓HG\TңԣZhTWۥwn3i[1"zmVMzZ)vM:{2i@T<D:[W=ʁcʌ{jn?o %(nŢE%Th(P@Z.~\&b"e" kฤr@0|LIckM>7Wt"g*X:794B=/aM(7$AD>ؐsrOR[/\>rlQ"M}u_c\ϲ>>l 'ҋYz BJYDDzFmY:(l]uT7ߥ/7.g ^YugvDi翤\f~L{W ϒع|0XCwgI YUyݳ`)$cU]qg{WOr߯ ?.Z;c~Y%|jvpI"ӄ";O2h=~|E:v?+5&Ȅ9=j3 8.cŚ19Î\.Xj=m .Zŷ?rs,mhqUX W*S{Ryꃈ\ +ux՝='l bڕ(yn3cbʩ=M:ٱ[2-(Qhղ*H~̃kz.⣊WK:FaNJz^& \ =bEPUHJUh92=0]Ȟ۞HV PH7ڨݕPP6 U/}7y8/9+-gtD>fR&AD`s`WtD{{@㐼b҇6.$ zj7!L/_5F nOΌ}-پ@ wZ3׳xx?Rendstream endobj 386 0 obj << /Filter /FlateDecode /Length 3818 >> stream x\Ks#ٔw#bXf"")JɕHQӍ XrHNt i_-E+O{v!w ~]N<QCOE˓ T.\zۨjX: "^F lJHJe7+k[%k6竵hu|l)2hEIJ!͏_Jƨ!l4͇0hYށn߯glޫf{ ) ;@XXӼ.lj5/0"t5~KI6HcT֩ vh`CO[!Z$'Ss0_ v{!LHNep'plpz}aͻtƪf>-mͩl9?nvTrTl%YY ziSuT1^W']X*pnFXv=oe#;ѐ`1 Y͆1cn/mc%痃_p4+h=AԘN(! ptiHܢA](']F r6-L 3w3 !rU훓 ϋ9%[W +el{.?-ع[:Qf7Z #-젬iA|ΰ-S0! lnI8֑|[>z!0׳LG@hY{eeQ]lk:,ğ[X+,E2*y @v \цz9y8r꾘ۡ"yB( BQu$0Y9i}T9~=a&Z` %V~݄M CjTƒm¤F6- gڞk\k*:b1 3ɉI4+I׵Zw?% F%k$ Gҡu sȖ88S ]VFIv7eAX̬.>{S;1Z8 `SsK|;qSHVKLq1T]M]Y=\Uկ?SU/TYore=(+XWV~ʪU/DYUse=('ߙÕEinJS* r\ٽ^!;#*dl`$ w&y[F/V|\@ur ݌sWK,'6ZEe[̳H{.O̊d[(/\Mi*B\ځ!(ASu) ͼ)麰'rJlf29TNy'\HǓkX`L`c&#FXa'ֺ#xՂq'ϞdKK)s^HW_h J V4t:j:}XVm 'X\P`cdۑ1s[oK>߹{WTP0K6 p:yՋIe|J$(5DZiR.xExB8Y /X|\*ko:&7\%leBn~`;2F iϵ.u"ͤM+'Q;GԳqء Eqh&'eȫ7D p6qn984Vɣ [k=XND%F ^gb 7UtPc4T*pm(N7x`K^GRa,k=P2syoYwzXN&]HI X< ve@>#snww»VUsA]NzӑԑOյ2IUQT"6* {ܰNR*br{OK (>+&, (R͡զΡtWq;uMH!tMmi4*lmN&y!$9-6I=G(cQ'W`BBz.^rʪ_+c959CՑ:+yvذVjs@]1m|>\AZ"/T1t?cL3wrifc?GD` L[PcPс֣y'<l始 CQ [%xw8YE4ZיZ#+#3xD/lxNXB_[-7pPAvp]AՏX .cTk.}<AIJLepUz:S*2~AK=bvn"&~:; XEin&g֫jDFnK\QiQ=3p+@1Lcb*3<9v=G*prTmګњҩ)\صC9kp$jїN1 9 J3[u0&LJX|&hnNf5UyX5Kl=0MWQv FqA(U QUw݄'s1oL*>~Ms K^?9)My+X9 CuVT]Qa(N0*~ݲF6s9]%|8ЄG?%+:S!6Ԏ;w;e CԗJgHiU`ʷ׿MVG/]-pѭߘʙ 2sz)Ŵ}ʟb DtE]@\GA b]ih ث@ y. )9QU:3{rMqK0 .CZ GYM$dOgq0ɃŠcN ΰ]gG *X8_3Xwx DU }jkTY~Z^Z r .%v=h@]WH)J'BLjVwc'?sV@IUI?Oz97Ąoʐ ;]T)R^J^79fzlIt`&u͈i q†]#.jyl$PX6 ^=8[endstream endobj 387 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1164 >> stream xS Pg091=]&vZ*ANU4b@`81X|7 GCjV5E[LggvvǷ$F$9"1y{ÆJ|') M1=ws@A"}B-+QhCP$i\Sh/1>WϘOWfs:!]'kΨ$'_bJ7>v^MX,SƂ&sևxAu:s.O2 BQ:MBAgM:sAyTjxxK#XBA(hb4"NaaǩjX%dO?yr Skuuk?= hԛװ+f8Y<ll˕ ǀ~3wcm`xy#reh$:^A|z:VE.sg$(35e;9qH?xrkA"ܤo fe66=-9-lk:+^8Ok-匹}⪊*XG[w^9(ɇ5n(ċ̞͇w\v%Q-`+f6;TK8vcmlm5f} ȬZjJ+6'i[y:XJr֯R_W!9RAtSR{QyPyB,[;x9pCҫ_ilr]PRcjWK87'|s=th\WiV,bOL*dw#I?>uZO>>V璤Yh%i@G.JeTȄ0.7xP7RVVz !aD)+HHHbѹ:&ŗ8YtTH`Q9#PheqB)NI ^/xo EȮ{2ϧK)k=s q<}4pcڢ3N%tݍֺU5)0IWۖMJfK/vvBBJپ%]ZtNfJ[ϖu9IBWe"ƯUtpQEb vﬗam?w+F)H1endstream endobj 388 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 608 >> stream xUCMR6/v-B@Hm  ha\mqCopyright (c) 1997, 2009 American Mathematical Society (), with Reserved Font Name CMR6.CMR6Computer Modern231wQOf}I|:}O˪16-X~_ȱЋ=:D\BEKmlGvR%I[Bp$^sjpmza(S(S ڥˋ- 2U9`up拔s8Tl+'yp|{mIK%gd͋ǧj~$`dًËËً‡ #`$vCoa  7 ޜ 2endstream endobj 389 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 3552 >> stream xW TSg>1sT xFIGWQETT'Z| I #Nx "AQv5ֱ'0w?vz;soYYZg}CL@p8Kq'0/qv8^"<ּ҆;':^9 {<ȓALe|T%3W$ h@D#NUR\dx*S4gTJZhQzzXPƭ@vHR$4AzEJE,\s})I*R8(Q&r`"i:e*5-]sP'g/Xx f[mvb6K$ˆ]n-"XC!Zb&6MD(S > <Obg 1Hp|8'p&O]}4q*)nx3T0e4gfɃSMielu٩M}̗{=쌆;gg8.Bi*!l7޹TU:JFvXtB,;Ce#T eF<|;!Y #J.@?A |qeʳQ?Ej`g9ihՇZ'[w&#԰8`0Y #S(ϡMѩIXt<[HvMF~XUW6 mTCTm<3>:ydx͘`|Et䁼?F6 ج:ܣ™asws 'a[pC,lWF)""@lv֞elܟmD_юw.5u`y-X:SGF*x%qPh 4MWv=WUFy鴀ɱs/Ys:E-:V8Bjի*CP mh+DKصQJC!st*xJ5 A0afغ6d[1ȮQD_(q:Wң7e ?ox׋j<%(9] +mje m踂zlm^`Ȋ(g7}zIwנWO#\HZ[O#š* )OHv/ eP?g:Vtr\YqGGs#f9} r{DZd8Ck[SYWy4-YG ^. 4պ\rhNfA~m^o<.(-++טq=zo^K ;*0uDT,S\(*0hYzEWh;;mV:+4 d'~ b(_vcVm2"^'$hYQEwh y$lq- \ֶ+W~ͩqB~+89nf^s-m@֔kˡNЪtQ D+m|Y]]*4TC/ϼwv);)D + cQmc!tb,̛q[v}A]슍hH bw'A:i 5o_d-Vc,hL2|ƄФɩRŀEj P]aR"pn1xD󪭍G4Ի,$o4T> PR]ZM8˜މmviOޤmq@6^Vjg(4װ(uYsjlFV٪6K^",.EoA (9t]QޔGr61ZX.FN=SET 2~XYiw8LʜI‰K 27h2g立 CVz}A>P[SꊐhuAۿNM޽1Ugm`jê'8)K4Ǡni76 Aw$%u=gNrHQS̈( 2c}P4:ΤXĖm w'Ǥ&DvC$HL)rqT~m:O2u/MJb5#Ӭ'Fz6ta=8h6]'0*}`&r[Mࣄ:RoehT)3"{b/K&Ȭc'428k!A]W|ԗ36t6qE=2VTrS|E'K?_xMUF ڬBjpB.`Y|wJEE۱b7pNch"#2bĘ{{.YδAIJjAT{tQy=DsY/Ǿ!$3'1O/< JMh՘#|e^rR?|YoYkEQy~X'T{AU84=DW!mp tƝ29ƃhh 7jmq J6fǍ.IG^J#ThWZQvE(6gw#3'4G RWd7V7s18 `=1 W5j )D@|c53<;&Sk߁#x;$ٹN +UcYCUbz)|b58 MP_< -C|Ǫȅs.5V_/wc87K㯻[ W*ۉ%u׃1"1@}u hi>CmhgMe^K.=$J{.[q6Zz0tb=\ 1K\:~pݯ%S`;t*SAW؝nIX{J>}xq磝f fTlg _C;mh s*JJ?ϭt)E~ _ 䬴#ɔ\ ԪedOF|/}PrA' =ziHu~mMYeeYLmC(Zm/^.d4ޚfRn%dHcXT\TGT|v M(AiFRR1Р xB +uP}eTaSuͣJt[Y.OQ&M)pbSifΙi/$զVDOX_V&üޕ[ϟۯw)V~L!> >~wj/5}qtt_M!󶥱<녧~HEN/ڬ3(!Srkࢅ'c5~dWЍب$~S?y>l3sr\濘t@bF|4֮`q r))l غ-+v =ƴ (_vRB_G }ϼN-$3;j{tvAdAŐ]a> stream x%KLQ1PY`Rޏ )1ZFSy H2UکӔeT^$b%!.؀q;6Οs> b3B$!RHJ+ IH ̦ P:գʣf:rf=PN){6[l4%EEF\v' ^.Nd g-+, 6c.r~εG`/{Zx7 p>ʷp>@ͷwpT΃ @l@*$ Gi G)2 YHTO3оe!̐H7q83bpkp(w"@}M5<p@ HW4j:1z 5XKݷa3Q푳9&:hG5+"R\f+5ua#+GbU\ӶsX|`~i]/ r848UTQmsK\]>VPHm(2TCçH{qS854Nt Xܞ E2C k/0sm \ϛҏL$tu.՜=endstream endobj 391 0 obj << /Filter /FlateDecode /Length 2430 >> stream xn1 !3wd[Aˀ"/ÊH-CaS=3U=Õ(X꭮ ɅW/[^=~]o#j8颈rqpE o}]5=/J9]^7[;#oVVe5v):#9)99#;em+8Ak6 7BhF[R/Bϰ~_Kct\1zpS@X$Ui;}. ShFNcu;ƩΐꂔڠN@NH oHA{4VV b\sM$A[rDCn1:31.D{d0B="F&tƪfu€@nLP;cM U*vA^iztU/LX,sk I*|?3zp1|E99xwuW80"K;kb$"JG \qQ%eHRPV6vvDP%aclAq>A]35e6ܠ luG$$yvZӟY\{͠ =t( t=~k9Fg\처%5CN_"?%^ΤI2^{UWUe\jYkdO=Rƒ*7U^לR9o y/ |r\vA}& QnՔH~l?TML J63= BBz6IhT9뼰15jnӱ*dB CKSQ% #<4b,?Ct.:!G0ـ`( MѲ '7j}~#52Z=" 'h+'\?`9%m-LܑzR٠3E;vE*g].wW>&YL8C <p޹! ٘_ S-Q\#N vSFm+&_ =$`C%̀%R VUԮfPczqRY$20ߜqQ{DUtz C>a睬fA?:CsEyW] &GOp.! /Ó/8/9Mmti:}u n-6,B;jf;oVlBwKÊv\g v(̘pv;Ίi9HMjn& 5|LhA+ !Ǫ~Kr"Rތtwss՟`hEȚ9`ru:<'V;?dm{p\7eg/ZͷP HN[< 8mE&\RR`}뗒J"Cxp&:*p|C-7Cf}kP?m[ࡅ1Һ+,i],c wU>Wjm†իmQ6hf:_3 +3t>o13CHZK.PLQF%)B4c*K }akIgSA􍳱yM5aAq/2eLon35I%zZ:/Gxc9)fvzB3oc aqZXb+Mw vQAWoJl-ٶ/S~|Qe̔^[>C'xN߇N"!pMK#Mu].w;rʈ1q3Vcc;"r ⩰t=:Ҕ\QdkQnc%KJx?Tv?k ?}Gu=%{o|P7[MlXso^FO|"cHafbEpbKxj.3V8kٟ Oϙ?Ats2kLv5U ?68endstream endobj 392 0 obj << /Filter /FlateDecode /Length 2109 >> stream xnF] =E -j uԾ$}K[_=(ΐYݴc;Y,m?YXwѴc8WJ{-mJ'u0e3 /dfp{ S*.L6**k] &lxr)8/oQ;Y\Y$f~SZgyKqD6 1TvK1dm T@7|J2ɴsƈl> 51hauOBJe+am%d !qkEި '(-ٟRUώym؊scUP0-su[}Uc cՊ)&mރE!<;&-SZdË(%2X& &]GJ+NpM5hҪRj/.mU%\Vz4`Оǘg#s6 \e#Xx`yL"ӫsC^p $:ڵ\1+'8EIx8p~.INHGZ6 d<&k]pdƍC?cdh\|O1 Qbę%@ 9$w{V '8^>|n0@^FG.F$ "n(b8 \ĖTogͺltR؝]u(P)lU:*p5'1P3cl[*nIG!Z,w)M6'EC%%=L5*QA0&/oǤYQ9#CوM <'~otNˤY8n+&f-~.yrxOSYKx*9;ϩ@ayd}YY+@E`YkiX!xU;"Q4\#[]dbDx3ꢛ tm|-60SɈmVpAʀ$;ۆġk֊1#~&Cu'gdp0HݿAj;[h4jVQǦ@,do4]P>ٖ(Сϝ#rm1 A$e y:5- |xbP#usvŜUJ(R3㾥gA:_4v ,2kIF7Ltphj|ǤBG4MئȸR麰x:HǏպWXBn^׵!ԏI7nj}6-.Qrtе5fm.&r{mdZpѯ| [fFߔU~;9~Ur~5MOޭ_XW;N 7:*}t銕jOIf#P446'4MhF;e  E)KwVm^jM^ 韽pCY&$qwy ͧUYt"e-/m̃.ɨB~MnƠ~J%jC7Tt q@yD]io\3?Q >aLצ7G1&UB2)S$UCeZ k&25< ׄؒ[c 3Q"Tiem^I[N3UP"N`o+L6t`\b[9?ѡgQexl6+ujȘɉr҇[ 7Q17!7ѡӆXȉuU>˲㗱󆳼y̮x%KӦ*SLE?eueUx2.Y*5- 1#[B6a LWg1k3熱N).܊VWiaY+=s[gMJ檊!&i#*[iJe&] jw%iO'Lŭh|n:U35o?@k,7i?endstream endobj 393 0 obj << /Filter /FlateDecode /Length 870 >> stream xVn9 WQL) lR@'FlHۈdG^hAW$oлY_vwS?^t}`ozMˑeOճC"!9fiC ΉY9xuLz ّ7Șɜ #"OlΆgC%8L, ɣ7#% I 43E`}IT %@$YcLbEGBtTj9g_"21q+c.ye8]a Q^[@wPdл %Q7d}&)nzPgc,Q,Oǝ/? K#FK)Uޑ;ѣu.gX cTmiAA vwl*{WØ+v@fendstream endobj 394 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 662 >> stream x=]LRa!;aښ:捙el\яp)j }fZ~R7ۼ覶nY7εiqҋn޽> J兓;?Gl *vޞlulvVJ*bEm j": 58 a1,ɥNSEET4jTzڨf1lsZϲSv@m0ݙ|n`T-m-m:ϘXJmݛ`fK[(%-&n(wb5$ o FfзMd wZ!lc]ӱGo^,i[iU R~?!<[^P7¶b~"M,]uie8[dS@r^'WԪj lO Cr2g^CQ!A\/''-mdQd5F;S'p7.S 턷=ӭz0-kj@%&#@"&zc;<@q b" P͸;\FQTp Us8`VyM 2>X_5팙0sP?)i@0t1w&>2ST2!endstream endobj 395 0 obj << /Filter /FlateDecode /Length 171 >> stream x]A ENnn Q/@aQ .1.>7΃5[pȵ*րGe5pe0~\>q"o_L~8U]J-^"i'bmUu#FLcmIP5{0vkdc`XO-x^V,endstream endobj 396 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 359 >> stream xcd`ab`ddds H3a!aVY~'Y׻yyX~'=O{&TFƼvʢdMCKKs#KԢ<Ē 'G!8?93RA&J_\/1X/(NSG<$C!(8,5E-?D/17UL=0霟[PZZZWP`E3Gsw2>){݋vWV]]R{<-[(ϸ{;?D'=cM䆌v;$&vN={?ξk'ι<<@endstream endobj 397 0 obj << /Filter /FlateDecode /Length 3331 >> stream x[Ys~؊2ksǸPT)\Uy!!w]ROlT~p4}|h`E+"Wr5Gow31;{?_'W? ) A9?>o\:ZiڠjLQA6hm.WH#;lZ_):eCY,U d Z"8U:zii!O3қ(rVx 2 +\aYtuB9DaNgCpk;M>30*Ԏc!7]ӖQ-R I&zL!-P CMo7EČNI6t+~9+}t뵅=tH8u4FΗڶ޹8&gΚQe`}28njJaB6ւ`Um5T65L8yQG)Z%70&[(H=!kI# *g4xɊde)̱.ݹ6?/%~*sBAL:h_ry*Ǻ ht9!l.:) qBPZZh.wpkޤޒ`[[ ѣ)GbK[k BIOpBVE``b L64 y4TҫOqYw'v$'T!CRn/Q)F=$/7_ ]R ׾ KYRHI恉XZ[Py!g[Hɠ@5%-k$Oaذ%Q/jX>="/ IGWHn+$ϐaG p+7`b)m'ϐdB2;'=dɉ;AZ-5ږU0NdYq$7H~dW!%;'AỸIynm9Tab8GDNQ $Y5om_}dDGn;H@{$E;j bFrBypj$ޙWTO6Gg×4ec΂u~?N{9d+Rqp–w3`d9|`"g']{cx!IzF@a=*Ȼt|@)7&¹;POW0r3hdkA{,NZ(LƇq0RCo #x :}i[U跕=,cHj̄0IYVH~$L$[Ad a~X=#9q~F%D 1k{Qɤ= #_SY8eGid,y:8P4xB<'T~5J\n 7d;J;pfUFVZHB j;0vx:;N>‘H&#/YѹCi{_Ȼ%zgٕ=g=m1;rdl#NVGlޱ{9gd7I:h|K?l +'rG$ϐh.x~r]r$MlNz@T=;ri\z|wl+w5v=,pLe{v5PMz!.叼MƼWS8;@|sZ'DC{tu:(|t |I$ =َI$ _彸n*u{ Bk7h~zS/=f|Q5yD&:vc$g-R/lK-x?&IgR]; Yfx:q cӦKWWM0 ږX k--t׳Bo~S0냢Yr9:/Idr}zv!Ve%n&ZEw3_P}LszU}YwT]oӻr:@Ei}S?ދL Xe8cTc:y,{Y=f O%A]F'7XS8QpX>V)[]2j8$#hcvi/=R9Z?YS0ց?iJzTU.S Ics5&0eN.:˝4kTpz\t,f ߚ>DM2V~s}9]!FCxJlBQaCݲsn ␃-{w"$/>8'#}WOY_G\Q4+$OG #RvQs ;HCS$ ~`{rw|exj_OXGq"6jtSn[RcȇFfKRhG,"Ҕѝ/"`;}/wZm|SiO[/OcK8bKm!< \&J%,5n`]&+q[} DMwx$&wL{N~|R̽[TYt*ЌzA'o/ չ&+z2 {Ҿ$A~1zaATi7jtH!՚VHX:b i,Y$!-?endstream endobj 398 0 obj << /Filter /FlateDecode /Length 3467 >> stream x[Yo~g#Ff"È8 ˰ bbať($RS}Tl-K9FzPY]gW׽oE'EW?<۷ozX;< pD #]Q<( ]򠑦=70K)"}s:y*|E $ ys$t2B?Y&@ H>GR' )Ǐ|i*?\HYU11GH.ªG3$2:M!)>]Jbj.$dC̱9=IÆIK5#uA e Z9 w2D3ͮƏ[p!f 1fs!0\Hs%X# w/qCD,+È4~ n]a!1`f.4bD vƥ#j0ژ0>(fe8e n$deı {a Y&\2o\L͈ fCL^b.SXִeRfœxO |'JfN{gts!f1HT#UDHd#{b.15s/_ڲ2=JfosqrRa9w'BE߼j  dڰRW/x%K.A=+ѝ3n@,.`u̘Hf W\NfU % 97)Ƴ)ؐCM2F:e#R.:!LSAkW@@y_g)htS|,)*t]|eDYXH `y#t#D xddJ,.e F%h"Va*'[HvVGmLQ ?5@l쇶e( NƠ2Ft[J2L4jVF_#ydGa#|&XQ`_{rݢ/&:.ϊ`QɗC6gHޙUNHsDѬ6zmz'E],ihFrGH6\fɓl`I a'PYCcsy\N~sFH1ۙH6QJx{ O.2YиΖd*J6h`χځxv3Y2a!+5%GTC4ȵ.[^hA.rCcexېJç AؐA]I^+sHFwt^:K0Fмz\$%zBGcl';Z]O 'ednQHPdM);Wڴ,}t!J[W#WTDL9?UӣJW,e9.\"yY=҇2܄:Ks.M1j0V]W+1!Lck$/XWH)k$e"yGH}M%x#ynXɖ觬y@ Owh $I#b7Be5]-KU72`52W(9y$_0 &I⠫9wzƪaN~?g%$/ /?|H)U-C}}qP]_ !4ی:LJ/ + d]vDh}]8Dr)Yh'ƘU6?L0[ЖS7Sẝћ5%CNe15<([v~z6A RrhR ` JpӭF)_9h |$Pbqr:uWࣅ"{=);|4WlJ" :5F'r, ppἛUm%1+w{AYfQ /4 N(/)3 VTʮGv<;(/H;/F!f:=GҳQwLn72{)8 yKٔNwuꠒn/w |Ut_ 5Y=VH6|睢K4pfCDwA{ ?/mM Pj-iZ3j bήdMvEK\Y$)dr=Y!Gd{:Ld*MfwnKe$ÃD_#,FU͟wnC`rODžbm9EADB.t9 xu& Q9>E\=(:>2wL|XzVi-v+\W,$Va~Ҙ]-?d4-A%DjAxje `Ǖ6~&RBMU0]rh%,Fz.| 1_VJ P$0 fS,Wu 56Їn5rP <%XMk2KDc =H! $EWw*pL7٦'m՘_Y1%'ѕG<h{U=xG>\bV ꗊ ъcH]v. Aח+o+J:1zGH+SO3/ZN[yyc{sւ\F'#z g3p5Ofn7/$dn y4> stream xuMoA +8+asD.ġ5m)Jڴ̤I?Nwmǹag{E#ǶӬܸ^9yL`Mroq{IJQ<>sIOa_ǩ;n{$#)ػSA6 n%cFa}>ZX Gѻa=w`9:ۛ:6˚<.>0 f$juUVe6fi7Oz^͜o]xLo*j{ hl3׋ĮaSLak^]~~4Jгi"/lXsL^v]sI!endstream endobj 400 0 obj << /BitsPerComponent 8 /ColorSpace 165 0 R /Filter /FlateDecode /Height 672 /Subtype /Image /Width 672 /Length 32244 >> stream x %W}'֤Ɛx-"plώmezVǧBS{. s)Ձ > '$3 6d HH?,;BONԗK? nw@rcaeG ;ը4: qomA JsF%Ϲ ç j(}Pn|}KJ+)^t 5=mo~(I2ƛL2C|8ʱu$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$\kI HU[[9cI%  }r/a?Lw]9uF@aBgIv~ЮQ@Sχ\Dﲰ5|&I" p7&UcQ%7>w e[une{hZ)蹘Zy݁D[ 5 { G#/QmU+0y(VKN':$|A/\$>zy[ύFY]%|^+_2> eFnE^׈}UJFiZHRwe u(? ]l16ϧ tUۏ(9m%V BU˟9c TVGO vyʻ,x;g#D6W5~>Ҥ*5]|Nʬ :@E^H2^T!rsG@$,By]!+c$>d#BxI ϒ=C_~!%XV#[Ī 0|H;J3|™edtE2>IO!!doQQiJNryG/BC*>D;˟U_-j \iKRm&3ZFvq5)7|j&hy]1}w'mOl'!@)OdpxY/]_)b3;&C(oL?q6֨vDع' mjQ~E?Ay4q)5&)阖qU.勤>ku CНOP?M| ~+?϶ߐ7`J[f`Xv^JWV^م~) J^䧪"~哧 :(?٧^Nj gVoRjV!><gB iqZ !~e-qt3պoJnYQT%UXCF(PvIdI-oN7C]?w(@~*S:eEzzį.p_^ n O,>_~^ xB[iGv|!Y3t.#h2AHh$j؎,J; IջJ}áEX$ _Qb+>d޶hĺDv%J ȇ g!~Ǡ7;'?W7h|Nɟ"/@YW[֐ -pCHGwG^xG~&T0V9g;2`|?RJ)BjD)9u6vdGa*~JeBOlbݚv)?o)*?BiKRm&B r-l+K>KWg"?u~k߻Ww@)>+'?Urد2ԟ(F%?:ZyٺHi$HQq;BTgbG#]xJG.xg[\ԈJSft7yGvVHJ;UfяF--ɇ,"=ğ#꠪בO5LQg4"Yfc?#f|FT5\Zo@!!=įL+w%9 y߀jt]M D# /oTJ #c߭ hmSyIj3!Q KXuhY/]_)b3\:?%K~#ᗖ\/)*Tx1!6T/M=!BD0\;j]!㏘?ޚJRl$Z]]me i~x/ϛo]6w]9Uh֟VʾBr Y~2I򿥾ȟ\oEj 7|K>hvMH8|T4E >և_[>0>:YJHY,(bM|}re$ԩC>iy+U2`>C䦜=-bUک-X'~Ưt۞i)߸,?ַ[ӿSA"k4Bmn]8E*c?;اCAC96st>#?|K(,ym@8rqep|8[])Ǜ%4WH|>/Zy[}~8k/3p@QbGD+coXl:?)@exv2av!&X.9zg!/l/mCmϖ*<(C?$c;&g-NJ;U.$X1*~X s˕?(xer r(;նG ^w ;_EjprSo/Gv1^Moplrr/=HY@++p¸x (JA6Q~Gxq ̡g $[.P +DV!G-.`k7U"0Yޙ7)A^l d~6 *n3qGMJLٟP&tf5:)zCYÜYY1(%ZFl$.:3*U)[ .(BSUC(tJZ8R :'4a*'_q @*nYpIr#jv!2R^W;+r<)95VR{?YJUR"x$Ro%TySHZv$%W gC|*~ Ʉ5:o4?RJ;v$dS83Tzk*!T(Ԟ="so?6WKW)Vߒ?3T-PaG s\F* ˡٟﻂ?kXR%RTh&@T`O)Tn2am6#D/o{:dQO apIVOav'ӃOvrO`r6 Φ|g.I?dgǟ`_95<uGQԊ?ORRB# =U\Ud G&g[͟?6}i/4$ = VO> ZxhG%C1CTvȟcom.٠+ry+2q %HGtaW㶎?#RWWG%2µlR✥q?z埜. O~,O8u)v%e򍧺Fϯ>Z'񹀾!i9(s?̬%HA!NjD#_ xAtO>'L9{U%t*.(g/ύ?B5HOi3?8 6#;эUb3:LTß3zSS?Vǟ. :rW2ypze}Ήs@j$>Q9Σ~*4OOi$?%A#/qYٟu#VVCB)?QCIJry5H'yo3PMlHt\;_JzOi|hy3ty 8;Ŋ9;Ov1IDACs DX|B{`-A#9hE:!5ǜyX(ܚW|뺟?d*3VoECg70gas"h6ϸ\O׭o?5?i 1>"țk{ A_'˟̟VqvGi8AM˟ 3h)Ul 坫\MN@ePXCi0U}ÝHrlvV$5& 0F#s1Ң(#(#7"pI?9qa?B 8pqb 5g['!H$)?:4s]ѐXv)ϏGajW @QhB)TWc%G@.PD$5 |t~H *(⣆zv? :O yrӕ,^LNIZc(!ϏʯW"Z|2C0,['/ h~ppcuh)+rEG>Z^zğ1س?zS?p5#qAŽLb ??W7wGL:@n FxWQ,Sh %MGcGmXȑ\Crn}#?[nƟd0Tqkk,%X7|׿7@-?j8f:5B^"oJZuFIc?]ɮPc-S+ȒXTbf|8D`qe<?7 cM?]aR-W5&S^uf$(@eRhנlu!Ѧħ98766ǟg[#ό(tw]r.s\sc㏘ddF"$H]CӠFz)Ԡsc\bscρ۟4GT鉓CRޱ?;UY=cpڑ̸ *b5 hŸeOջte GM-Ϗ}c9I"H+09>i_[-Z(TM@*%C$ 'pt zC?)S!o+*@f3t."#NT0uk]^'%J^ܞ)MElҵ`$爤zB!qzt˟[ß5ȟ rfrn@tm9aɢ!?9j5ΜSp;I@,'< FL'd`UE'NY?#S_G_[-U$E´#T5ZW2y S%Yu~ڟSRTP JʴB!>9+ϟG )[ b%Ҭv4 e<qS0\r7o(TxQK1YwKDHTRr*F#OcsSk \`vIfgDڟo(M_"a)*OE;H~Ğ8^mϢ4x?juu B\syN,gś8c OA'gB؈SKB9$1W3[whtcN Iǟ[??7ٔ?f(4 J\Scd<*IyF#LN=4^ 49LcG5Gqr!m-fS2b$U* n2k<-Jad$SmCǽo_S/glQR,9 zHF+3/U54#3z\PD98kIbIN[hCq${ \9BnfaA^gY`kñNiPbͱirBWM%J_?ƟT%+!nAYhv=,xquQ@s̉ICvlLnt?S? L*eBTzKBX4jh,GcI%5ۓrd{$y)M t#慕 +DTF]aFAI!-B\cIULN%Cxx0u)r2^n9:̉٠^Ϲ3f)qKQpPfwZ 0g@$ \{đ2֯~|Sج%HwN^$Vٟ9n!dU;#P `e7";]SwÇ8 sD lN@J~h$FbSzbPMyC5UHuCc\Z7^7 fځBDxuKZ]h!c31)E@RV{4 ]ڟ]) J>C4tI`:&gsPdĉ!>Th%(/}>rQ>=1t2ZaKd0LѬGY>B (akC90C9"'{ϊ8G%_hl5}a/!{H= ZXJT `zl+\u2,4~ưϲ(Ax-a0^>vն X QnrXxzwH4S#SmNI;/ς$H,ιm"IGNsp^_?G? GހA&|G%Et L7hϺuKw1&[dqZ a%Ħ:kΣG0??Ӌ>XG?3Ft`;ݦ+w) ^UlmQ!@ك6AT ˯U$ V8Hsp+˛#G^T/nO( x"8*NcmԯNBFH8A8ib:/`JA%ΣG8vD).z2/N;ˇޭàl$K9-NLp,u]'@-ΣG\=^KMOhRTODdkYNu6X;nh=tխLPEfIxlŸ9>? қhaNg929] KEjCG] )1w'?AZd۪ (,_DGD{?)Qd$f$H )0fcW$cYԊ3ם͉Y'sRݩtģ. ??2_4O@[sԣj]xS'q / fێu^>|a,i\Ʀ[,)3*[ IպP ܘ%Ü4KelJ(Ktɜ žIVfM3ܞ?4Bs$2]sꦃ:2aҬI L8ig(y| m۸r]6}D?Lǂ7`L\ DT2]aKR DNmCxrN`͟^'A>OUSxz5FHRb RzVQ%ԩF%6kyb3tʟ}ڟVKl 'eKLOjqB3F#(JHyĝBh%fL50:Kaʸey@Bȓw \d}j< R9(ɉ?_FaNA3BXȋ4,sQ&kU$(ٌiEWRאY7QN?< ؃s±p:DJLȳ3 ?|$GA(Bw6iLS.94sUBnLԧ -;DP@!wR %1IΊ4vcǎ'>Vœ'M9F_}/;:O@Мu/."挳2n RLDTc`Vc)gpr54F'V@//)s(~tYBH``Dc8kdd5U7&sJ$9^"G3g򦛣'zN97#$K!*.n;m>RѯH  aLpIKzօLƝRcˮ\b=>;+!;}AgIfcImS&F *b>KÒ|`jB`tNWX.^vDjfR XϝD]|ʕKK܊ϗ x&G t;ۺCn<*64KΛnH`fCy?C0:O}2+k6/]g=ڟӊ߭Ga# \F:R'/.P!~n)f}uȱ!ZݻNPstYJ~فTDv A&EVg+dŢZ8QF'-i9Q%EfNvr~xNǝFٟ}I U=]lE6C8k|ۢ^eL{~4QVW̹u%J>DgɝgGȍd~]<r鐡pʦ κ!l;V: lA>' O0ѩχKNZGuyDG$>":(o W·0:Cew <1i"$ &ȟ4pʼnUE% R"]ęNYA`dm7peREi $~96WcuV̉P\BfEQY`n!? 't(_NK(g{0RMl8yZW4!P܆qN)-OOS%12wnz%BKt=%pgfa (˖ls؃N tfQ q.QعMu 4gh}k95>;1F?ra% " d | =uh]wI`f{G "u;Q Z70B?:DgFyeb B۠NYN0TmwW@_P.ce<ڦ'LϜ.w%PbPȟ%wƀ>Z_ S,$wiϤ\w9&U"̝Z>FW`"+V{t?J)D#*ᕽˍ?JqzhHMblB-vI?zf$3DU.;$ԙsg{҄Yi D#',(HNGbZ_HXEj)8]א݁XQ=cQ*jKd}8|RST1%08={8q~FܐEFDyґY:~HaX5j!π }#ߵ9iEGg4mjwY6uz8q9:3? ?KjWvyڟp<彷6Є <3nK[la *j_}rfz f1%K9w|xɟwusufc|?{}b181*)=cH"H5D"3'-biH Mi:|~vP_ÝT ^gDqE N[;MsaNF %;iyPfL R;{nlY@"<+g,4nLВ+"E,s_A}3~G]5:Lp'IݥK cMG' &>Lb8=e'Å!~v0tM;c>][o/?/VȟB\ Zj碐%'t\c#M0!V7LʊgLy&%:Z(yǀ5VY .-,=O@x6[Wf?Q[nq)>? h'dM.h,QfL54?s./^|\ZΓxԤ QJP:`4,Gdh-U~#N7痪[dVT ~߭V^_JGx|QaxF1g.JUߩR8@ugd&Ns"vNĩSv͞N"7}J;Cx[ C2 BY?;iWO0)jbwڠtٞkRx<%$Jݷ{M<~/S\{L6r;E90Q\s㒨r?:pz2(M[j{ί?>pzF33N!&YEAl`98y"q9D2i ( uLvFڗLxwdXg!Q}'9]3aE 18X#lIft% t$!9(W|D'$uIY2;nTRg̒~-JcI}xk5Qo4Ѧv94$,{=cs_Y'_3ϱY#|r@C+0@\S!/(Q N`&k޿9CBF% aBP1tt5R&RßVu}AdCJGz(3g_f%WmOQgeqyo}^?3r8 2(MaNfʟm,O#0)gm.\$%<]=qg<sM>sjsótK/xX4 =@]ORRֱyž4ydgV™Jn|mʟp^n+|-KkK؉TMw0 w^ $@vĮ+,,gVt;YN8+"LQ3^B?8=}ʶ,zJ8_܆;9:trBmӳ䋇i;iJȞOnz ;Pu±˞hlwLIw?'&8#4 i)<g"R5; {,qJVisc9H@?ɲy}6G1جy*&]LzO]G!Nwjorr%Of,Q4g!kpQ2:==}?_'Oxi/dʳDu'v'0 @vDZ5FĚBT5|=(DS_{?;ٿ?~+ϔ3AZ@W4 <1h|^)HМC _-8TmˎBO`Nds$E|DpKxI UyۯIFjBordt[?h4g=?~"GyPS|3Ɵn8=t$!pe*)ui~ަ|2P֧ji()I-s۞'.]ޙ/POO%ƣLQD?^CN,cIy"\sT;mO㼜fY/}|FL$MGOyb#wו]?(yFq2:-/m;Wbⅴ|jjΑWh=> ˀ:ϲIZjNK\nO5)C˩lI'Rg?_'|OQ ]'.]r$?O٨^, r0IUĕBEQ{fsv%9\uUu|=h7 r|: RnS-@}؟r8){oI _$'0؟'ROϛ^ycOǟΗ2ȀnJQbL01['OcwZrv8s?[_(̂9\M' i{h~B߻mǟ:<)ph"؟u:zAc?/~NW#_֏<]#mg>2T@tef;Bga\x ,5$Rp ӯcU8:~ ڟŒKf;v`n>-_~r8:oC?Dޯ]r <` у]*xv|o7_Ty&v>!|κjd!ϷYM#|ϔ#ny1:ﻫ _o{W^R=|j ٹn84jxC:HO_q Lp@Wͻ/y{~1yǨ$"MOmQ~!/v"|ۙWwl.j:MtSK] o6~mwZ٧9<cy2@]}%Gc; X9loǤ޻G韠-/Dbff E, G#|Ɠw.UT$Ɲ.2!]&܇{T%;}t$++0(z˫ǔ_,j<MlO(iLhgπQ0:' ?i%|2)}5 >v~ZcJ31;T/׷+%vϨυ)ͶDբD\%x*2 h ]oi9ogٟ Fy_Qzmnm5ZF9ao,2VNFA^$PhAP?NMCp6Ԭ?;xv92adIMO(' (DGl1$? j%gЋGRCtRjqMfmşGHo%]<_{Ĵbke(GL|, 1h/V4| hDA1EV/IH "%L$7{?qm%g1΋m_M4ӁyBD΀5Ajbz{50B%$Ӆ Ϯ@%RYU&0@m(9( 2?zA۟[w J$Op, +X L*RhCWO2dzyx0u rA$۠[=ֲS>r;}љ 9+' &!H4(y C˿'בf#< @$iz Xr66->- }kpmIuq<-"w.B_[diZ$&2!eG @G\C\ !SR `*Lhϒß \{6y!3Dם% A:>A7ϭ*kVX,L:K1 7貣/"BXP\^寷| :ǫQ6JӾ('oΟ3woK9 ?Kş)xC \6Zv>pc4!H}=DYX(xj!Q4#/ӧ(%"PHv-ߐ?oms߬@ VD:=DذnXZڄ?뼷mΠE P}iNKZ˧`H҉BHx\4>^:V^O]3ψ#A[">b<{r}РO Ь{ (1(ntz6 '\,Pǡ.,J.As+P։D8(Хrgr Gxq2\|y"P kAO\J7}J}@2XFQQ7!R!6Bh'!֎%<#{IOOH#J {#:8b&&1V@t eGb9BwIZntB%1j1& kJ޺E۟mtraO̟DQXҧŷ҄D^4%vIMd@#-Fi{ek$PFbi*|ykvL3gST)(sGá3Cի۞;ȧ<ɟ7i3DOG4J{b{),se R){hR:,j¡03_s>JgFg+/94~*E JW"@1/⤒GBA*Iɢ|2^̀D/;y6e2AiˊMJK>aψ?%4}OǝFiy6@<#}MAJ%6l:C7 OG( ٠+]LO\KB4vГ[bJeWsȄCFAkw58<`*ݺKSJ{qQK#a~-Wz3g7P-;?q 9]DYzD6<5Hg*?2" zEFL)z6.ɸ5$o^xg,<| Ož)χrRwM/7j6`;`:3B((jN'WkcʗD-e9I>sś,`H4C! L`]SDra ۟tu r|ª K }"f)zJxX)7(n5|Qo֙a<~gX.K.}y>i{Y7@M2'PgjnGpR t/I&P̟8L:1q 5]r/7P҃L0 6 o.7C}>^&8Cw|f!: IUDk.ȾObURx#wEh\T OݯtM7!t.y͟E/,ttϩ8DOUɕg=zP#p}\Vm|"K~U r‰eҍ1T]ZY:$,_=m(O2 D(ƚ"տOV ^DvrMb;!|g5#Kb`<+'u5*C7=#ƓР@`w?^X:?ڟ!61B#s`)l4mS]8tS:ª`|)  O<~c‽Y(z4.( 8!ul nUG!kz%0@CywfV]ϩK[v|\ ))Ӟǫf9BQEGP"u拊lL4ڝB+/K^՛s_gy,?OQħ4>Nϟ@TӰlv hVhFʟѫQCd1 E4Q,űU2x꜡g(T*LQt!M Fx~BiL:!>ow8bcF23(0O,h) zC]H5t>?OZ7w#Tǟ 0}gD5}ˆUaEJ^iNt'Z SE'"e?U.%gAF4AIsOnOECcZ@F8zWқ̬MmS:B@j_~gmHF Dg$&:KLZ) ·DL7EcG},*j BW/7uIiR?Z`~ɡ[|.@RYD .;J:ژS ^tshQiU=Ԡ(ğgvIf+6<`RPnb'XǢ|| }c_ϗY` -F۟a4 NGQ{rZ^:m4Ħ _#h%4_8O= _x{3S=ᓍk!'l,ϓ'Q} E}18f6J q=y| _$=G7Ͷ KZ?:S3! H5xT^q<*~y?Ն"sD[?oЛo0>K=4j4^@V_ng?U/0A:{K0f=eeɔELy>`J[4ɛՔ{]=]*M"lыHGG7㇁K==.fp5W`ja^\cV4 cu/@UxA'T+N2YN5(cYS}/#>]򝞅oŸ13R}a{̢)aUk;-tW#SItDODB"`O7Ia6!TΕ6R'mJ|g:Tˍ(wz(g/OcP Q"&jxN3VBl.CݏYtZo Yj2U?&߽{cN,J$LN^5|.M{ܗ`ٺH#P[6.*Az! G43uL2am CEE9V+Z=])ϾH'HZd}gϖE){3Ehs%w9]ڨhK"HU^h&?")BD$b]p'QlQ[sC.rEǑP=XֈScU>6݉'CEc(}NĝjB|Ljy#oXeL6@H4^G?͟=D -nU1OL$09TJL G0l{?1+z8O"Rm~]?.Dw`Tyn= _|5gء^z7CDbLHkF/3T'3?3o{btl4w`TJ(W, Ieуt2 J(>`|ճC/}hZ :%њ-s?N(E N(שrs&7^-. (WJ|~˛??ecdD9$6yl VH$Kfɽ .sG*|ο课be7'*"XcWFeTD0dgfdK4LP||>R[R>׽ӯ|rŧ?kuk K5|;QT?ݏ^G{tZ,욕Guz3`~Ɵ^w77/FKFOSuc^tldT"Q&=[#Z'_P{YWϹ؟xOkhRm&2feccT4E7^w6'ԓII)*z.% ]$>t3',:Wӏ]x9䇒e`v2Z$|a$ ]|o p'h08H/>!??i1d ̎JO~^' SDSB9^: 0ȍQơ´xudv7O@ˏ!A,͍?a ß~GRP8gR0sr?iL;2MR0w#|h>?s75t,բ/?ag:uHE>q"z1jIuxqO%2wt_`ȥ%md4,o$0ς89kz4eT6rOßa @=?k'z2ڱ1 #Ed,hxhFztCEiN'#/"f9DSlC!(jT=OoJ(:SJw1=Z}eg)O`Zx(g8 44Z NePtWQq ְU<ş.)a"?JWt/[laBy$WkM_;6Ow>}z$D+Y5 ǝhߧh'c/vQusrzPH2(-]nwpqdx].=uڏ˯wr Κisdڃ$hC IOK,O6[^8F. 'PĠtڝ=k(iN|].}1I!M)6j7"}/1hX|t~sv;jxA׋/vS893c,*a|,@%k"F⳰?!gBQ 1d n$&47#?<êYo[["*Ѭ'TRL`s.|ՌnZA5]grSrhMnfZ~DZBbȋ=Z'詗h(N]SbO ϳo<$<#-g(PO 3(8 edcTP}(XwcmO$kʀRhGx?U},ӨgQfHqH tQǨ`ՈmpTşP_"3KЋ*}zu#g>l|7K@Xa%c-`)ЧOd:2ZFRIIRK]h3~wAG% NFMN) u8e;T}R v~'i_K FKu˟ bZG"IG˟Ϲ׏^Ƨ?9Pp1Aa);2@͟1ZCDE8nT #ؠGH}iWIo Iе¥o=}A}>{4q=J:G$F?%4Z:R:S0~n(?LS_f)li#V2azΝ?j5CrI~߾V~$|.weR/q` $(,-ljBWGɊtٯ=7?;\MuvDh߄Fώ?Uoy*w=*3FZjxCy?V;`<|Gb0{?)ʹN;ܼb/"ǟs?3KZ=?kKA5=/̴NGP>R~Jyx1wکۃ? ?3 ~ɛXOiğ,a2)w0 j^:ol<19xz=TSUg](j(fxuQ32 Fc/H@_L9';h-B Hj(#CCɟBjx)BY(Q{ύZy<.H0 PJH)m#?3)M`0!IR̢r)?w6s84[$ ƒU;!zJ{^@i.si1ȟsݜO?DЂ9q"g=`Oڦ3۽-DQk-1g99oBU[Ԫ2Pv +/I%@WQ!*Ӌ$Fw64#[&#{OR ׮a=F4!s(bw28x1| j9تf)B-DŽ勽,lŅCrX{Lßjȟr:OrZE(aӦHisWmvK)3mg Xv0$I:b3+քL5*Qw`>aqkÿ^ƆtP3%Ig_PH0;$(hA(0JAv);TN]>)xFnG-9 Yت'?Y5`?;fZ,KP;ཛ __˞u|O Of T'I׊?! >kk@h`=>o?9biڋ3?; r4[gFv_`\Sq(>҉5~ߪ'?aP|23mW}*ǟ[$,,P :=u4ͦ~d R1/93P? ٘?3qqх1&$"_=H,MS'f@NvS@p iJf;s> 5}7w:g-`)pAԔ'V3<Ĉ}^bZ?>@#gFğ?iS.?Ch`"+ӡ(3oۏ_.]v:2MS,6y?9h#pRB"Ȓd;9R!|t|"JANp=pTG0,ц;HF+Mx?+t 7X#HdBaZ/Kuet[482 ]'HN͟+ `,'3?32nvC)a_ FwF3d U\,.^B/E]>fzlf hKcJPE P؂ A XԄ3)*]0z(Wamfٗ >yT2l#3XR88ez$L*$ɲE:A)W]:hs  l$pE 5"}:iI^ƨPRcC2Ս?3ڣG}BH# 1WRxlMF1>F#31FٟkF Ʀ%Leh\XY.\"Qj`Am/ѧ7gӁyw8ۦc*e,JJ1㋬Z-{ :&υ)T pP=s?g'F- ǪFe N@u)x3p薁?J:e,23z(?C|v@#Ҍ-_b9w1Hj3N!k(EH)J*ulaEVWկ}|-|" C 5$/[;pU+u:a* !&ܽ`1̹F_uÀ Z!#MZJp<2R-IOoW٩Iǭ[ʁ;,>6?GիZبze?\Dy;lZlsfxG^\6lR N# "}nEz!Vf2qGs}TGۚilyяo@AP:)Dۄ9N*pxKd(PYep*۹՚C:MXhSshddAO >o|܋(eã,I7\hjt䂇焟 ?= vkD$8]HERXpt\oH2ՑA;f~& Kf6gUр>mk嗒 m32BuG&#BqIh7#RS<4!3lsΟm1)Z Ѝ]:ɸ)|ύA}W'U2GSrhӚ2XR:'1\_խ'Վ ϛ|h(,64CKϏ/[Ps]&)XV_ cܯ#׻cE~+_Š'ǿYLP)L%Չ*oph= ?IoZж@Qri{FД e#^Ѫ_Fdt8zulf?Z!o2sԤ jCOmkzyXn12|nטb;X.oFs'!*q1;lz)Mq~=:~N^^t|/ɜ)}Ѝ&0$vUFfd+0zT ZW3SC?G*<(LTDy# ŭ(aE̎It޷I!Q֍2;U K>U~ŧ?W P&QE RXquΕrC)Ytjk{(Tx;ZNgisWwͮsq9%̶N/Uȕu4<ʁH2677KS+), GZ֮/\I߲9`ڣ꿚!g-ߕG2_MK]zr/ \`9ݹuW*Ҕ!f.;E^߯i 颣匽;Q.@Hq PeoǚE 9U{JC?}YױfvQ3Crv`9]2b!v~E š˟sn5I3os1[> 5cfjƟ5?ЁlнCfQ3yo{Y3sX3u?.5k5+iT{c= WWp]O|$D"Qs&7k̎T+?Vo.,,(_f(II6ӣڟ)s/|$G5u<|AKu2_=W R9pzv= jm_`pwܘw۶Xpv=Zig.-sl]Z;=vviÈϧFܝG;^R#ƣ -Ԉh {hҒ$I$I$I$I$I$I$I$I$I$I$I$I$I$I${Pf~H;k.x\AaF6ݸ f? qLdFg\MW{RGW4a3]^϶fO|~ }əgr>;7>,&>bgbG]>;:[;Z>?̢; ě33;R6h paFevd듣ǙE $I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$I$N&I2ki$$r*j~r7*Ppk&Ls%Qܗ b`LO0l$ B}c3 q$Iz,?OLҷs RV/8` IzRY|$}IK33LDħӖgߓ*>m9> stream xˎmq'/@, Ŗ ɒY,~Tew#Y C-,xYx??b/zޤ_}SU(微>y4=4ڸҞ>-Kӵ|\ǟykgϹϭU/hg\^J+ϟ8Guk>tzry9/ʓo8C?K䍱[¿~[k豶;z]NԂI_-~cs|~[J:ۿP9{.!?Xs޾{&>}ELkS=o51+7G [kf ?SfƷ<Νگ+ztW^9P2v]|)x{Xf{I)Os^S~a?9hOrnmSJ{Oߞ~^e?[?!P/EfyMZJR渏rVJW*ǧy|v-tLU'#vR:`Ls%Y3['>}K_[_%׫>d PܯPHmRSx]| u^ O~=!OOsH)C/^9/`[JJ}ދ/퍓[LvOҿ^ 3-g""~X#'Oh䲵We_RBF B.I #R|.r6yvH]k{dB7;Iw>oj+Edž.V9w)N& i{4\Zey&>]3?eKy4FA'HbO"!WT_ҩ/^!;u]F݁KWG\!ƍoSNiNUƺPgy5<%{L5gq)G>ǹ1ߧ1___߫|| b7S^{1xWx R׏xZFA{ZHT[r&BS;1_ze3Zwv./9kyv`^}S"dk^)p1s`YTN R4R$֧TZP߮2 *Cm0bCXP t(J9JCQ]b|{% KAQɺ=GMRH&UФ ,ue\R?rq1:n[R^=cdt/{wQ#_p"㺃ァ:)GǤQtSc..jsxx0XN)F o^#@ hC`V^h/g tnk/>dAB@ˆK_FOA`eCi-"j/ljٍ"CP+AE""q(Ws9 " R1PǑcrFq 9g ߷raX aE=U829an +M"v V+:;jJC=U%VPa#$c}a UsT!r#Imq%:} Px&†$=uɣq@ʪqEJ&_˘O[0OSPAo7i2EiLSR`-EZԐ"67[(7%v}oD{QBFEш"ꀂ^x#O('3Ȫ(W7 3D ǐ#uHz H?l=Ȑ),R?H2g6=ڕ"Sk$yIPO)ɳ̦SZhnPdŠ~E6H@G E<?Ei oYXԆ IR6qV.=6No(wF=6'J ꜇%SlPlt}Plbp Y Plʾ6*o׈ qFQl,,*6Sl<6NQYA/\aCeSXG]<"Q/ i~GzBSp" O9Po7tm-5v Cj Nx"Y xx(Ct!Z 8s7,)_G}me[&L@ &&L(M < Ypʼn I'ɸ %kC`y#0BߕlU:L+`2h4lՠ) 1auqN(M4hMx@z8 5UkMЄRфO@HKMhb%Mv jh4A+&RJXhN`xʼnvg8A N8DpbNDONMGh"*s8p"ju8Dp{!TD@b C54d S p2%=}vN!dOuQVE 9iLP40y$ȗLj"9x ~̉ÏKx$߉K!|\_Bd+cAB'OjKy4J~[קx{;a54~T0~b7~s?`GRx<'V<we=!*t:zys+߿ږ͞;`b@iX&Uǃ!cQ>r4&zI'h'?Kjbɪ#=0Ƞ$(F#,N?$:c)Oh+OJ ۽#O ֔'ԦyS,-X@K) J6L?|J!Dy J R ŷ[=&.EX%Z6~(vJ` EPK`vev}g,AhK"f,7*Kc%Ԇ0@?'1ѡEFlMڋUVƯ\!ErKB#.amCǔARA[3l,b9ȤWi ۣ'a!  S >QeTt9K(:h4k+kXr ~ZCY8 rLlԋ=#%)9:(9Qo45.Sз+;Qa0vbCn@th:н˫.b:jxP6vJed9t:Dg|k(;ræpdz" 㟱dV%DLVP{㜆|uI0@:'yLe%B%TXH&X2/l1%؄RL,-%&~^dE~^dfE OGI8p(iSfiYWo5*$+J2J\DRhɆP*JPk%j0# l$QJ5lm$ڹB$Q'2ь$x Q7@$΂$P# $IƋ#=X;>0dgL!4_<2d!D`H eHHCH9lE9 D!(De8r6뙉cu@ā0dN@ C* S&;`A M  iXW7 ܥ;(Ai))#JVە ZC#ZіA` #ћi-g6?C]/4~4=~x凪8~#P*u%?d(!GXId=IcTD !s`s '$t2̆|6#ޕB02?u6J+HH%$\~QO-0S㓃>Éx䏏7)({o RGoxqW)Dʔ„NM8l F[ r,ـKS -`LPC`" U-%j/ l ']?+(y<[!gLM`Vs<0deWP0r>22`H<˭TJ sLYΎ2?Z$^]ӛ2؍˼!?Ϟ!)!!nC\0DRh}15Th+!(C` eZ*Ctf1|`  QG2ٌ!]O!Yc7@hH:3 !PC(!DT">/ߐ;۸{y.,d=X| XOFw9V<< d,^*S.Nݵ~ʶ4,pKi,\W}0byuZ&u^c y%0,Ez!v>2*7rKuzغ\@\άrO u۹O {msk3ATm#~*~Ɨ!h>˒`6wKᏀ*AZr&1Hs=i ‰c$j;=+V[ ګfSؔEz1{mW=w׭"nmޯF}R@mhLݬv1FG)VRSۣ+ϲE;y)NϹ#QO| NL`Z8uZW IC@q ֽ•?׺c z>u˳(׺[Q׺[[,ݫh -׺.uE'+_u\zr׺#]\Zwͥ׺k.wk5EG_^_^\~u//{?W:;wm䋔k#V?#yCTVsS{߿0&soyendstream endobj 402 0 obj << /Filter /FlateDecode /Length 4399 >> stream x[Yo3fmC8HX"Ф$&E]ԁ|U=];F`hX]w}]3yQ(_wS<~y6isz18e*񣣲ToDlhi{3ʒ;YEkώOܚ8;mtr5aɸ闭Q6L'nwj9Ki-szGζjVKRQXr.zV1918|vpV.'8omwٙN2sfnx&ly31,NpdzPuXq~%+X ϐY.X0O?JFx Bc棣˴]p*nD 8:fV;꩘m"bZ&inqΑUJ(yBY01T@݂(#|E+TagrfS6l#孯AI')G~P(!WC;#4}Ae״slZd9SaBd}Pר͙EE}Vd#K?44 X/vEQE TJ Y)_pVȑ6Ft(Z9Т*AP3jd/ 44N/VVD䖈p,F:lêP;GcJ[4vKH J,jfHL@W"b(eOHA @+&) $U󑠠ԼkfKm +.)سl>UԺdtfka[(%JDgK8]j]bAIDAgw8DAzυiKB[`L 0F񕇆vFY>J"G[ u' `*t&d@s< s~څ _E[_QP\ -'{&f҂]IJ 7 #%S29`*r,ڵu ^Ɉ'n6«Ău4PMPFo< #b[;(x=5vߋvHMgtS[DYָγ]yjuy-V жF!2a`xCF#A#=~D`!WO.h@YkJϽU&X/t ƂxT,SU)5?W)`0ઔ(,>Yy@,ޚ/,_?/CȿԊ{Q0=>m9{ F6@6 og'p`hy DXn ֧WO.[y zqOp ChoCؖ ~2wE_Q>PqS(WAVC Djx ʇV(?F( u(;n(ߢsUJEhx3WO{-$Q>np-(A|*/(A*%ʧ꣬D. wۈ@d|aD {\$'D^KO9KrM0 @.j0E(Q$(?Dl ZCd{k% D-(φ!%P@b@y vrApDp`k G O%ʏ&PP~b6͂#dDH1$ #|WYrx16p~Nq>w*Yq>Bp>JZ 'hcp 'd8?ь*Hl݂9 EܬFO8? Iqȓ`]) ϸ AIJgpg| lc-xHIg;gDa~ ʏ톸|DG G0P^P>i@tߒ(?*KGA R@P. Gg`W c!AI5 `E⼂?f: - a_<U(3rJ^lPdS[ɵ6]#94RfKN6d.O5Jpڕ-FhpX0GfaZ#'c]Tz)fa$ lJ'xCzqABzg !evtE+b9a4?<>쏐MScC,w^py¯*Hy<#O)Ccnǀfy@Ī(bךh%PZN57,;86ۏK4IAME?*z٫DoUdV zôq|?~u| o_6E4V| Ӓ]|vp?]=B0Q;)87?:91?>? g;ZW'Ǜ%,?^H`wZwGIL{ӥR/pT/3IKQQ]fZ+cӗ,Ezx}5>HKn'JO 1֖dӳR¥~(<Ξ3W}@oThlX #1Sl[:SjH9hZ׵yyݫ~CӀtW5Q'MmK2u zMHI'/鲒™x1+K˿'Ȍp5n.Ӣ@ɀ=y1ʰ#5pn8ӗw3_ ^^/(`HTBY4 tY#6Ȫ,CKzepk^H%rFWVٖ݇s Zp&U W]R֡,/Ԙ?' ^T( P E%m[TUM4Wr ?(qs]J ŀATKƫ˧1 XBaC)$PZ&7ݖW7$ yhK'J^K:Q"|\ݝNpQO!ݾ.jz=k94$p! i?K[SNԏ]"jJP1sxCya E $>W_#k)ݒ a—PIIf| $\#o:E&md~߅>qkpa R/WQ j1oP#ƭl:+2|@ݘ"iv=CF(E3s\BzW1}WzEH"8.kXQb~mɁ9_/n1`D$Tߋ|ڋ yYY}b7oa9͇4^{О&X>X<-=a?h_GwYNN34= tC}S0g}/ߔ|v+%ak$Ŋ8sc<ZS훲Wd |LfCʹ1\bKɏLFfajBz|H!<4@"uޡJ?`_FX:WⱣ~ڃ|fV=O 1y7YfT:}z .TGl`Hz7 u~sň+AaB&[k, 7iW=!yg7vm^\#|LN~P}Um# m{3(Qgkf)_'twoWC/sv_Oy). 레 +Qdkoevg1M|:USwhu8?ٴ^e˰N'b *٪E\AalkU5r?uȁ# ^&{A2z3NW+'ebTOgqja2Ƿkn'돻# kiM?sy{ySՇcgxendstream endobj 403 0 obj << /Filter /FlateDecode /Length 3017 >> stream xZKsNḐljrHII%vETB"IH\yNAP%)|ha*7?y;=L|~_"RDl)X0Sg\.&'w3lI \u\UpI N9߼͕R4/Ӫ&4\V Z2ETYAxnn&Bh8@y%K5!n972mdvULZDq(}ָKZvFf}ٟ4rܸ z9D5mY+Tnk) SP M!M螄Q ^jj7}PʠA/N'уtgMhӹ264& 2وkjtH"*+1@^I,I,;&\-qO4T9bMr@]$tʠ_-A%N^f&Bd/AJ󨓷E=BOG=2K!M1Yt |κ8 A|ȍ-K~lC6t.3>zhv#D`6)eBuA>ͺ*7Oz ͗qwFV>%`r>TFes )⑈̡U^4)n<#~79YV[bXu%O+fƉl $ aB%~apAUѹm{ggh?C 1l@ɘ*6ໜ \d0Ȇ0 vgH~$,f,oYgER:ƍø`yGJcQ h`Z._dMURaѳ-8bcu]U.c`"ڰɑuxXu%O+ .K:#-@eG+`'cZ 5*bbpشO_/spNu83+Vfh?O30XN' J,SMá@_i=+ UIS<^,,Fi XdL\=_/&?N 'l2VrQ LO&l,Tr9yyO˥ ajѓ-o- [a O޿K eAkhѐJv̿=Y˨P<Q^bMTui`zu(1FxvشXȈĿc;0u! v6SG[U y5-Jv*aJFSaEy ǩaIGD)2`g!ztai1Ԁzᐬ=sooG؏U+V< JĨF'fͮcbҤ*i:v~,ҒnN |Bs+_0ѲW`ǡiry{HoB-N6-UI}Z)xO]̆="}Jz5l 1IcalMWj!u~V畔gC]ճו\UlO>C;o*Sͧ9Vrɮ~`?䦒1~~I~Atţl -IJJdo=,ǒ]}383[>~9t;Q@Я>.סk}3{<{TI~l7c ";Xs JV5,a8`D?|WҀKO$g՜u‚vW<> O+ o*)+V>@ ݲ],<RB"{4%YO$ >S$%+$TovSVmWڧýJ>g}X5>s{% +?*=KoYn¨'M ᢒ wOr/1 oH.q}I_yƻj۱6nwS۪[![es߉k㠏 p{tg(͔'tNI$O<I:Nqkۚp\^gpo747ӱ{V8))C6^fDg:#1 Z@s0zp=5wڴ`@pr::zh )UU.."j3xKagh3#<NuRXxdKq[Ѓ,ttF "VrM;_$$"#&> +:9!KGǟq\7,V K˿YS=sڎa9ht{%cW^˫eIK:&2߱ V;$gYD3QmHe"HSEG4lxχ̶Tݙh\+1Pɖ]ߕu2lq3:ظi̩=yB'|Ŏdh#Y%:yI8y+ob6Ζҥ2؈;x%&Ҵqr;SI*iX;QJ %]%%gd7~FNM:Œ:@>g,TҰ[ұ#e$}(<_mx" kxH6omb6ɉ]ڂW1bq:|&'v^k VgK o`*)=@bדw vm!E鏓>4endstream endobj 404 0 obj << /Filter /FlateDecode /Length 3159 >> stream xrN#tɌ̝P%C;IQ $EJ6KKKT=h 1\K>tP 4ݍy`_0?:KgW{lq~_鿣`2xd/ VK88~͜yAIg^u ۭza~[l+_|8+ ~ޅ1\XλnѝŘv(Ikr K71ۜuVݻ&Ohr79#dqgsݶ,l3D!yމ;)*ca: } ?q 39q˖1ªaJ(wE B1ڤcJn $i-) U(h) ',.2w/%Z#XRd+il7K/Q1 -1KN$1E[G=q9R&q]Eދ D%Z=H҂$n6΂6ʍoQ͚YW4ix3`\U#nu1蔚bzRyに UԐ**;K5VRH* X.c6XaJX"> VB L$' " el1i4ɞ`qozCŴaॿG~cHރvZB7rYqRC(]G!haY4бFtnG1%qmSl nW-&xBؓZm\u Yц\&bbqt4(G+$s~c-~1.\xT&v$aGYdW CA0G}#j -U"S0NSʢT!|[L P. 6&TaXN5,:ś%^32`) B1xpvҾ@noz& QAvL#PyTA=#ZdRb*9RPHRNU3 SsCr򪀛0? PV숰x&l_*ș<[9TQX)0 ߓߍER$1ӭ~ƱZ&;8q8VVSMGͮf8/cD+3PpIQ:p<wքpyh?qQ-  dQ*0tnNTD;ey_>zHz:MʏC1ýĉI0sdS0E#\gRTe{[| DJ!%g!<OķU#ᵖwP |X_T|U&Q2]^=)\+[rr󧰪#H^W/(WY΍H@q.TV{Y@*&ua'ppW|='QM iz[uapYVY>+ 1WͽQ臙DK`We-;ٲzCeGR,VpNgKQ$~G+.qj:i QuP>+*.cDE'FGI[`$p?G`!ce4eF$L3TLWM}uqt, |b) q*NNO'|՞*6Pf|KoP _:yqet] <B>ti^+OCO"w))~؏}bbkjxhkW&h{NB&n7jWq&WlnTnyƆ vHWxΨ ٖ#}|->Ef`^szil qn MGp-e|(eg"vǨv˼|j(KRV۸ŧlEVwC@II?m+ggJRxDD} jլ^c 'Nc|`^р)=c *äaV)-foyW{ ۷!p)yjVnZ@ND0Γmc)en)7%g[*v&)kHBf A)ږ8= ʛ׌jkXMG$ֺi@x Y|Wu|휎fe2N{93}>2GBcoYݦvVbv *Ò$v3=v>9nH9,n8U&7ض2Ejk GmjJSԺꋂQ%CeP%ǁΥibW2A;$ώ'>[];{Ӝ}`29[HWit+ր!]O`N W?򋌌)poA*!j"}Q&pLUR@lIqH=6~GG9~5SSD覚 ajKtD67w/6 (KH=K~߮SL޷7Ry:niHG$M9>̛5`-ڃ,R5 *M9)끒:o#2lc[7Y~5"B[7(=fu&lxYp*W5s[ԫ潄wj~;ڄ40[ lx{u/c ~\3 [mb4ޙ/npc󸓋$Q6WD/OU8_s=ݳRˑ:9}"V V\c>Y"*Y0Io|A+~[~mT^ 8m @3;˧- fv`6 mNOA7endstream endobj 405 0 obj << /Filter /FlateDecode /Length 4623 >> stream x\Ys$G~z`g身`a^lƚV i N]Y=՚Y{!aK2+/_/~*Y~}Low翹@*I_\Tuypa;;]\>AqO VVЭ/گ\Զ¹Ų_lp=\ϪE^oW}񪣩C@?̌)vZ0Fw8K{0 FX#k ,R ?],5+B (pO8ݔ{1z4bkS y*cIoq Ju[DJz ;voaU*D~/[19\'8O'F)k4'K:LfboOt$kNc+fX:HJ%ZUԣ*1+2k"Ηƭ<) ibz)Y,I,GG#u͠)f3@,xlw<A7籉-E CpA 7㙤ZQʝ/5HH@:."JpYt`;#* huVVMl^A{BHr"DC7kZQ1ɧ1צkL ׆S4+7E}i>QňiqDQLQ@v`J&WgQA 6ޕis@##p `9>MH&7Ted d擀Es^uZck9 YާA){,=At=mq RwVFy Jy/ɻ>pQe+ >&D! 'lM !)_ v|sx%፰ƭ*Ǩ@.~ ٬[Q,zF[Ƅ)P9ظ',a~ /[cIhT-oNSS/]inJs+ ~#*/9TzSoܕf\dcA+YˠKd&l1VPǜPS x\"&UN$A$M2wι&u_? X}jV%Oc-Æ1b@{@9F~"3[0L# vG n JO!(ر@^$Xe3С 't'iOPS{O Y;8]H,FiXAk)TAeitfN0:`n.wVq*M/"$\+`BAcBVC͝NKZfδ%gB\u7GO= >Hk<,QEC9XWt! ى| >%QK[Z+ztf./?nj$y(-s̙,x~掳\@^˻+n$_ AH[ Z/h<+ MQ-&A  ]k36M0~JVNǹ\ vRvIJ^fk*f/AB9B >..m(g\6`%hFD Nkm5}F;23X:-.Ԝz1u8Ol[J=k='gO %QBo&ЏCʏg|5{N4uwA\KG {.U6h,4bU=q27$->z@_-Ç4L*;KEINhy3~]=wb:]3&UG}XCLI~8 <bK }ّcM0#Bn3z3:'O7s'8IdNZLHm)m43rB64)W~d g9(=5a̡w2FKe(o<\@)Cu) /సaWN|򋃫w! 3&h7 %_W_:F\$IM,f͙l|p(>N`>!4{[ hWu4}O6y'/ːgqNg O}pgDx;˝@![jtnbw|:;Y)]G1'ilT"5GRCzq1Z%qPx}] <↪Sx2 5"$ˌv \#4 tf"gmcM ʢZVP5s}B\fDͻҬ.e]ޫesnە(m!&l}86V>ۆ%M5iXX*e J> M3qaq]|,4e@_T0HF:3qLg3e%$-m/K˽}VLN7\ IP#T޴ic+oޗ&Hpǡ8 G$k͖cnYaS(\wmxĐG<ԅy~X [y>xǟ@WKE:>75GPN^QZTUɍi0ko&'p^o3sͫB~qP0L)`,ck~Xp>V5G6G";`t4^I <49|=.WFXE|÷HMyNCOrIyN\ѣV3:!>+=)J\TU-! L8#D=4%t})䆑!.S_]gzsd]*[)$49"̹Ne7"7sHYvuޙR%b%4*Fm~K|m%\?eƧft3oǸG{;~ RΙ5who^}_:A<-6Agbw{iXG8Zlϼ3kn{"|t_N?y|(n, AC +OvӿÐB;&TH`^y&n᩺]#t ҷfz;QdK)2GoUm,`LT/l}yqg_>endstream endobj 406 0 obj << /Filter /FlateDecode /Length 18362 >> stream x}ێ%u{Q0`P~ 6L ` ACsf8rfdEZ{S]Emن zMȈ};C~ݛ5&=|o2=vŮ<_Oϧ]<ꙟZM/{[Se>~mO}뷽?T㇯z.=ս~9_ߗoSڸ>?9O _?Oɮ)ₖRlWz? ޠ`?{Y?~k+`ٍߥon~jcZŮXkzw~k=n-]iZ풽z]r0Lnl ij4D\b+4[|M{Ð1(G6nk#.6b4I_4Ւƽ>e\c0z +4-xoxQm.&&X](쯉kF1 Pbljk5;Vs|b=Zg2ZX. f M!ĔGOhra7Lqhf5j ;stLh.X ǑimtavM)b,oU76(Jp3u % c0e@w P}PK[K ꫆2ki L#v[3?!2v;h -1d2q\T\+{WCV(!2uu{w@%f {YaG`pʙÍ1i%(am:x SQH`2 D:˜rA5s&H5\SE0mvg/L3[ƅKZu7;``&\39cf@uRM 7gnމwi/gǐA}-p 5T÷A:&(^+WlIW'X#7'N! A$6R](1TwE5tNoOX&{S@X-3]6ӑN̚85wA-{ ek&BCG==: k!n129Y!8e5]eWB>&J#lh) bC=f%-uσki!= vv22cТWn3sM5t͓f0x$y@YOP4L+wG]4՞)&gW;{ WSry| Pm Wkx`%m! @R4<Ӏ#[N-(Mץrϴ!눹CCnlwAd1Q#B$iX+R ̗2utŎY3t!m V"kH6F4"Ն1%1O!#,L4?\gx/ynj-B䄀l$NÀHEiXiBx EH3-T-v `a6m.ۦ= hvC(^k̈́WZp z {jBf:lD݁oYF2dh2 w(s3Cӧ;s-@/J .n{- K7K 2]A˚/DEAoqD0ٓڥlaump uƸVUMU + @oRrP%Skb[-3͉C[{ni2]&RbxK& ˣ%ՁFbe@uZptx 5"<39?= %z@pVqe}2'#TI~i A0WDO6RUc } S7V ]ʰ;Gwo  + 2 "?{R{qf;tO d⚒Cͼ!H'RpI##07!C) a'-@6XA"Àk=&|>6w ՎUiƸMJwdf@LZanؕ$0<9t;o(j2ȊF`ܞX ',Yw@>eZ E&4}Lĺ5 ՙTX|-d+aE m@PBFUUbV%=dVmhcRUHLffɞQpM (1vC IEw0GQjGfl=ԛ0ƣ'mEUCmFUfw@WX$ in״Q@!f&ax5&ő -.f͢{#Voߘ@9 9 j i71 b+l-.y{($gTJWdlhulkTv`WcpB3DʑAέy^>6#A:XZ;@iOcf hVjrn%7K`6\Ʃ4pK@ʆp? !qʪ8K` ,l{Qkw:KאcH?tqS!48M`(J%f4R_vF(cȞ6Y)&i$CiD4zp` Sc97@K0ғI%R,r"_kJ&o@҅d~k{^1#5DVJ{Qt(Ob}JqC d-!5(_(V0>;V;Q996zLâG5 `%. f UaCbA8F|箪{ltY%KB>YpW`ejJ(⭶&8 O!e #pu$Symd.I 0u' -ps7ףPh dgbjnƯYOg /' @F dE_Sb[?cgJ$>ǐ;-Kzh 5תsVOb6 K1XEDƞs*b`t&vyc(3!V" '`eǷPsSIDEe3(P&F?cw0Qq%0P&EK`5{ebq̯}J p dwK"mk+a@7"1_b ԟY\p/0șUKiC:nulef̢eޫ̄"Xb lv+B[b po> p?:gf#,Q""ab֓Lk'xyF?%X%7w7Q0O H^r͏HGIo˓jL8RH-0A+\)A]B}Aֆr5\$6/"pƉCnMBrŝQqB/ Rle9A#eڢqֵ6}w=%A@覼paPUHb6B6`pc$X-kYQk]BsZ ɹ>HRlFk )p e\B_R vb41pU|Hʁ@J8  ;|*P[n}X63.ڹ\l/M 9'@hMnl쀴 ҆}–3>Yn ž_7<$d.dS-""rdOIsL,l:&`#?Cl c7$M@߷UAG_B"'[|Mqn3"gi@ɱSE&jC]@쨒J,xOTNbǣEUxHҙ1gǾߘJjp/m:= vz@^-igb3XwY-ĥa@tT,a@Q{S+rC)pp5!TX 8WtTl(,.7P{>*/F4S 8>t)xT,{ = (AN (%[(J^L݇͘NpQ[GF 1]<:-vZv}6ΪnCo.Z'R=qٗ=NcJ3 Ų3 PA~w .Z;0ಏ6W;gng1kqwˢqL5S@ GJ>F2p6\AR ;܀SgljsrJ%'W!9)*#)abhgz`ž89l-I5`7YB98O$ kRd1ԿC@ 8嫻+;m:+哷H:g:S%Z,;m% 9js{'z##~?fRf0xA"Zdlr8q`fAOhG* dm|oD }E kB 6};/4IԍK,dLAH[N=Y=!$ kXE;j89zgHo^ 0=? ĀrBd6 2wڕrJ '%/0ϾY$'y#DP=&S;V5y}4ye֊2T\Ab/#TG$8+{G''x2կa}ĩ(zny^":W`g؉pg9E&g8QqR{cA"pZ鰧o W^xOb[RN @ii#<F^qVyզ_8'X&h ґL/+߶#NHqQwvuohDZ k 7OݟyJ]DVր$taa'8W0c2eG`x.S!t!ISZ$H(n W>WMMr``lKێ-Bq+N * `[ BdPdΊ@[Gz-W'4W&;Fۈ0Cg p4uL𗢬ѐ%-I "I΃E~- 3Dġzn<*'Mrhj#=|ѝЃbIQ]J!"ov`_(EG](V Kp.ʽxk&Ifܦ (.  x؊ Vf5DޏvRo3ÅΩ:pF\W\bMúMaZRvN+{T7BK`aT@.ęQ]S^DࡻMrRjpo/V%fs?BZT-@Gt-Yl@|2CKx=WgwQ8TA FH15jurB@ ֑!$ *磗[ &ZL:C'Œ!TGH/g8PfP6BH q8qV7z#Cz?;%FR!]:\(Da\QA39-ڕ S !BVvY (iX`o\$Ry PSue8^Ahf;.fi@U#ٚEd6Ob1@@ Y:YPHm\"w.m]LR̨%qS~h;(Aɪ'W|+جy_Aw_eE&0̼158N,Sӣt0>Ǡt PNDjG=: n">BV)8pD \Qbnc\NS ԩSP,okE(ʭi mI8?oehסu&{n0@"t<DɬX.ZX ({)tcȴ|5x8Rh}O^::H;2ͥH rWwm* q&aNQ/idԎĉJ1ʟN }qDgc j) !"v5"oBJݚՎrȮ%^*zAٹAٹ97Da !GS "0^W2gC=\ڬ#.vQ";؛8AJ7gL."Ap- ٹ%ra6)fT@8R~iTNC}y*c E 3JٙeIm1$nz,x*ѾȔ[S5հoN @YޝuȻ}iE9y KH!G$E 6uDC_+m[(0v;" {׹QzX$Omx[κ Ԇ kƛouz!b+JC !N1o7[gKC2oO:*B*3n` []k"LKB^:*'bkQ6BqC|bqv@XUB,%oVV8 uŽXJ!JJM~aϘ8DdvI"pBCξd2%̉8jHgXC [F^$Df?ΤD<ÌAq~@Φ~7p:rr yb)l@ipCNR^ !V)ޡFt{؁`ޡȳzWj9yq g q AdCe}!T#A EY XnWVtWӥ>O Kb@;h}@<~7 /͢SH{#JIOfx1I@uܬ*Du@(B}k z[ 967-S5w%OUH2=¤d7H!V~SPLuEG?H%Gh=tgٯa'*(NHp7t6j^BHۭYEI&O)񘊆 d w8B_Ýc뀰ckR16a2 k!'aXDu@:M  a fF0HOPj ZI .Giu3,/JO(t(׭xѽALWvsӄ|8i)*`vUzee6q+0 y ʩUJah^NU\u.ۧ|S-X,FW%P\('ŠaUevʁ" EKwMYMT5LzV NBU,tj0?9TkJ5.M\N&.gSu#Y4x Rw,l<1Q=3LOvjt۟NtBjOvh6 `b PE3v&.]Fr7:ENg>576o8˚޾EP < ' 2#Qt6![uH , !kgG ds6O ҩYb+8kxPG hnD)?yFžSao((w}R!7er=JC5]\t?I`5@H A2mU-: iQrTlƑGVԱRzfyesBz SRr16q6nN\*)hb HbM򥼉;or'ȱt1/n7k35ZӐynw ݙ8|BV lpI p_Ipı|pzH'N u05V y1@TIs/ Z%@&` oUbM8Uq 5**V'k/6qؠqwҊr>SSD|ܪx W"/5iO N=r{" sSrt8RA$!Kv%s.a;C;7'B=[m?v, @>Jә؎M>vv R@W.m)(D95:|hL,'oFpk-(%q)AVj^%XӝM0ӿ S,%G-6Joo߬֕ s=<<9쵓~x'boR( {j?>E$de`S9&O(QA 85Qq2:(8O/V_@ЯJ{!xad# 㦾N1EC)M\3ڏ8\= 08lԶv/< KS:3c1 ʆ E9>@c-s }9l|o~G d+M~Tz u |مVtK=fJ}0#)hb_H]7Y2+$E@dqs2:Rh5^׊,C^qn`MUo)Nc|krTC&bh_ej daMD߸s:!.;C@|55vBE u8#}dR Dj?EDMa>$Q9zK.J)3>~EmYkD H'7*/S:<~8=.N H9*ۋ%f:D+ \v%LVk'r˷)3C~t%muI,w8ʹ)OO)l",G~;%l5v;+ţ ݣq|d>ݴMm$9S~6܅^ec"QwW_TPfm(bPݫK$Sb~cuv>tqR7F:8I<3췣]8úӤGSqVw>|.uWK NϮl[g:+Lv >}d!u|]!@goW}+_vⱮO߾훒JyO<|,=&?ޤ~S>rx z>Mt s{Rvpnv.=WmVrz||/.""56 1F#)|ݛLoߑ>9c4up^༂6H*ZQxKXPT\@3Oip\7g߿ljgs: GL~O/Hr%ig<S7~vwi1Ip[3cl%:}fHY[5=edt7>҃l~5)CLŻw8F1%"6i勷K&7NZPWJ*N|LYț4&^soo~NF{ܩP(]7G:6G%e|VY&LҺ[򏿿١@y0>|9%_MHwåAg4gW\'҆[Ǐ?R,4ܲtz/nR{6W'{5=RZJG Lw ֓EޖYf/RU 5#+N|SYfY>|q[]p`Hg:ګP~S9C?~Z䈎~Еf2,^ve+|/-y.rɧOo9{QN~C&q5;$IN:ЁfJ*&WGP>/?|Ll3㑁墚n˼MV|hC]sTEz5?l%X/ny''u{9czI-^C_eBxҋ}-8X+t&i_<3._>y.+^qRu ,4:U~jqGMhA]Wņ0m_j^r8՞$[HlM`g uhfk]^ebOɌ.H6XR.q÷w=\Ky /KA:2{ѹG/4/aw+k^25lwF|Y޿{]=w.A\>^_c@#wM^V)ZIj,;2 6OYW6#6}>qM<^_Z3x4xVl"t{1s BB;z:b},[7.?ʺ#qpE^ }_"7GW#*>UyȽ;#}]bO7|ͮWJiT{3_*R-B,:BwJW A )]%'/R{U.uPWhy:V:?>7"&`y~i ^13w.\|1^102|E{nײB#p֓-rt'&Y=&{6Kڽ&>f a3LϪ^ PgߋmlR-vvl.?Yذ]&Gn|`z:#u3oջg|1`tPʺ(ŀIY /d~gNw(^3^#2h2,Vg}=;+K܇'p͟IFR@T8PYxV]H.͍[xTj?z*oqOoF;{u\_Y^aK#R^ ϕ}n-{%#[#ǶWaeFp3@Wmb6ы`0~N/[||y]g#cF//8.yoQø$*z`3EdW7}onf#V :Ǧ[  =rJ5ˁvw/.JY^}p,t 7d?RbCR.S}ryf;lQO g|7{%vUeMtA6- Wd~WJ}T⹧a/חvY.ι|P(WYJk]}ywgw*,3s+,fێ0Bܴ/Q}8}M!7pɥ FJ||gːL*7yMg^5^d>[0}Z?%^֝G+yϯ }`Fa,X,_Ie"ϡ11Nb(L>ۗC\68^o;|zRT~&ĴAOKyKA0`l*7RwpA!ds,^/Zt3)} ikaU.U;#af*3Qfs\S;%+Ws]s,_-`%^lgu @GJFZ{+<vke)n_ oIBZkM"?/r:on~w۟//0rϊ _k^_XR$%FV]UCB kD#m<{d_\6I/Rq :s<\]ƇK@xb_mMW޹e/T&k5Bkޤwc2zf@43wQMsw=]s3OȐ![7~F܍Ϟ~ 9,sJgA+kqEs^f༮Yrd+i}vc&*YgZnB kMiԇq8tw)˷)O{?dM\,]w^뭴7lwp-IRpx>]G2-~X.fߴ_^byh];Kb̢!LqFQIPj sKIZ^H9pRn~ue#W xt_gh/Fq1ofϮ}g pwf%U]y靤SWϢyl=z o1_bnvw.^g<Y#b|#wfqgM;z7y>\o=٦[~??GlON< i@lHjbɃ5ƽK4PM['L};hr.^d۽su?ۼ Vo8/iqnvü .zf|DYʝ9& wnsg&2vyĿ]#q)?l~endstream endobj 407 0 obj << /Filter /FlateDecode /Length 2582 >> stream xZKo#nj?gA1hv-h)}0tD)Z!Z$NE8ρ`uz0!?u(?ʺ*.\ JXM!@xWA[W*@usE魓dp&G[UQNB`d1}ѐU>&8mLxR@K }Ae.I^z&u[&duuY }vC0yga3Z R5w̃mDE]SD:?BVZmr G.cY9$:ڗ Qrh jU5ޘ('fC:zʕ\1aKA"Uj)-PP!>nGS)t-l] xU:徲.YZ4뎅!%g!QI=EY?(:c?5ʅ\44WqVt0ʈ&ǀɋqtt%3ȊW*'ܡIBw0.|$B>%ד2SYS "i}]JѧMt92u3a nв0 HI| ݔ͡6@}bFTM㭬nqP0^ FwT0g1:!Q@najF>mw$~\@q@b+/ NY#1׫ jNS!fqNÃC֤(¾ fӲ*𾴵CNLcF&ڦ&.6?2U⦮Vf?Aݪrg(rP#4!,=Om;$@ܨКMa-Y{P1g3ve&[jԛ &nNLZUqP];eڏ aoa*IS\P( Bs0V mͫZ?e0i$ڕtB|]hEbYؖ1ޕLpN69_mZG0Lh8.q0iz5,Vytc.ŲzsF䲑N faB1 6e\9u[=ħ Q\Cxo!~J|VPqݧnccĸvt ƇB 'پy%UT?1ͣ.Y(*{qrPgRHfb ] ^ _$lovq%?VC8'xi~:5aWsG@rњݗtL$#)¿$E$G L.pk9z -&w=5n ;m:|"%cIDlȻ 6"8Q k(W$`'4G*`ˊ{V]G{) Oi'NR^ҠqQ}A>/#{쾊"~yj(С8[ٰax XY"?ZrR[%!#"fx|A_CV D3~࿦50 7lUD=KT '(T耘~tXendstream endobj 408 0 obj << /Filter /FlateDecode /Length 4497 >> stream x\mo$G 6Гh:wrq:Hql%`H*7j =U,6Yak`KQb^H}X X _Wxڟ '"vY z08{wB g\YݜtjX!NZ wKz-Ki{giL/ejUڙ譅)Nj.~* K|[~1= &K%`V4c+ㄯ+U3g&dtR <ZKZR~#RU;]_%1j >xb/`پ{Z5. Ai`O;`> 3wAk-5TȄ>LxS~FvȒڊSqy쉢fFTv*e̖Ma{WJRRbLﭥ. he]/WfelЕ67@ , !2Q-jK n9j0*>^ewgD3uJ4t%m,!sbEY;_6^^ gR{WX˷pVF^nQQ1ydT}I3#[`$k$fef$$LNq?M1`U<}{5p$gfН[79"՞GL `̭ɮ"kA $Vju9HUq@ipԱV!ǂ멾 S~! "= MX .J ' bK>™61.ʇC>@m5#(J?OXRQ䋑UMG|fF/SZx$_vȒ|V s³|$-0B>•$ %d Fiyb{@2P`/pRbf\yv2K j/w1;FϙuL+kv`{W69i"be/$8t7Vzw%J|)B0{lS5uOG;- ~YQ+l$S|2Ok?لZi/9^ph3U~nlhn29P܁A s n ,XYO D/%KfSP%͌д q'IX\eld|&Jn RiLUS>s0%yJq^J In7ڀ ) ly nd4g'KFd}޷vi>縼+wp!Z5R10L.pMCx}xrG禓{R͑["NOFېsW6Ժ@~: Q1E͏UD^(dj?O y䜛ʙW!kc.ōxzL:c4ߖ~`*{Qza#W4-߉XwS 1, )oYzKUK/+l¦|eiCfE6qPy-SK4%g.e 'vZ c`rO<ѩypJV_}Fx#L3as a.{FXضG\ +BLjGx;wOn]wƄ?^:ނ8/#eчXhX9"/swԍ5fy%,׽%&9SKUq{!sMļiTǫxyQrz6c}i٪Tx{ra <>im<KmBR\?fu2MT r.OƮ;h_Ϟ.ToŊkcd3xw1yWJ3^/lvhv8 k/rn˩*x#< g4rQ+S"wageo׻ ii]fr׬cc2޹\X3c1B~bfgs@MX s3T7gxɧz^wT:<Kž4ـMI*J/Kڰ˷$iÓSNҋVr%*b)ݯ8'1M22  t\|SLGYUic9TYچ%]>Vbm5jR|9'204sWg\2[C6s9Vr{5}I۱v0OG6llyhk:_6 [3p =Msf qZyA%$ݶI MXͰfE}s}4Mi&r$ì>$K񳭇 m+)61K `dVBn_{9V É1Q0S[8]]fנ^s -zr.z2u0O45sT Gq%czg`}|S]nkeթt,F/{8g3Ҽ-ͷe,+>1bP-oͳ-]f: fk0nW6&16̆ڕH¹ik,_m}IM)\Oч62 5[~!븗3o\۱( *r Qmv̽PTI%t_;7Y*Z3"T; ʐ30x%qutjF:#%/=;6% bTl{%5]DM@H̞P H;ȲWD +ߤEM4Qc'f3o҇³yRI`H&ѤMl&Y6> stream x[ndǑ?q1/%w]f` "R,hQj1iE1bTUX.LpNUXK3_R)HDEXG5]dETd HKeuLXJ*0Qa)@%.SP+SdJeL*&Sxg2*2%!˔.Sr-d GLIHU0"S )lEp:Rd Ud )2#YZE0"S8e GLH))ٵ!oaN+ _-XI4eš0_1nBRr*͢E{y%*aS%K] K9.KXE1)p+caJUg+~`+!Zr2VBl%$nSʀBWBtm6ͦѵ#V+)tHkUl ];RʐB׎T2Е!teHkG*]RʐB׎T2е# )teHkG*]RʐB׆42е!#]k}D_$g9wUr|l0ZB;na[]:G~#`H*w,qW ZNZb%/Q(M/3) * K&ӗ}[Rc/6p&٫125\M*yR*UvP @m*m;PXہBTvP(@k*];PځB 4vPT$6(/-GOh*|#kQ 3V;ja%MS-|뙵Y1+{fuY̪hCfCr5:dW"]f`'˥OdW5ٵ ,w] ;³@Of’\ ’\’kAXrOaZ!,A w'ׂ-\ ’0CXrnȐ\B/IR_Õ:V U?q̴DZq"uQM?VR/|2?ȃmW꬧FL'+uVғJWݦӳ#@(~MglHgm*?ّφ4~v# iHgC?;Rّφ4~v!HgC?;Rّϊt~v"oҭ&'qL.-khp.9)5V$}]Ufk+LA^p~P,TA "њ*3k zwV烀ٚ5:X7t%\,Wo&..- %N; Nϧ*//sjwKnW{CcSWoR<Ak4r-;f}g9SJ*3ug Ƚt?Ӈry缹\/5>C[co7%*6:)'\ym gX{>D+Ju8k?$ⲽ1_4کy{`6lnoؖkzJv[ ,b_D4޴؞#-^vJ.[.o-zkJw|5?l֖"v;ssp6]`Jh7қ/"I@ 3d4h"=~E D1}XiF_?hEޓPַz{q^7-vޅxr2ХJ6֦L[G НpRCzJ^xIahV jX:O*/z@x1}iZi/v{Mr!KCnQKoUpz"gJa7gBH.?;V2/ÈfM:S*RҮ-= jP9m~TBy~mr/6E 全nx>13J.=R8V`'1yE/x_7x[KZ60H䇳߮,5zwplf!c#2^m#O_e;zCot;x0|Hu c<_⥄&+_E0!TCkyE$b ܼ%n*yK᤺x6o|Lګ  >}]].:S*ڱ"}(X{|@CC:q6Rf[mv!(}X}5(8]SB6]"dv{ULsQfM .#WlL u &}3L [Su7jT!df4Ǧ! lT#[Kڕs6E&2_Ԓ/+zศ z"o4$p|Ԙة"Lt;Qc@#rс+#JN` Oѧ7c)15!uRCF_qy#Fˋ۠NN7lDtu8Ӏmb4Z ЀyԽI0VċֆX{ fPzTlG5q)mud8Վ$|fL!+7w<F::|Dn:Mɿ<7T<:x FICJ.{Hot#HOIW((5]J< l@;6}S88VcCE6?]ךG/4ٙ&!x҆6 ~{Xz$>MRiyDlKXj$*)8'<' ^'X$g3벗(mMwt}CrY'_Jׇ|9EEY"N5oO7# IXm€ R=1ȿֽ6cJ=;FN_DР^]@P".FŃN牅pH#pPqyw,e) |O]=VAȸaЄd bVҔ0~||6ݾm{zgm :8cGKuԊ%lЧ9gMWRAK/K_wiκWLDWr}p!N?MZF|Φq֧ڽ^)~4;.nVbz;"o[|\EG#p.iŲִ?l%wӋ'Iīa󐳏xU'SJVފS}AW3&zu/Ձ 4ae`}`|7YFu\ֳ́qVl9ݛUUgZbuau8g+Xҵm/^WЋ^dwTtהs_x{[)~ҋoq09e]sc؊<h:Bendstream endobj 410 0 obj << /Filter /FlateDecode /Length 5993 >> stream x\]\q}GL%3* ?\qRJUl=~XrWEcx%=\Fw ݙ ?/i^^|{aϋݿ?C,T{jwrKqbؚ[gog_tpy ՋKK,.O7KZC}GZ_KJw}0UkL6epYjv1h kw-ׯp_hk폷Y̠csajå2E)gKToWԅ[9=`e  Ujs%4^xCp6&F .LlXA#d= oOdńW,RD^rx}O[dեR>P?3Kn1~SK;ivegmE\rpﾇ.03w1ÖRy主 hҚHS AcĈt 2b I`_Hv4MF K]2I w `iD8Ų0MNXXAdT[2vr%Fby P .3b 2Vƒ,sm K65abiHľg+ %,P*J؟HǥxzVZS0}t!yA*xrcD ] yɁx%Q"V=j<RMS24'oĔ {d(d)[XKW=<4)yvPdO#;A%%D@F??i3T8@Kp|@K'OQ[7\ Q`{?؉zrHLb9h?؏pɆ$&I#rD#~9$H怢jv:`q@,mo%d( Idr〢Nԓ[F T (?Lf$p\<ϬR8(re6؁&7L##(f%9hV0)'lnk'rDQ9&fP(/ &%ruBicO"PDN"JRB M"{Ɍ5)hVfV&GD $r(DA&A`?Ʋ zT|.;VDAչ1;S&xG]o_4 FG94T᚟]__PA'v2b%T+D!" J2T`'P@\mmz HTCx9Ϭu(bs2.mu(Ru(P(U^FwҦס(6j+g(r5Rv(LKE);B*^B-Rd(r3Bf]Bm< Qi.DEAz! !H1 Qt ORc]Eu#)2BTx QH xAz! [WhWt!^/(,E);:^*xժZ!s/DHnBTAACP)#HCp7UЪ U(dPlvkdnP5&Z*kZyEYjB(CVphekVJmVJdRheI*e oI*QTTJdcY*J\bX7 /Cq1ҋVBܫP#*F M'W"U( ЫP*F ge(2F ge(HJ#e V҈? CiP^҈ԡ4"u(HJ#L au(HJ#0BF)D)4 Q ' Q '|a-D)2)o QY+QY+Q++QKQ8r.E \Zs)J#OKQ_ B5`11y#ǡ8"(O*3XAy<#"&ar#BU^爩ՆGL:X9bg(.;Sh删<_9",HX)sDBYWXa#&^#;M) "rj("B[)bAwq:@2hHVZq%&" )N)0XAE:E Y@יPD<תS)?1ę)O8GLt>E_)}X!4+R}X!x:ILdF=%ʾ 8UZ8F$* $*ātFHBI8$qEV8;AW`%+NL9DYbC,#g3KTș%ș%rf X~xwvffbZ;Dc*B V#V(&9Asx_"arz勥|}8Q e4HWS,PUo"_$,;_,%3}X྄*wX hډq'D+!0%l1",O#QA0"/a)& 1Cac"J+3FNλ7Xi|SFҡ픑LY(딑LXꔑzHA;cTHg+2ƁqEVƸ"$όQM9sƁ9BΜ}纞j]{1p,po={H 9|$'^(:OA#0Y {է#W yI=V[uw{Oơ㏸]D& %o/7c~\i$j{ZS'n7\@Dp}<*A:WCڿzJrrM8SG%`)(>~+Aھ^R%\n'ett'D9 e+B<{۴^8x3x|a(=Rzx7oxP?_ktM7x=ЫfSއMqf_/6:@APn<>o)$Roxxˁ{]\}@X+ g+|~ O#ѰJAܹg|=koP6 Y7(ڬ E ,(A]Dڢ.h;GjFrסPKEѦr+0q(1;}ߎzĬ&8^7RͯF^ #]Cz/G5M~z>S1\{{y3toj"%;] Q^l^_=7fK"A,zBȂI|iлѼw- |G_?z;\iZl6=v[^ێM_SMɥnO[ 盒=l j31]qDio"8r3zoE2*n Jo6;SWkxiG_}6WgU&S0d`y;oF*H2c7O7Q \qD pű4} ~Mϕnx[(Z'CK$7[ZغF.r y|- g ߳T؏E~wI܀V/.u݁~ h}d'Fvbc9?H$ARRǺݷ|r\F2eӂTKF-ȕfBjPrp?~-ϩ7}dmhYTcXJҋ(yK!*O+;ȜL+oŌRK})of(pM*x'k&V ./s5c|`u{vjm N0Lq7QhO$J%HZb ۩urp.L:^ tKeݶ ˣyʚ&+ /O0n8ad9 -Zݏ\uiu^0æQV#f_lFn#~_2X)H6W{[D!uYqVWҦ%^@@b据ߛ#3jrȖHbRz2H,0'ݍ\ZA,8'lje=pܸX|Kyi{|Zcۭx6tU|E=lC#*?Uz3\g>܆cu}7gtў ~mh> ,q)pz8VW9xXX uG=K%r:QS=l2E"MRY6i"4>OLuAìd5ZN\J"hq3Byv8K\w - 艚 9ohp!6B#'Ｕ+R 0֜*~Mdgt#f<E4w<1$stjnFc|:Sdx[Αf$);yࢆ:5EwZEi,RJ9Cx'&/x ObM˕=6Dxp3Lkؔ:ŗc{Vu`;Ntd_ה¯N3>䙰ɼg}K8j91S>Mލ\D.TQJ7Sq5|8]є~}XaΖyQcw5Ưx9yTb}CO3糭s9%BjzX|6WnNnNmML}>4G66o66g=|endstream endobj 411 0 obj << /Filter /FlateDecode /Length 8863 >> stream x}Yq;qCOwlUrmz YI@a %CaEzU]=ß 5rk圬?şG?7?=דϓ~u.uz#}ן|iz1|?y/=o^1?v[o(յp~k:ƈ"-!ugw\ob8c [I[;EtqWTRhI;UapiU}ޓKgka-ǿn}أ>:|..ri/zӫG–;ѯG>rR%$=Q$ihj`:a|/C%D c/."h$-KAT|PH<,m|tq TAOI"IX8SI4ئK"Pf=:vH$Gf.mrdW8k³5zEбo^%,]@]XUJXgAI&]U U*J| KhoSJ§{SPw3 ~PBIPʪmLL %7duM%E2:t4'H`@&bci*7 Ό"$yDg*vpKgTDR^Eq*3Q 婊R40hҤM00AZ}DF !DJ>S/ p@pA<4^& !BK :uKE*pH ^z O" j!Fu wY@諊PI6d0t7݆c9NDe6H/ TUY iSm~)4,c,u ؄X&:LCj%|t2M JAm 94$)ifm9ô̬sQit!mueꂶm: cD%u١`yH:L#VRIi04SEzkca| *NWigy:H_$MfP S`ΉFhS W!b bH8V5}>h6NFSpՔ,̣VS2\ZMΪW=l)b:Q[EJ\9DNeP wu-Y>s0V 4o;hէ`רw1ͭ Fb{`(N`(!5'd]#[hQ2n5#JI{w c㽆,[R 0\]wwm9$U-#"c2>ss{,Q{\"zgb}D8^=ADD=f|\?{?CZR3ᅁ!?%m2&*{0=R,93:fA`^i/p%c|_18ig/`K:$_@'B 4x A }>r/j^_DiGb& ٨A:A@0WbAsIY!b֪& ي0bG  ]7 ]ʽAn& uAK^1HB + p@:_Y!d Ax AO+ Y;hSqE!BmiFB|ZQ XF́B(B@!0y }5 >P@! e  Mw'DĀ sN(B@AJjY!%}AV@ @DVBIU)Z 0%eAaEb dz(d f8P"1P\!nħ B6BBdvm3 D XAf%P;@f[Pw" PcBZ ܮKWqA!@}P^7`c_qз,mUbkE4ͪBѦe}%%sCԳ-P {+1XJIxTiP)C- -EYTS)K'B,"3E"O!BҹQL ; jJ)(ψMo~f(KLO%kI%MN ֘($As,&qcs2%!'祌$19h ZO\^gnXiةBrE<]&my!s6M{-œ.S$i{=J ܡ. e xT h t'$vF7-$)z $/ `S4$"5&5 Ϥފ_"P <+CsviԥS1U]"`lrT$~J;Nʄ"vf$׷&v͘c X~V8L1.< 2 6PbQs3r#PUEl㍉'td 4N FR*rg#WR faڸx 8(nbY~y6-`>mkOtR :`$VjI6Q R%z %B'b\38x ًZ6/4rm,Xhu"]BKp"%U3'2m2NB̥6e镔P$,S 45M5N72#TO5T3}Ӑ%V7f^ʔjWnqo4!#*mbD`ِ>:[TXhv Sk$t%9i< ITbz^1;u(AdH2SQ}f9LIVd;xi5%KQVSQqה,_odi5rk5%K;^5W|GYɷ?p=!*#*$򂺇dm5VۉҊkLkd׊q,F4ɮhic%ITfF+6Wׁ*K9 ˬϘ`;'{d ")~??5U_~sxh}c,?"SɟfʟX;iOntmN9$PU3ƠqIl*Wo*uIϕ?!7eT?r#O,w )DM2f#B>d} w⹶q-O4ˤ UPg Է ]Xg==Q)-O%蠌J~3n <:VW^%O8-Myuǟz@yI'8 iGH׽e J1()p ^LAup(1իa0(/ rH>TW0( i22ce.? j`'IqNy:JX?dEɟz:c2!OVSTL>kAx5Sv8AiJ'}i0f'1>hj'Z ?z5SGbψ60S7' 2ƟzJ>uѧs1ޠO˺u>cO$Dj>uM2SG&R?OTѳ8dܾۑ+ )j! ijK 1`Hk IEf!?7R𦔦߁CVQ8aG!<a!zl0NM+چD(X$2,L;D^+~Xt`s<d :1,pk}`^S,PW,BExE"a"<6U;dZ .rL,pj` ,ʨ,4g]#| FV0bc Dbe[E$5ၥfEP,SQ"hN,[y"< k!Whg@gj;(|Wr!M(#"\@"HWZ-N@"H*^-04 -1 nk"(\CB`pyl(:u[ ͒ @YL )JA"XRǕCP"A1H!إC l׎;5;RhQq!P4 dT @b?0dHҀ* C䊏[˸r0C p(Ao}H@LCDbpFqHp$vtm8DI@ `!w&8#ȕT"| SsW"jXHah_d01!"QS2RC 4`KC/&!4uyYypM'^㾺˯QxRy r5"p/=fyÇ`؆k^ni5AojE":荷<~ox:(k _ -ţ/ zX5o{QYOoGS#-G{󚉇-Þ5:0/.+R(9l6ky__}!îrhw50uL,}[|[5OpOG2ޙa+'D+a%Q ~y!,cm9tq`#&ƒB }~7$kx7|5P[?F#x/x^no`7%#b֑^m_x-|Do/8X!{1#_xs؏' k,o_^3wW$r\L~Aa篷oYƑ *۷9M^ r8#oSku-Lb>_شУ~dz b48_ v{Ξ}&!cttںj@=ߌNk~d+%(.&-PUtov']{i?wRvS/3 зXqhLxY|jpÎ[`<_I㊬~Sfݩ/S;oŴb 5x?3W,^@1bˀXs||=|aOmÏ{-cnmy2Dtk1=Ps> {l]-6_n&Y~R<|oY6/7㲶]3*'U÷ll_g=C+Yu4Ȣ3nbg-`g5]#=ښyqX/T{:/x$IYCUe?"VyςXdc`g.@E(ڤ/#?ĵnuDlgϟ_8;&0OBKIȬAњ5^_1lb *d*ٱs k2񍢔Zf>ӏds@*sS|f[[@奰7"?0rd,tDm6bO5hE=z`vmVCğT,e7wWqV`@7/@hxWGU7OxKbş YNoK)d~M Mވ3D,{|4mDkq3wh.ßY[wӾx"BAH- w`RqџnV<ƒJ?mþgIm/6'P\Fzާ+N+cBf ʋ L{rY^z'XF5٫A.;z+ų0R.9/-uͿ\M V2/=L&q y) O*.pBg@ي[G$Rj߼leo܏r_mwYut]μ/V\ԵV^p2&($ԳT}N35=U]Lݺ5;nh~(nv&}nk$U. kB3)hIJE-/_Pه?-L@uq+oxuzkF@yVxؠ{ӮnL'{]y {#B$ò KjN0WWez杊@b}" L*?~"P8bϷgTc [qc=EPBrЙA>.T~;.C>yY*WC~^'qGJ7ȱf/?hpQꍸVzN7ws|u#ȟkN<UkU Nfxq,^8">!&,.sO[{i]*qma<hl2<6+>"\.-m7YbfJVc݇g}ruhj=@Ҋ﫮17خ\l0+Bx鱅 m]b*wCsf4f wg0wvH%EYIӮ ~T, (4 yJvQGz䲲;`}{_"~ /a {lN'5yK׼Tz?]"=!FJ>5N{x{{`DPɾٯdX|^v05Bsa?+FYj6Sm}I{@~xG]tgucrеze=ɸOyP(FJZc-B-ZE)LOU`wYIRt a۴V0Uu2kD4"ڜqND^ד%I)3O_v!gʕpd*zȞcwbg {f7 OMvZLwNįd},{mK*huӿY,eIov)[o.4)\n_oݼ?܅]EGɕԌ6=^HTUGV)kKju-,y6odgͳ>"?xY`Yŝ+(P.s_\W$çЎeD Am``TUHa bd/|%ZڞNBJkN^'GO W{T{Yki*eF1 ^؅kendstream endobj 412 0 obj << /Filter /FlateDecode /Length 4603 >> stream xnGCf #H~HÑil+\$&?c{kvf)9@`*j뮚! ?/ҙóvxvz8<`p3w!7n>ڮԇG/`qo7 bV;[DwVZם.RJﾏOо,®< NjFHѭOH cE 4w{VÆC:a`Xxַ ]:}(aas{k {mjp1`S4ylO~\8 Kp@ndSB݇Bf6ߤgb%x'op^⫗iN/A>DVSKWΘ{ ~y`X*D~G;׿A]@YGq\NuM^f.x\3(;^+ Ѫi$)4hӮe HK48tU@Q@C޷'A4X$Vp4\fᭁ$m2D\F t,TzG6NdgSzHDZ=0~lYɧ2haG!C4к7I2<KcIz4 J"SVzm׻TIl?oHN~guOSyёI|ɧ @1#yN=Zs)#HFv*ܰ-сΡf1 "g̰=B iWO{$G\Vwk%YJ)\Q=J NiUGnMEO2vl`T.'אOh:~wn~]b0A_6RG@OI5_;f[`?Ui?>~q&Q&]=.G}]O);: GH3SʎMdqa¯)dvH^5Tv l;Ѵ_lH~ VvIxDN~R }5}q+{ W:=ctaNy4EZ^|Rf+Nf-,[)%Y8;}$"'M0:p=u 3i\zf?ي9+ݻv<ا ylwY0_)xJ7uS_J^YM $q|W\Va[M H5'p[qډ02SӁˆLIT +[MbA_@TT|XAde&jkZV|j'AXE4tmgy1Z\ :jh p_1!Z 7)̈́pࡒHxRsx]RAп,șm `*M%;/ԽMyiq5Pϊ&ҡcRE`5i^v< $ 죆+pK (][%x[n _ۂC_`>tb:b[|Ud?\t Mo'(< ' P"~,=ǃϋx`T_ pqXϋS³aS|:NyHpc_gwh9|2Rd¥x峼  (0 |{nG Aw h͜FY.!^#~ #Opa2FcH};ZM*8c9btrʕDkv -]v|1ý,຀gAms:*xPheuh8c8gAX1ZyOQ(h LΟKeaŖ*ty}ӏAONI)FMZ8iIܘƤ Gbtcx7Ø0yo yaU9YDf ;q|Zfw@bR(ahTMBB""PRధ!(srUIx2sYuJ*2.*z/]@  ~R=I*qA'j+OVld6"UL 턤IA&E%qDii҆DsoZ-5>M5F) YmY^c ,JѺ(D).ӯOD ,|^fb?8Y?jn##j?}iHcm+:JzXn炼KRi[RH)v5#V Ky DUmnEF~# ˇނp(ї i,Q[xdLHI )ah]|o 5ɩI|hۚbĸ>|)z%JlD:v.7 !. .PB\9k;Y&=d|,$[^ 5Q R5)fsxVL8_D=H5ߕ,YX[CYu u*ޅD XݑU׫D&~p96S$@/^AY6qTbAG.KBq^6%mڝK[$Aj8.7SKԹ3) 0u MBiaQXz9WdLKd{wB` c2tUHPoQT-"D XS6%ݕ뫘3iPzvY,!qV|e!ܗnZu:&AENXH5$@vhD?^SUbPQHK6Uց_9` kJo%-[- j+~BFFf~0rKąd&d3Fb\ ~o P:H;!8>jXf1h2ڗ6JE7C;R< AxM0yDi=]6AIT.QiK$7JiZN1>O5IX3U2$Ilo$;qn)BMwT~AGp߰'tat`ЖWЈqQU +T< B)䠑ߦj#+^F%28DW+)p8ke->əF]^e:j* 6¥b>H_Q ]9Dv,>Y=01(œIcC@ljj<\pD֏р/&E1gn@= :fr(_m_S2x}[561tV|WFt$Ȍǻ|0NVxuOU"\&!ظp[gJO|:1W@;jd܈ 1Zg>vڳ^xz}n'bjV2 wmo4"QhG2&# d7Ǣ\ڡEn?3[KX_y봢6LN[5/~6\(S-gb)y/93ЊW^y2"zVm2j\ C \.S4J,t犮fZ$+)j䡈I%Y*Ι vt}n|:a{v>@zd@{Br?}U_C㔤+} s>h1EA~S v _02b.-Q/往(I&YsYG ¡endstream endobj 413 0 obj << /Filter /FlateDecode /Length 1554 >> stream xXIo+E[QNmަH ^<8$Fb$Hw{8aTZ,|փyW\o hf1J * PY(҂-*[AbLķCT\0b FHUeB%4Pʋpƿ@N n#UDYub28.icC2"IoyԬx%QB4x+F֑Bމ^ʡ'2G#!TB(Cp$ve(I# hGx%de^<U&$՛F)@'J<*i( 4'eT$aWF]MC-[ x>b~@EF@1ҶE]/C4vLt4&bv00 / 4\t)e%r)f-_b,H)cRIi1Pe M(m w8SY[ jD4a0m1*m UMc4U -5-m"<]:<7#qKjB&$VUx;dBSRLuǂ}ӕqc|9^)Θ&Mgr:i2wFrFd)K|Iz!zIYY`eW; ؄:M"f f m_/4B/v $\hrDJt qZrJeOQ )mN#3$C&o3Ȧ{"W$lڒ]kVÁqbUwB]H`]e+ddSL^ʚHKeGe˦(@&3 :R&( *cm~6) S/ʤ21fcv쿶pp@}эz*;Nf)]bY\eDH~HZ iQsc/pSZ:`Ҽ#d7t 4nxsq(# S(IAt;"VWwlf}y>]Xh0 HC7lolM>]|TME͂^*wimڣ\ /%>衁&ޒI4Wt|YȂ߁ Gi-PР9I(U|e%/X5N)bwE78jC1oIƎ~ql#;"Bzǂݳ_NKYH|߲5=S{ޚ6soOx f3+Yeό=o3ֻ|Ml MaM15bsc29{K{lw9wr׬gy>6e2%*^6z깰e_mX, Sw` ,w[I Z]Vر¤s&h r:ĵ3UՏTo<#Ê rYH?:ݹ/O5o8\k?W L 1endstream endobj 414 0 obj << /Filter /FlateDecode /Length 41960 >> stream xIeKv6/TDh=4, @dB2K:7ޱW ZAV{ڈݬϯo?7(?O]~~Z~ckG?g}~ӿ:gW???VV:~U'Ͽ_w?Jy_cK|׳q|ɟW?\{7_9[О-9g47џ` _{w__?}V?>~Ϗ{Y~)iB^<$L!k%BB cF$27rVsrHccH}7psvz?gϑ~3zV֯}ƏNͯ}5pw.^DiXQg&q k>,s*9O|)d`y9 '8d_uǬ_-78f{"WL g Y'hu#v>y\_DpHh>몝;d9׶*)pyk?<+{/: c>"9=p&!qd9wXsO}Y$$; g1<:X$1|3ovyV>@_X,F΅9mi q KGN-Pl ksTu5Y ~ȣ<;Yqỉ=KSJl6Gmg "XrD[c=6V⬻#~vJ8HFU־#,Z3opa$ߠFl;ȃ- d<m#Vs;g"6%ȑ>ORcdEt?Gu\bD&i4DAքp;Hw42Š=ȓ ǜ|?{g`b~5Xh##[?YUulP<48\WoDR|m%2CLl! ga!wCv|H v7|K{{?A9B}w9+GBnG* G*iwl)\t;Hz8Z%2C5rV rpgq{ k/7iq5jmEhD<:_*O;}k刮blx;_e#mAy[ m9f"oÿjHWǟgj˟?֎Xop^#EP2<}jj2A%/dQ9[9j1K_,F<,,Ef[9O]hDhf)aAףp=z=2|&q/>|lc]ȑk=ڸWZdz1;u }AI Cb !Nن=44/{۷pv_X,3t/_Z!bbW̷ dۇ"&1bK=LS߇LnodK-Yp[ަmcv.|sTz_ߧh b{?藲rT%sHײ4ꌑH[`l16g#MJwnIʂJ66l:ocž2ڹVX]zNE5iuP}̐X;/12%H y>O9FCLn647LjK"k =maYbFuKb ތbL LdSFJ}룁ylXZhkF*E[,` ,rk@IHSsv=E͇8k^@DLB D=R@6mc \OXU`l`dP7 畿~.)Gʦ޳ *3Sr{4 ~co@:?&i@l5iن €ȵ[ifx-6l6^1u>1秿$\ŁL8z7gӑ v m?ikƶ񲎙Glߑa*g^ #NU3شˮ}[<^g'!O*)~aJ fIi:]O `ۺ`y|/L6_h{yԆt{@f cD߄Êo$gH`~! 4_H#K2el&FmźM"72י7ڼN>񦯰ش l01f9њKa0!w!C]pA~m^v/YbzlQ60G"HT4'R#wk/f^!k6C 76& UA>ΝRB0xs}=<ّ R v<;f +0}nY$/Jjh2g7-oI`b!6w"z@TPO`K` Jv1d ut֊U mw0dU/(pͤqO1a#YYOOno̴ }.ΰ2Zm-ǒklS Q6$-6Bd!8 @H}oef;&Ps!*?#bCړ+xM+Q=Pj4AQց2Ο pl--: gB1c>LcKŖ_ln 8[[|kxiەN HeP_lS@@Щ9 1S&' 2|RpX 0?n_B/!ăLg 9-T5,se.EXaLy\D>k!9M/YCK |樒jtڑQ@HՌnr𕛤ڳO:=^DbHdS.k-HH'7;;huv^huDݽ"y_a-"pe/1&p^4՛-X q{te) my ցcc 4 2Kȝ:b"[I 0uHeBO >R((> o>a2.0 aؖ܊^DNx.%! d[c٣;=kqED>Ͳkd3oJ؊)b Q (QNoX_oWuHɀ} CDLRZ&)$2oB"I od3oy!Ge +bk~;rAFY>zI&gj_ؼvٞyr%:H=1VǓQN cjRҦ&RмR]FV{[]lf)ȱǮ&-qPkE̻},Wz;&5BiQ0G"Pm8]i\9(b&ze%wW8f\h6\"9[ SXґu%#3^BlP|! w\ڎ<,P\0۟;=JQ(6#0E1d!37Yn?C+ARn(p6s((Vl7}l,4{ޛ"G1V"LJ~,$;}zt RW%?SAB>+2J ~QFxfWA<`r xqֿ:G"{Q8H+=sc~I _;pU,y?ú5.> L~ѳ#;LŠ3yIFfQYFz&,ZVrRӊߔ1\s&1V6c2C3I(Ca?An^-ZK`w CIq%=CBMD&ĜW X-Q7|lW/,EFRןq *_yj< ~Ѓ};;= [n!G^ozBF%k '|NL}7 d_7; <>_qN6yg =>gG^T)Ȫ|aYҔ^A+F to/Vˤ BR}x=S2rzcw8+7Ȍ|rT0}bC'Z~q2U7+%@/Gx9Y&@y3wԮd*fU `< xR~c$k7W&IiR^L2=L[qNYe-H[LZnT|3XnEDXEA.߇tt+͈RBGT" #~,VgZen{(C 9kI{4)Ũ$]ÐJSp aa1X=Si|DVƻh5j[>VhĬfțhѺuK`B25/.Ƭċ6"Z,7Dd?YvwQpA\QoWvOn- !A=1_P LP0A35eTBoPڥyU?ߙ ,0;/\GX}M#rhz"f ֎܉УӒK_U D9'*?^Un'`} 'w;q]FS( `^r- vd3R0N$3Қ{t r|e'd}#nv N^1A#._Wg}~OQPԦ ks+W.0:PBS [P"cl*DvX:BkTeY_~|~,P7?+'~6O?G:N,oΧ,?_n;Ǯ Q>=[sT"_GEe@u :Q?dk+#5̸`/;{{!g':G/jFEZOK@B? c4y[O{e;50ֲ=wgW^j~uK;i.c}?B²@ǧ__hgTiԕ5|q"r ;d=OS,jB-LW&2Lf}"yZazeL!~G N37Y %YǼvA 2FLⓄJ琊<az36տHm6m13]if ,-{hq=ęt/{gRgRu<+QM0Msӷ_Pʉ*VO`~lLsmNQ搁r~CEuDM?.%ǁ]%,7ʹյ MC4č035Yojf&Z攬r@YQZ"VÏ-kkU}+H͋0!%2-}[QC7`\+w~瑑t7ݎyhdWCJ0I^o+%:@H7AIjE`';j,U!56yh{V"_Q}؀dJLY]yCl*Q 2~n6D󉼐D#m7 ~FmI]3KL!l~]itt,u4$ZE!Q܁+vl}JM 0Pуos ;`\#\4Xk߷v"ajV(jXC1*dim6:$لm::!4|-=s84mk8MH#r-6[jh46!g؈&;Z;5@1҃ڵ(5'5!=}mB}Z"TU6BVIm>OO ~{fwdlRu`au^% <.2yj2q6UxKltr;QrR䲜&mR{ƭHMpdۙ/tPF}g:z8 袴mw:jhEz@hai@ۓJX2E0mmq#mmFL=a1'xM6[> n'W+Y# x\ (,ldv!JPV V=1^Pb ^\&_rНYב4 -†s&(mIH`\X@ śbCПu=U3K˾T3W}*!E)Ff ڡƣ쳺cm(b+`A\a-쳖yW۔Ea(&cQӯmYy{Z$޾wg"c+~cj=|T5w Tθ2;kӫplz :沽PEmlη5Y䔙rER`am?*rKQ#aٱHt& e|KK6x#7k$v^lgz&&qqDGriqݗq2GcY˯pXj;@ɴ+0m PEܿ9BuCq\d9K m,.)j8)҆S Мڶfs;΋+v06%^J:ݖUSZ&PFFdaƷo66jKHd#\5,"[rʊ Զf>*mLQ ZUb߯\\U׌[vҜⶌTվ^;Z>z/^qV_W_6j!WtoC = ,]rHEql<;%w"%I>jϣ7/_S":-(,|dX_ȐcQ|1#T]2=&T]k~o8J3"Ag`9c>Ĵاr uO~nAS'ݚ]s.cNQp쉑KF9,Z1u"нd!6G ~P' 52Lun }܇Sz[Nl,KR"{)le)6:%K0}`Wy" f^CDݛrU͍4V89|%'lNCcDvtw~rr'aW@y[Vݍz](okT3`'2]׷tưHX:)Eίkǁ6+z*$@#fN~w[1Ѽ<"SfWea4\SmH<-7[Es51-N`sEsX{G?;?x"6R\lPթX{ m,3:D@E~P$%`{0Kk <Ǒ"kszABj;(e\1Xs? |fE",i}0#n@diX6הmc\{3d@m]_40V`;off.{auW5*?gC< ץIޠMM}=3wFT~cSĿ׻ )P AmtjID}hVLߜŽ T41l{aaQ{6N*)+7~fW_DѼΨF8149$G䨒QsvLQ;ItHu.Hn"}BOfh!Ud[p :3AUIQ˱$Sc;b\ǐp*"̷jJfSHJ$BVf>gS?~Xx P~} QU |)D(;X8]?yʨ/>6Q֛yP`GъmGu_Vp-[^nG%w9!{ )OPb*j6%=eOJ]0uuԔǚnjk,;̬ *N F" ,N1O~SaQ/ˣxcNl#]e= jߗ#9F_-˔a߳{m'͑uMm +b(aw +ݙTQa1("j*3wb/Ϥ(z=tw' u3H.1q⬮b%_E;54s;#h<[aQ]!_ drUpBT-o^ m5,14%DѴOy)V_,@afzN4ܢ+oe9O=m]d+_.q?@_cjç@`y,f%;{Pe#Nc[U}=<bܦ|C۔ Y (FlďƶiD *8$:[qEmw2(nT+ #yy6Fv:$@tDHo"ְu{/ս jNWT DUwNYRB%38aIn {4:ʞpd˓_OI m0@vU37IjoFlW>Ay^_5sfMac{^1'^U0/55@-#eW"_W~*,mIV }`oPXVF F⬀dkKu(C}w@T7I]UY+ 9+̓ڞW&Caj"9atӀ ?*=S05m۽h6m9S{lօWOfvA"P#y1ͶVgF*2.H{v5z?]bk׵F#&T" ,µ^]uaK?EW }m@$k_30oB~]C㺂-ۺ5'("w7b/]bakE^$zCKI٣DLW.-my(Zg'澪"RMnW["lY\3i>P0,fXpG;ۀ\!?Wu#vvZ Ka[2uyS/6,ZF#4N٨ na]yKa+dY5,nJ%Ӎ6}t!n@rB_jxrx9'ȥ5 NB Rr))q4; FyJX 5'գ`XaGOɭI Ӱ}_[=[{̦4n E 5 쇞`'>d)dQ> j1"*[fE8+sLya“f|Ա}5Ig6U"?=${a߯vAҜQShtTRCq'?XWK:+cUDj8]Qu|ըURDŽ?x8mZG5jmIPg7=@.f?(ۋ3lS`7M_H>3)[M<|(BHP}#!(B@viDD;z[Hd aX^1#׍?HJ2,[mw@mm!?mAA6b%ݝ1Z&dwH[Sb9M3F 5y6dx5P!9t?r]T!<+2/ SEˆ2i-DnVqq?YN^G-ЮU̧%.ӏ]s @sW~^hv@m-@HD2'̮Y6ѩL _K #yDP sՅpGC"nv!(Q͙ f1@0I; 1A7 anrb?@lvyˣ.nyy+&>aQJsT"~DgkD?lOH7ˣ{=_"dJ(( _@>Q]M_GlwW<^O–ˎP(g1j/Ts5qվ w}> [e |A' jS?={QE`F{5m~v# j'AÍ do!˶i m8D6 D1Y9m 'u5 tߟ2J3I n,C"`XwC[6 ׮6>rDMjLpv-9eB_*1H`/)˧4 WG"0#W奂zk7˱o)n3^]U实_ 7rUކz9zoK=o)1?_l)kwmRrdHZ,d[?mTer7IL~1DfӽFrO^g8xWsfPjs=&oa-4G9I$물nܨƥ,pngܾ]vcrOe6C-=ꦦqI ~;izP6^1}0njuc:H_ &Y\uew-~\}-zOLg?ܽ"6OHφ9Oxv~(c5ݖ!ri4[L3㐗% b;fyZqEChUycfoPiJj9hbv1ۈ=Srckn-‹fk{b7jKd7HfqH+fC%EFV} %s흖P W,?jխ^lxvmjp{<*F}-(L7醂f&$af/V@߷="3L-73"C\֒¡dҰ9:_T0CY݅d sSHhE"%27Hai86'%jtgD\cthUkܽ>FSkXfq$[ %h@BzQY<{ T}1t6J.ᦳ`[^jȭ^50mS9]G"m r+>N*ػ$$5g"j>䧛:Y>P,W鼖@_M#[ 2ޒoz6@ELdHxxQQ[.ϭ幵c<=F#X-m_:QrVL"]DXL=4eyHZiEnF[DLGx 3yZf2D u(үIA16rM'ڇllR!{#D.L>eM I⑯&HdVrp.ܜ9lmx EQ"b;)Q碌C_'XyI)=qm;٪J Bڴzm` Ϊo4/Ld M)T 2lw>sg~@_\D|F gm)b1=bĢ}MC#߷5]@;K=!ݞh#,"TvboG,wP67jp6/o‚QԀȆZ_ :!hpE!^{J/Mҥg:̻ӽxjDċbxzusդĸ1ѭnC ͮ}X%>d?羔_0?ˁٵ )tٵQfS!{a ,*qd_SPo05)עKz֌wkdYT +G.X5P@A (ۖ o^4 KNK:LquQAE(̕)B}$0l ,N#2{@\_X n c;HߵXק)*5ΈfrTm-ՔK|zNO_ue*)V+c '-T0# ZO9Z"{6gO{MUBs>mw*ECj{*WC\ͱ;NjTVa[^AB%XIg"l+Ʀb 67Vͷ `K*=kU޿JTlN(e%)B L)D"Y4-ٵpQ,j{fM#~y ga˘0ioND8l(F;SӣQY\@8rD/ >,1"{(7|9`1g`o +9怡FfO^6@dxl"(+m[6@|R>6OF>J-4V2Rz M *P%"khXг@;j9~÷γ F͆z1Csns">cN9$ Ӆ>ųt,3ԁn>❚1.cAy5%wx@y+r)b)dU䤀;F}JȉW;  A->:1V`4 ~?ż9 X2lL϶O{X&B_H ?i-Rj:`~ MbDV 0W^+mJ4S/REJEZ0fsz7R?B' NTԫVH^bPoe\iT m`I9="^JfEDSpyhkEgdߥ^! ,Y`!^N(vZhRD4 =N (3IOe%v;[Ӭ|s2(`!4<J54P"(l % f2pNfÌgXċS@CCW/^&<7I^T zJ -2]!d5$=nSmMHz[[ v8tUɺkY-l92Tn5z+6ל݃YLKG ;b_.Q5=B7l@O#@>h5\*>ʑ iʡS2(GI0]ȼ#@X8SA剼ԔU\ ph$jhOqeJ[2WF(QK@yW/u}ql4a4[lH_fլo ai%< ϓxic@*+ƙevI~| nWczk]6/me|*;Rq=ߴ޿vJDE;}6.;.;%B_#eDaZ?HQDf[tMrS 򺇶Y`zB/Gp Y Ѷ=a,`&3K;J4{E3Nח}gy2I@DAk 4۵DWifKfqúG}5#̛=~ڸvot ܄8{)"tC'@6K:=F0X:1=?az~>Fܑsp_ruY6idsE۵D &J},h$4.aZy12TEنlcC:Yj+w#Px)yDv?@w"ƾP>]L_,/8@x.6 \kC%g$q +G4+q>崻;fPWt'JQs3P9ZK#W3T?_1=>&@ɧ[4/`] l5)x|Ldi`+" Ts*T;qfғdUTM"/]cH2IV[{ J0 =QNRH3{GC./Cޓ pE:w}6z!"{i3#f?@liyyˣ.jEs%>9y0DGd}uM i#|gӒE \}TG:ӱ'u[W/u؊MeԪ"<ﺲ :_N /wFx\|: mbcpDU2 pet_lӜ`R0N{ `$/j֚l#-<EjHX87ʆK)d@9RY*vO4^(D q- 5}n!yPg"]SͪCi&8-ZGtn8|.VBQqIt'EMPdz!7 `:Y=^#+]P^ɐev )`RfszvNB_oy?GeӼ\"A^TmD KdVzu0HG"K"|b l Y/2!pʓ~<=el-y߁T1o*`*n]~p`7NyM,3UM5B4/2)WQM1wHo@!Пjж|FмmD@B{NRfK b ɈBkN> Gu{"?<&`D _4# cbե4P R&Lk%ӮP&znpŒ+Pϝc!;-B/az2AW dɪlm, t.NVH5y /ʒ? f!,ޖLMs/`fT-66Kk{q1[Z/"N @KoY qHeG5 nCoͱbܼ"pMy/BI0 űdS"w9jxR3?lBD6EHɱ68vA>D7 &$I{C}0=؜|$23!;7ϑzl?,G!@,xAa1M&.8,`ʔEm4gD, YY c,s 3U>ڒR]{"{{WRӁ2"ںhe )~ghۗ\eBJ5ZTb?Bt  @z׀.0p<p(*"/f\!iކ6GMsiw#VkpY-AX#{lc<8};] ꗀ_H7 &rs ڞJD ِF]c{vj $Bd {etlY9Log+b/Hfb\ԍ9'OҶ,D%F+ORK9VF, " <'Nj]w<}]U/a<=ϔ߻F&l)߀@vT'%{phqݗ dv=wb\;Jow)K-g,TϒUL]Jk0eAȪB ,Ѧk1)4ײnCS|,v_C (C:N'¸E)쉀f'F=`k@}op{s>d'tyP=,M׀[_0aSahRT\oܴ9wxb1GS z**odж$Rc'L=,MՏ7>YVL1}d@x់[cg|*[N)Il7,Ln-5 ZSJڿZ3|Hw£QPg`ndB7Dm[XUN:<woq5)aQa'=)VMG_#{,6ۯsHҾ9/(dg`H" %Ey)ZP&LdHmbid֯/dsݹJl bB+r QJhH=ƨj(\` 7o0'}n$04÷5;FA"hfVC:>͢DC2³abp<L5Rا z2%ð^C@2fHg)f.\Rk&2IRiYvZ`lBDžDS)<= S %虰3"þh -h~q"PiGݞ^nEU)zn$v*ɨbb e2AdЍjkޟϊz{qm1ls !4;勁!k=5!ijkB'ՙ30 `'0eM'8'X%1%h3Mf_,a\kS}b m|k ';غU?jtA$"7ԅiw:Itr;W#:ذ/@jfj~"c tlD[)L:3TĽ @ZNjnD&̑߻T#/p5og`%f?G].ov,l ,O0gy瓛PP0Lj\ҷ%r_GQ1 Q*R.E.Ḇ'}sDh#o_iH#CCBִ5foC88gxM ua?Ԅrv2bSmEzrͨaR(~lZ%7Ucgs2W}[þ5#)JuD8;Vv'Hc ӖK )hD&gos+w y1; W7LP!WQJL D|eo.K^/ ݣg DL=aҜּ@FdYkH3˱*kF%+(8_ E2z5;X1h,v z{O"'"Dlڴ9ىec1|qlh䭨ŶЁDF!@VB]MJ]jINjK@w6{㭘цrbjꣁ߁^@E.~ T BUt&+\2H%MJOL>5J=\}͒^~(2wR;Jv- 2 zf,$%x{Q6~$dKn dxAEJ>fkZkSȦ=/y${ +&gLqԮ/VE`j9 lGt3UZ4{8Ѡ"dTe&L&FOȺAqﷲ*)%ek[eIOf2^R!AB4%ʤW#^PbvscT#+3}j^kngۺr`ILu?`nXQnfFg^ wBf?R¬d-F&zf,o ZU$4ud۽,}Mc-2BEiT" 5ͺDPv%K9Whq$Th5vUuj m*<%52> Rr5eQuďi˖ `0}!b+#˵*Άw յ}r)< ȠIzɩ ȽnsW+ j'?*V˿.q>~HxRݗpF]- Jb${$ ~hP$1(^єIvheÐfyIw b=?*qFNf"1/3HkʏZ7zA6x1E2+YO,BƳ^-զ.Bcj.@k(,j7+BRC("[E iVO0^f=tjs2Lq`uV c(Zgv 19nEMkL.9 Bv.^(1Y(3ܶ:l1mD H99 pR(/1J[55PiS{ -!ܒV4nsK1ſ,mlo_ _!A'U@9>p_;A4qX5|.T9|2$g&эB)oX0oNq3OPې81J6.OI[;J^"gK@~EDv}p+UIm}+'kgP]ѾxwNeϙՏ3C+wZ ٹQ$_ucPhg˱تWe0\'ִ5R0SbxO:5gF69l1íV*鋁Cˀrr ,0WQؗwE;KfYPmt:qNӜ wz7Tʿ]\A5JsPʫP-B/g 9dB'ىRc1"\w ;k!_A1 +9 Ŋ@kGA=+Ux E;/GvUi&=_1bKgbfa", (&RX{I6T V+}w5Cm%iL@ Mm+whQ~v :ЉZ޲y8#ڹx]~rSiR "(]))gSْ|"<bˋJDr=vn0)fy~r_]&Qg@$>g`=3X!:Ҷ GΦo΍32EE'H eg8K~͔jM}4$voDQs7 |AHѵ(>ˤ&6~\|^x0ƕ3enɢ;7p_fCiy h&NdGaO@rh>7C0v-O!? FS<l9ME75[r`nxk ln@ љ JdQo0(͋8\oE~4EgdGQ<L͌ekj׏oB^l )Uq*{FX|#V 4 ̶be: ##mi~W}Fn+UYWڷա&섮k6jFW4eȖ$ȑ"S D.nz>zoV,yjf@\yrEnܯz'4BIM1lT.BOGb/>~z;Ge$vj r$G9vT*yuy;{|ozq^+i=<|n|sLz1!Aڻ|j@><飼q%[Q+~yAk 0Q|MsxLXɝPy9!{q@Mz[EuI~FLC۳FèF $~-(TLU^M R1 zi $FZ4iuQlk4}ehLcaaƼ#̛=p p? 7v >|1.|cFJ&8G2Wa-!@Ӑ%SlFLKڵ) pZ,Ycz3w4N-ymԘJ\I}Fv{tJ,) Yc.S:1E=o̯p?P4kKeSxu=y29`V3&t-'h [OLLj(2܌SZSb>#RmqwCV)M_m[#$4C~c!/b&3 2#rke xI0!J}gVK $9/Gwi%?&$% ?A%J>ިjU#=ˈ7 ~<) q-XoK.@X z"{cDY@{̏|[jɋZ}BoC@}ĺ˕*sI7S[f`7M##wS?n ~_݀< v );#d)X 2uhc1mM;A}y ڹGǜgM7@U'^ѺeMnfRS'^֨!n6/Eq.[WlC##Ú?>d~s n+bT!nP18c=8gMM0\-75ڠlCG[5O4oݮH3X6M ڃ[Vf۵cFHdH=& >rYD(U-o.t*lϴ gyl#XQE2؆('µ~sW#v`Ko#a7hMoctiF[m#ܤK7/όLUX7y^>t}J${%3fd`ncZS3^]""b[ _c=Soa&5fb @\UWT،ׇ4ͱSu|1r##*9OԵW[=[IHMMZb_[l^Uݞ= fbzv Qq[ϳk[ f$Sfg;)@0iFΥlUdk.ē*4$7K XߤJG`}䪱!BN~cTն{{bdd쇬oURo2DJ;2ǏfՖ7AKYƫ+?wgh7+i!Ih+OFt93$FY.Wm1򓠋9VYPu{s-{zVGa~\IW@VMX/ܒ{y\-ǞLL4FԊ׼,eCbmam; sfKmiVm a%jYguigHP)bmz(@*Zl)ӊ^2BzQzq|!HzǑgeb@Iƻ#[(֙cM3SRjM''DزҋzM%6 к2BR/)"gP[$u+Sdꏸ>6ӗzQ{JYh@_5L.Ttaj2Ma6;Hlȕlk>f ;?*Y 9"K 3D"Н92ɍkikZ*%~a/^qTd*u~Q7SߚZS+19Q{k³\%Tv) 'Y<^>@Dm mLe#O[|&H%PZ~}܇fT`vfd=U]s'C ˲t=PTЊ/;#T^;GH|6C6#;d'A#TՊ_zzZ:>=h͞[XR)#g!Ȥv= &+'+If F BݓW3mf>@9kJ6t6^ǧ|2 hlavW pUeꛦܢP|'k:۴M@sfNmޕvb~ȨM:,;jF$|mK7lz^+MJ~?Ba'FBޏ^/YI<8  9A冼+Ou+/ 9 (u{Og 0D؉j-/c$5ֺz"l[W&[n *Y!y]2m- Yı8[A} ̲PZ,v5MV$ `q ?"oJjSH)$|ف޿.({ ,+kkA;d-Ǘ ~j92S1Zi) dUij-\yY82XNV_5.+G(bY5%huehpYsxF.` K|SvuE;Z;ϥlNEbY5FƓϥNKH_.'Z[Gf`羢 6u(8[R fN r*3 D]%c {ۮb2[x#*3X2(ꃦ"? p,H3¢sbXGD#,煁 6ϰn}nB^`0<\ЙuQ?pZ\0/X~m]9dž!W$ o pjfZ5x7זe%TI,p'U97< C<7*{u[읟SW[Dn Zdv 蓓7]6O2g-xXw #V~]^%U&dqp m_=%c{.n/) ꃁRO{'dcFs/̥̖ix#}yq];##6S/)_}B(7Uךaz֚ƒԡɢX:D5e&@}/~m*JYbSl*9~.`Q No[ [WHGe&ˌdBHJ-I].Ԯ@1U[JZ>{Yo\ m?ZWs=9v$4U'‚K(K R3݆j%U "kpͯYv,F|"9kҦOb!#IdG8#pGZlIȕ!VZ*Q%φPb$ y|\5q)o*}3# @$m.l7!:ĩٛpKJY@~UUv$g!U.F(/aEJi\(xM:EiK ȹ7ZTΌ)8Sӆ~-I-1>l1-L )8_-#Lzk~їc|455i473_iY2E̞.*f#wj?x2µ?ňm YCӈBUJؒwagt:lM0GFd>,RːBed [DiZu7Kq0O,Ɣ!ntp{EF#GQ5F \^8$haA, BFgiè>!BS(Q[eLKSP`s6W~賛EL[d.Lj#2UG<Ց7qn \m.%rG> P?xf"q>EӀ8&jY.g e49µeU\v>Ʀ=7sP?E*KyYrƧq1~Eh@MיY{K<.G?XADPWΥg8p)ɷ-G,TKI2BtSs EW~/jv-߀7B5䖴K7-hKs ,45K@0).P<`@Rl%706L/vU<%GEm ;rl;ykcŵ,pkiV(&؜b7Kmݠ3!2C+M؃^٨#rn<4k=*#oL xC5ёTyQG9v7Fx%翵lԭ9z"7w=-BQ/?r.q#oGH0(GގBkzk%W_F_9Z~*@"J^_P2}|JHk )N懆*R__dc*FI;*/]c5"jE_o+ SthR*?^ )0AXJ;n\U{b|VjQwaqWf]Y5c| ޡcB{&UC&P.1eh-c' 1d7i R|9Ʃ;8D ճQ <ڣA6tg<9 qAی"u.dV*/K-eʓamweZ|FYhagղ*ʁuQj]FN?\EDQmWH".'EUg.mU܆6q"ZӉXrYI5#i{xtLݑ\Cno׷H&R{Do?5?\qDxW՚l'@R$xx+z x,O_Tr]]|l=M-{),UrUc3 /j]ݗKm B_7.t %EӿJ)A6xlRYI$T/V,(ސ o4ϒ*/1MvZ_P!rvo joéE xV++uvrodT.!Cz~vlGٲE41mBUb#L7H o_LOUCGXC JJsiU ->/-R"踓*YBzWMjM/B}EKbDEHF,wo4-90\<~mFnaX;%(P*.m8G*'nR aSjUIA%r~L[wWw#AFvN]Ue5M*$ku|FN2Dǒv.xoHHtDd\2e21cM-OHl<$Zc[XK*#)|$#iq ?<6ט 8yr`;@?ds4Gjo#H7 a| 0I-RifǍ%ϻ*y>N'!_Exm{YW{{cg}^D{ i=".2Я;: bESakeJoC kLS ?e6n[AH̯f(O@sy9E6p3*xc!ArqKyD Eɚ.#)v%tQF]3cQ5rfuJk旷,)FB&]w#u2o͂8O9dC?,gZ8V9kp꺫k& 6TckzA\vEZ7|P) N|N#1),e~-IۂE*&4iG*2pI*b$g@`8/JI٨܀Dm_hfƉ4HٖNS6K3)HgP=XQn [A@#k R8B_3.QK;nW!~\wgVi%55i@4S*W`x THo8a}\l$B'X<Ԯ32Ü4Y 9xD|a`m$ϯX8|W_lWC8j6Eσ`H|D%ђ Fnjk*xIWZ"6FpՋ!zǸ /7t:Y+CYGMp9Kt&ب3Onv)/b2%t* :f[B,ps#H+͒͆c֝AiXeLoeSa١0cn/1iwY ){UjUЛi* ULWd芊2gvݪ3-/WNGȠWoЎX@NY&h6Zoc&9Z)j! ȇR-~KF,_`3Ӛ]њlp@[Fu Xi¦ye^(@j}Ȍ7#ڍNH? Ib@awcȀ@cM4:'{B'vn?FeMSe6K1C~ljtfUH tz& xe>&X8^*t dq'oZ*0 :-2v8 qyȔ^ٞP%}eT%YȬ8yrNg~ϷKd w|"s*xLgxL32?hH{9DZ/a:ȍN.WW|>Q> xst[x-问TRXa9 b!:UИuLCt?3]!v :&M%VDÝ`;]h0(ӹ_~SӜol ɪ&nÞ/ĬBtZ˪.K`fGB[ z%ʆ-ryB_CXlpifj1~7KEe&FD.%Jr=یfZk'r*,)meIBkcl]CZ6D n6kHwʾKl1 njXg%.<+!I"Ę/lP58ѦDWQ$&Msr:ue]PРTցb5n^УھlҤ-)C4mmڿmkrh,Wjmuu)j+9bIk'\dRm e ѠzM=v8;.e^2a>P5oQ7Rj$Q znE%. $]N&B]uw5P LedZn''ʳ 2ث'/$sv_ k :l vpN{0EuIv[NLpg=gfm?sg{-OwΜiao'R16o7⦓|#AeH=!z3eΣH1`?㛧>6zN|y)t#>s?8[^q"}=%i0"sD˝Ø}|h5Y̤ _Lo/}}%YdHr0 U5'$3z}˗74ފNdRz'2/O].4xڒC-Vd!ޕ(\(i~3<=60U*n5:\:z@hҭŤf=n9r> kJĨ|&ވ`ȗW7eV|gWO @*2IIZ&d- JaKӥ܂fkJ~4e5mЄߵ<xճҪ\c?@Cw&5_Z e디.s]Ԛ\S f|feyvk䩁CWiuWLјimhh5UML{gyC&U@䛋}卽ԅzmGjGVs@1%kAP`qR\A_3u"% gR.3LLP4_gzcYA$tq*#ՄöKjX0=\ÿwYY㤧呆 h½^g&4k %,DC u(yZ _Dt=#0)gy󛛈ȇqf+^xܗ_+ oFGJL{8(>镦9}c9)xrA@Z=2&|=/o\j93FL}Bt='1s2)֤^V )CKctG!bK@fa]CG*̪d4x%[Dk:lK2C(K,~4bR#ZTcjdƢz[X!wlZY؀ܳ +$3v%Q]B+kR5*s1S*pMSPyZ,W}l1Z73lUQrcRFLp7P07E b4#.-$.7H'Qd[OIQlP;épCy$gS.9rKbpܝJHu6I5X^V˶j'b4+яK$,bD<8LVWar/H/ΞS( N#Yhs aB©P 0AGfBx3`-]gdbd-~ӚqvNrD)hYto {"0ٽ̇?@RJΫOɽ"2O\>ЂDn2Denn $^"3GwDM8XGG똌`U--B"}4%u}W/+1HW %Jsgˀ،{=`rD yhHPv=D(7m C".0_)@9@K U؃!>'=B5: [7][;^\<gÇ4۩3b[(2V oPo&r#\%KGĬX.C+ozh%Wǫ֍.٥\} :KsTU E5s$`Ӎ,1)YuD_"͖!ak;Rucy1tSүbREL|VUBCC.+/PȈՙnF 1jQ~Tyr0,ܒpUiORUsBn,^pQF2&zo?MVY&k{ T m4_*AEnQ,yLi](8dV[ Bk< Z$A\ە;^M:l.Mh%sP*-z9N>6^cA~Cҳ9UC٫0tdgEW])VO>{]Fkd~~ پu0(T ?㩹@- |JzC!kcE~PRy8;ƻ4C|$jXD, Iܷ1Hoj\?xzC"Y(?x͂(Kb$$!hiٓ3r 8Y|?@lZ<&oIt|S7 ȓ(G SetmL1R֔N,9uG缵ͷGe)DQzIe&QqbR4x71^kƏ?Q~ (htmÎ-;b =oBR>b)vLCwގIA(Gގ:@P0H2=[B>6(|my9gZU򯾍|BImPϿbi/T?y -EiyG7!krt^`wֻO?Z??G2?`"j-_?:վ~#Ea]o_GGN_hQxp:Tt/8*}n籏G?<^ZG*gR^OgˁƂ>vǯJ%.s[]W)Gsd}3J 6ۧS^OPk?snaX~_3chB/3u(]V4;򿁁!6^5MB Gzc:ޯ5|QE/z߻h羅3#?~=?sendstream endobj 415 0 obj << /Filter /FlateDecode /Length 1963 >> stream xMo[EnVOkQQHEpb!I(ӸM}oguD=zvfvgޫ1Ęwq9慷͈OGF":g!x. ƳQ+3vuArt~`fke2v1 ;SḗlN9ώ'SO⩕&d*]Dž;2 T͏6*ud¹Cp#fA KP^Z`r2-o2$ʀCƱwbx1l8Z(KxQz Z.y@Gѝ q&p&TTCV!]pL'>(˽E1, .&sʁ+ |vpt+'ۋRkpԁ/Gi8S:~Zu3g~g9P9@J@.D@.i6R-<^$%o`ūI$xΦ( cP\'UT@;n .2{TO3/szԨH gXKp3}KR=N#TCY99Q,- MT:m!1|Fmɠ:e{G;y! ( i>*GM. xD 2L ͩ2w< wK\vjV7ſ_P}[N#% +÷<+yp~]𬀗46pSg'T4鼀Mnriyymokq{T,昱>' d |=:o|p޼i^! /lC ^"C<}u~} ;o |yjCU(5)# "6Z&@Ϳt}ܥ"IR ѿron!%WT,aZv(%ۻ^@ls5ܠ_vAՉҶ?N:{Add`f))O˛U 6Mm{45{AO|g18*`o7zZ4C}E))kzm*Rcʝ$E6OiH-7$qE.׈Ny.=7ͤJ#y,L/̾}۴@[tgE/3-L r붪Mؗ?x%y +lj!_P\^G WP$FZC5q[TGR iI OpIr9kW,ȕ}c3҅/6ЂYsnZX3knޠ%/f{,zXq \k֤17N4Fku֢zFΓk6û1?FpSO4FM-bZWIoq cTdQg^P|DyQ憱mȡ[c:N xiHn2j O7Qw[8=;׿Z)[_ .Ed𔼆D wop= .q/"nZSsQtJg;^$Ǒ;nY<KI #{N"⧥UsٝzՖ _x3TqYY?j*QçkLi=V?F=Ѩf_߿endstream endobj 416 0 obj << /Filter /FlateDecode /Length 4306 >> stream xZ[o&9}ϯS0i| i ݠ}݇L&n2 9ew۝dZƩTSv~ةYW=:W).#-ήv>V9w'ʷzC㜭ߝ\=9d7bh3YOc5ǜPJfhcZEYifaz f:=ا`ne\ Nnzƙ  t M&`+M)d?M%cc4)wGots%5VmH6v|E \)M䌁ɛCqQwCٜd0d}}GGO^MOv0u6sлt@z8Qu~I{7)2(d| x%zvw I–-$sIֳ0DOFJ<*f(mQ4~2b^$6 .9qx,j(qs&eB$4bM8 H""($fC'f0X; %{&$%nYNx1-%˨ӭkX*u(‹aGh1)Sz - _ -@X)=Ó^x ֓Y$jK98%!@'R5!PI|#4)BL\%!uG(dږr"C 0i1X6?I őA@ZGa3BZZ Ͳ!+Y܇^XXqKE8؋hF@b@$- ZQ-lEȋ=jDa'N8$/X J4y1p^<(.f/+;90 7 }ditŠy|B;lSvB}C")iI.ɲ!)FEJ bˋT$)c'BR̤EOR˦JHǦ˯QɉN9Y{IXHɉ=+Ӏ 4RVHNL1w"J8< 1qd$ŎMAҝVY!>v$deQXJTщQ<&XŠ-)a89!ŖȎ M%tێز񐟁sd<  7Q:R]?gtdRNe -6lȌrK,·NKrlEtϮ cIlthu$Ɔwe,l)sN]!xB5Ώ c/Bb*Q|DBuDJpڼ-}Z',Ha&SJʖ 1E$3&I27Rn&<Ι5U 5G(ŌЎ6 ,obը۪QzBWKi,jTAv-?Cx;,R:~E`oVNkEN H5^6:ՆNxŬX ?a]llM'se{(o**>N4ӷ8vis͋Pxf}kHac8˫w,Avq02XCOEӋ=1"O2/Û6|نm6<^ӫ&}׆mxֆopo?[VNǡ&=m6jû6vߦUN~|pē=P7=>oCӆɺOZ@gc!GgCl7%=K&81*l.G5y*ًi>WYhwWb*{!lpV4mV{tf^˛)21ݳjkyw[}^&Oۓe} n [(*[g]좼@[M袼lζY3](׀ (HzR<2Ns?bGZ}u|ҡ|yVa5_ eak*Y _)' iËQRk>XTeK4ޫFh*o2} 4iޱeÍXPMu*kИR|= de?P84D)kIDE9A-wP-"!GzzpqLq8x6WCfRX&Tn$}%E o먃l8$idW_h7Y&y6/P 3ұis?R!e.l(}U_-yBVx*_ɿDViҘb6΁bIq(mXo+;u2kC,'KJ۲͛_vʥByψn\4?}Q;n:곰SǓOt=׭P e9U̓evj[ΰʆ!Ny;[ oZ j(w=CǠkñԆ Ն]O?S U"ᗯVSV?ZԣB м 8Tʑ6XG]C3~;iEI,+ ҂!0 w+m$p=te4BnD7C.h,_یpPGZRkwʁw/5/jJ oeO<͏,+z@>Byw4#ց;ClָvlGuF}!RW:G:j*ƞo7OIww fxѤ)#/Z𑧇{o|R6g4Ci7٫&}7lZk]7mrNp oGoOowm_q8|&Iw#ۅ zt']>xby0]Wà>i __7+C)=2 6<<,rfaWeOp? :hC_jj`t]XbǗGj׳C ^={O_<qu^<hTneendstream endobj 417 0 obj << /Filter /FlateDecode /Length 3957 >> stream x[[o\Z7Em_@ @h}dEk[wfCfMir873PPo @>? )"LQDyx }+ [?Fm.YE3lPE.Vk1qVz԰^0ZkYlvJ1u5))mpژ " B +>Ý#\ cp෰BKV1UZR(x8 v!Fg/VawQ}+jFj W<Uаl%,"cj>P Y7vڌ/!Q>j tr0(:C5õcp=a2c *= ?,]/:|ZKa)e:_ۻ_)0X$Q1N $Io h 72d$p.+.4Pi n럥ÆtHX!kDM̃%$+颠U;4ݰKjzQWgHC)/N}'UKܚ 2n 71\A#a)jC*tEbuI"%pBM˯HJ6(_.a F;ɪ[P%aӗ݁ې!Y`p.2CAO+2FRk9HZ;z&*FM6I@ddIbTY> &Z`პL"vɕZ1i mWB(ɶ_aglJR~hqYd#(e I]@p坃ESi'؈{fŴqXR "L 0)-<0=/amԓlUȲ&H.Ἒ:<ë:Tn]]7uvW7uÓ:|6uF a"MDhي'<w]elZygQ7Pڇ@!{O֖gN{lʻKú'0эu({ k䬋dZvi\Twkڏ@P~ +@6"[蟜4%3Baalg;â6H. 3v*IW^Be6,M&.J}=tl\74 n Sj-(iw5pMiˏ3E[g WǤ A8"Vvl9IœRRԇN`s6?˛A\#'7Bg@D˄s:g9\#L!\bg 6\ KG/eAccά,:bf32۱,~h`!OqOC 6V>g$!J,:PUݛm2*N7%HF RdM[[s9oX]a>gm5 ro`1M^tUݛ&>ƌTktbD3Ej2mjg4F2M`LzfQ4!)ϒ.@~4{m /9vzXWAZ:<:dH!N ] 1:n6vg_UJr4XdLGϵD19ZFh8F#f3oV)28"e(>O+سB@V3qo`p|ZF?\`!sKQcPXܫKk wcq/WMőƔ'Cr:. .kiBD@bUZs{6VޢI&y_~X¯HӡƒVd >xq;93U,ۢo:za\2 팇STBƖsE ±S,F5fW-V-XҩlNjR:2(Ӥzhir  yPAݦ4ys}YlV~Cqm{CjnY\ nKss':gSY|M1eKYXO.GV yYQ{ q|\ؿKq/e:dJ}kCw-+{g$3otOl70Hoꐡӏ ؂϶y0<I^J,U%D>7x,UKhXAG4[H}21"\'ih{DHW #iE 6ˌ䇙odOb 䅦TAI~,;mS9EW 7t+m7j +ʹ.0xIh f9-(I g[e{M(~mC76/ YՏby`Rvzz++|\̘"g. OG#t>/^m;|H+G>q/ } >;H+g+J(fVx}R1̬ȺppٳQMڟbl":5xl}tBá+E90 җAΚ~9!ǓwfRrc$mj] r.Fz@UUVa}ɚp㼕0&;]YoI) Y]]\#N@-In|9Y*L F)9].~wp,d4ly\kCڀT.+:p8B66ȑ GQ^aM#xh)vcŃglhH@MTn)'*eCn[\wlI>i=i-רU% *qW~E\0+ 0VJŽi~ަ=ߎzv)2g̤/`FާVy}׉]^vFk %*;k<"Wscx6:M5I@l6VՍI,{9"->bA ]JBS/τdrCHh07iQƙZB;9:-C$a"^lN$u]qSቚ:\Y(R433%uOuo8ٰ_7^e|esUid,fS2a&إnp/ǩNݍQ>dOɜ)ub2)e穣"R M9?d4%Sy 6B~[hgm@kcq8kQ uXendstream endobj 418 0 obj << /Filter /FlateDecode /Length 36578 >> stream xK/q޹?,{րa@3ԀD$0~*"'2"i>h4y'2_>_?t}O)w7L6}N]>ZjG}~q|YͿYL_~_^cl_Ai/tY(C,ܿҗ2s_J9GRZ#s_WMz˿E~L}D|8)ҿË//rҋs|>Xm| Vu<qMSM?/kJ_>@E/ܧH؏?W+5&>_9k½ɞ;Sr,O_ݟ%_|wU>ϩQUO vǻO$z'&-}NzRr?qSRf$s>>8IܷOrZݟ^$DN˪$UxӨs'4we9i4>8I{y//IG'9w哔rVw;ityzt~:N"KA=iurӪ}˪&=<('8Yj_l7A?I_aA;au :bPNrZ叔OrZF./N ̓&U;kMNvֶ/rԶ_Vm7ݤQ{y]$Ma^V;䴺A;iuޝpzVNrZգSOpv~2gm<8kMAm7)/2wqz:氪::I'] Iiu̳KA?U&^bsYwPٞlOrZul ?QӞ.$EN2c.$o]iOrXD7q#OIN|O[NrZe.c w!V#Eړ㘎$Ee5P՞dDPמ#w1'9n"euv.$] 7 F`]{rO2cGI'iϏrVPUmVEXHfHORIA$"Ex3'icq}@K'et%̐4ʘ!=i~]IAjEAv)/21f{:f>0Ez*'vF\nrԵ1_V'um&so$^ކV4ʘ#-RNrz1n2Rx~ד~q_Vï'GEZ:D> xғqj^!=auc391CiMNrΐnR^!CsӉq"TgstcsjS)?&EΜ&Q܃~NH(i*i~ENE8AZd;b"C -RISEN$"d̗ o"s_1'9cNrZ!cNRIh$JԵEʋêb$pF,RI8:F`O"e''9.^d>1Ezd_K=$z INtV_Vl79YrI!c/U&U oIIZ;i50Ezj`SE=Iߏ)PNNRTEN$rTEAN_ӪDE#9%$%-DrHH v Ih#6MNr,rZÁъ$&HVp`(]^1AZdwE(tEQ)GJNEHI"D_ΏpЗ A8"Q߇ňӢs3&Ea]mAPhr#)6hNH*DŽh9H'h'`"1!ZSE8!"iQ9(-cH'9F9$VN S+"\eAr-R_$rTEd{p"sѓ1%''{ei5i%}Ẍ/>ENƅѓ9HguS Q. *F-@;/Kz=3K'Z}zIrhJڋJnfASIN~gnr̂-*H'9d͂VO+ހɼbH}z*HRL|@S}̃," DžjLj";hϘ,YI"UYxYܟ$@$fAV 1 ZD6#N^Aq$#nA 9"aE[dDE[dy)/2N= V#4QHi4-rIԳEN+ wɌHEZ;ap7,^d+\/I^VR('$s/q" %Hyv"uZO26K$Dm/j[J>OA;+%"%u攽,NJLmRbBDRH}NmPK "QP$ݐ;+MhE"1)Z䴒ef{Qv_V䴢D$$˨br$r<:5xa!' ʟmʟdDޤ%ͨnk0:~Eath z^VAX*@KX-ˆUVh+{0E -BVRߤ͓G*z vI+tQ}D" q HfD3K&Zdd"!H#ʟd] b4rLts'PcPcq;uY՛>-G(c-4Zdc{}24cPY$JΤT$"T$Uh 'Iѓ̃ N"ī" &2<zNBhF?I}ָ=I;CۧS Yѓ-rZh^qvR VEhE@rV% ="eJF %#V|%eUqITE4)QռSR_D곩[.'_*q:z%>iۊϕB2ZFF&ώQ0jo]Z-BGv{BI\`JƱO|dDAHI{sƌ{# |+"_!HWI\JZxnCz%$H#S/jh4{AԂ9*ѣE)Dy̍o1DQ$ i+q A|:rpqc2)9$u* >j:3-qIԂ8W)σxqK$1gIJOLJ2x0PPJ dI $Xb@|ty<#xAmy@>ղBB+WDmiLu9MUMmHhh6п+ d*a~jZcD@2Ġo=NBlj/ 1H'tB+]j ȴƆ.Cy4SU! hT3V٨fA:E$Vϔ80Al*[CM6#46R==Fx*V+N!Vh [-߄Vx_ŵ KK۪PZa _mĆgBvy HyxQO@+$zA#r@C #|h}pM4([(V)ljyq h(l H˾qE7iuCq⚥Bj C%^1;δ hEh#*4@UĈFBZ TE*ՈUh@ӶzVjĦ>bt ĬBqe3"hߨ0%(PJD=KaR6 Nߞǘ;L Γ#&|DI+W3ɾOZ,%ˌZJ0y"]+ҘFniPn!Ͷ 3cQPBC3 6̙QkH"cN'^I3 sw+PF1ݣ5[Z2uDkjJ@1`8C~Z%>q 5Xt ȝ 62!IfrH@,8Tґ?&(G -@ ]XIܨ5`%l;iLQ&qְCaPD8 553@7A= "0\- P2?1 }"+4h?PHh Cd5p!>LbYfa <1hAWD"qWA7(a3 92_ ڵ@وծuuPBG#e@Y_&ԍT*H1XvG4zgYA ,A -Al3/<dr#H$Na%VVu XJ*ȏq |G:ۋyy3tG!AGcjB tydvaM$6([M#WXũ3&ބUt1kmDŽ&t80}偖OφO9)h5(*FNIħ&.E3W TqQ1dCqt5A mU%އ@Y\ 6D0(gp4p{|ZN%O%>I(SsyS_TE$fu+O+qo#kE;.tdSՌ!b_ M˼^/4*I/lW p'~L|4f0Pbfcs   hP'ihT`t'(?5r`FYЭ(yc@jT'ĭhnҏyfL+)Nj.uDAH+Z͈+0S6@#}rCƕĦ/KX]K+FhہZ-b8 r'xP~r¸]IIBO-@85B%_ /#O~LbE!dJJr!D)S%Jv t]AIP}@xw: dwؤG^HX/Q t]L`s<+9.4}Jb Wؤg56&=8hp>]ӽE`D~z 64swA[ SPMburj3 ՏW STD}NBؤŌ@qMdZƄU uO B*J 1+) Z+5X)CR#@ tV}GtFׂM%cR *¾u^#+\*Td V";J|.sa?qjl| ڏb |41UtE_|K;J%Zђ^y hs'MAs'%}4up&qwN\0?)_qw+(C׆$Oʍ4Q)ӯ5}[4N%>ms'yS538 \I~:I5UhZx% z-$W.(ѹLgT.HNoZam#(JDg@_$ֱ.PS`5Yû ?oĬz⠮zY[-= ?DX#+?)%Z3Scݥ4.h"[wFb=;'uG *_P7L@w' zcHI'йH(i>Fd—. H ھa'\0*n/gxz }heQF0=<;ER z鱝e *Ν'ɨ^"Q' Ոp~ \ 7] zqoi]D7lOҤc]M)L*L-$R,ڏRxr#>A r{~R|⹁RNx[Z')vr%~GB)$cl"4?:OE=R+~Q7߲͵H:9TJR$HYN !VuLUPl |].X' E ̟QRtN~'Fd+\فRf8[]D58Pn@ |o\-LFިD(˲JZIH2fjS:LVĭ=2M)C)_V r׌M7#n@B:AbVڴ<6-">z`D+ev*#fԦ7FZ5Գì|AH'W7UV&]lIFDNĠ2+F>yX&.~L *:X52O*&i6*FF.bbPc#fT e24.Xo ~aM8?M2-<$XaivU')T}: 4606R* $(o¨uTWyWAۉWǵM)k j*.+FWdH=>* BQ5B//%%㧛Mz4fĶJ&ǬٜZc+9êd85L9kY.^75%X-UF[ϒײUA2kY q+i4B|tmԬ*muL3B"h.m55L}Lj-`W6Y`lJ^lXHs()i+H^@EJl+Hշs' }?W,|W4jHBdJ)΋(@U =F*71aj4 eݷ➻ILqIHO,יl絰@G,6?&IbmeQ! 08~Fbb. 'J 1F*EP]J9ڏPʐٌ؄TZɁ+ qC戠VW̸ONu](q=V6ϩM ؜HZ]IL,d(_p~)QNPlu\zܠo"keW]ׯeQhnD in37׆dxN;IjĦ+<@P Lq 0TZt ͳ^XH Ce8Ƴ1<^dĵ\*y|CX̶yV7ip\32LwaeSG}+·td4S4ׅt[i$:NF|ݩ]^s]HwLĬDXL COcbVhIfe{M`}ut8hpݘ =: ݕ! ]UweHw4È{V ۿҐ!KCz9Hfkw["Fp!.v詺 C7_#:;Lu'D L,GwЍMs&1!u׆ls_t+tDnwڐqQpmjC`FYXKCU_pi^M@evWRXݔ0<. ]InVXSR:+ppm_m{Efkx%#͚p4^i4[y4kL 'bM||@]J"l(F |@HdIc0dWBɃ>@L#|07aBhCHB҃$7a_/Kr| b^:# n493ߕIt~RhHiPџT).>4z7Tw`4A9Ml&v , J- \3xJ,bPP :P7 y|T4x1n%iP0Ky*Y 'ţFcwy@Ha5- e h.>4iX\4i1MbqדĭZi^At*uӦFаQ4ahl;"RM*4R͠PJ%h%p X6 |#LeEP FbZ,^i YGZAq+mhS^$$ZlD&qҗ.4ⷬ0i= xc>|I$s:ݙ 8B)$̣qdߡBѬ@ۃJ-"s=F| 0WHױƞ4}ty[7%Xye%m'edp%S0d2dd1#=\ ʐW!QGꃺL@˸vXQhJ6ZXR #<%22@뙷%LJt| ğVR0Ѩ/7k*XI5<AU0 <[\XeRu7ҥ^ B&4Q2AF :T,^'=Jz ,Ϊ'pJzyRi$%׃$x4ŪW}pPR\8 oAڎ.@UL $3df>zqAHD@ $n42tqPF6CӃ.5>T%]=n*bqXO3I;%&%,cnp>#GL^Sǥ5 N0OdJ\),t&FJFuB {ͫ L j> ]JpuVhAmo腯B [  >d<71` >r!pՕ1BD܎S]u$WIlteLo5@W͊AUu?-4ϸ+1p4Z [ϓKR-4&_BI2F` xâ&l\E`Aq ArrOMlZAP8F*Vp5!hvcDy55O#zJS5eu2ʥc^{!kD]ӹ\,e1V 7ϽSh.(=:iSuN+*\t@ENΑ5N":ڈ:J{:2.6‹TsAeN8jXå{0w]R'P8fĬņ6P.(:u 5d Y gJT-yL7+ mMwv}J$fj<Dž|V2)?;m[UciMɛ@0y%d3ApȲCi%$!*ъ&{ш@ZeO(E sp8!tp hw3\90 V+J@*FbFhj-Yqqfŗݭ!oDO-:U֨d4<*\=OCː4`ueU29p$cǔZ5n!ǨVܰR5O@@#&|@]hDe 2e6S2n" V-*yjKL2  |#1WNa@z<@?O TZ|r2wdžYc Gѩ@9Z>xT;(d^h Z3 |78i%x'Rx78" @1'  ; :jF3v`FVc¿2ϝdgAA0/C8 aD9'A2)pb4;Ž Jef U͂:|]蜊(q+z5H}/|,2H@A<ǤJ؉iA$QUVT6l䴪VWFFN#WՠX=i%gOR_k"P6IdjFjԠb9lD䴪l䴪QH˪EE[Qi%-0Zl"rVLMIXH gjB M iI' #AOrZ+ΓZ$BZ,FZX-RIhwTMa'$-Dy"2N@ zC|DvRE)$oqMaAoE(eؚÊr;ZȧgJL}kf2:ZQi4j]18-l0,VjP MhjP5a אbSլīaU* M5ׄ hjϠ5Aj*q# dp(@vq%| eSQb`jk=kyk$R Q,:` Y$YL\YPb QW0w\ PJ:eI21wNPbVPC#nEUS@nnH!Y;@X E腒BNwT.s&1#Ap?aBFEbL*CysGQTk!. -9S믌NR2A Wд}uBU!+w {iMkFfmUs8A ua$X! dIRP).]F:B7%J . zq)f Ӆt>b4lk{X=_ r 8LČ*=׳Y/5ٝ\1χ&\yOl" ,{x9"ISPnи+ ?X._w1BƻWbAm\%bx%f[-xp\bɰl%8F*#MŌdݔkXmVKI)!%|ςeBf%猘j(d.BRy-h1eUopݶϸ".[wNbd2]eQ#/(1 v6Ė"m-&HD 0ɆT 2gv#. 6b%zu ? uPC4&G>:9SĬ,FYWNdT4xBFt($j#5iz٠x ].E#H(l\X>)lg2(*DȂوj=:;S%fUM\!a@#1+0 n5%΃ĸS8ĬrFp7`@2̡D}bo<Q$BT1D %*.oRq\"RZG#5AxxSp#Q:m%{NgD7 -L lj[9Qb%&99ЍtEPsx~)F8R΢`+Q(ٚj 84,.֒+Xa;:jiesBNOr4/6!–BhkhTn)Vlbbd"o>ԅU"DGZ[hp*B{[>NpU ׆ƭho*!:iFO'QJI+C~SR%dleTB+ݮ.1,+NanWX Niig>?\ $Q&s:J+.RC]dW.Bޕ!%uiu*CJꦤ)Pz:OrQzӈ"*쓴~i_UViViViw("'1e VؔҗBAݔH%_I =AF}ɯA`*K2jJȦ`jEEhEXP -B%9H!/*C`ߤVP~KJTES IA_+54X*Cя '((e h@c'hePz(0ˆBf|ǔ(_yH'3-Le4 f 82 Q, ,KT2@B2#2 "8O]h&t3tH1tV9=xB,sgbYHU=pl)4%b~@e1oІbo.(4t, PTRgճchj*0JPz!,\H4 iS?03WjiML[X=UbV!hjDpFD% g5)5`rX^܈3oS!1J:K2"2KTq.8FmbÁHjJ`7%ě~%k)C4J*28*.YW$h#KCCzESqp'|MͧBITT|9 ! fJj&\sȌ$=U3aش*h}c!%6izTVHo$XּXesf>h|6Ӭ9p;JmN>Hzs9`d_w]9Ҽ+f_.z[wqU?M.AiL s%/Dβ?54gIJdJE5wasck;(<\-WVh _y lXf̟ʈf!{O$$XJ#!MOITu1ݭUbD%f5[UBV _ٗ+ WXc_/$Z,-1+6}aw5X8HUՇ*]rh:Q|[oĥYw>ޭS]S3QKCʣjcf~'^`t1oЇ?-IwehtT F_SB]ݍ. Wsu_s;bjӘDbVV[]_x1_pAS1 趫jղ:AjG=,NZ=,ZR%P%SQV*A+<ƥ (nmeQKAQt)Gؠs%cx^:.&TbRP3YemrxQqˮ߶Гʺo[ *|`ZĶJ%^Vuv*j%ӡ7/[@eDhBbT/ <*]'T:A$.r>g4h>QP}dZV}e&)`*Q5DN WTĬ@Qbke~m/$&fçĬ4ˁA3]**YaFwZ[%ۘ7@S{Ү@-*s4U.SbB #S%:.r::#(.XMD2=: 4}H9ܠd.Us,%=؊k%l T׌Ә$T5QIҩB 33L4K9>ݘ"d5܌)BU3 ^vȜ%NlP~lExN91KktX!%s-wPDo|FGEOG;w [d Td/Yd`Km4Hx&ON¬JYe.$8ΉHM"ghBq U3J|28= "WYI#\z"-l3{S*;A$ H/ԄFa(Ԅ$bJꖰL<3BI޽<0@.M%+<FhJxťG.UeGzGeD.U^|U#`*Uލ"EۃH7LFk RI6A"c9EʋêȾOɞEzdQUI HdϢHY#CxUrQZD^VrJNyJv«"xU:Z% P^IBZSEZ; %v$:VrZxH0HG% #E^3~L$WgT)@~ķ|KPrES#!.R_$$WWB"r|1hR{ "sk{T] iH;.!VPt%aϨ_-F77y"T^ BOR7!S8H,EU'aUQ*@M샚uK%=dWg F(KN╏F|#WI++A-+fV\|d I(L%u[V. $E-w\(x,X%A BԔS52ȖL D24$ŔZJXf [df [ʆP]:W:ǔA2({m*ƚF|*):f4eɘ y[db)lC Ol)f* .d*_`rK z-@Πkq!gРIIÂA˖qDw 6r5TbVli"^[qCqy v:j+qJ^ H%e`\H4n\H4%nŽ1ǁ+tg&ߗ{c*}/s|}/ ~$DޘJl _d 7:|K3%A56R7kێp9\ qyloLؼX7A)IM"OH4HwTɥb6IYikešlyӱesIu֍4Q&=xJLy)L&Tl* c JyR!H$b`4[ b[^^Xlv(zdtWLzW2m;.]BD堫2dxz%]v'+xFv=HAb48FvAH(S7K+1u}{֋^9%e, $ep>OI4*Ww7PQ϶]W?}/_6S?{2$zQAtBkG[<"yUenyEQ?&"yuG]~E9>k)w߯ŎlYxŒ?/J'WosFȗʆ/_|O_(Y{8@}j8 Uu],+"qvE>hZ 0O56tdA2_4oWo}ѿuT7JkG'as'y֖B"7Y=RzK n~%__}?Ww~:BKfG;.GxdA wmI}ﲱ7#ejZoooo~7;#Foo 7|#oE7Kh8 D1?7HF&Qw~+bkwai*|DYo`׫E4U#㏁ub-D& ?XLZH72d}SM""UPD˛B#φDG?؉ԟC-~UIK[h7~/C%wM j-ʿ]^BoO!>D?k?L' a$nH=O!L9O$wCJm=IU"NSw@+wkOB{#BބFW@JoMW WPoCjY hIT)η?d| D ɌH {#%`z~?ݤ|M#Gʃ't:&99do7NR^g~ Ju7߲i@~X|]$I>JWQ"|E*PLH R"2NyG$$eI\ǣxED^d=!@h|H/Nr5v8AP('[5>I'I[sU̯i INC(_#9 @H|vi_$ ȏ:op-2O s#_9:Xrgc{)?Hp Y_/dx<&"$ݖ|iW؈U髺i^\V%[v8MqLܟoF9SO% >`Fg4ӷV3>mF_e{HU[ӲH_Fx;|#ng1{D[-⋸,{5p/=A12*$UNW¶e`H{IZjE1rLlt:gO3tl&O !Q>I.'K$cdR-g\/~:t9 /^H|,))'QFt},WQIxV<%wtyh]N2AtːlOyϖJI'i[󦤏gdgéd>V-X.ۧd+I[C$ggnݎkٺ'FTW<޿ѝ>z ټF^'h$!x= \c#'"RO2I[&9n^YdduP,"ki}|<=f'Q0b.egGFab%>ڏR[G4iRQJv[ݯVm[oc.*lCɬj~h-A/}#~7vegQM'idmq &'ckof. 'nH.e:8O$<NSw[U߱;=c7a>;ެ>xzj<sF~<!鏪MY\^#쓵OBOHm#)x5RnIʋ-œHb>1IӪlۦVГr8O^V$o,uxZ[\O/oAdEIY|d~(J.rbIѸ wE Q)YӆlUqHGgmU:QD, iٖ( u6TU4[C*|-n£PIAC˛==nFwę{&l.?\M Og8vG\=V['z1cWM }p)q.EwE$$YCZن4OMV5Jy4Z V3պo}k'5B+&hDۈNo4ۈN2Gwb^g>6ӉY|K}.ѡF>jtL>&F|$gnMш;ڦupNvtq-:g\1jGF]b_E&8Յc(^r]a%=˹ C%6WeݑrcJ09=jo$}ƶ\%r Z}ૻ{̈́Z5Ԋ^W)Aq)%.%“RԄ3(^E `L K|* g~rX,b|EgM+6bd`TY̶/=A_Ţ̦5>&jbol.=C>CP UM)>/ۛⓟA0i|Sr6~S)w͠~#DSj>,j]W}Keuܼ'a~?2K$gdx Ċa#FSϹMD=ZUL%8Z]ꚟ/P ;&jr(W$PYW*g5;u/+詘Ǒ)eeB9|]gIıc|dp݉{8.͔^8ƈ cE۷6leN ٽRj;;K+[ 8,rvlsb25+TVtw;۰ዷQ=17*Cǂ9OpF8NBvݹ?8b9z+16xc:F&;N栗N ߇ÞMv 8k|_~}ﳵ]_Onxg{iX1a)FZ,y$#6R!g_b 'TCn=>"FA -jEKk,ܰKdz3xM5N a+gXc4cjJ :j=o6EPvyd}fSV']o:;d }$pLV6qЮbcWEY ,"S"qԘsG"Q: s(O 1Om)Ѕ;$i:a xjt[{#]sMrX|<{1ɶc:21f #ݺ{LkG Z.dl ejs4rX1:oZ3qE^]F7+wOƣng{j7@YM^zSCԁoaTT{ i Geъ|/Q"l%母2^hdi^$i!%(Pѵ9iW\:'>8'&7{83=\-573_5>Yҟo`{3Z4i5iH ьΒ45&;P@INQY%w4>p~Bsxg7#2<]qʕ:J+!t{RwH/sY<(3Ɨb-zE;?rJk\ʴϏm靶Z]0A PNߑ*7) H  kiĨ5맱T9к 39خH)32ڮ9q3"jZI{9PԾF9t!EzWGT]?]d2~Ɗ#B$м2e$pvly dSb[y5q+BR= bG'}L; 4(N24J-7W$P6#g^Za99 wh۫N8=c1CFOVKuٱN0Ѕ?v lZ(z8H=,wC VPjGN:;;̙c㉔&E:ΆɈE==K1{?a\եLHCck))kRU-!Z- "McRKliDŽIzyL4ԲI4Fn xw--5[P [["@ְ&rR*Խ?[XHwE8\Dbyf]J!8<(A[ћkn38@6#}5S%=@^J٫F M荶E2wNl2τ,^@P,nEф8yxz򺝓QMNj>as&#j̽SvH iEQ 3 NDVFD{$%/$''yNd"}L.W:@ne z׬|OFʷ'zb_+v/fVL|1{F<˒H$zFbn>9H/ g`[>9KAy'i/j4 :o 'η13;Oi6cƬsV9M4)B\Ǵe[?Mp;5?l@zK@`1NX֫E+$dRpWَ.|r4ji4i<0l[QODNBj[+"=T+8 C{FE.*@<}~e i!e V*/w$=~J~uZs./|:NT(Ӻ%91<降0IIb k? =F3d2" !_INMыzwXp8y͇LY|qCY/ڦͳ*/ xMBwG4Ì2WL"$IaM'f0e/qɹ#BFq%~sgYk?`8#b,091}fݝ FJ,4 SSzX[q]PI2ԑz@Թ!H3x,ꎱ9sFQ]`; 5WI6 b)!jNg |.=& \_)a^I\N Xmм[sDf;8HԐj5EXiDk܄$H<2Y6a%ZZu)/6v=%Ys RwMTR]!w"$'kmZ@žI7 z ' #? f}ٚbFUk7S I<X2 %{ш` %æ:G.'o cz4Ah|A i ^H8aHجBsj@#U=Ӑj̙A0Ytf|<0 )v09bQϮ spiLP !a+΁eF&k{~|E|_obư=uGzCg99g⦡WA\eoFaD 6 |͍swxf,v6lI>tM,L 6Haѻ ?DX4a7JGgc7@*.L? gxbCgb;(L6fM`N+"4eEOb^( >J"E͹3u'&pv yB-ux0v#C]/ 5pޅ͗n-=KC]D// {8aHxs)~$&j%pnGL.OxVT&dyY̎ U19)IJz7uJ2YZqہ0 msg7m0KoFk#Ou{⢃'a.f$) *J*bYΑeqSKJ M]!(S V=mcvz8/zS&rR:kSCj*C?F"Bq2`VX\;+P  =qZ.!Gm[%-sK=`9YRldFOLl=P!yvoZ\'ਫ਼E:zq8Yڍ"fz8h \sS u/##fm'GfbOR_T :W@Í*!lTE#1!S@F" R_ m~f=$}X> ۴>|ަȌ@x)܇~ $CP:p/TF4? W ˈI\:J#'7#^>,FS#;U#o,r|JD]~p4Rʟ?;P^ˊȮ?>WIbaFb\$*}y)~0P<t?tGb\ "#ޑ4/b /atf^">O_"Z4pχL\s?g|ceLYSC7U~>'rμmUϯ<}7/qG2_2Ϗ6oY=cPGbI;H9ԪH 7ɂLxTZY*XotZ2$-|g?Jj?.v4euQqMv.R9O Csy~\V,x\tqCdYeVY63UMٜ66_hc7Y"Dkʃ "-'mYLRm)I[ʒhHZibۊ [GFv5Ԉa-lnzudnpYщ0&0`ut~%ؙM b+Зҿ0a1;y73G| O3$|+Tv6Yτ֪b{(!'Yct },Ro9 |xKH %j]!~޴: 2mw/#X=.+*%^TS Bz[Zh_7)aiq>ױ>pZKR% `a)G`)\7M7k$QsLpAXq`,"PCO׿>CN~_<  ]BN}D-ӕ~r ]k+_|DXd+ona+}DU~S%|f*ŌS1QPT3 SyeǛ\.a!S\f*C.yB9~$281O>JUyːTO27WR@ W: әQJUZKW`5(T D?n\,5Sri:H.-RKܾtT7Sh (/#/iAv*">os[_٭|+|+6 w|K[`D3?YɫcEXڒ!lNOϜ];== XNxr9Q x~}9qKq˷bk#|l5$ NfөB+02>S癕t`s<EA_iKt 25,8eX\codsV4*_@9\41Y1asfJPZka]5n b8\m a4Ƕ<+oFgO:6ݘa:@X(]j(bR}$DUʶtU(XO,cmk RӶZ>d¨\aZn z`x;-C%e6򲥰L6 ?#u,.n4#Yk K[M3VeY򃴴’[؆֛\v6[ iiv 02_%2ŝRFf\Mbt 5[ y;xa%l%9l&es.-ǥ2I kI\.OǾC}"d-LVmт%#~f4h0$3 #OHd7*Y !!(6s.Ss6 3Өu,T0+1keosf#|PpZ_C~js h`H6[RrU&Jve\7ߩ`M+հȪ,ʯKRrU C3΅nX'j&0̔*+l/V>*T[Q|_zKBѮVn:rP/Ar _7yŘER:IMEC! ӂqgB2%w`=_@' QߞVve FaݎMO.+x=|#uy󐇺<r=^vxJ]ĺǫOl5y|b^LbfX/&$$/&$߄22%6k.}\bUhyhI{t*S}uoMX'Rd&]bEYQ0wRnX1G,t9J`E)*iqi@pQN8]DʓWmMIVV]+ yKܙTKFn+Zj)] 8ӐZJmKXK-Nғ6c|);@ͬ4PQ-͵fqcEF KD%l78&I:H3*Bb\C>]0,6E0\g 2M4]4`ޝ6^)V=XLT%B/ X@ec+1$I*|}nNsM98S+b/-2A5*~,b:=:zԨ6?v-9NȜb8WDڇSl8AN4D~S|qK8J,ytq5z1}k?)6˿S[~a20&x/L&x_\Y?,WOf؏ yb#,2_$2_,66SRd3\o6S5liɛ $3A2ӑOeF˛˔lLdf&3|AfL}V)84d3M^(R^L6۳]#w2P{g}~҇*HSPVkbrF.ցHh6 wPa&t6w .~4:Ԗa2F?,2yʀ}M/zf幎"]r$2})  # 2Mߍjo5٣U, 4Ʈ)i q|`.y@|{롹4cG9LczXV8e0kӽQ2wP^..͞rd-"jGKIN0mI&8RCCɜNd[i3X./<˜y&`1}'ʇS1~ -AdqERXQ6#n` S=+ϯ!{kWb ȢyĘEgqfj3ycg(N-S˂w+ mYSj53Oc>ܮ0PCKPC#}m)ƈ9U6 )dF$U[\vMRES .@'ґ'DЪʙMfێ2! H}vSju->2s}wZP&tZ yZ.wӻ_qBMw :K|zԉf- "8c<QU㨈<47+"ϣ>z3>Jox=?ͻy}ox[%f4*uWnc/7(޷~Ŀ~gPk)}omj]mip#\ؐ̋(^}>*"/GEzup~r#$Wx4"!bU^/z;ċ0EΣ;?ȳ٣gՔًwW{h=鮡R})Sq8x7{kCt}2r ѽ,ך*t]?ۇJ ״V]+~~@(?|~z"?k]˜lV/ףW+g_a,M]9SyMSri/?|0)ʹ}hws7Hk>`-?_k_|{.so3endstream endobj 419 0 obj << /Filter /FlateDecode /Length 3203 >> stream xrGLԓx:|?RqluUHel&Z8{A0Arc n}$k10hl`w-P=zc~p+-d;=7J8e趎~`CuuxCTsx")\V /:Væݏy9%}[GIc]1`^k*prywȫ{eijq+^a{39`fƀ74gV x1s,IZkrZ_sW!! /|f灕p81d孤1p5 {ma:QunsY]eU%$."0 icYVa̒+x13 cr19Rq'H9Vc*c+ cz131I P Q\]n8t$䐑 ]OJ\/(l8ˇ!QLi^)10C8UEW8Erh|rA)aҸGEg@P(OK!1& $XdK(90Ù0OzcQ8sc YL"bHo[⅋S288K j%-Fau⾰m 8I:.Xb\ ?(:gFE@ ݴ}" %ܡuk7HO&`B!@orH`DHU|V^_ΗTAcJU C/UQTtRSLr Ṵ.^}ÔP.ގFQt 1FþՐ/b-б!Sżoȋ ) i)=%I{H 驉1."D1NRm! mٴkl}<"43Q%um$O?[qݯ蝠#_/AފJyŭk=>@5)3*. [n'}m7Fix}ڴ:>.)i{Z?Fc=,%ɻ^:loqVfs[-cS A)ؤ{JL؇LbGJ茖+MޟX6Ҫz  :W[Ig\LG>V0B!'iˠp ֜$`Ns1l%È ln҃9$ACeh bwDlUe")8|JX)D UY\6vfFxZ4>2X * BB:jA88!d IC⒤h43'eKR47G"nň iUևBhr0W@l2c*C}x)'SANWkAͪ}M4QRTOŞwa_VDFΏ| )!iGMni0[˻MW)λKʎM4ILq&7cE1fN3:RT'C_鄪Uеhc*n6lqU>֨U mXjNlKdq1O Bh[mmLڵO kG-*ۺy`` eڕx =y .7ͧ畷Q'^EGF>g Z9utnp$SFUmoG?W,j^gߚPBB{rߓ[ t)`S]r~Bg&E./Sb+@Oq&T㆏A](jxYհRsL=A'ÿFɟendstream endobj 420 0 obj << /Filter /FlateDecode /Length 9839 >> stream x}Keqqw5;{c&B3 IZHάNS")r EBfUwʏ/>㋯ߥ~.>_~xgXk;4?f~6^KRPi#$~ٯej./ߗj{ګ$ϿOK֪gr>˫;~>Ң~~9S\J)7*Ԕڪ/Uϼ{*{P¿zIb 5Fy~JF& NڗV=xMИ)<ǚݥXDy͜,5ET=vy>hgqB}ʻ_QZMKPwJz}UT`#(A*o4pF]b,U%74+i`bQ9u{W $h04^r >*FL7md`Unޫ6ǫr|ti-=xM->lGZsP7waLG6RKņ5kWѺr頂Ś9 VڐXujޖy~IN: RͥBF z]x2nW7Hwiյ5vA"QXA0PggݘJ@& 2W鞥tٴnX+k֪]D(Hݫhb8[s`оzH ;J4`YV N7Z [4 k>Ơaz^:uKB;:v$.\h7&a܆lKI J2jTV ;sT`+FP v:TXTs3j*|ژ;(}p~ ]ΐ|Xy]4N}i+:9՗S;'f\40UTY1kK`ttEFj  N)U!N"*A8ib#MI f)mꄧK=/oY)P1LdtЊκo"h!_7k7H"H]%b0usC!8_>|<%6>jG ,7RYG`ľBC֎, 'XOm’ibla>rnzǺseڔ*. ں$0U'u*3 VWFbNohZ̧ R`ؒƣVt2ez %2e>-989 xkK-Շ֖Z*-9>9w ?9ɂhnCH~L?栙}fgDg~#AL,Q|i$7-KnZ"KnZVvrMukKnZcsh>ǙShD- VN|Iq>3*wZ} :P`uLRY$So~Th/> H М_ze pht,o|d&cGN&*[& sQjI"Ղd˛d ա+'YƲzeu,aYVүekc,57be5V,I`Y>:%pT$heY{f:rU3`YٺYVŘˢEAfYU UUfJť`6hVE'}4Kb4K:ٜ͒:ϒ:x`(*Y}gʍg 1Yq&1%l;LE,d"R<뢻̏xcF㚍19j:"j2g@h3h۶͒d"&pUV5fY٘,2o#C gx2}oUZe*#@ jp/Xy`Yf96tX4 2hVf cbN zg6h`Mieifl;p< !v,:lg8UHy9b#~<8xg@g7UpD;sr(QE gaY\¸B.a y&g+f\gh Z>*5Em ZXBl-}<~#ZDhaqUoDK,{< a=A`$ mEcӢSi`ZR f&S00K0tqbz lAh A&PC'Ϩ uTdD`A}sG5Wg`2"Co=(I7Q#ֳG>7أJ<У”~BwpQأ?7X{Há# vm|< o`_Qa sU9 77AI2(QbтCۂ-;d$0?he}ltc2`,@츑OiN P7އ^݆2#zd$dBʒM5[⒥Nna`m8`BJTY8`|-:?+_wŸi7pW9XuoYS6s fkbQok1d˫ KSkQ 6+lѕCQZ9'`s'*|fLkL[^5-Mhy9)tdXg|2U׸:* ` bev7"Ձ( |BzÉN(H:<%nStʗX N3mN*}w &OKR" sPV:8sSyt/+Z{N"1&l'6O{6! wnN _RZ"NChO;%S}+NZ|XҦU|]pX=C#3@ɘ+%̡nJ#SpYTquIhmLJ֖\Zq5nɡ&ڒCw%/CkK}OH3T0\@'4.}UGrbpQ#[%7-gZ;qhb曖KnZt_rj5EKNuğ&͜+Qۘԗg?&\cVӿ^AGK>K s_`i@O?i/ N@^#EPG+R.5[~#]Q&]aJ,/ҕM29.J>Hݍ=9/Hbp.:q#\8K lmE.9͹Hj&]S-8HFrh&j6$@U.ۛ}䤋. ]ie ]eIW/f]tD8UsE'r安uѭm h.:muut@n.bdg]o.EXκ:Üu%HW>tM&];bd-'H]#{u./97"^75|7bև@6/Fw 9%hⴋ^ko`]`]h˾r֥jκN&iؤkЙjTY q, X 2嬋)NvqXpY@ibY7֥8(.[r5'Vo5z`]tw.A}yښ ]c 5^o588Qd:8ĖDp.:_lw/35xeT)׀qo7EsjH>(%FHr zTO9Zk0S.Jl墷Ș3. 9{rE!`\8OSʥ96|NTb)JI4gS.*qʥNT2=)j92ʥ#NTRMbK%d]*qg Q.FI 70$cn -\u@xB  hvmv"qC qOBAh Va"T}ѽ2A7"gqC M8JrBa AwgCAvbCv"c ;N@ D"'=\D ّ@7(l'a,Ұk F0_9a,i0n~_C; (8a*p B#nNɀ $Pf%0ɷrszh@ ^l6HK7a@6ZO`00o_r3@Zl@9 H~-fC=A(qcf0>WA(1c] A( L;<0A(i'imQU lIN@ 6@(1 Jn~_ Pb,, YĎ !NB- 1%v9$AcCB!W!W\ 84@5B B# G!ׄ (ZB(B(ZBZiwǯJEk(  rb A~C! B"D2KᾲpP{8<ytB_Y_"NZ OduF'܎LMְr,N*S,ADeW0EX~e oǜI%g"?GYt~$ x/zy>,:a%7ẙ{0itG̱GV4Nr[fytkB[83:ˣgdY"̲H$A1H'j)gH'iF>' }j,N=e#tHL:uJtϤTGԥtw#ˤ6I'L~aؙ/)}dO MgKpz"h2,0.e24IWlM2 O> SyawE&]!,Ϥ+;L•jteFoA-3l;#2 IW'lx&$tdqt<:K\۝jO+TΗ9-2%aL.8Q}!%r^|903/KgLI@ZΧDNQf5cJCΔoLix,3gT|QaNn?oGG*UZvJL#>o<fUZ3TiEyS%0W#ON֌Ubl_2.*1 S5=M4S5A7|a˨n7[by) $O7PdpY rC/Gsu7}ONo֏O"}+ ?(G9@nr^}cC}HҾǚwWO8q!DqvI|B%sm! !4떂LG26x@,LFo|w8l9g3yn>a}\-Gx }J{;BZm/|ڳq5t^{y ['?vSໞDuPcmcc6V@̕crzk`k <g m8(>Ng賣V-uB"q9SA׶/ 觷V)Noa;v§<@wRTA"zw:|Rjch!_몁B籇1mۻ+U(-B;P: !q: v{;Pv*/)+=BZ⥣| G!|s; р}Kɫ,BB V@(D8|R%|wnhG!w !ʶ鰅#"L' ųBTN"3h(PukHE$ZɞcAI^be' *+ԆA$E }1z9^k>Q5Z$@&U엷?!aՊ**oxDT/YL ʞC5y;t_,};2p7DB5Lu_ÜH)JL:ڷۡz)VE' oՓo6~B9'SթlCḹKn liQ,1LBIZ@!@%} ޾΅ tRܧn|-K4Xs8>5ABgʪ—k WZn*o y %Xnx'J`BwOR/-ܨ07:oΎ[YmyFve1Vlp\-uf> stream x]O0 }-. ?eB%:t8K结ϲ(MnH`Yhqcy⨼M,2+x9UiB uQ41 > stream xIݶ/|a/)^Rv3T9(,;rR䛇Y嚙֏ $?Ԭ?_)^r>\oȖ$sVYnZ.Շ9[}{5p'ZeU|Wϧ&N8xy4aɸ_Ggl^~uVEۯY֨9jfST+UnHNWG=+bnj"jrG`Z8^;ggn.9ho9i2烈ЯZS""`:bNit\^afNZO=&3dm:ENӯD;cr<@n,9[+eFuLk7>8*Rm;h/N=}&弙^|*]ۢh_6;Lf9u|;W h{Ek2"owg=C|SFנ!јC9bqg_Uf6|ŵ!ZolN~~quJS&}|IhzLMs6ǃs7s!_Οc&ot J\ݜVI 3 J;u˜R6,`k=:^gӬdqڨ8'Gmfj;QC4KWwMZ 9PA%xU%$*A*(gjA#댤 I-|.6&-dn;907n{4ȹiCцo3AgMD^x|^ɦInIuspzQ>D'DK沢I25tkMڶŁ!\ Cf7qVhis֐!=^-r*kz n6nX)5=#ㅴa>CfYX87Eo笕د)x䧍4 C )4DOPk4pA&3 jT\fJh2(z$Hm M`6"Lַ~r= KI;h- &PLטrBk0UPyI8+T%eZid N4bR.KFèK#0]5j1@@IBY}6dD?[#kZc猞!zB{{^ψA?cz m g vm9OG],! q|̒hgmFgmϧgLZUnuنH|c_6d'rQ `o{~vZ%=OX{d**X EL]Ԧ/K=rND9tSV? YG(-I5?\-l5 *T RU"DIEeDPhDP9RUTMp|5;KG} \1ctHxjg-:Qeu8say7t̠[1ÎG{\!,gc]ЭH.cCGc 9mK27k~?fmW;hz,<(g>IuV ֔KhTD4VvET  @@5 R^=#$"u^PUǩP x.a* X T4MOR1VԊyy8G;ķWh-*\@ Wf4PU"Wjb(jDPEY@U)V@U긁Kܷ.N+LnQeһf|39({DScޙK=ٰb '$=q'}A6ٜKclMR (٘5m^!Y{4h\g/]IV0F$Z=&AV j=PMT=QW`b'PR.,:xhAyـe6e 2$YU Bdf!,!6 Bu,[% `%1)8>L3%) . ~KKV(#˃Q@Igzz&1) Yzթ|Q WOzd6e?[' I YOk݄[U"`*A*|T Ufj.kpcJ,n-?lNlLIr"`=h-״JTah_)C $"cfJY+U%= ~.nsָlq;@Y0rқWy)@Rg5 !ts9McWB,+ZB,'>mD7_ihv+M"(oT`;ܷJ?e;Vΰby/gX!V+H~Z%3סsZ%A gtob+!MױL+ ! 9ToƎ 440etYwTy\+R}vss2sEZڜ.]MOYw1Z.i^YT`igz*ڙ&@f9 Y2;RQȫa NgP(Gj&𹃅5DP$$5h=WJ$Ef YPDPoƂJ e(SDPnNZ(}3|OmMh}/R1zwTd̺3%(ȴ[>s%3D!X߳B93dcl.clM{Gui AD*a0Ɛ,<~>3n(g}ws&n &Q}7`Z&Kr*@&cC/U Sȯu # yP.b̖ MNQ ,=#UεJu Z v$%P ]*RPީϫ7I#v.x2K1ѽ+aNeQ]9F.w&uD}ʣ{!^'Ӵ(U2.Ȯj̬+[fЀ@/$jZbd850ܞt=Z>U0c_x+|<#lB%JCzҶ~#f=}?Sx|1"tg*ޕ+O?/isw6 ?d-i#'g/,m^ qsh۠e5ЙlwEު8}Q(E]1ا~%Yw#Yendstream endobj 423 0 obj << /Filter /FlateDecode /Length 2807 >> stream x[o7G*6^2h.pZϸCA,;=!wEW^ɉáУ!GraJ>d#k> xr88s0T:lPzXtR/'G  HpXƬuQ^1+%Wh,a튫XT%{VJg6 p0ghmTXIS6ppUs/YUqs&iI.pZSL5e$ aJd`]JKU\-3a+. ^Ǒ`Ϊ(Qk\cZ%0"բXP0Mm7ڃ0lhJ= |$v#dzA!cp,ui'UmŌ҅biOn</Mp0i F5ǮRcl>֗yfaH2}˫īf1r/G>DFbqe`/GOdUlb`$y$GsB%DEs؊Z? bq ]L/YK~/&upE<"H9iO`[낑ri""y#*6-fߋA ~z\ץa¸vE:&yyŸTDd͒ތPF!J97l .ћA-\Zw|?@Z3QZna~\*c%` ºY k!4NI<7ŻVpJ,GbuK@4 .9  ; -# %\(<#!`kM2@`B9oU6͆cEFdxJnUaJHtWyyB[rGsH.C_ŭ/88x88=v/Ja}Ac$gghyIlj' = b.I3Rb{1{I#;=Pw^t#ǐ6?\|9Sm`:@" #i$.kX@^0iaTBBzM8B>* ذ7WwV%dSsbr; 둒gi<.Ha].ߓ >K+Rhn8Q0r?сɝcOȭC]RᶃS^6˲rz\W'۳`is:q~^^DvmP~wߥwk`w]L aܚ$V'azs6Ea0} ಲ Y}huJo%n'\EԜ{y]w!-0c}7|3-MQ2ËpU"4j”wzNNTllc],zYi7&(k˽Vԫ (zAm۶ 򶼏lMmBu7v͞ Y[yQqVQBHsnP*>'Z%ɟ0/51ypzJ1 xg;mi͈Q aJyy G`zFϦثigsS U!E" Ǹ9=YoH \*66y~VuQ?ODwj:{aOuN:q>ɔVM. ]9N"D%4D4V[3V) }iW!d?~q$<0~:1BTUCx3mQhz;^"/H}av:YiҶ]GznjבӴ)TB'2hTcx0=z]}e9_ɥ{khQQt[&: a@,+IdUeCU -F/Uڪ9^;"|#rҠ1 JW e/{GvN eۮ`楛t*QRvgb׍i϶wT "Q6+Rg&'9}LڻHLً;"w{Kgmy:UiAIUqqȡ qX3,/Vj+E }OQ}>~mS/?[ź&mi_/Lw? տ*=2mPEzW pl{QG|Pse"y"Fdt,YUVCNZgo8$Ӎ_,,l=}j}f}-~F$/ŏ~Uendstream endobj 424 0 obj << /Filter /FlateDecode /Length 2949 >> stream xZKo+Dr.IA| CbXx}%۫D[OupzM6tPYUa!zoqs-=Żg2],~NQHEg\QY?,E^F$s~yq|ob\o2Jh׭߽YDc4޾:g'%gdM1\^/,*"tq 1twK Qub0BhOK-h.6Ẍ́]}lޫSvH{*r5SbHr2BĴ )A1hGIm#q)}0ii>:gB2HINE40!:aI;!k{a݇tƪndIZy< u;tsS{T샚nʋ +C[sTZ^ΘɛL|2#I˔^oet\Y}(]E! 2 нΣ6}.O ) ïKZ%\8 B>Iet][M!/5~L,$tUțBN3N2]*+.u!j#&A}o[M}[G|؅ Gz v& B6vW>r%abpRVYgh>O5ew WqE*ӀaN|]>7i!+ R j|2 JRr(2#Rpdקy*䏅|QUTFA)^v?@Hs_FܷĮZbWPek⊡-y#6tӅx9)oQu:XGi +:KrrlF ZO1K ,116ӲhBZeP0Da9BEsha?*@+EdknnfcfiqSrUHMi)brEEA2QJRnW mjHb 쨔.X.;153 lp:œ6E4ZV_s;cS*HX8C5S6KG0쥧L:@[ P N؜ FDkrXrͺ=J "0*CuY TR`XURPdKNqJLNu| y #))UN(~3? ]Yea@)UT0IE!ʐ:$/$.o[sete y}!ũ&%Ȟ{H d 3'hQ½GH^  .٨){Of6}S˹*My6p_d^<\澘!M+Λ!dK冬.1d@d_却s)sP~uD*rfcw^7:Ui'Ƹ*s/^jN#<5y o-}ʓK9D8ecE'wh ACfΜ\/C"h~7`{,;W?]̳ub]p `4!$68ToT:u>__҇J]Kmz,gmj1o| w=Mf=k~Q֗{ ڡcd}[ '4X˨Y~+ G} C82" wUx*K> Zū0qm;,l#xn6v'؛6uK'|UL6hh*A@ )\l;"<$ut^yYU)l^98q5o98(livԕo[_HYXH޼z,3m>ּc]1b41uX6q!u̖\΂ S~e*c^C8׻qj qX0<ԋ=N6> stream xSM1 "`;NpDHpb #cOҕ@=Ll?;]mR0݀;|VzTDK ˰t5Rvf a`֣+FN`~H/WJB쿇#A*~9} 5{=X8 ~"@4Li#( !"8C:cWaePZnV۵#Da%zSX&o!R(]R :$( bʁ-IьXA˧][2 r/GMe 2G 0uc z.Ֆ8_>%eNʶa$\)QBM=`qvYʳ>]BTT%TJy=LOV]}QIMx]nӍn>3>m~W}[ɒu ޥendstream endobj 426 0 obj << /BitsPerComponent 8 /ColorSpace 263 0 R /Filter /FlateDecode /Height 672 /Subtype /Image /Width 672 /Length 34599 >> stream x \T/ XI4Pђ鴦Ā,a5E%)1$V1:A76ۻ5M`2}rHb2k,k6fɛ w9ۙ`9w`̙33b2z"{79=#e.ړ+#9U4.??ǁSY42A$e?bOMN|-~N2VŒ+<=jVzVE3ڞjRYEy%b(&eUUIII>ONҞGjRܲ0313$4??s83Q~:ٞuM$%%uuu~neU;'դ0C)Cx ffV=j&$gIrX t茵-ЗgTg> #GQ2dSxdb7Q N;'0ch %KJC K3?1A AFvO~o+hO9Ξhr! {¨в gDաL=Q8@:[ެ"PW8ߞ?an+VAYR(:`ikCmmϯ̏Ǒl|~:Ş~Q(ÜjoпCz~ #8.9&i-?-AL%UɐLNYY‚<r='03y%%@+?@Bz~>? G{ڜ85!t=PII"EJ?a.dBH4 ?6|9x>{B L+~N7{nC%@*K {]>;KJچjb~m$쫹񛗣/A_r='d0S|ӗԕ$&~M[R-|XM+9i9rKfFkjj^s??IL8ȞhRI"g]rb򶺑]%u`ų` MDJ4T3slA͂oa]Zl1f ?h=*6V\z[y$ h f%55OhѺ:xF ޛ mP?'?G!?G1)n@~BacO8Fsca.aLٖjX4WX3*9ٴ//מq?g=oڕSu}۠~DYs/&vsM^L/{޿dCYY׶s> 55k6`.X >Y{<~^o=y3n>x] ̬ۖ62r~+@~ !~BVBzb~n@YV;ؚ߉x=CkJe_<{l<.t%l<626 C0?ζ>L2ϱ;cNgM%f=]@D< m_ 򢶑c HV A{{rFa|s{ v=ÿm*1iؒw$mm#}0NXMMȬ1XD |X(#, |sƚmSjOn"NÀ##m~AKI5!~, ٛ~ {Vb~3̻d_< eG7 ]ƂY ?k~!,+=~/mSc@*( 9뀟,5C; @oۀڛӋ  Vg$z9$H/ok{=0l޶F7~޷fCz;ӻ poH69qdsz[76_oFڹ`#@X6V9tTp߹xG̪7_y>Ͼa0;i4}@ˇ6o>Tcc5CSxecEgIՍCx[߈??f/msPMxfhha nj{gs3gCrdL{#o+"3͞>W\0{fl`ҁJP= M/|f5NxDrNvVVxc09 ~0s׌湚K~-n2(3 >| Y}H@< u0QX_켱Fnٰ` 5c0i_0"" AKs?a38xp~&GP?a7v{͂ٳ~^`R$YQCC%=? 8B?kz6;a9!gO߇`) Ĝ1Osz1r6ZY4 =zr?9zGg(vEܼ<0 Okj3`@^`@oY l@lgiKi36/^_a#qn hlnٳeϡ1K !߹xv[1?T¸O@KㄽӝݙbL]M|EdX?q ȳC999EͤҖ%O{np>mg/$t?gϗ7 ko@8A rrzs@;pkQr>ooZ bNS v8tpqz7?eO7mP'] `s g,* (ds?96%DQxTDij`k麏I'lיgOC50q9V[tlvρ[?@wAAG9x?Er WotKƥO:tIgs9ɞD?5 o9KEx:B )@?MiQeۅ=!/"kzT`&x^ο[**ГKş̜9eJ/an;,׎L{Oz,ZL/{B>3$mP>KQZB{FgzbЛSZֻ ')*7U-rؚ4'p 2sHшf)gKK%ǟksd;ew:Þ@xz¤Tƹ?XPA''R$KA~ ܚC;Bmdyyyg6K=oVɓDfM$͢fƸO$aBifO*R8l4p6݊[B*+|"Lσht?#awXET'ݢ$BO#AlOٜ˖'d)+^v#8K'l̝,?'e'491oO3`JO9I@kRR}=5p ?pE-;#P½7`Oz fΫ%UxɝްϜ`O˿3[J6J<%^N (7 ! mSJ#CLOsQSnRb,JzY7͕I<| }Co{Z =Wi"$EQhexz|mk{!8\ /5=)A؞ Խco_vY´Yp x?&zaU>iۦɒΘcG$=זwLH= hL=fF5EhyqϞPAJԌ[2dT1mԈxb.CP^l .oOR{2OAQuPt+;͞:<o'> P12|/l$D=o'\=6:o:e\0Ϸ4UOnk)\dq1)U&s4!Iw_Ol&9ޔk鍹@@kݨ,0==z $Y5x̺N^%1lɒ5zhafp\R)I?a3+z~Ѡ& 8!=9., \uI/4:ž?V:<q s A]( u~n'9[ v\RbOĹj|)?k'|6g))7s*zC30j 擂1d(, ndHgR8fԂfD K==85B;EtPL P x"`)fJk$i 7\-&RQQS5),bNIʞz7HJ^f,Uy$UPÜa|fesޞ&?XIp--"99AL͞ @?|-s0?F  O/NRhr 2$o#hX{UxO? kOc毛Zʊ1 AgOI72sP K6>=нczdq+(ʢ 5%>|q'F`>a3t;%! t:О+" ׶[9)7a~禧czg8sO.wR{M{fI{_,=㤞y4?52uĝgm:Lx֖!?=fjdvsO h"?wszKӌ?1+(TTOc ;Ԟ<>;3R ?sq^  "~fg4Sa}ni\HGOф ),[W+2 Hk{1zg \)SRNQc.qYރR##s2~d?b'?JAcǍ04{hä&XaiSMǛRR?~)ǟ }3Y֕Ω0 3%]ۈtcJAw HsTתԘ"G)Ȝ))Ǎ0|aGv76cǛ>­%|X{J xk4pp2n 0=,'"dS7#OJ؞GzGaiۊK?cu?Tz=U߽n|ޞ D\h_`|ga@U%x&2"Ig{JPg'L"KSExp˻ { LOޔ4'fw¡q\>Ϳ%Z;3dO+2:BlCзC$E;=.뢋$Çw'hO4Ci }?]u4@l$.Ӣ,6 XAy1aR !{~S3=7=%=3/. OϧEy&"B)X~>\py)p CO'+!p'=I?9 ( KޞO~]bO?sB~C'go&"Qz¦纁zע,ȝ 9My!=ģ:.R${#OOo3FƧ7IQn]z)~~p” L# ѧjfWg{=JNQf\i^1 2jG}&F !6VjxZOq7hH:Mp .x쉯{טBgݹW?wWǎ1 iihOH_O]O7'LcͷĊe)6\*)sÞ`)G Ӽ <$zu5χr)g?{r|}^m\Wwë'@>]YѣIH:Qx,L~~ hZ{kX,|h*Iw=gOxW^mL_o'90&[^ Xg?Gt);xP3w߽lQύ0B4S +7gnztXW2f#(dg<S>"{֢qxrr$^˿[zm: ͹L8'jzsSnrRHdONTU73Ӽz7৞OHϩɍ]x='-G*w<1{^V@tBq'jԮEȺ{"tcCn)Lݹ}p5 '3 @K߁sJns0IW>uJ,ĞC[0T=SwpԝۇWp= '>8%{̠A?2dt2xVR9vyr߁~V<-MzYnZﵞ '\?t,&,NHA9jeq;ƞ#ꉆܧIat=Z{+K`9bΠť /'JbGdO|JySpL3F:)SnZ8xO7Oz{Qf!'3BgGb;ݔ?{=еdgW?9 ~:Ξo(wS,y dSwK<88IwpvԬFuvҞ)FiBywry Ks}d)4sNxN8Ş ϕ~-!(uzozso'`|-:n ]77 (RD'>$t?2ΐ 4~9u){72OR;zNγ'^lDlOm_i vL6g x? Znʦ WzPφ'Ğ~X!8#(Gng)Sє맵tKd{7 * ]l$:wk?B<tWvؙ53DksIS)[k "$x?. gx\Ņ-3~:Ϟ nIP=Z@^=h%㝠u0h\™6liZt%oLSS `UnniՓ;~Dv=!s4 wB>= \ ؓ:&ҲP>A *g5k7:;cc!J9x됅1'gO<oAxoB>\2U<;Ɩ:1~zZwF~{fTS?{ َU9xxs  Һqfg;W؞^_݃E|NĞq{,cOp^M_{.]t2 }1݊]=]FϚE߃MY"ޭdOkvFZglvB R==]q!kϓ>J4M(DϪe,b{ :Ȟg}IOW|;´';OidQ1>{0~{C)Ax3n6?FTfC$Kpxw$L3?ܷ0?I$'@4n%s kY ϞޅEJF ^͸!7os=g=!?#v"$pa('iğfR|wl; C8\$ ğ$s~M{{ O]=5Tu#|,8jrܩXC@݇\rp9˞A͹a0) )v9C=Gg=!?:ef^j T Ts 23iz"x|dݿlCMoO 㰧O?9;4霣et\>98u=1#Nݞ3UAӜdeNinϓ;S`)Itо`Lo{tо`Þݜ=X!"YH3Hp""w?:5eppߝgτn=a1Hskcδ߯9Mg{.c_~X96I({F܀l, _n:Oʞ e~xǿAsߧݙs'Mgʞ>e~_PsfB3P.=3 BBn@}V!>I4=Vv3/`K*bh!'~s\_ޞgh3.;S."Hx=e"{&gO"RB3tg eL=="RB3ʈn˄6`+%a@SAAa7V)+طD ɶ u7=5G)1YU7.n{0=~b~?u,R)nюK)U揌I=5SM~&a&ф(#3?|g'ϹnN⧇wݤE AV,UAc./hI%EZe(EP}0h)IKt_߸o[^I\{?m?h˱d$j>?h,{ja%!6i "S-QA%dZ#{cL~(s^x֋:u/ҫčLk%ѭIdž¶`d{u~*sHܡS)Abz}?LC>l*nw=XN'낽FzDAs[' uJ9~r(z+,`c7 #_5,b~,㉒*3y;k{<?9N?tMHTK22Y oR 㤟Ԡނo>?IY6S^ kF[5W~w[fY]:z~K {L~J\7끃VfLJ ΜxJGKòs6a~mŽ|?^~2 u=ѧɧ-X'pD FE׹ vfb &G?n%s~rպO|%fuj+ -{ʩ'O/%uIԠޜ?u,w>7S\SZB~ȄgÞ~ỳmK* %ZYh&+JOY:O. C)aPhJxCn|{8KcϷΪ%_=\T5 bwTJId:MdA(\Ǩ>okO?Kk@*J1B"nj.$'.kM^*{!O/,KIO<&0`?7n) fed|#>/vx_݋{(9򅵖{B~w~72(Sl\>j#ؘ!BD{oJf  4jZ/\]݋ZG ZD맗*ϋ ,47 򔕰X&qj쿝Q+SåNYA)sbˮuFminU+oQz#ɖ1ټ$.0ؒM#6˚GӞ~d"i9s^> 'ݵT?˃:~R3Fd2K,#$e'JoZ,c,߶H/@/f%Դ#"s=;Λc#;rOʻ #E|b0ˮc>B럴>2B˚ۄH8?*s N譭&-)D!=mw633wm_QEOX ɏa#̬J>QnwڻZ)%˩t^0bv\Ϗ(6i (7 +{CQ~qD%+F3i|W_H}9x_% y7Ό=h ɲk]I3WM( D m9.tYtQǻuݱ̷6%w0<w*d Ee@W)eD45`,ZM4◿KiG\ʵP&+M`SBWe?`?ٝ`?5߉F3w.ɥ EbJNM/q֬ڎcaH@5bVVٷ#^mw&{ٸ5Ez{u4ۅhA8?5颽RF[.%LOL/G|]Y̎řWfm:ۤ,"G(Y%IKi1h}kN*rAl(f';e-EqPu\\ʃHZw2xs9ZG]?e ġ`NhC {p)ӎpo/2U/Dwݪ.YeJiSH6bX6Lâ9݄RTHP5a]P9"dD}p!O.n4[o^iubպdy.YѫrdK6ugS5 O++2V{y>׸M=&`tGş`ώͱ+#, ҵyJ(MRd|{gDAz*acqrh"vߚ!wYnH4@KqE!ױF>(?X-J]ax'B&g碍XZ4v&|:=Q$Jњυ("/NX yI~;4W+w,ݧ׻fkY 4ϷKW :}M~$'T(( _ֲ1_6vF[?CGΒcYF|ow]@+(f[2b/3lXd<-.w(l}Al;7TwGԟu?gUն?'K)[QS}6(-ӛ[aT ?Y+~ 'mį|͹5M.''F{#8qy$& RzJN^45U`M8I4^ɳ7q(/2yfC沈gn~aQUMb>yW;EF^cn׼&#$fZsSj^y;B\1!8h7jPAl> ~#^wQYm=z9kQ\,XbR d/7bC vBƴhƟcG#ՙ s8, ޗ,7G۹p7N4Uy$ C%$b1F߅6~e7C;SS'wKOu]̱Wo+|ø [d|N:?֍(nl̮bV&< ޥ4@M r;N&U|Q^u$ŒQ/^3}6OȦӢ/J)E%#OH55^K1EP7R&y(=ɇȏwPW:~͢N_q ? o*\ɦ;?=|Ѓ,M'hmY3OdYHw\ִb *lGq&Ƽl!ܻ27Ah-zݖb;xz;W|[y^ fYQBMfESw eU佱'F{(17-6o tžc];_zk37t期ػ|>dn 29= |bIx-u6>kV3S48iib~piu=8]g /$~Nd*gR1)Mc. ;F*R̹Ll6ѡ>%!&~I_$ {Ǘpý`Wz>Ro湽tk'hwIkӚHD8D"?XS菋~ڥ%!x$qF!Z/[OSӠ'hg2'ꭷP?9{2ߝo nvOj:;2.y7D?. l$ 2VnglϓRc$ukT_x7vd8{7')))fՙGï,d3<oi)mPEIH6ekwgU{y7杶 \']ĔI~-6]0&&]_>|ZqNZM޽[^\(CUzc!S&UaĘֿv!..Ҩ=l\|jgkRž+ TW< ԋrʽs%ZhRm7gv]bNwQoLXc>|vN5O ]_ b6{\]es;/Ȧҗo㼮ά*$BAz5%u,i})NLdnzDV;O}|)L?յ};sskߏ?c]ƁB'nB|I'h~ˠ#\BΖ䬥LTc+u!ݻl_$Q65NElB N r럒Wu+b̼q<]WK).?, `S]#h +8xjVhR Dd&$ߊ=L}ix`"ݫ;<';rޚSಅYd gu:&ԥr^XXY %vyWޚiט܂EVt]ȹpa|/bFr՟oVXw݋n5:Tid#n&eLJ|Ũ u㬟9K;m6QMy]ttln)=_jqY෾ޯ[ pԔt9.'gk׭^ N.ّΉEv5%Җ\OV*`=^ͱ/>ų:KIMZ@,[yz'ަKoc4OӺ芛nnS'uN$Kx|&Nֽ3ܠ'I/>&""h FClH;jS2u|ixIZ=||ҡ o_ԒQq꟔AY_%} ZSgAzNZ ):Œg/ȫ!|DU*WY) <=|H٨I'px/UTdĊBz7Q|ݚ}/ZW{7椥g b?VSyA83H:]oG\C#Cf/kG 'tIA܉YtXǟb.|/9[||mZI/+4 2z"uf-FbI|`nMxa3ߚF5v֘/CحډS.4 ⣟a}]?Xu۰1~ܾKLM9O+9>y%pSh`Qtj3|V25㊹𱬘r9)}J&zZ;g[O[g[̟uao'N//W܄W{?br3k(k"%|l8hK1MuNQϩ?%滐Ӈ5mr*̢u~EF 2{?`ӇG3]ng/ |yZu^ZZҵ8;~$ѕկ4W)gO2KɋLH Ne|ξFQR5'"MlyBL5M L٩`۽'/kݵ<9;o}[SSR ~%{Ma x%s˽kimh9,bH'# J{w$fޘY*?=YvD,޿۹wy91B;!9֯?yl{:(:p3Q2=Bf%j++nJ߬9?8,la4rֈF{*g ̃ܞ&8ioqzVW]#m" X;z?*,,,27}z/Ɏm۾Fj ӊm\0[H┒<0 5-8?Cz3d@s%5N љZ?{2f-GTgjpoĿLD}Ẉ［da-5wKͺ*%ֈ<޹7Eb:שU1 WKqbM3R Iu˓`r]wgyN~ZaсYEbEX;G7~&ҥZb"~ cĤRZIk*yNLi̚d#ҸBˡja(+Ɣ4e<_Ӂ`~躨4 Ms|pBO_ +*+:ƟRi?on2:grr~J"'I$4;_ZĶJ^qT[?cKn%?c̈́5h~VM!MORR2R{+R*RRSSݻgmڴ{wb_iI?pّYr?E{0toEFƒwoڴlÆݯ2 ]QrQћ R= I%#O;Kׂ^V?$˯2q?Ȑ52_a T ~szlV*:"&gZZߟQ=%5b:;7rn(+-~N)ބe|gS&pmZƇO+A7zyVJ2&oT!zRbjD9QR"TJ]5D;mӰWih1½`'HJEoj‹ײ:7mYV{wg{z&3 ~>0 ]رqk͠;<&vuVH%QC+.?(3ldm1a l5.ҧqHv}ZjAZZzۈ}tЅ !;7dt{,)a޷+3UOϳ:?u/;'Ia@H7T@"2N{%$CYx\C-Y]B.=4;:`|k󗴴^}J时վ6=5G?)\]@_Czӊu#dRSfFOr(DQvIoEY~,)-[rdylmew2Qf􁸺VjnW7ʑ?p_Xv#>~܅/y0+uVۙu>SyYYzۙ>3?DL;1W`& yBg˶0iZurx=>Nd)GjXETVlک^:)?PAxji.iOӥCń:6Ƿ.:c ,qY@<_~u7^;f̈́W(^#0IyliR+꒨gH%trDS.I9ss$1gW#~;~eC$?)ǟzнs2xB^>bէtsipz[/%c|gS~;4OuvUu_f].yJli*T,)qz>閷/?.]zKdΡY׬zyM.9'y~;|=}EzGܬKW8&gb#6"%gBL'L9o$G< B ; `Sow֭޻uupB=kf~W{;YXn_~Z>M"rs+_f WaicywSP-1J[VZ͕V4 ϕ⠟|)/Y]H sVtϸ܍Ξݼ܍nϞ}S/47747ZUWe]X=CzfƍC`?y\b +yh032Gˏm6C &H鐔,9;}!zcujsr1ŧMJrB;u>;k7g!}t7yhr~ȑu hʚUR77=Q tquLMGWϷ'Lڞr]g:?=i'7> @)kT4qTNZOosisyօzfs nS"Z yn`Y#/4ܼ'\g0 POx9`/1\}ӳW S#J?ukD*/y dw{lkPNH (.i3謱v|F;k G^X^um9bg YbÊ{μ |uO(7A Sk#?,ʎ.J^#-OZLI Ҕa5 Ԓ>:^\&D@q?ɯ9S\uO7l.ԏx674ŰQ ^ڗr;>xV+FY۶7T4I/?ڛge֭{'!k{WL뜥M, +8q:?zߏ osHjIRZF'5Pbvكn' IKkݓcSOؑw'il;矾k$7\b̩ IC_ѓQֲCif?k;Gޞ1/;KKM |4LLXL!'~lf'`pٗ\)gw/dg&[>׋_߆HiaۢbN[bԿ=~ k.m`G,!wAS@Yǭe"/2b0==5֞,G5"{yazAzpi I{)N$xٗkg\:/#}v"U1?YEm,r!AqV0KtN--"'T_mэq0TH)>aYxxǚ z>Mw|:996unmSҲݧgs׋_?j'S(e>AΝ.Qrِ}oSE6dɞqΞvʾ& B}i(kOӥϷzҜ9s9=viΥ9v\ux),۽K0vsHqKNm4 5o? eֽvX5-'}ަKӠЭufRndbT)'[X Wd)Qd1_cґmT:P=ޅP/_e]˺^޺u--^XwµVSƍuc5 jjjnO+W,WeVp~z õn{ \0?er+~L"ʜ&c9yy--eխqzMD1I .C.N|-ҦtnԺ悂U˳ ,_Uyg͍^| ih}Iq1dgb""&a_X?1|]kqkݢ/ɥ;?MG^.%˕Srnj% >.\ۺGµ[oc0 n\OK#k'RD1Ox?d~fff|`GWge#+z8/3H3Q hq K5u?JF$iQJ7UmJ5y6q'N 2sy?r;^9 D%d^{ =3fOfP?L,uGИ2"CՌXQUd2LvCb9թcUS@Ne cI}V/n#-} >8yd_OZZYC֝?'=`=h9:\pY; # 78x?k3?z$# q{{+"xir1cRL"Wbݾj˜SCDC5L۟FIkw| v)V){z@ݺpg\Yrz"{=C>6>BT4M)YCf5^*'37{BX4I ^ڟFMNj#rJ}O?qrmڵ`~ͺ!%!+7s Qя1%b%?%}dQTUU4y[xQ%?iet7c)2BL`Ld4wFקCNԃ; }p7g߭k:x;)4 fBz,~3V~Z}z_Ek=;u1ETze0!2M[N!SV1?yFy2oyxzjiFrԄOԏ|^lsNﾵk;zE|v1= '%ɸ:>~)3X"ub)J%t1WϞ[KKm]w!ںvd,HgMgn]_܅?Jޜ{Q#S<4ρu:RݿN1fO 4b'dJ(k~ұ3zɸÔ0 A\Ea_W?ck珼Xھڅ[1=K'oC[yzlf'3%4 uGzV{VbMp5~C\n? ̿{9AjK'' 2Tf_[fV:UO|cv2l`*5].@wljw\| r֭Y׮#v[9ڊ} 6ߎfp6K<I'O(v t{>;x&Ƿ>Hw~srD*A|ډ"5vD|'GI^7%T}Zz%wA? HZ@?S \YyM/d+E~<Ҿ"Ǜ VC4et׮b#32=>Vis?3V|GmeO0D)pNDK m 1)rIӬe"_J2J>uju?)7ΖXRx͸vʯu0ϧt qIWϟ7;O/d9 `ݵ/Fzwz0ap1 x1uv ˷%>aֿêک;iſ*_eO0;s2ԓ9ٯ Z J3u3b+ԣnjM"6mJhBҥ']Vccz#ƷN<腬Z /뺢K' bp0ᄉF#я\hXOqӸ+A P<=YW2V%oz⼠.'b](b TNO \M~$ ݒP0 oT%ܓvcLX2 >']㕤w݃YI]m >188x'_}uV+1IO]]ݮx{t_,G$BcXa,Z#X(EwAA٬N7N4כf\qmȐa@6 u 'u qi+\.8}~?w%+&}w}~+Mh]!g~j?MCY2gwv^FO1mx^߷?؍xwbɡ+-^$f?I;'+^}˷}`h72`|'.5󩞪dt! G1<T-`ha,ܹc Vv t.gmm_=_6͙!|:C>?'PBŋQl/G bf_wnS"_|M4v>"cL?u߭Oŭa5e2c-9a 4U0vjcn}Jޓ'+5^Y~Ak:='@;V?y61a'"~VΧ~w:L9ebn:R4Sqc3چG6kZJtt1"qE.Zxx`d3ߐAFP 70;&V?~\dirNO+DM>?It2]QI+&N+@(pB<|6b'SG&*mm$ / 7;'5夰뭾 ڒAJNqHDH\*Q HmK?OwڇG5G/\!3@MuIPBy82]"R tK;&]?nO+@tjWI%jK'≧|f LJēlHMtXc^P>G s1Nv qմ3n6<^Rr1dgO'9{ِn˜u*&j) 3 u@q@ڟҩ3篣#9IOG4/Q4v"-dT\G(IYIyT].V *9Fb+wLM,\;~R]NPўgɹ'3O,vi]7\ ~z,}Ovth<)wF۳&&*zb~ 1Xtѱ `AZV̮FZs3t+F:A'"%xFCT~Rڢ̾{/W?_-Ⱥ5Qꜥ&rұOQHh2@JL]DB=]xgT]ٴcKG<:tcKg0tk$X3c$Hn0treIt  sk-#)i?ё[YiƌbGBsBm+'?p#nS+M" -CF+`ԓ'1y{h[nڽ{7˪9#{CϤ ޷_'O*rϯ#_0ƍ~0}dIb?RԋE̥<ٍEXؘIP@ahǐ~xi'X?ndmËW+zHd=dR N+ o?IUGlٲwk>|0TΗG]p ?3g}Ap%OBϿEsKeޅ=d3|~jVK!Q&M_ $#3~1 -{>䁣55X:[[]FvK)S;995R>AKʟKV'(?YclT灰tJxg}`gI"\vĵBZ 秜"hqfkE[WEgwA흖)iex [h]VjۉI[jYpbߦ̷N|: V')]DR'm,[[Χ {#֝w`EԛT>ODA/տty7X[| w3dĢ}#?nMZ< rK# ,gg(p7;w9/l\j2ϙ[[^Z\*ZƮZH]yO^13q;HHM;;iJ>qa<74%EwRo/Ȣtbwz~ḭr'M+~WCd/Nȶt(쬭 zvpz'H=T': #-ƭ qvW[p!M?g1ZSRp{g杌Zh'VM|OnnEDOt]POK:t*s#-&g؈ޮ}z!GiiPZGKhyA}--#-7S IRt鋥d$ f4|.Tc#+URxn(SY6C'K;7btj'bgG'zU\.JHWZ)=:BD;GHqL@q'W@|/Oߗ&vYG~>A OˮySdE().(R27OwrƐ'q[D\BWmػ=ܱž;| 5z;OEU*cLR!4伍H'*w)VT P;@;8¸G$(.u0Ԋ2Ţ%;F =1C{mtxܼ9bV&k+İdRXOb9u+tU\ʧSb$Yd1;lZ'-ÇI š|T5IkgE;*GG+塢|#=RGu2OV#HB:*Oni$8VG5oؖZm=3γ4:ݭT1v~~8KL~4=/!Q;3y]$>l@;+UNUWظW|r Dl?NzpI䳌'>O@:s IuP?mS]mTox4Cu?i^A;Xz_p?U~p!܊ɞ6"XE]N ) 键CS' qI@s>y(="g61-{8?+^&Yin=ka>&_ ~^{y/nhѲ7yd 2L r}~=GAQ+r?MnR_ngg'NzB"{ \=E**Jk5wӊG'ye8'ɢ>.~Bjr^K̥٠nwgZ6xXsh]G{)(T4S.Fp܉S-$ej&l鑊v:U`nGZ -r۳Ur4zi =؁[\"q'}$ AC@LsQSzn szҹuL?nмhaaCBDxX'I7Nd"JI(4i4ނ;wډ 2=_!VxPsy>'fH? $T?L8#6##zE#h/tU,Z ڱ3&@?yaߙuw%{|;ꔞr; v:bQ\\gGA$%W>|@'=NrL<~|R *ڌPϋj1HX\2<P`U?{o@0K ?~~9\)53Lg3).51Tk.y=n{~ض|>ߝNen'}PMۙiG==XN{IE[&.oņ5O}׮[\⣔v/vaG.'җޑudVVG{Znd4_I$gNɾajQoOLT>cǮz!tK3}k^.BC|-?3IE{B/2GR>{$!~'1ig[(R7W8bdxA(=NV{$o\狾q{&+_?~&3_7>2c[[|.{1~ޣ= ?Kgs@襳u9F {ٺ#㧁3]6$~y kWKz$:{Y:\2_r"fr . %xu 8?Kftrvln~Rz̈)3ØLDo29ϔ_>s~&$s LoϙY?*?]8 f& ɉ48U.37v"'x4`%{˾9ϙ6}F3> stream x[Yo~'AcN>k/v7dj;=\Mv?΀yttk U4*b6!WAu@lMZun=+ $nA[Ҫ[mt!LH;2)rVpqQgC.Cpb렻r W6oi[mŨwaU51e5_TmBRɴ(@>f*a Mhd=1[ ] ʨ_^[Q3zvo ?)3\>8[vh"l71މwB,BFUB}wAO6ؤV`1GU2d糑< 죵YiboUBу.ğԊcQE+d T`tz^Y,: &Fْu~BƒGJ ߘ~!d)pR2YF.oR.3}W'os)!d@>U|DXć(IV (" Hs8{  ('z\1Zwߒ;0JH;/M2qw lH%{dr} `Ի 6j;<{mxF4E-Έn B;(8 GyA-.\jU#w ^X8  lv42q1γ))LMA @Eպr[=sv0ts ?mvQ ku" "X%dʵ@q*LqA\XI,_HdnQ8e &,^wwlv6dĀeT9P'&g܀Ҁ\[9 S}\"Eqh02` :9_K2AHOC[Vvpo78 cсDJ.u=Ҍ^PIFLXцpv e(Y;Q|,VFӶ.-xH{!%K敖l0y-qz-NBO@f}[q4l6dܶpJW:LkI(;만3E;ui'nSR%e"ԫ|M'9w^a8͖pu>cFgf-żf?s0CUby}0^h:S:43 YA %%Hi@̄ 2@PhܮTbTs}?5/¡Q1fVB`0l_E%MsUG$/Ͱ OFp:WtP>3NN&1NkBTrMk1;.:CEtгsmbKji{]$̽qH互J.LRF5 }]hSŻM%IO7lX$G& Nir}SU;$A2o :fU[=~kF{NOg֛uһB=daCa w֡۾ǝg2qd׽ 7۩?XLKKo*Se%7!9d!Y%{ȇJ$ix,X瑖X +v/ceJ?J {=u5umXm=a~%!9BL OXE.j.*ujcqM%0c3{%?AJ퇚jKOEԸ#vI$G4k.`.Te#[ɪcI/Mri'i=I+)clV̪|^Q`$^&5ox lF )/r:w܊ yJJ:E#k PWc%ܠr_SI]Iz;PsAA2F'E=˗,IϊYq,_?ޡuj?mKm6Y+j^_}E\H_yGʰ|cr/ɰv+&xiUo wq#XK} `ڟX;nS@&+aomWbEqǗo`-Bb ;6 #+>F,7\uweLVŒS|ٗ:q{3qWDL)R +7]M;?\L|Z}uoJ OߠI(Jg6OV!j򭷐BM=!a+p/Mk 랛!m9f6rJuy`Pdmpz_>s[<^a!o|S?>Fnmƕe}OH_CHΟ4uiE)*e1xMV!7ǼAE2a%gR>fhldYf ҵ0]e GdIBW$. ktp9$o,Փs+(K,S Bs(Nl JceJ}6/PK~M b{Ek*J(C!Gyendstream endobj 428 0 obj << /Filter /FlateDecode /Length 6963 >> stream x][s7v~W\_`%3)qҸNR]֩쪒FE)8)ٖ} M4rPg xݓɻ'zxsg"xsHKRg^>OYTgC2ٛ';k%AYgO^U:{.j~A/WϗIYu]ÒѧjYweLqwګmeq~-X\^bn9K);]pZ "tZݽooD1w_C6MNŐbܽߗ%ގ؅>Dv1[`qZ[B@v[19o;`<4nuX_868A}EVwL\ӻ{${4MtNN NT}n=΍;DGsPIF$LaR4m̒iJ, M"I. ]-~`G74 ! &8qP+&g\FˇIEgLZŦfm{QWR8)2dilf7<#(B[: 1]9"mIPhpS98qVF%%e K^!= 7Oww$FޒO 5j\zs OEs $Dp{YH(wM6]DQzL` ϑ=FjRbd1LQ6&b.ߓK7ЍY }5Eoė0'LJ;jB7-7oJ= {SM{n"xa R .zE&3F@r>b /JrT~k`'C_H8Rφ~ }ʎgd)T ݍdɗ:>N<lpCNqޛ }5rFܿ @aM!s}aV=n3DIPv Xl؀EɏqȁԖW"'J WCE#FحL[o;QP0 4Mu5RE&49'K4{֎]x ks2\#B(_l: `}YqPpb)I{[7bbf>!֝$22L)pU"|e sӎMn6; Wj .It vӻwt|EPkx@N>.>zh.zT$BzO!V)J|`l/1O~-BNbDH|LC:u=?V*cMl$N*\]r'+ | F5S !5>x E]J~ro)Aƹ%f-.U`HaB_Ä%ACtI*)2(bx)k؇-ױݳ"J`a=zKY/Z!c\.$bF-TN &#cA{hBn]P›֏Qz &|]ڢ}'Lݨ'zk-OC-w|]q˜H[3ɏx=Ihodž>nOW$+n(j|{52ooG+;x-kRH`{Vv?GY.Ekwb>49s z Dcq$ڞ׷>~W C$SmpWm߀"3Ox>ǻuN'~bbxS/6r88,HYrhtZmmvǻi=v8<Km|OK^GAUð_㷲a뷧k]>~;|8<OĺC0Kiら_ x]u.u.@⋇-QP_ p_rn8X)&ʩE: $>dw1V p".u)&" ƥ?<N"\w/*Jr{aN(i)1#1*$``W a9I覭]R뗷bPP8>rRO]pP&l26ŧPT?f*Yz1͹SNhdoS rIy LhSrX"Af՘MkNh})*+?KHˢJ%m8 Cǡ)"z2ЕUӵ>n& `^`W9'i8EVrw)2qK4{hx'60Xߎþ5Qh-xM'e 8ȷyN8ILFL*:iZؗ%YzKu oF_rb;;pmAM<"v1v!H9DÇQCuΘBlcډRfބebQ-A=%G&_ۃk\7]¬)O9#E0KYM'}G>l/ AgYzU̕`LO[gޭS2AYVHkB dTHp[`@&49_o՚vM}D1LU)rjEQ(jP:48ҿo_`gpEY ,YмAu7upHvG9F@'\e^~K}vqdi-`fg~6hm&/$RCAWVa /)BQ}$pa|btI(IGd3HZIrhp5)"7)(9VR8JYNy [|GҤmIt/5IVæt胶4 ڴőwW 'VHdYFYaL>KeV 2pH9iQa+|B\8e:d,nEqt (UޡHϼxC6yg"T55$b9e H>Y(uq|^_>]1y&-N%scq m+\-e!s&ApW匔ej5Y֥䟒Odo7["DZ)T#Ahi#q@_$XǞj4VV4q1[pBU>z7D}qavDHm3o>Z;7Kר6s3yJ4 ,<Vݲ%-'8VVXn9nBM83N>n7_mU.\"Gd|v{TSkƑyM]"AWBn™Ml[ TGg2ai{P oL:[H3l~>P,oַx[ǻayq"& `eʴMj{$N{&$!_+Jm`Kh+b-T#@L,"SMJ5 JxT]G@pĤ縺6B |}&(er2E+踖Ԙ7ڵC=1}vΐVeyr֐#وۦ+N+wXҚgP. oxQ}$]Wd ?xqpÃ:sp)oKo\K\irNY(LQ3h*w,W^殗~JqȔmo=d~|XZ0kvP7'q_Z9ewkyƔh'ĵg:'6U*` LJ+2]; q┷|ǡ .60L̇rih{J|><]4DDвߤ68vbu.UY':ԣGNRelre~YzeeU$gpk*ZV] vlN(A\%UEnZ0IB!!2 (doSE._N3xBsXxX52apDqWXO2cb3N2,٭QR6ԅ !Uqq|7b+^RpH> էDF"bqΛm 5.D/C=/V_jɢ໲qb I\GމN\SsuChꮽyzx.CJmi2^)?M+^0 {4-}m?;J.D]Bzs1 :;zEJgkPgyK(p⛭gΙ{3=\K19AMz$HY juXܣqt' H;ngE ~rA0]3uv]WϞendstream endobj 429 0 obj << /Filter /FlateDecode /Length 4142 >> stream xn$]0 =a$7p|ć<Ы{#i)k%ȿdFw%]dQo {Ͼwfqcӽ7{y6rťt|3wv}uI@5eoSB ;-Q)*mIOdtJN(_@^RK :rp)U;c2O Ѥ“S5 a5Нsiv\*9" Z܅儓U!|خs'Ę3j=`1I sKẬ~jL4ssDס +ΏpĪJ,3ȔRƐR0ngː+"Xnǚ }0b =/5oM1AUXȎ71jDJƽYYQ RG0+JsK\ff\$|+k:sG .N> RC&H(gW3'Fa":HrJT}`s ӸzJ$ pR1ko8pyӔۦ~@A(20aS[ ^WOBg2n;릀o)գ|t{!/Y*XV#EYboĚ"F æIyޫ .'!q2/ xBa_iYmUQ!MZxȺ$7Q;v7N:uzL_PqisOα,"fer(*u|X>{KmRqKE<{V ?6#j\){2Ӓ;Sv!|D x۽ @6w/i t9*P@Ruj8 'k.X53;A.v }gqLU}'d uSʗ˕ fB3GNim&y֜+J9l 7Ro{m v*UKHUH$iWlP|PUEu{"%A*y&ۦ.mv7޴E _P֔߫fn{٭ w]0W=([*˹2i bSd((7ܴ. B<ΦaGv]Vpw.k[8zoSC{+awp HY;ҁ<#ft5,ڽӛ Fr2k)r-5$\ q7pd|`%)ljVVCjwiLZx}ZPmן<{P5I+2v [YU]V&-}nd Pg}-Լ!QՋwuu wek5޺ZVی)D.&&)y69:>~2_ oÅwmZ:5cS-D-0l!85=,rnӣ@O|!ѭ2E{t* D_t"6GqSɸQn 랞 (]?Wט JAP+pS7rNpPć^\!ki7UzDs}^_hFRH+UG#4/= ɶ+"[wlLHra2҉ C|C;s=y'YZeM13Cm5wȤ.VPУR pNʆFɐӾqLmoHs-3}4TP)\xSFBI$R;-g>ϙG6o>ꮡplDCXG^o,Jy @.!&ejW1D> 0YC#=T:aWJVa. WR'JCp[OH#D>yX3Ws=\eE"_\Ӑ.]HZ7#|YW ~uhuu7wzG& L`Yhlc?=(FF<=Skc81mmc==y(klZFcp }ji| }1P7B)L8/> stream xZYo$ ~#Kݮ0dyH|ĶPbcV#i7f:b@{XG7Y3dg@J*E>L r&O}ry7o݁_'?(oL0Xig!j;;<82ɣ[\QQv^ >hiTzTH}Nݷy)W~R Ҫ[mty!LRXL"ͬ`q%"iX7]uH"H+C<6b{8&nFjG&q:By0TmByiQ @~*&TPnMhd=OFY ] ʨ>j <茜37JYKYdXOY[$$+$!}[$o؉wK$'NRF0*kpk^:fCQ8{BoYBB׬`LR&{8tI8pZ'څ.y0NFgu6΍;"TF7Xf'RQ"̳A+T[Ul& {F*EVi>&M`!/)Ѳ⣉躮Vt0IE/uhFD{QG'e. )FUNCԞyi|qU) X5qʗH;Nf<`a?fN4]RJv @'\;a0R5~l,x\RE9-A (bd+AP%k:cb0-$8h(+&eC=gI6ˑ7Լ<2dg$O}R&c󃣏kbӆ$L&"=*E)aGjG$/p׬nqh{$_ DLb'9?}=i&_d $O|K,gY5U~"I!yllY.Y_؋\Ks\_OKOPhkQ?tŹݓ8JPld"By`FC';$D3$X {q,Kb8u;؎؛G")&$1& %rө2w?BR"IEZn kCWVXUSo+$w[0GV<(yiɛFo/2;rwqQe2_skA4^\xyCJC~ۢIlTSW.OU) ;r`SLJ72/ˇNP<ܷ+#-GPPɛy$侇jЂ;=k-jUm5$fb~wNMg AJ#'`ԢZAX f[R, *DѪG)C]߄8@EM؄\1H'*|}`7 p%ȹ#"r#p~GLbaG0+i_!8D &Xr[< 8h&"IFKX'oN!!+a5K$'XV+al?w tIaknAH$nC<45&`-ü`7j} /]6#,Y8o i&-YGḚ E9'6Sq=.XBh5uB 0Y% C:rO>JY{S-$=b^B:%lr}H/,8ز<}}f"S:H76[S=p.R YZj[)<xQY?3!'dPγ ?"u 1wHhr_KswsYJ@@ntrxz)[}Ez{Z\$cIf~d9/Q0 ƯlX%4K.(ݰJ;*Al~rs'6gME*X%ks`ޣĂ8r%KZ7>C\9Qkj;bUG/XC߳ʋ+~5Ix-ŗڝKEo'.HI4*G { FkXSo1^")v9c?w]1;XFzmJӪ*Kf6Cd,NN> 7߲īOcLdY=ף+ @ɓ'Կ\oo_z7M9\kiyYex^?}Orqvz.w߼OuROoc>Vv?zk{9J~t][/^vW%~]cԊ\[?ك=x|{{'s_}/EzLW֚zrZwm weͽo?Kn?^oQV)iշZ;rK^'WRA}Пh=*vIW<y]}kOddW۟W-ں?y!n.c[1ֺVe^g}bKL_j_G}ٯ1Gv2[e6}go~ϿG8y>YFL{RRno+ȋ&7yOI^Ͽ)=x魔6_޵ݤe򽶈7iAp~LiZۼE_/y~v.?ksבb{:o{wOX{de-k]3WjO+-[} ,DZ ,]ڤE&u²k<_~$'Df0O諵ʯN,-c%@BmN!-B-Kmņ$-KDe2{ fJ@J*#*c0JƮUDm åV y< Z/+ޙqOgl"|pG4:}bfԺ䁯H||rBkyL{yS:[CX'15lԒR]a. blv_."\u7Hq7: .[dܭxWw{xoD'>o ^0 SC.Ga͙axpIh Z) -VIjCqA"dY"1:|JG&-ۓ:H/ ?/$ XGFUmQZ4Kh̰$B$S[4Z4 wK¶&1/HS=q:,Rt#bLB[t#` 3 *2 q$x;m-TOdj1'r,^iPYĨWL->7։HE l*iy$cX$b 3ۈo܆OLĚt*bĖ %-Cn*>l1i$\oܩ-uWAo R@Ӷ9x\`+o>ܻ9?obU}gWcbgLNL1 CdД0Ǟ.(d9x^ey)y d(U͡T^#|M|ۇ `3^bZƔyB|]9[Xdsf0}/:TʃF@ڔk#1[ׁm-֐i98R%(_xZԀoH^b% rfJÑ'IHql,Hh-z(ii'rHi$^imitDLo~}[Ci_:rdt~ց3 Sl&xV4,&?[FiY۾S!J2F3oxzN$eBfe -GvLyFQ$iM#HK?ZYJJwNX^&b3֖RX?o1ȉj ˨Ր^a&2.2;]lrwfH”o1+_sdt3rd Ed>Zc@=? 0D: CVKȸ=F dv]T)#مc@܇"مEj _,}*‡F VvvP.C8xDV a~IĔv@u fך. /6Sz$B2wO}n5]b3 z?B$@~d{rU4%fS!ЕQduȟ`-"w-Ѓ!uArl nC[BMʃ,dyCbk_/bKfŎBdV&&&f" {@XZ W!C³nrCaa)_M_4f$3ԀPuBkX Z3Zd3' dE襡/zw$_vW38 >)ktetw&w6w"y%H @N$%- Kd2TzP:SF W '*xqj;NÉ'ijt8. "LG _5/}BYJ/5p1CRK5ibȖ Q)+:TPtu0l %ޙhJUh5h )6IK.wIPε)JIðǞh˜-J-I%Ӭj`(*ICq(l_;7tƝzA  "@ WHPΘ܇Ib &z?>؈ Q`&6f\CA1'>x&!SC܃78|{ 6P?LQ!.Ref -hx StlV`FPtCa D8Kip69be$y a M ,kM &:yPڶ$WMVZ&ۖ0>[ "4\>}ۖ-֐44Mg!m{,c*MYg3Ҹ`0t6] 8IKu?0݆h( |.k>Cvb> )T`7A"(|>x|CUN4TN1$ 1H$85bn!g9F^v-QؒgOan_A" ,-\>p$BH͐X+" wE.$6nң >0֌0ě:2rsP!j J5!Tbh!C Sri$!CE QJK,-0Ѐ0R )Ѕ!2 !*4_(U B/D10 f!C[ -4_Ht5BB0~]1 b(~PO>+J}Iß!#tܼM΀< z)3 ICǕ%ǡj)YSe u\*t\9t\<=t\nVn+Vm Ym trc9_S0xk5_2"nKUBmdŶ) n)4Cy~ڸ}D&vYEvWuA ѶCٙr:9۴|,$8;3 Bf~_.~ cp5v#jrw_C2p9[G(c}7i]T" |3쾊; X7k їMҩ)|ծRkEYkaIEjIMi] R^E\EJ*H4?.{4ZЪך1V])nR Z-S MVeQ2-c7(low-^wQzq/[SWc_y6xau4,~_.}) ՊLdiec^WwYzO_hhTU-o5U UZ) e@VRg~rVkj[ Z [W[@ ٯz׌>;QEӨ"""gT{FHMAF͘5x4ưƴ0i~UבiTiʵnۖKkjLjLyEϢjL %&67C0KL9J8AXR5,C Ut8AJ`f@zё* JD>PrC$R!kGNj:ԢXvj:t(i(Lb:B:H&:ŃTB "Un\ 8uTq1P$j2^BuIWfw6CIEW](Jג"R@oJפz׭R}#寨@"c5*c$(@c\(zTe0J'PA (0F"$(@ˌ NjQ:nhdN_t6*%qҨFzpN Gr9j'T 6+%иR$ZyTJG{TJG}JTOԇgS;SRJ,"EoQst6 .f ,:m9ַSU@`]{mT/K9&y9ub[`6Idds8P<7dWW{Auz0épm)z 6Uaw9{S|I `%9ȧkTRmKk='L ÌO@ݵLGXmuV^{ԕ â ٦zNF`ԱJFem{d ~pT 3ԥ=~K~=t}^?|hKf;]T1&0|RLP/Z\5*m)Y>d"G& +,H~& 8-Pe@قz`-LKYO @j3[SCly$4Jjo[HOSeCPg@قܦR}lj>y*+uSBd u4_L-Hw?-R%/DP!N6v"x"[k^=lAZۣdr G*f ^9 *`lWs:yͅ!TQ_BB=7߹*uR*,)a;JP5S=)YJ,Nanb:dj\jn;Ѱ8<_gTx<{S:eZ4(o6ق%+εy*v JB*2[ /*/t>:e~ J,Xcg u XyB1c0XI0M 4XpXWa@wU%qi9%m_oǪ?bDvXsptXLjt ?".%/3]Xr<D\ w .i!Lz.ߙ. ֥ua3]@L ΰ*{Ū5.ڤR8ccL@Ҳ;7cґa.vcb-!t-8Xit.՗Xt!"]c qNJC Nq޾U Nh#_eZ< ؑ/|/'|4$ h#E$Rsq40{Ss0vusX́DFʷT?una-}'џ27V{U&PhۈU[Q;ۊ!k/P%~k^u A9о(MA.S>l t5Gôf敖rnzpU6=|]N|c5]oc$ߛ@v-/[+ obKqrs2{~WquVSu`(c]xBWe,RX.4o$^C1Ʈq_VR×|>{I%bD" l_o1yhl}  c2v&6Je9 r%;Bȕnl*+fwItVeMr%ZE/͛$=%n!$NB]|s$NBճgv$NBLmw=%q%) UVQiU3Gr?Nҍ.w 6xXH#dX 7D0*솽y$K{Н\كW0yC|pG_?5saҳZ](9d(PR|2^uv_Yʃ2~HZ{(Sd: S\ 8m(Ab| 9L]Z-M(!Ѳ(!d.t!D1KtV% B{,u>$8O"Kl.%8O"WGR<;LFwC;,y+דf mwiFHi\{VݏEX]?{z/FXZہMrdZE:erHي3B] ރvv%܁Ğ;F&w=ZWuxD)Q8-HzԎ m+l=Iv6%s >Sr]:&()_<[KKn<[;Z< {Hxɷl52MiCfnZfG=(c΁7k^3y$Ë$׽0#Uh,}>8NDUIx/>'}M#@S,#Ud\9v[V+ۆYwcψhNTyb}iF)#J .J)#J)c)D(Ad`@`G`#0VI><sȏng~L}E#HgǩuC"j  0dջ}@ yTYL06vjŪ2H]_E!CTߋօXi.:rF"L3>#x]is8i w(ehi5\# `ר>8eUitK24et!x/c1|b1yB|g״,sK2ɿ_i2/My?}sLXAslnl 7}&u[;`Wr qDװbK}hT> qͳ_9I7z6‹q(ɆZ"S}nOs7뒿fx-CQp ɴ(龲/^F΁NWqRUJ5_-c$!_E_3:˹F .LℜPi3r3#̈/-HM@øZLHc?$wROmdjpU0Nj~=zno__UyY7*8VLBh9GBVo] )٤N)Ě/ǒW< 7f|D;>ǘhͅ'5ä9Oc;L_~T_M*yL|t9+隖[\~ݒzYSZb"׈7=gʹ$0>GF ˞s%Fc@=ߓr`M"?u>SS,|_EZ\7;-+vstVIH,J~PG;kB9f$zeٹzv[gm;+8h; mٱx9bLW;~V8g G~弧s/ZX?{N_,͸'bOQfT?Gg?`"SCŸG\sn4P^%_z96M!ہug[=5]օ]*rvm3} NX*E躖KkލЕ ]%M_1t~> ޒOw n/w=Olg;Lqp)!CtGO5jm!uws)-t;mϧnOKᚿtZvzS bW*1)ODp ;ɣp8<.u17{*џ9.atĎ~ yĩ Z$-6xǍ}D72l?@kfRf"4wŵ{Fx#SD D1DUDyDDAe0ZEVB#sezIhHt( ^^%*H<IvlLRgܻ6c棇ڱC]4s󔥠I ~I Y 9 ^/r~6Qk*M5q74_Qtuc(`Y}hzn4_(-T귗\Ԡ8SdL _?ay>G9Ba W || Ў'z92Q":<]:y#" {x\i>cs'洔h2njxH2?v>v #jWQ'>_A&2fK#`PCj>ӽKoavbF?烓5Shqg 떏u"c֖ 3ȗ˸of<;1ޏ{X:l:M|C|Ӣ\o^ d zp sCbnȄ9dœc'ư9D5=t|z '>O4҆=A$(A=Abz>ǼCTr^vn_Z_RGtҦ rH]4ݶxCozI+3okNn Ha瓗/y(Cx_DxE]RI׌llv$s>R6]-$lK9ƒ5&2rPM'o ۽m wCT=[EL뢆33n fF&*FioC|15%`u\%s5~.Dx:&]@@>Vy`jD8P<1%FsK'^oܒ7b+~'x#H˪CH$s$WuIw#әޝasbzzsݿ睘ғ\ 9!H2]?Bv+=;= A84]zsLk78#ȸt3d'?)بmdVVdd7¶-軰3gդ^>+I l[lER}I wY4I|@a#2Duqd1zǸcb~(8$Oe7aHa+dS'DDi`XM,ퟡ8!>y=O2m8_u]Ɍ-TZQ%:O"Xvqnj6IH.5BKp#UF#%ơZ~@~"sRu"3 P1t ߥeJǘHBcoql|H%#y&mrZ&rC={O^02{`8  ퟾ ơgU?* ɕAgՖ!u8 `8:8bg;cT:8pQ-% nHCK@ kOV-~p6&‰4tҗBRlg(Ӕ h JO/YCgY h}5=&xAaLMq"JPW6%XH3s*] 7_L㎘J8h`,D_j%Sc\z ~]]`v:2@'rx."NH_"zXai)8R oR 3~P -8 <`FA{DE` F G{ %:`a.g=XߵŖi ƎQ4-oSz^_!R]i-W##cκ/ZUUv]Ҳ&rYuer֡0ݦ|=Jnߞ:X$rW>z)Svwyb՞pl+_/䊆Qb!n|TՇC C3Qb76ETf`/:86/:ǣڬñ#|O}hc1` a^T1)~ڝ&#-bK-bcE[U ˥xND<~xceK0^)#j<=cD8jyH%i.M=o<vD SFPqʊCk91 @'G,Swጦ|?FSX0r#)!r܁G)!rk)"):=gSt,8p'4ӎ=V?!{s 5+/7կƩ x9~iN})3i8"!Z"R$;HOOqmY+@{A/= Y!: = nF@1L[wYyu5; 9W$XhVnI 'cW>]: 寘t0 S_^SgpsRaBhzK7IL~q-|TsBzB{> }ZPp}DÑ1S31wb"fՏ?) Zݘf  f @y_n>(eWbk.xbL i: |FY2xjي_aFa񆰞,,z +`~8^n10f24c{*V12)_z{ݫo[?Q2(z@/MT`/u4/@F'C<]^jPzrui0וphJΌs~쳲AIg| USxx;[8Bt<=y;R jll.Nd>)<-* /MvӾn%)"I(HZ Hm<X=NaiG^N'gh&MʧDz q hkty>%g7r~SX##_q K³1x Z%_Jy SXpU>W^NaU> stream x]o]ҽƷF] E؅ۤHpIkI$wýY$-R~`=3<(zy(Ow/;<ód#hAZ*<m.:Gd)do5Go/jTC:^([Lvamvd ?#=))=#{`Lo/T 1߽msD0B`w -h,؞ Ը̆0 ۜvJ <,toK}Xj'= ~w7r$Bmu$TZxu wm~ ?|KJWNra?B:a@}0B o cU,Y) 6QΈtN WR^T2jЗڛ^[uԶΥU(1{^" q#Yf쾮_We߰_*س3vMO"h7eWMZ vI_TPVE]b[WD݄d:. *ix[es[ ;*׬.o*n=N*&+oX ?b)+',nQްS|Mүܲ>/J*'RL W,.2:⁅8y߱yj)o.y_XAE֔?g5~ংqcٲ ]}QJư|ga5=w +q&qF@nX\!FEB&:y|}Ȕ1bۊI||C)p-KgT\%[\niz !U#EDt* S6b^KnJ %Vsb6bi11Dsb#55 ]Ď*R_QAREU ~V~6C*/b;h"vFEx+_ 7тSksk!= npRE:ڿg>:GN-X6Ț=\ h^Uu޲B3!Mj CbRE$K|81 w$Kj%{]{oհ?rp_ vO5dV99&|qBv3P:ɷ,1)Kz߲x?V\ұ, s֗5rĽj,, l*^i?Zj[0WdJ4}BA~\(yk:n5 mYMPz%zuzJ1&[iY;E#K58dϧ-&nMK&dBPKW^Fҵ"kx5Wlʧ}PD.GZnMg,T)c`s? -xe,c:y\Ta1ucy|_P%%+57RrV8YrHKJҐ{7= o|6BBdp qNjKX'@(N~;.?*/F9X^X(-X/zi.{4/S'6IJMJ ]xU6?ܓNU-8B j'&Lc7 RhlȕعeX}]eRԲ{ƃt\@xHK𬵊$z+M+J*G?䃺׽q]"P?&/hMyv7%mlS 3~|Y:։#UE`/M"ۥ!YwP9fؖ4EOUU#xvFْN>=J[e 'ex?Ƀw|&1L/'5R~Z CSTv &dOZ&+$" ꎟm6r8ݺn.0B؈~W.\]9)^#m Ld7):&w bbo2JIhJ{|o>a%YʃqaM~M)8tߴ9&((Zy!^=NJ7{3򸡱"P"K:WitrK#up mǂgE *g3(ޖ`N0{4Ti\l^sC~OU"i]U<; "X:!AܓGUB ԌL?09KL޲_<廬'xW#6,n*fɒ}? =ٹ}cbL~nΆٱ5:^:7"D ﵟs4b5Wsu% W02ڌźcLtZڕNy7}X駣rwvgj\}_e*(ȼyTo+H޷ZDS6yE 9c&?x%G{)4oCPo &g]އsD{;7ن=AN!+y'UGL8v$1&nLrIR$ǜ$< ? 9l@k#ثE)&toI߻0fQvsmx_IerD7}hULٞd!"(dUnB<>4s7 C&72*| 9̨y I/Rڛih3FW捆 w1|#]U[cj(Ox[)_: Uwp~6jrcC II?8ZRc]g1a/Ć(54i "%T H>B$z=^8 %6/׊vo6aBm%yO)$* H| ҒV;m]A~XÂ\hlEuⰺwx EqP;DR"[Rz֐zѾ}2}~t7o΍Pendstream endobj 433 0 obj << /Filter /FlateDecode /Length 1553 >> stream xXK5ϯc`U~7)p Ɉew ;Y+&(U]roߋG% O_trG0\`W@NpiޥRqcvq8wߏ_!\x~eP J̻EPʾBsǧh|\7@FpL^S0_aKb*^JeTd$(JP3\BA4jt.<~ ;JTs rQM1T8Gz ( q^Mh)}a؛-{յEB0x]XUh{S ^=GĨDp%w_v-uB 'W@14)Bdx#Ei#SѪ`8Bʊ\'H bC㪸 [9A.D>:feߡt1&NЂY #ApcSϚ]=kF:V@9~_3ҳ8#]gH:cYuTrL 8$HVq$,)ǂCn-m1[M%RĜ4!k.<uzQ+i6$#M$:lH BH!嬮pG iԹ/F̢ufa# ">3rĈL[YrH谸Go/DkVe4/+gFMj)iIϥ|ROhM+&ezq,Kw77w}W^~wu{{>o. 4G.RI=;^- `IZ"Vk{G e}pɞ ,SQI iL-9 Q -Q˜=tEorZyqFGۉ )rݟ2cc?\0k*cEu6>6O&`fs0_tۼcUp(w[~~;l&v^jW '#'){W^(xB,p'ɕendstream endobj 434 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1255 >> stream xkLSgϡe;Jj ^9˦nሊ(9PEtW^Kyz^PERPm[>}q&2g&o%>_$INސ/dx^LxpnD'69q< ΋UB3Jf,׷fj:\ +V/eWjNY(հRN!SKb%BӳWf򪪪"E]Rr 6GV!Uʊ,cI2 jʛGV]vlmL!ҖU(ITI!2MD1ML - Tpk|)N SDgo8oL9C{5hcXeA$} ^j\Ƣr,2/$%y@EIļ6L bsϫM 6 cl G XZ3h_4CJ#z|[}jݶ z[SWK%` X|9znNn3kgbl+#@ 98ᐖQ~(,Ъ?r4O&w ryEm R܂ә7ߏg*7{><%Mo;xsأ+@@_٠j60;!±Ojns~smHAdn= Ы :>jj&:㓅`Js+(>> F{4_VW6&>BLF&l >DGVmlTw=47=yٖޔ-KjIMV77N6@'_^k֗ 6n|o$CET7.K~ mVp,:rlnIMSy7T\t]'xNǣQ(D>xe^s-4Ask%I_C'Yzw'OӅzhZC$ Mendstream endobj 435 0 obj << /Filter /FlateDecode /Length 4083 >> stream x\Ks9Vi'x?!ĩf*;\O74fgV$.ACG_70|{$zy$_j;:[ۅL=\zH"ʣ+ [Gm?t]EӭoQE.+.UzTw FzCw\i'}Z.WB*DcuNiխOn$BzHae0 Y;2F :(\a1׭層R9XaW02t1:뻟Rta1Viv|a][C o=qhQ :"c@"TpMhd^{wI2t1(s}\ڂo.VȣTb ֯p)X*^hة,WF>:R[:ZAuk&su37mIgef(&fg#sDrn\($A5/q?kv:$ 9$ijk[@O;U A %̆V6W͂&Yw4ufN3A~fUɓuRi e  )reQX|?D2fvrW i`m$jgu`3](p 9^W38O]}sP;/&Wq7zfAS6&Ѡ VOWhCv,i@6]sChџ Fk_Z7ՔC|5gog5"gpG|;r4'ej[E}]IJ? >n$`'}3ZǣOhXqbp0_n3=% ͷ1wp `mF$V!4_a 1$G./=A3/96e$aKG픙u,Be!ȨzRnz7dACHѦhFn8RH !Z&v#q9L[1FܒT0¢T|Gr\ٵΰF6 1\yۺs]O(3-a"FTUԷZ #zo$ iW1N%V+mhrux];YGH)MBYPh?XNŷ Q$ZH-xwlZXc:ՀQ0ŀ udrT x wH@#%=\O<*(!<`rp+du0 S}NsڨU)܀ <J$!JM/DT줕ߚvJu8񖇑s8{?k]ilhg-I4Ǵ#p79ᶶyD3ٗMxn' @bwCiUR~B&G&JZgD,#"фXX˄EdЛ@\zmCXt2 zp9K[o}}r@!Mv+VGYV9i%?y`-Uh xRS0*ME%yy92M:ФҔV\oýSQru1ߤ}\i7T!1{jj^H0W񉯲䈵иBƹTku,~>@ +I4~F@|2JyCM) Eya[[3=eT(n0mތfO"Zc3;UwRUrKtKbR.mi8ZRr9^ @G"A<t]՗I^T\g |G=8$)5XP2HqD \DGUUn8@UD;Un9Z(^,\T F5Z~"Ibߐtԓ&rc|44S qC?eERx] fi8@B!"Ż(qZP$؀*$-3!q tS; ,Q\sfD;nƓbJ$x &@??GYf+򅙤"Ó!;{PmVcm gG,5j^;8'9nasZdM5mEL2*?G0fl1;.+OV#_Zy+ ,73YΜ"<_͜ũv=#}t K3MAmt p M|&ӈ+ѧ<]kUo]5Z{L cl@Ǿ-^3o?y ƾ[.i \Za^߱e5B5}a0_s֕#sm%S݂{J`#uYY!ݟMٴx(qK?~isBǙCs67~W- g*M>KB93v5qacUj9aN,09)0m YmfܵUO~>@2Vlj$n0/x%}*4^@U<z ,:FSp^+Ng?ex'/ϝ =P*aGDԜLGDxLgn&!wWCES3bTF3 *SՃK#}]tx@(VG .ԝ e{hDi8_'{/`җP44[-J z -h=V^pAi_XҲ>7GdCglBjʾx27vOKܯ5 L QA۳˞H>hxKNshX!AhI4Ř&RTFC5(2ʨgMP{J)p̤Wɛ]oBsUG`؊qbLV?ahJ^fbB7iI=]U_g @>]nk^@tR>yjI`N,|F`֑j~5RBttkr 54խ gZg};W@e",^n(r +Gށ÷2endstream endobj 436 0 obj << /Filter /FlateDecode /Length 2103 >> stream xYMo5+]<6qۤI IMRJ^{ٕZzA=ufg^GIg?w?o3o(#.S88zǨ @bS{Wh@y1ʍ6(#NLWχuϾ#~9|(#уH^3!10JQ6נ)柕{ i?N^l+1_s Pe2ᤵF)BpJwCCUqejAt$6>RC }E BNE|!q㎮&['2 =CF*W UbzH"Y9>stAJSTEOMLޣUǓ !Wgd]AA0om-( [.FbZ;Yrҡ&d&} lXe>蓩e6Dx)t) 8eߤ祒 %S+7}vG9QB0hyުP`CDCVK>#Uibtx&dTE_b5%J0ݬ9;!d:$P̾CΌVuY1 \)IX" :Zͫ8-@DPqSE"%j2oMp4t]`{1J.\5_ی Ta ]|a\>eۣF>D`sTAwhHLy+ꔖ;LR ifqwp8)?b:6?ڂE --"J4{zy0"Gm䄸E[f8_ A`gA"%A!._\7j@˖h˕gx=O9BCgM0"ձJ(`JHt]v|z|ގhphC;ڎwwӎ@[qʎւE>v&~u;'tM%I sJv;C3zdpdW!`+ :1 Smp3 ST7ڨM/,vJ@mm;xߎ7i $lrCH2_4o cZt9!0\\~)$RKu4#"067JLK+]Y;,d1$ZtNj0wLrA&,c\|%P@)/j!SF%*Կ6U?,8 -iVǪ),(Y#t=D&h$_b2T[$oVO T0 Fg*\7lk590xf((.j.2 x6"2jPܐO"Xi 3:Aטv׵94A38m̞ԯd_ASYN,Z2 !8gΓfn!Z:Ϫe ۝넏X颙LC/I B%Bcws؉kEF!vn~o)FY<3r }D.ʨ@*OXe)* pW:8l9?̿i0CLG{}JOKDj'Ɛ6^l; ,fGshG4Ly~d@`"W(ZJʰJ.Jtʨ/^<8W@pWZr2 ~z&`L:E7i|qpKM8O@(C=65YJrܷ0\\ s!oGYs&!>*^R^*Ð-xY\u.G tfzK)K&M pͺލaLP(r1BV꾵KRTr7sXov6vAkTxh`;YRޥ}~iNSFAWnRI+eLP^jxD(MHr`ͻOLwjƀXtKt^oNlʽhǩQK:v_/vGۊ2aj,D/endstream endobj 437 0 obj << /Type /XRef /Length 346 /Filter /FlateDecode /DecodeParms << /Columns 5 /Predictor 12 >> /W [ 1 3 1 ] /Info 3 0 R /Root 2 0 R /Size 438 /ID [<6db5200b0ed7b67656cb6dad296aa2d2><6080e2c976876a456b1d11aeb8914b28>] >> stream x핽/CamՖT[itB.A,fARM ]$&0XDb4&`":='xܓԱsl _ˑ`:U+QiaXF_襢kRaXKE:TL* k_H\hN-gqT[(cb}NKxUhWEg_ }^qQLbңBYy %Mw kS\?xsx,^P 9B-эNBue̞ܿW?gɒpRҏy[{n*ldoڟshl3,;ʼn9o1dPF {? Ao endstream endobj startxref 710687 %%EOF deSolve/src/0000755000175100001440000000000013131751003012452 5ustar hornikusersdeSolve/src/lags.c0000754000175100001440000003707113131751003013556 0ustar hornikusers#include #include #include "deSolve.h" /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ time lags and delay-differential equations; from deSolve version 1.7 For delay-differential equations, a history of past values, past derivatives and past times, is kept (time-lags). They are in ring-vectors "histvar", "histdvar" and "histtime" respectively. These vectors are initialised at the start of the integration ("inithist") and then updated with new values every accepted timestep ("updatehist"). When the end of the history vectors is reached, new values are stored at the start (it is a ringbuffer); function "nexthist" finds the next position in this ringbuffer. The history buffers can be interrogated in the R-code, via R-functions "lagvalue(t,nr)" and "lagderiv(t,nr)", where nr can be one index or a vector containing the nr of the variable whose lag has to be computed at time t. These R-functions call C-functions "getLagValue" and "getLagDeriv" which first find the interval in the history vectors in which the lagged value is to be found ("findHistInt"), and then either use hermite interpolation to the requested time (functions "Hermite" and "dHermite" for values and derivatives), or use the Nordsieck history array. Note: findHistInt finds interval by bisectioning; only marginally more/less efficient than straightforward findHistInt2... to do: make lags callable from external C/Fortran function (thpe: availale since v 1.10-5; tested for C only; todo: Fortran example) +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ /*=========================================================================== Higher-order interpolation of y to x, based on Nordsieck history array if interpolMethod ==2 =========================================================================== */ /* definition of call to FORTRAN function INTERPOLY, as derived from dintdy */ void F77_NAME(interpoly)(double *, int *, int *, double *, int *, double *, int *, double *, double *); double interpolate(int i, int k, double t0, double hh, double t, double *Yh, int nq) { double res; if (nq > 12) error("illegal nq in interpolate, %i, at time %g", nq, t); if (k > nq) error("illegal k %i, nq in interpolate, %i, at time %g", k, nq, t); if (i > n_eq || i <1) error("illegal i %i, n_eq %i, at time %g", i, n_eq, t); F77_CALL(interpoly) (&t, &k, &i, Yh, &n_eq, &res, &nq, &t0, &hh); return(res); } /* continuous output formula for radau */ void F77_NAME (contr5alone) (int *, int *, double *, double *, int *, double *, double *, int *); void F77_NAME (getconra) (double *); /*=========================================================================== Hermitian interpolation of y to x (interpolMethod==1) =========================================================================== */ double Hermite (double t0, double t1, double y0, double y1, double dy0, double dy1, double t) { double tt0, tt1, tt12, tt02, hh, res; tt0 = t-t0; tt1 = t-t1; tt12 = tt1*tt1; tt02 = tt0*tt0; hh = t1-t0; if (hh) res=( dy0* tt0* tt12 + dy1* tt1* tt02 + ( y0* (2.0* tt0 + hh)* tt12 -y1* (2.0* tt1 - hh)* tt02 )/hh) / (hh * hh); else res=y0; return(res); } /*=========================================================================== Hermitian interpolation of dy to x =========================================================================== */ double dHermite (double t0, double t1, double y0, double y1, double dy0, double dy1, double t) { double tt0, tt1, tt12, tt02, hh, res; tt0 = t-t0; tt1 = t-t1; tt12 = tt1*tt1; tt02 = tt0*tt0; hh = t1-t0; if (hh) res=( dy0 * (tt12+2.0* tt0* tt1) + dy1 * ( tt02+2.0* tt0* tt1) + ( y0 *2.0* tt1*(2.0* tt0+ hh + tt1) -y1 *2.0* tt0*(2.0* tt1- hh + tt0))/ hh ) / ( hh* hh) ; else res= dy0; return(res); } /*=========================================================================== initialise history arrays + indices at start integration =========================================================================== */ void inithist(int max, int maxlags, int solver, int nroot) { int maxord; histsize = max; initialisehist = 1; indexhist = -1; /* indexhist+1 = next time in circular buffer. */ starthist = 0; /* start time in circular buffer. */ endreached = 0; /* if end of buffer reached and new values added at start */ /* interpolMethod = Hermite */ if (interpolMethod == 1) { offset = n_eq; /* size needed for saving one time-step in histvar*/ /* interpolMethod = HigherOrder, Livermore solvers */ } else if (interpolMethod == 2) { if (solver == 0) error("illegal input in lags - cannot combine interpol=2 with chosen solver"); maxord = 12; /* 5(bdf) or 12 (adams) */ lyh = 20; /* position of history array in rwork (C-index) */ lhh = 11; /* position of h in rwork (C-index) Note: for lsodx this is NEXT time step! */ lo = 13; /* position of method order in iwork (C-index) */ if (solver == 5) { /* different for vode! uses current time step*/ lhh = 10; lo = 13; } if (solver == 4 || solver == 6 || solver == 7) /* lsodar or lsoder */ lyh = 20+3*nroot; offset = n_eq*(maxord+1); histord = (int *) R_alloc (histsize, sizeof(int)); histhh = (double *) R_alloc (histsize, sizeof(double)); /* interpolMethod = 3; HigherOrder, radau */ } else { offset = n_eq * 4 + 2; histsave = (double *) R_alloc (2, sizeof(double)); } histtime = (double *) R_alloc (histsize, sizeof(double)); histvar = (double *) R_alloc (offset * histsize, sizeof(double)); histdvar = (double *) R_alloc (n_eq * histsize, sizeof(double)); } /*=========================================================================== given the maximum size of the history arrays; finds the next index =========================================================================== */ int nexthist(int i) { if (i < histsize-1) return(i+1); else { endreached = 1; return(0); } } /*=========================================================================== update history arrays each time step =========================================================================== */ /* first time: just store y, (dy) and t */ void updatehistini(double t, double *y, double *dY, double *rwork, int *iwork){ int intpol; intpol = interpolMethod; interpolMethod = 1; updatehist(t, y, dY, rwork, iwork); interpolMethod = intpol; if (interpolMethod == 2){ histord[0] = 0; histhh[0] = timesteps[0]; } } void updatehist(double t, double *y, double *dY, double *rwork, int *iwork) { int j, ii; double ss[2]; indexhist = nexthist(indexhist); ii = indexhist * offset; /* interpolMethod = Hermite */ if (interpolMethod == 1) { for (j = 0; j < n_eq; j++) histvar [ii + j ] = y[j]; /* higherOrder, livermores */ } else if (interpolMethod == 2) { histord[indexhist] = iwork[lo]; for (j = 0; j < offset; j++) histvar[ii + j] = rwork[lyh + j]; histhh [indexhist] = rwork[lhh]; /* higherOrder, radau */ } else if (interpolMethod == 3) { for (j = 0; j < 4 * n_eq; j++) histvar[ii + j] = rwork[j]; F77_CALL(getconra) (ss); for (j = 0; j < 2; j++) histvar[ii + 4*n_eq + j] = ss[j]; } ii = indexhist * n_eq; for (j = 0; j < n_eq; j++) histdvar[ii + j] = dY[j]; histtime [indexhist] = t; if (endreached == 1) /* starthist stays 0 until end reached... */ starthist = nexthist(starthist); } /*=========================================================================== find a past value (val=1) or a past derivative (val = 2) =========================================================================== */ double past(int i, int interval, double t, int val) /* finds past values (val=1) or past derivatives (val=2)*/ { int j, jn, nq, ip; double t0, t1, y0, y1, dy0, dy1, res, hh; double *Yh; /* error checking */ if ( i >= n_eq) error("illegal input in lagvalue - var nr too high, %i", i+1); /* equal to current value... */ if ( interval == indexhist && t == histtime[interval]) { if (val == 1) res = histvar [interval * offset + i ]; else res = histdvar [interval * offset + i ]; /* within last interval - for now: just extrapolate last value */ } else if ( interval == indexhist && interpolMethod == 1) { if (val == 1) { t0 = histtime[interval]; y0 = histvar [interval * offset + i ]; dy0 = histdvar [interval * n_eq + i ]; res = y0 + dy0*(t-t0); } else res = histdvar [interval * n_eq + i ]; /* Hermite interpolation */ } else if (interpolMethod == 1) { j = interval; jn = nexthist(j); t0 = histtime[j]; t1 = histtime[jn]; y0 = histvar [j * n_eq + i ]; y1 = histvar [jn * n_eq + i ]; dy0 = histdvar [j * n_eq + i ]; dy1 = histdvar [jn * n_eq + i ]; if (val == 1) res = Hermite (t0, t1, y0, y1, dy0, dy1, t); else res = dHermite (t0, t1, y0, y1, dy0, dy1, t); /* dense interpolation - livermore solvers */ } else if (interpolMethod == 2) { j = interval; jn = nexthist(j); t0 = histtime[j]; t1 = histtime[jn]; nq = histord [j]; if (nq == 0) { y0 = histvar [j * offset + i ]; y1 = histvar [jn * offset + i ]; dy0 = histdvar [j * n_eq + i ]; dy1 = histdvar [jn * n_eq + i ]; if (val == 1) res = Hermite (t0, t1, y0, y1, dy0, dy1, t); else res = dHermite (t0, t1, y0, y1, dy0, dy1, t); } else { Yh = &histvar [j * offset]; hh = histhh[j]; res = interpolate(i+1, val-1, t0, hh, t, Yh, nq); } /* dense interpolation - radau - gets all values (i not used) */ } else { // if (val == 2) // error("radau interpol = 2 does not work for lagderiv"); j = interval; Yh = &histvar [j * offset]; histsave = &histvar [j * offset + 4*n_eq]; ip = i+1; F77_CALL(contr5alone) (&ip, &n_eq, &t, Yh, &offset, histsave, &res, &val); } return(res); } /*=========================================================================== Find interval in history ring buffers, corresponding to "t" two alternatives; only findHistInt used =========================================================================== */ int findHistInt2 (double t) { int j, jn; if ( t >= histtime[indexhist]) return(indexhist); if ( t < histtime[starthist]) error("illegal input in lagvalue - lag, %g, too large, at time = %g\n", t, histtime[indexhist]); /* find embracing time starting from beginning */ j = starthist; jn = nexthist(j); while (histtime[jn]= histtime[indexhist]) return(indexhist); if ( t < histtime[starthist]) error("illegal input in lagvalue - lag, %g, too large, at time = %g\n", t, histtime[indexhist]); if (endreached == 0) { /* still filling buffer; not yet wrapped */ ilo = 0; ihi = indexhist; for(;;) { imid = (ilo + ihi) / 2; if (imid == ilo) return ilo; if (t >= histtime[imid]) ilo = imid; else ihi = imid; } } n = histsize -1; ilo = 0; ihi = n; for(;;) { imid = (ilo + ihi) / 2; ii = imid + starthist; if (ii > n) ii = ii - n - 1; if (imid == ilo) return ii; if (t >= histtime[ii]) ilo = imid; else ihi = imid; } } /*=========================================================================== C-equivalent of R-function lagvalue =========================================================================== */ SEXP getLagValue(SEXP T, SEXP nr) { SEXP value; int i, ilen, interval; double t; ilen = LENGTH(nr); if (initialisehist == 0) error("pastvalue can only be called from 'func' or 'res' when triggered by appropriate integrator."); if (!isNumeric(T)) error("t should be numeric"); t = *NUMERIC_POINTER(T); interval = findHistInt (t); if ((ilen ==1) && (INTEGER(nr)[0] == 0)) { PROTECT(value=NEW_NUMERIC(n_eq)); for(i=0; i #include #include "deSolve.h" #include "externalptr.h" /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Differential algebraic equation solver daspk. The C-wrappers that provide the interface between FORTRAN codes and R-code are: C_res_func : interface with R-code "res", passes function residuals C_out : interface with R-code "res", passes output variables C_daejac_func: interface with R-code "jacres", passes jacobian DLL_forc_dae provides the interface between the residual function specified in a DLL and daspk, in case there are forcing functions. changes since 1.4 karline: version 1.5: added forcing functions in DLL karline: version 1.6: added events karline: version 1.7: added time lags -> delay differential equations improving names karline: version 2.0: func in compiled code (was only res) to do: implement psolfunc +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ /* globals for when mass matrix is used with func in a DLL with mass matrix */ int isMass; double * mass, *dytmp; /* define data types for function pointers */ /* generic function pointer type */ typedef void (*funcptr)(void); /* function pointers for different argument lists */ typedef void C_daejac_func_type(double *, double *, double *, double *, double *, double *, int *); typedef void C_psol_func_type(int *, double *, double *, double *, double *, double *, double *, double *, double *, int*, double *, double *, int*, double *, int*); typedef void C_kryljac_func_type(double *, int *, int *, double *, double *, double *, double *, double *, double *, double *, double *, double *, int*, int*, double *, int*); /* ----------------- Matrix-Vector Multiplication A*x=c -------------------- */ void matvecmult (int nr, int nc, double* A, double* x, double* c) { int i, j; for (i = 0; i < nr; i++) { c[i] = 0.; for (j = 0; j < nc; j++) c[i] += A[i + nr * j] * x[j]; } } /* definition of the call to the FORTRAN function ddaspk - in file ddaspk.f*/ void F77_NAME(ddaspk)(void (*)(double *, double *, double *, double*, double *, int*, double *, int*), int *, double *, double *, double *, double *, int *,double *, double *, int *, double *, int *, int *, int *, double *, int *, void(*)(void)/*(double *, double *, double *, double *, double *, double *, int *)*/, void (*)(int *, double *, double *, double *, double *, double *, double *, double *, double *, int *, double *, double *, int *, double *, int *)); /* func is in a DLL, */ static void DLL_res_ode (double *t, double *y, double *yprime, double *cj, double *delta, int *ires, double *yout, int *iout) { int i; DLL_deriv_func (&n_eq, t, y, delta, yout, iout); if (isMass) { matvecmult(n_eq, n_eq, mass, yprime, dytmp); for ( i = 0; i < n_eq; i++) delta[i] = dytmp[i] - delta[i]; } else { for ( i = 0; i < n_eq; i++) delta[i] = yprime[i] - delta[i]; } } /* res is in a DLL, with forcing functions */ static void DLL_forc_dae (double *t, double *y, double *yprime, double *cj, double *delta, int *ires, double *yout, int *iout) { updatedeforc(t); DLL_res_func(t, y, yprime, cj, delta, ires, yout, iout); } /* func is in a DLL, with forcing function */ static void DLL_forc_dae2 (double *t, double *y, double *yprime, double *cj, double *delta, int *ires, double *yout, int *iout) { updatedeforc(t); DLL_res_ode(t, y, yprime, cj, delta, ires, yout, iout); } /* not yet implemented */ static void C_psol_func (int *neq, double *t, double *y, double *yprime, double *savr, double *wk, double *cj, double* wght, double *wp, int *iwp, double *b, double *eplin, int *ierr, double *RPAR, int *IPAR) { } /* interface between FORTRAN function calls and R functions */ static void C_res_func (double *t, double *y, double *yprime, double *cj, double *delta, int *ires, double *yout, int *iout) { int i; SEXP R_fcall, Time, ans; for (i = 0; i < n_eq; i++) { REAL(Y)[i] = y[i]; REAL (YPRIME)[i] = yprime[i]; } PROTECT(Time = ScalarReal(*t)); incr_N_Protect(); PROTECT(R_fcall = lang4(R_res_func,Time, Y, YPRIME)); incr_N_Protect(); PROTECT(ans = eval(R_fcall, R_envir)); incr_N_Protect(); for (i = 0; i < n_eq; i++) delta[i] = REAL(ans)[i]; my_unprotect(3); } /* deriv output function */ static void C_out (int *nout, double *t, double *y, double *yprime, double *yout) { int i; SEXP R_fcall, Time, ans; for (i = 0; i < n_eq; i++) { REAL(Y)[i] = y[i]; REAL (YPRIME)[i] = yprime[i]; } PROTECT(Time = ScalarReal(*t)); incr_N_Protect(); PROTECT(R_fcall = lang4(R_res_func,Time, Y, YPRIME)); incr_N_Protect(); PROTECT(ans = eval(R_fcall, R_envir)); incr_N_Protect(); for (i = 0; i < *nout; i++) yout[i] = REAL(ans)[i + n_eq]; my_unprotect(3); } /* interface between FORTRAN call to jacobian and R function */ static void C_daejac_func (double *t, double *y, double *yprime, double *pd, double *cj, double *RPAR, int *IPAR) { int i; SEXP R_fcall, ans; REAL(Rin)[0] = *t; REAL(Rin)[1] = *cj; for (i = 0; i < n_eq; i++) { REAL(Y)[i] = y[i]; REAL (YPRIME)[i] = yprime[i]; } PROTECT(R_fcall = lang4(R_daejac_func, Rin, Y, YPRIME)); incr_N_Protect(); PROTECT(ans = eval(R_fcall, R_envir)); incr_N_Protect(); for (i = 0; i < n_eq * nrowpd; i++) pd[i] = REAL(ans)[i]; my_unprotect(2); } /* MAIN C-FUNCTION, CALLED FROM R-code */ SEXP call_daspk(SEXP y, SEXP yprime, SEXP times, SEXP resfunc, SEXP parms, SEXP rtol, SEXP atol, SEXP rho, SEXP tcrit, SEXP jacfunc, SEXP initfunc, SEXP psolfunc, SEXP verbose, SEXP info, SEXP iWork, SEXP rWork, SEXP nOut, SEXP maxIt, SEXP bu, SEXP bd, SEXP nRowpd, SEXP Rpar, SEXP Ipar, SEXP flist, SEXP elag, SEXP eventfunc, SEXP elist, SEXP Mass) { /******************************************************************************/ /****** DECLARATION SECTION ******/ /******************************************************************************/ int j, nt, ny, repcount, latol, lrtol, lrw, liw, isDll; int maxit, isForcing, isEvent, islag, istate; double *xytmp, *xdytmp, tin, tout, *Atol, *Rtol; double *delta=NULL, cj = 0.; int *Info, ninfo, idid, mflag, ires = 0; int *iwork, it, ntot= 0, nout, funtype; double *rwork; /* pointers to functions passed to FORTRAN */ C_res_func_type *res_func = NULL; C_daejac_func_type *daejac_func = NULL; C_psol_func_type *psol_func = NULL; C_kryljac_func_type *kryljac_func = NULL; /******************************************************************************/ /****** STATEMENTS ******/ /******************************************************************************/ lock_solver(); /* prevent nested call of solvers that have global variables */ /* #### initialisation #### */ //init_N_Protect(); long int old_N_Protect = save_N_Protected(); ny = LENGTH(y); n_eq = ny; /* n_eq is a global variable */ nt = LENGTH(times); mflag = INTEGER(verbose)[0]; ninfo=LENGTH(info); nrowpd = INTEGER(nRowpd)[0]; maxit = INTEGER(maxIt)[0]; /* function is a dll ?*/ if (inherits(resfunc, "NativeSymbol")) { isDll = 1; } else { isDll = 0; } initOutC(isDll, &nout, &ntot, n_eq, nOut, Rpar, Ipar); /* copies of all variables that will be changed in the FORTRAN subroutine */ Info = (int *) R_alloc(ninfo,sizeof(int)); for (j = 0; j < ninfo; j++) Info[j] = INTEGER(info)[j]; if (mflag == 1) Info[17] = 1; xytmp = (double *) R_alloc(n_eq, sizeof(double)); for (j = 0; j < n_eq; j++) xytmp[j] = REAL(y)[j]; xdytmp = (double *) R_alloc(n_eq, sizeof(double)); for (j = 0; j < n_eq; j++) xdytmp[j] = REAL(yprime)[j]; latol = LENGTH(atol); Atol = (double *) R_alloc((int) latol, sizeof(double)); for (j = 0; j < latol; j++) Atol[j] = REAL(atol)[j]; lrtol = LENGTH(rtol); Rtol = (double *) R_alloc((int) lrtol, sizeof(double)); for (j = 0; j < lrtol; j++) Rtol[j] = REAL(rtol)[j]; liw = LENGTH(iWork); iwork = (int *) R_alloc(liw, sizeof(int)); for (j = 0; j < liw; j++) iwork[j] = INTEGER(iWork)[j]; lrw = LENGTH(rWork); rwork = (double *) R_alloc(lrw, sizeof(double)); for (j = 0; j < lrw; j++) rwork[j] = REAL(rWork)[j]; //timesteps = (double *) R_alloc(2, sizeof(double)); for (j = 0; j < 2; j++) timesteps[j] = 0.; /**************************************************************************/ /****** Initialization of globals, Parameters and Forcings (DLLs) ******/ /**************************************************************************/ initdaeglobals(nt, ntot); initParms(initfunc, parms); isForcing = initForcings(flist); isEvent = initEvents(elist, eventfunc, 0); /* zero roots */ islag = initLags(elag, 0, 0); /* pointers to functions res_func, psol_func and daejac_func, passed to the FORTRAN subroutine */ isMass = 0; if (isDll == 1) { /* DLL address passed to FORTRAN */ funtype = Info[19]; if (funtype == 1) { /* res is in DLL */ res_func = (C_res_func_type *) R_ExternalPtrAddrFn_(resfunc); if(isForcing==1) { DLL_res_func = (C_res_func_type *) R_ExternalPtrAddrFn_(resfunc); res_func = (C_res_func_type *) DLL_forc_dae; } } else if (funtype <= 3){ /* func is in DLL, +- mass matrix */ res_func = DLL_res_ode; DLL_deriv_func = (C_deriv_func_type *) R_ExternalPtrAddrFn_(resfunc); if(isForcing==1) { res_func = (C_res_func_type *) DLL_forc_dae2; } if (funtype == 3) { /* mass matrix */ isMass = 1; mass = (double *)R_alloc(n_eq * n_eq, sizeof(double)); for (j = 0; j < n_eq * n_eq; j++) mass[j] = REAL(Mass)[j]; dytmp = (double *) R_alloc(n_eq, sizeof(double)); } } else error("DLL function type not yet implemented"); delta = (double *) R_alloc(n_eq, sizeof(double)); for (j = 0; j < n_eq; j++) delta[j] = 0.; } else { /* interface function between FORTRAN and R passed to FORTRAN */ res_func = (C_res_func_type *) C_res_func; /* needed to communicate with R */ R_res_func = resfunc; } R_envir = rho; /* karline: this to allow merging compiled and R-code (e.g. events)*/ if (!isNull(jacfunc)) { if (inherits(jacfunc,"NativeSymbol")) { if (Info[11] ==0) { /*ordinary jac*/ daejac_func = (C_daejac_func_type *) R_ExternalPtrAddrFn_(jacfunc); } else { /*krylov*/ kryljac_func = (C_kryljac_func_type *) R_ExternalPtrAddrFn_(jacfunc); } } else { R_daejac_func = jacfunc; daejac_func = C_daejac_func; } } if (!isNull(psolfunc)) { if (inherits(psolfunc,"NativeSymbol")) { psol_func = (C_psol_func_type *) R_ExternalPtrAddrFn_(psolfunc); } else { R_psol_func = psolfunc; psol_func = C_psol_func; } } /* #### initial time step #### */ idid = 1; REAL(YOUT)[0] = REAL(times)[0]; for (j = 0; j < n_eq; j++) REAL(YOUT)[j+1] = REAL(y)[j]; if (islag == 1) updatehistini(REAL(times)[0], xytmp, xdytmp, rwork, iwork); if (nout>0) { tin = REAL(times)[0]; if (isDll == 1) res_func (&tin, xytmp, xdytmp, &cj, delta, &ires, out, ipar) ; else C_out(&nout,&tin,xytmp,xdytmp,out); for (j = 0; j < nout; j++) REAL(YOUT)[j + n_eq + 1] = out[j]; } /* #### main time loop #### */ for (it = 0; it < nt-1; it++) { tin = REAL(times)[it]; tout = REAL(times)[it+1]; if (isEvent) { istate = 2; updateevent(&tin, xytmp, &istate); if (istate == 1) Info[0] = 0; Info[3] = 1; rwork[0] = tout; } repcount = 0; do /* iterations in case maxsteps > 500* or in case islag */ { if (Info[11] == 0) { /* ordinary jac */ F77_CALL(ddaspk) (res_func, &ny, &tin, xytmp, xdytmp, &tout, Info, Rtol, Atol, &idid, rwork, &lrw, iwork, &liw, out, ipar, (funcptr)daejac_func, psol_func); } else { /* krylov - not yet used */ F77_CALL(ddaspk) (res_func, &ny, &tin, xytmp, xdytmp, &tout, Info, Rtol, Atol, &idid, rwork, &lrw, iwork, &liw, out, ipar, (funcptr)kryljac_func, psol_func); } /* in case timestep is asked for... */ timesteps [0] = rwork[10]; timesteps [1] = rwork[11]; if (islag == 1) updatehist(tin, xytmp, xdytmp, rwork, iwork); repcount ++; if (idid == -1) {Info[0]=1; } else if (idid == -2) { warning("Excessive precision requested. scale up `rtol' and `atol' e.g. by the factor %g\n",10.0); Info[0]=1; repcount=maxit+2; } else if (idid == -3) { warning("Error term became zero for some i: pure relative error control (ATOL(i)=0.0) for a variable which is now vanished"); repcount=maxit+2; } else if (idid == -5) { warning("jacfun routine failed with the Krylov method"); repcount = maxit+2; } else if (idid == -6) { warning("repeated error test failures on a step - singularity ?"); repcount = maxit+2; } else if (idid == -7) { warning("repeated convergence test failures on a step - inaccurate Jacobian or preconditioner?"); repcount = maxit+2; } else if (idid == -8) { warning("matrix of partial derivatives is singular with direct method-some equations redundant"); repcount = maxit+2; } else if (idid == -9) { warning("repeated convergence test failures and error test failures ?"); repcount = maxit+2; } else if (idid == -10) { warning("repeated convergence test failures on a step, because ires was -1"); repcount = maxit+2; } else if (idid == -11) { warning("unrecoverable error from inside noninear solver, ires=-2 "); repcount = maxit+2; } else if (idid == -12) { warning("failed to compute initial y and yprime vectors"); repcount = maxit+2; } else if (idid == -13) { warning("unrecoverable error inside the PSOL routine"); repcount = maxit+2; } else if (idid == -14) { warning("Krylov linear system solver failed to converge"); repcount = maxit+2; } else if (idid == -33) { warning("fatal error"); repcount = maxit+2; } } while (tin < tout && repcount < maxit); REAL(YOUT)[(it+1)*(ntot+1)] = tin; for (j = 0; j < n_eq; j++) REAL(YOUT)[(it+1)*(ntot + 1) + j + 1] = xytmp[j]; if (nout>0) { if (isDll == 1) res_func (&tin, xytmp, xdytmp, &cj, delta, &ires, out, ipar) ; else C_out(&nout,&tin,xytmp,xdytmp,out); for (j = 0; j < nout; j++) REAL(YOUT)[(it+1)*(ntot + 1) + j + n_eq + 1] = out[j]; } /* #### an error occurred #### */ if (repcount > maxit || tin < tout || idid <= 0) { idid = 0; returnearly(1, it, ntot); break; } } /* end main time loop */ /* #### returning output #### */ terminate(idid, iwork, 23, 0, rwork, 3, 1); REAL(RWORK)[0] = rwork[6]; //unprotect_all(); restore_N_Protected(old_N_Protect); unlock_solver(); if (idid > 0) return(YOUT); else return(YOUT2); } deSolve/src/call_radau.c0000754000175100001440000004603613131751003014720 0ustar hornikusers#include #include #include "deSolve.h" #include "externalptr.h" /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ RADAU: Implicit runge-Kutta of order 5 due to Hairer and Wanner, with stepsize control and dense output The C-wrappers that provide the interface between FORTRAN codes and R-code are: C_deriv_func_rad: interface with R-code "func", passes derivatives C_deriv_out_rad : interface with R-code "func", passes derivatives + output variables C_deriv_func_forc_rad provides the interface between the function specified in a DLL and the integrator, in case there are forcing functions. version 1.9.1: added time lags -> delay differential equations added root function added events version 1.10: mass matrix for func in a DLL karline soetaert +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ /* globals for radau */ int maxt, it, nout, isDll, ntot; double *xdytmp, *ytmp, *tt, *rwork, *root, *oldroot; int *iwork, *jroot; int iroot, nroot, nr_root, islag, isroot, isEvent, endsim; double tin, tprevroot; typedef void C_root_func_type (int *, double *, double *,int *, double *); C_root_func_type *root_func = NULL; C_deriv_func_type *deriv_func; /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ definition of the calls to the FORTRAN subroutines in file radau.f */ void F77_NAME(radau5)( int *, void (*)(int *, double *, double *, double *, double *, int *), // func double *, double *, double *, double *, double *, double *, int *, void (*)(int *, double *, double *, int *, int *, double *, int *, double *, int *), // jac int *, int *, int *, void (*)(int *, double *, int *, double *, int *), // mas int *, int *, int *, void (*)(int *, double *, double *, double *, double *, int *, int *, double *, int *, int *, double *), // soloutrad int *, double *, int *, int *, int*, double *, int*, int*); /* continuous output formula for radau (used in radau.c and lags.c) */ void F77_NAME (contr5) (int *, double *, double *, int *, double *); /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ interface R with FORTRAN functions */ /* wrapper above the derivate function in a dll that first estimates the values of the forcing functions */ static void C_deriv_func_forc_rad (int *neq, double *t, double *y, double *ydot, double *yout, int *iout) { updatedeforc(t); DLL_deriv_func(neq, t, y, ydot, yout, iout); } /* Fortran code calls C_deriv_func_rad(N, t, y, ydot, yout, iout) R code called as R_deriv_func(time, y) and returns ydot */ static void C_deriv_func_rad (int *neq, double *t, double *y, double *ydot, double *yout, int *iout) { int i; SEXP R_fcall, Time, ans; for (i = 0; i < *neq; i++) REAL(Y)[i] = y[i]; PROTECT(Time = ScalarReal(*t)); incr_N_Protect(); PROTECT(R_fcall = lang3(R_deriv_func,Time,Y)); incr_N_Protect(); PROTECT(ans = eval(R_fcall, R_envir)); incr_N_Protect(); for (i = 0; i < *neq; i++) ydot[i] = REAL(ans)[i]; my_unprotect(3); } /* mass matrix function */ static void C_mas_func_rad (int *neq, double *am, int *lmas, double *yout, int *iout) { int i; SEXP NEQ, LM, R_fcall, ans; PROTECT(NEQ = NEW_INTEGER(1)); incr_N_Protect(); PROTECT(LM = NEW_INTEGER(1)); incr_N_Protect(); INTEGER(NEQ)[0] = *neq; INTEGER(LM) [0] = *lmas; PROTECT(R_fcall = lang3(R_mas_func,NEQ,LM)); incr_N_Protect(); PROTECT(ans = eval(R_fcall, R_envir)); incr_N_Protect(); for (i = 0; i <*lmas * *neq; i++) am[i] = REAL(ans)[i]; my_unprotect(4); } /* deriv output function - for ordinary output variables */ static void C_deriv_out_rad (int *nOut, double *t, double *y, double *ydot, double *yout) { int i; SEXP R_fcall, Time, ans; for (i = 0; i < n_eq; i++) REAL(Y)[i] = y[i]; PROTECT(Time = ScalarReal(*t)); incr_N_Protect(); PROTECT(R_fcall = lang3(R_deriv_func,Time, Y)); incr_N_Protect(); PROTECT(ans = eval(R_fcall, R_envir)); incr_N_Protect(); for (i = 0; i < *nOut; i++) yout[i] = REAL(ans)[i + n_eq]; my_unprotect(3); } /* save output in R-variables */ static void saveOut (double t, double *y) { int j; REAL(YOUT)[(it)*(ntot+1)] = t; for (j = 0; j < n_eq; j++) REAL(YOUT)[(it)*(ntot + 1) + j + 1] = y[j]; /* if ordinary output variables: call function again */ if (nout>0) { if (isDll == 1) /* output function in DLL */ deriv_func (&n_eq, &t, y, xdytmp, out, ipar) ; else C_deriv_out_rad(&nout, &t, y, xdytmp, out); for (j = 0; j < nout; j++) REAL(YOUT)[(it)*(ntot + 1) + j + n_eq + 1] = out[j]; } } /* save lagged variables */ static void C_saveLag(int ini, double *t, double *y, double *con, int *lrc, double *rpar, int *ipar) { /* estimate dy (xdytmp) */ if (isDll == 1) deriv_func (&n_eq, t, y, xdytmp, rpar, ipar) ; else C_deriv_func_rad (&n_eq, t, y, xdytmp, rpar, ipar) ; if (ini == 1) updatehistini(*t, y, xdytmp, rpar, ipar); else updatehist(*t, y, xdytmp, con, lrc); } /* root function */ static void C_root_radau (int *neq, double *t, double *y, int *ng, double *gout) { int i; SEXP R_fcall, Time, ans; for (i = 0; i < *neq; i++) REAL(Y)[i] = y[i]; PROTECT(Time = ScalarReal(*t)); incr_N_Protect(); PROTECT(R_fcall = lang3(R_root_func,Time,Y)); incr_N_Protect(); PROTECT(ans = eval(R_fcall, R_envir)); incr_N_Protect(); for (i = 0; i < *ng; i++) gout[i] = REAL(ans)[i]; my_unprotect(3); } /* function for brent's root finding algorithm */ double f (double t, double *Con, int *Lrc) { F77_CALL(contr5) (&n_eq, &t, Con, Lrc, ytmp); /* ytmp = value of y at t */ if (isDll == 1) root_func (&n_eq, &t, ytmp, &nroot, root); /* root at t, ytmp */ else C_root_radau (&n_eq, &t, ytmp, &nroot, root); return root[iroot] ; } /* function called by Fortran to check for output, lags, events, roots */ static void C_soloutrad(int * nr, double * told, double * t, double * y, double * con, int * lrc, int * neq, double * rpar, int * ipar, int * irtrn, double * xout) { int i, j; int istate, iterm; double tr, tmin; double tol = 1e-9; /* Acceptable tolerance */ int maxit = 100; /* Max # of iterations */ extern double brent(double, double, double, double, double (double, double *, int *), double *, int *, double, int); if (*told == *t) return; timesteps[0] = *told-*t; timesteps[1] = *told-*t; if (islag == 1) C_saveLag(0, t, y, con, lrc, rpar, ipar); *irtrn = 0; if (isEvent && ! rootevent) { if (*told <= tEvent && tEvent < *t) { tin = tEvent; F77_CALL(contr5) (&n_eq, &tEvent, con, lrc, y); updateevent(&tin, y, &istate); *irtrn = -1; } } tmin = *t; iroot = -1; if (isroot & (fabs(*t - tprevroot) > tol)) { if (isDll == 1) root_func (&n_eq, t, y, &nroot, root); /* root at t, ytmp */ else C_root_radau (&n_eq, t, y, &nroot, root); for (i = 0; i < nroot; i++) if (fabs(root[i]) < tol) { iroot = i; jroot[i] = 1; *irtrn = -1; endsim = 1; tprevroot = *t; } else if (fabs(oldroot[i]) >= tol && root[i] * oldroot[i] < 0) { iroot = i; jroot[i] = 1; tr = brent(*told, *t, oldroot[i], root[i], f, con, lrc, tol, maxit); if (fabs(tprevroot - tr) > tol) { F77_CALL(contr5) (&n_eq, &tr, con, lrc, ytmp); *irtrn = -1; endsim = 1; if (tr < tmin) { tmin = tr; tprevroot = tmin; for (j = 0; j < n_eq; j++) y[j] = ytmp[j]; } } } else jroot[i] = 0; for (i = 0; i < nroot; i++) oldroot[i] = root[i]; } while (*told <= tt[it] && tt[it] < tmin) { F77_CALL(contr5) (neq, &tt[it], con, lrc, ytmp); saveOut(tt[it], ytmp); it++; if ( it >= maxt) break; } if ((*irtrn == -1) && rootevent) { *t = tmin; tin = *t; tEvent = tin; if (nr_root < Rootsave) { troot[nr_root] = tin; for (j = 0; j < nroot; j++) if (jroot[j] == 1) nrroot[nr_root] = j+1; for (j = 0; j < n_eq; j++) valroot[nr_root* n_eq + j] = y[j]; } iterm = 0; /* check if simulation should be terminated */ for (j = 0; j < nroot; j++) if (jroot[j] == 1 && termroot[j] == 1) iterm = 1; if (iterm == 0) { nr_root++; updateevent(&tin, y, &istate); endsim = 0; } else { endsim = 1; } } } /* interface to jacobian function */ static void C_jac_func_rad(int *neq, double *t, double *y, int *ml, int *mu, double *pd, int *nrowpd, double *yout, int *iout) { int i; SEXP R_fcall, Time, ans; for (i = 0; i < *neq; i++) REAL(Y)[i] = y[i]; PROTECT(Time = ScalarReal(*t)); incr_N_Protect(); PROTECT(R_fcall = lang3(R_jac_func,Time,Y)); incr_N_Protect(); PROTECT(ans = eval(R_fcall, R_envir)); incr_N_Protect(); for (i = 0; i < *neq * *nrowpd; i++) pd[i] = REAL(ans)[i]; my_unprotect(2); } /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ give name to data types */ typedef void C_solout_type (int *, double *, double *, double *, double *, int *, int *, double *, int *, int *, double *) ; typedef void C_mas_type (int *, double *, int *, double *, int *); // to be changed... typedef void C_jac_func_type_rad(int *, double *, double *, int *, int *, double *, int*, double *, int *); /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ MAIN C-FUNCTION, CALLED FROM R-code */ SEXP call_radau(SEXP y, SEXP times, SEXP derivfunc, SEXP masfunc, SEXP jacfunc, SEXP parms, SEXP rtol, SEXP atol, SEXP Nrjac, SEXP Nrmas, SEXP rho, SEXP initfunc, SEXP rWork, SEXP iWork, SEXP nOut, SEXP lRw, SEXP lIw, SEXP Rpar, SEXP Ipar, SEXP Hini, SEXP flist, SEXP elag, SEXP rootfunc, SEXP nRoot, SEXP eventfunc, SEXP elist ) { /******************************************************************************/ /****** DECLARATION SECTION ******/ /******************************************************************************/ int j, nt, latol, lrtol, lrw, liw, ijac, mljac, mujac, imas, mlmas, mumas; int isForcing; double *xytmp, tout, *Atol, *Rtol, hini=0; int itol, iout, idid; SEXP TROOT, NROOT, VROOT, IROOT; /* pointers to functions passed to FORTRAN */ C_solout_type *solout = NULL; C_jac_func_type_rad *jac_func = NULL; C_mas_type *mas_func = NULL; /******************************************************************************/ /****** STATEMENTS ******/ /******************************************************************************/ /* #### initialisation #### */ lock_solver(); /* prevent nested call of solvers that have global variables */ long int old_N_Protect = save_N_Protected(); n_eq = LENGTH(y); /* number of equations */ nt = LENGTH(times); /* number of output times */ maxt = nt; nroot = INTEGER(nRoot)[0]; /* number of roots */ isroot = 0; nr_root = 0; if (nroot > 0) isroot = 1; tt = (double *) R_alloc(nt, sizeof(double)); for (j = 0; j < nt; j++) tt[j] = REAL(times)[j]; ijac = INTEGER(Nrjac)[0]; mljac = INTEGER(Nrjac)[1]; mujac = INTEGER(Nrjac)[2]; imas = INTEGER(Nrmas)[0]; mlmas = INTEGER(Nrmas)[1]; mumas = INTEGER(Nrmas)[2]; /* is function a dll ?*/ isDll = inherits(derivfunc, "NativeSymbol"); /* initialise output ... */ initOutC(isDll, &nout, &ntot, n_eq, nOut, Rpar, Ipar); /* copies of variables that will be changed in the FORTRAN subroutine */ xytmp = (double *) R_alloc(n_eq, sizeof(double)); for (j = 0; j < n_eq; j++) xytmp[j] = REAL(y)[j]; ytmp = (double *) R_alloc(n_eq, sizeof(double)); latol = LENGTH(atol); Atol = (double *) R_alloc((int) latol, sizeof(double)); for (j = 0; j < latol; j++) Atol[j] = REAL(atol)[j]; lrtol = LENGTH(rtol); Rtol = (double *) R_alloc((int) lrtol, sizeof(double)); for (j = 0; j < lrtol; j++) Rtol[j] = REAL(rtol)[j]; /* tolerance specifications */ if (latol == 1 ) itol = 0; else itol = 1; hini = REAL(Hini)[0]; /* work vectors */ liw = INTEGER (lIw)[0]; iwork = (int *) R_alloc(liw, sizeof(int)); for (j=0; j 0 || islag) { xdytmp= (double *) R_alloc(n_eq, sizeof(double)); for (j = 0; j < n_eq; j++) xdytmp[j] = 0.; } /* pointers to functions deriv_func, jac_func, passed to FORTRAN */ if (isDll) { /* DLL address passed to FORTRAN */ deriv_func = (C_deriv_func_type *) R_ExternalPtrAddrFn_(derivfunc); /* overruling deriv_func if forcing */ if (isForcing) { DLL_deriv_func = deriv_func; deriv_func = (C_deriv_func_type *) C_deriv_func_forc_rad; } } else { /* interface function between FORTRAN and C/R passed to FORTRAN */ deriv_func = (C_deriv_func_type *) C_deriv_func_rad; /* needed to communicate with R */ R_deriv_func = derivfunc; } R_envir = rho; /* karline: this to allow merging compiled and R-code (e.g. events)*/ if (!isNull(jacfunc)) { if (isDll) jac_func = (C_jac_func_type_rad *) R_ExternalPtrAddrFn_(jacfunc); else { R_jac_func = jacfunc; jac_func= C_jac_func_rad; } } if (!isNull(masfunc)) { R_mas_func = masfunc; mas_func= C_mas_func_rad; if (isDll) R_envir = rho; } solout = C_soloutrad; iout = 2; /* solout called after each step OR 1???*/ idid = 0; /* #### integration #### */ it = 0; tin = REAL(times)[0]; tout = REAL(times)[nt-1]; saveOut (tin, xytmp); /* save initial condition */ it++; if (nroot > 0) { /* also must find a root */ jroot = (int *) R_alloc(nroot, sizeof(int)); for (j = 0; j < nroot; j++) jroot[j] = 0; root = (double *) R_alloc(nroot, sizeof(double)); oldroot = (double *) R_alloc(nroot, sizeof(double)); if (isDll) { root_func = (C_root_func_type *) R_ExternalPtrAddrFn_(rootfunc); } else { root_func = (C_root_func_type *) C_root_radau; R_root_func = rootfunc; } /* value of oldroot */ if (isDll == 1) root_func (&n_eq, &tin, xytmp, &nroot, oldroot); /* root at t, ytmp */ else C_root_radau (&n_eq, &tin, xytmp, &nroot, oldroot); tprevroot = tin; /* to make sure that roots are not too close */ } endsim = 0; do { if (islag == 1) C_saveLag(1, &tin, xytmp, out, ipar, out, ipar); F77_CALL(radau5) ( &n_eq, deriv_func, &tin, xytmp, &tout, &hini, Rtol, Atol, &itol, jac_func, &ijac, &mljac, &mujac, mas_func, &imas, &mlmas, &mumas, solout, &iout, rwork, &lrw, iwork, &liw, out, ipar, &idid); } while (tin < tout && idid >= 0 && endsim == 0); if (idid == -1) warning("input is not consistent"); else if (idid == -2) warning("larger maxsteps needed"); else if (idid == -3) warning("step size becomes too small"); else if (idid == -4) warning("problem is probably stiff - interrupted"); /* #### an error occurred #### */ if(it <= nt-1) saveOut (tin, xytmp); /* save final condition */ if (idid < 0) { it = it-1; returnearly (1, it, ntot); } else if (idid == 2) { it = it-1; returnearly (0, it, ntot); idid = -2; } /* #### returning output #### */ rwork[0] = hini; rwork[1] = tin ; terminate(idid,iwork,7,13,rwork,5,0); if (iroot >= 0 || nr_root > 0) { PROTECT(IROOT = allocVector(INTSXP, nroot));incr_N_Protect(); for (j = 0; j < nroot; j++) INTEGER(IROOT)[j] = jroot[j]; PROTECT(NROOT = allocVector(INTSXP, 1));incr_N_Protect(); INTEGER(NROOT)[0] = nr_root; if (nr_root == 0) { PROTECT(TROOT = allocVector(REALSXP, 1)); incr_N_Protect(); REAL(TROOT)[0] = tin; } else { if (nr_root > Rootsave) nr_root = Rootsave; PROTECT(TROOT = allocVector(REALSXP, nr_root)); incr_N_Protect(); for (j = 0; j < nr_root; j++) REAL(TROOT)[j] = troot[j]; PROTECT(VROOT = allocVector(REALSXP, nr_root*n_eq)); incr_N_Protect(); for (j = 0; j < nr_root*n_eq; j++) REAL(VROOT)[j] = valroot[j]; PROTECT(IROOT = allocVector(INTSXP, nr_root)); incr_N_Protect(); for (j = 0; j < nr_root; j++) INTEGER(IROOT)[j] = nrroot[j]; if (idid == 1) { setAttrib(YOUT, install("valroot"), VROOT); setAttrib(YOUT, install("indroot"), IROOT); } else { setAttrib(YOUT2, install("valroot"), VROOT); setAttrib(YOUT2, install("indroot"), IROOT); } } if (idid == 1 ) { setAttrib(YOUT, install("troot"), TROOT); setAttrib(YOUT, install("nroot"), NROOT); } else { setAttrib(YOUT2, install("iroot"), IROOT); setAttrib(YOUT2, install("troot"), TROOT); setAttrib(YOUT2, install("nroot"), NROOT); } } /* #### termination #### */ unlock_solver(); restore_N_Protected(old_N_Protect); //unprotect_all(); if (idid > 0) return(YOUT); else return(YOUT2); } deSolve/src/rk_util.h0000754000175100001440000001060713131751003014302 0ustar hornikusers/*==========================================================================*/ /* Runge-Kutta Solvers, (C) Th. Petzoldt, License: GPL >=2 */ /* Definitions and Utilities needed by Runge-Kutta Solvers */ /*==========================================================================*/ /* Load headers needed by the R interface */ #include #include #include #include "deSolve.h" #ifdef HAVE_LONG_DOUBLE # define LDOUBLE long double #else # define LDOUBLE double #endif /* sign of a number */ #define sign(x) (( x > 0 ) - ( x < 0 )) /*==========================================================================*/ /* general utilies and interpolation */ /*==========================================================================*/ void R_test_call(DllInfo *info); void R_unload_test_call(DllInfo *info); SEXP getvar(SEXP name, SEXP Rho); SEXP getInputs(SEXP symbol, SEXP Rho); void blas_matprod1(double *x, int nrx, int ncx, double *y, int nry, int ncy, double *z); void matprod(int m, int n, int o, double* a, double* b, double* c); double maxdiff(double *x, double *y, int n); double maxerr(double *y0, double *y1, double *y2, double* Atol, double* Rtol, int n); void derivs(SEXP Func, double t, double* y, SEXP Parms, SEXP Rho, double *ydot, double *yout, int j, int neq, int *ipar, int isDll, int isForcing); void denspar(double *FF, double *y0, double *y1, double dt, double *d, int neq, int stage, double *r); void densout(double *r, double t0, double t, double dt, double* res, int neq); void densoutck(double t0, double t, double dt, double * y0, double* FF, double* dy, double* res, int neq); void neville(double *xx, double *y, double tnew, double *ynew, int n, int ksig); void shiftBuffer (double *x, int n, int k); void setIstate(SEXP R_yout, SEXP R_istate, int *istate, int it_tot, int stage, int fsal, int qerr, int nrej); /*==========================================================================*/ /* core functions (main loop) for solvers with variable / fixed step size */ /*==========================================================================*/ void rk_auto( /* integers */ int fsal, int neq, int stage, int isDll, int isForcing, int verbose, int nknots, int interpolate, int densetype, int maxsteps, int nt, /* int pointers */ int* _iknots, int* _it, int* _it_ext, int* _it_tot, int *_it_rej, int* istate, int* ipar, /* double */ double t, double tmax, double hmin, double hmax, double alpha, double beta, /* double pointers */ double* _dt, double* _errold, /* arrays */ double* tt, double* y0, double* y1, double* y2, double* dy1, double* dy2, double* f, double* y, double* Fj, double* tmp, double* FF, double* rr, double* A, double* out, double* bb1, double* bb2, double* cc, double* dd, double* atol, double* rtol, double* yknots, double* yout, /* SEXPs */ SEXP Func, SEXP Parms, SEXP Rho ); void rk_fixed( /* integers */ int fsal, int neq, int stage, int isDll, int isForcing, int verbose, int nknots, int interpolate, int maxsteps, int nt, /* int pointers */ int* _iknots, int* _it, int* _it_ext, int* _it_tot, int* istate, int* ipar, /* double */ double t, double tmax, double hini, /* double pointers */ double* _dt, /* arrays */ double* tt, double* y0, double* y1,double* dy1, double* f, double* y, double* Fj, double* tmp, double* FF, double* rr, double* A, double* out, double* bb1, double* cc, double* yknots, double* yout, /* SEXPs */ SEXP Func, SEXP Parms, SEXP Rho ); void rk_implicit(double * alfa, int *index, /* integers */ int fsal, int neq, int stage, int isDll, int isForcing, int verbose, int nknots, int interpolate, int maxsteps, int nt, /* int pointers */ int* _iknots, int* _it, int* _it_ext, int* _it_tot, int* istate, int* ipar, /* double */ double t, double tmax, double hini, /* double pointers */ double* _dt, /* arrays */ double* tt, double* y0, double* y1, double* dy1, double* f, double* y, double* Fj, double* tmp, double* tmp2, double *tmp3, double* FF, double* rr, double* A, double* out, double* bb1, double* cc, double* yknots, double* yout, /* SEXPs */ SEXP Func, SEXP Parms, SEXP Rho ); deSolve/src/Makevars0000754000175100001440000000003713131751003014150 0ustar hornikusersPKG_LIBS=$(BLAS_LIBS) $(FLIBS) deSolve/src/dlinpk.f0000754000175100001440000003516313131751003014114 0ustar hornikusers subroutine dgefa(a,lda,n,ipvt,info) integer lda,n,ipvt(*),info double precision a(lda,*) c c dgefa factors a double precision matrix by gaussian elimination. c c dgefa is usually called by dgeco, but it can be called c directly with a saving in time if rcond is not needed. c (time for dgeco) = (1 + 9/n)*(time for dgefa) . c c on entry c c a double precision(lda, n) c the matrix to be factored. c c lda integer c the leading dimension of the array a . c c n integer c the order of the matrix a . c c on return c c a an upper triangular matrix and the multipliers c which were used to obtain it. c the factorization can be written a = l*u where c l is a product of permutation and unit lower c triangular matrices and u is upper triangular. c c ipvt integer(n) c an integer vector of pivot indices. c c info integer c = 0 normal value. c = k if u(k,k) .eq. 0.0 . this is not an error c condition for this subroutine, but it does c indicate that dgesl or dgedi will divide by zero c if called. use rcond in dgeco for a reliable c indication of singularity. c c linpack. this version dated 08/14/78 . c cleve moler, university of new mexico, argonne national lab. c c subroutines and functions c c blas daxpy,dscal,idamax c c internal variables c double precision t integer idamax,j,k,kp1,l,nm1 c c c gaussian elimination with partial pivoting c info = 0 nm1 = n - 1 if (nm1 .lt. 1) go to 70 do 60 k = 1, nm1 kp1 = k + 1 c c find l = pivot index c l = idamax(n-k+1,a(k,k),1) + k - 1 ipvt(k) = l c c zero pivot implies this column already triangularized c if (a(l,k) .eq. 0.0d0) go to 40 c c interchange if necessary c if (l .eq. k) go to 10 t = a(l,k) a(l,k) = a(k,k) a(k,k) = t 10 continue c c compute multipliers c t = -1.0d0/a(k,k) call dscal(n-k,t,a(k+1,k),1) c c row elimination with column indexing c do 30 j = kp1, n t = a(l,j) if (l .eq. k) go to 20 a(l,j) = a(k,j) a(k,j) = t 20 continue call daxpy(n-k,t,a(k+1,k),1,a(k+1,j),1) 30 continue go to 50 40 continue info = k 50 continue 60 continue 70 continue ipvt(n) = n if (a(n,n) .eq. 0.0d0) info = n return end subroutine dgesl(a,lda,n,ipvt,b,job) integer lda,n,ipvt(*),job double precision a(lda,*),b(*) c c dgesl solves the double precision system c a * x = b or trans(a) * x = b c using the factors computed by dgeco or dgefa. c c on entry c c a double precision(lda, n) c the output from dgeco or dgefa. c c lda integer c the leading dimension of the array a . c c n integer c the order of the matrix a . c c ipvt integer(n) c the pivot vector from dgeco or dgefa. c c b double precision(n) c the right hand side vector. c c job integer c = 0 to solve a*x = b , c = nonzero to solve trans(a)*x = b where c trans(a) is the transpose. c c on return c c b the solution vector x . c c error condition c c a division by zero will occur if the input factor contains a c zero on the diagonal. technically this indicates singularity c but it is often caused by improper arguments or improper c setting of lda . it will not occur if the subroutines are c called correctly and if dgeco has set rcond .gt. 0.0 c or dgefa has set info .eq. 0 . c c to compute inverse(a) * c where c is a matrix c with p columns c call dgeco(a,lda,n,ipvt,rcond,z) c if (rcond is too small) go to ... c do 10 j = 1, p c call dgesl(a,lda,n,ipvt,c(1,j),0) c 10 continue c c linpack. this version dated 08/14/78 . c cleve moler, university of new mexico, argonne national lab. c c subroutines and functions c c blas daxpy,ddot c c internal variables c double precision ddot,t integer k,kb,l,nm1 c nm1 = n - 1 if (job .ne. 0) go to 50 c c job = 0 , solve a * x = b c first solve l*y = b c if (nm1 .lt. 1) go to 30 do 20 k = 1, nm1 l = ipvt(k) t = b(l) if (l .eq. k) go to 10 b(l) = b(k) b(k) = t 10 continue call daxpy(n-k,t,a(k+1,k),1,b(k+1),1) 20 continue 30 continue c c now solve u*x = y c do 40 kb = 1, n k = n + 1 - kb b(k) = b(k)/a(k,k) t = -b(k) call daxpy(k-1,t,a(1,k),1,b(1),1) 40 continue go to 100 50 continue c c job = nonzero, solve trans(a) * x = b c first solve trans(u)*y = b c do 60 k = 1, n t = ddot(k-1,a(1,k),1,b(1),1) b(k) = (b(k) - t)/a(k,k) 60 continue c c now solve trans(l)*x = y c if (nm1 .lt. 1) go to 90 do 80 kb = 1, nm1 k = n - kb b(k) = b(k) + ddot(n-k,a(k+1,k),1,b(k+1),1) l = ipvt(k) if (l .eq. k) go to 70 t = b(l) b(l) = b(k) b(k) = t 70 continue 80 continue 90 continue 100 continue return end subroutine dgbfa(abd,lda,n,ml,mu,ipvt,info) integer lda,n,ml,mu,ipvt(*),info double precision abd(lda,*) c c dgbfa factors a double precision band matrix by elimination. c c dgbfa is usually called by dgbco, but it can be called c directly with a saving in time if rcond is not needed. c c on entry c c abd double precision(lda, n) c contains the matrix in band storage. the columns c of the matrix are stored in the columns of abd and c the diagonals of the matrix are stored in rows c ml+1 through 2*ml+mu+1 of abd . c see the comments below for details. c c lda integer c the leading dimension of the array abd . c lda must be .ge. 2*ml + mu + 1 . c c n integer c the order of the original matrix. c c ml integer c number of diagonals below the main diagonal. c 0 .le. ml .lt. n . c c mu integer c number of diagonals above the main diagonal. c 0 .le. mu .lt. n . c more efficient if ml .le. mu . c on return c c abd an upper triangular matrix in band storage and c the multipliers which were used to obtain it. c the factorization can be written a = l*u where c l is a product of permutation and unit lower c triangular matrices and u is upper triangular. c c ipvt integer(n) c an integer vector of pivot indices. c c info integer c = 0 normal value. c = k if u(k,k) .eq. 0.0 . this is not an error c condition for this subroutine, but it does c indicate that dgbsl will divide by zero if c called. use rcond in dgbco for a reliable c indication of singularity. c c band storage c c if a is a band matrix, the following program segment c will set up the input. c c ml = (band width below the diagonal) c mu = (band width above the diagonal) c m = ml + mu + 1 c do 20 j = 1, n c i1 = max0(1, j-mu) c i2 = min0(n, j+ml) c do 10 i = i1, i2 c k = i - j + m c abd(k,j) = a(i,j) c 10 continue c 20 continue c c this uses rows ml+1 through 2*ml+mu+1 of abd . c in addition, the first ml rows in abd are used for c elements generated during the triangularization. c the total number of rows needed in abd is 2*ml+mu+1 . c the ml+mu by ml+mu upper left triangle and the c ml by ml lower right triangle are not referenced. c c linpack. this version dated 08/14/78 . c cleve moler, university of new mexico, argonne national lab. c c subroutines and functions c c blas daxpy,dscal,idamax c fortran max0,min0 c c internal variables c double precision t integer i,idamax,i0,j,ju,jz,j0,j1,k,kp1,l,lm,m,mm,nm1 c c m = ml + mu + 1 info = 0 c c zero initial fill-in columns c j0 = mu + 2 j1 = min0(n,m) - 1 if (j1 .lt. j0) go to 30 do 20 jz = j0, j1 i0 = m + 1 - jz do 10 i = i0, ml abd(i,jz) = 0.0d0 10 continue 20 continue 30 continue jz = j1 ju = 0 c c gaussian elimination with partial pivoting c nm1 = n - 1 if (nm1 .lt. 1) go to 130 do 120 k = 1, nm1 kp1 = k + 1 c c zero next fill-in column c jz = jz + 1 if (jz .gt. n) go to 50 if (ml .lt. 1) go to 50 do 40 i = 1, ml abd(i,jz) = 0.0d0 40 continue 50 continue c c find l = pivot index c lm = min0(ml,n-k) l = idamax(lm+1,abd(m,k),1) + m - 1 ipvt(k) = l + k - m c c zero pivot implies this column already triangularized c if (abd(l,k) .eq. 0.0d0) go to 100 c c interchange if necessary c if (l .eq. m) go to 60 t = abd(l,k) abd(l,k) = abd(m,k) abd(m,k) = t 60 continue c c compute multipliers c t = -1.0d0/abd(m,k) call dscal(lm,t,abd(m+1,k),1) c c row elimination with column indexing c ju = min0(max0(ju,mu+ipvt(k)),n) mm = m if (ju .lt. kp1) go to 90 do 80 j = kp1, ju l = l - 1 mm = mm - 1 t = abd(l,j) if (l .eq. mm) go to 70 abd(l,j) = abd(mm,j) abd(mm,j) = t 70 continue call daxpy(lm,t,abd(m+1,k),1,abd(mm+1,j),1) 80 continue 90 continue go to 110 100 continue info = k 110 continue 120 continue 130 continue ipvt(n) = n if (abd(m,n) .eq. 0.0d0) info = n return end subroutine dgbsl(abd,lda,n,ml,mu,ipvt,b,job) integer lda,n,ml,mu,ipvt(*),job double precision abd(lda,*),b(*) c c dgbsl solves the double precision band system c a * x = b or trans(a) * x = b c using the factors computed by dgbco or dgbfa. c c on entry c c abd double precision(lda, n) c the output from dgbco or dgbfa. c c lda integer c the leading dimension of the array abd . c c n integer c the order of the original matrix. c c ml integer c number of diagonals below the main diagonal. c c mu integer c number of diagonals above the main diagonal. c c ipvt integer(n) c the pivot vector from dgbco or dgbfa. c c b double precision(n) c the right hand side vector. c c job integer c = 0 to solve a*x = b , c = nonzero to solve trans(a)*x = b , where c trans(a) is the transpose. c c on return c c b the solution vector x . c c error condition c c a division by zero will occur if the input factor contains a c zero on the diagonal. technically this indicates singularity c but it is often caused by improper arguments or improper c setting of lda . it will not occur if the subroutines are c called correctly and if dgbco has set rcond .gt. 0.0 c or dgbfa has set info .eq. 0 . c c to compute inverse(a) * c where c is a matrix c with p columns c call dgbco(abd,lda,n,ml,mu,ipvt,rcond,z) c if (rcond is too small) go to ... c do 10 j = 1, p c call dgbsl(abd,lda,n,ml,mu,ipvt,c(1,j),0) c 10 continue c c linpack. this version dated 08/14/78 . c cleve moler, university of new mexico, argonne national lab. c c subroutines and functions c c blas daxpy,ddot c fortran min0 c c internal variables c double precision ddot,t integer k,kb,l,la,lb,lm,m,nm1 c m = mu + ml + 1 nm1 = n - 1 if (job .ne. 0) go to 50 c c job = 0 , solve a * x = b c first solve l*y = b c if (ml .eq. 0) go to 30 if (nm1 .lt. 1) go to 30 do 20 k = 1, nm1 lm = min0(ml,n-k) l = ipvt(k) t = b(l) if (l .eq. k) go to 10 b(l) = b(k) b(k) = t 10 continue call daxpy(lm,t,abd(m+1,k),1,b(k+1),1) 20 continue 30 continue c c now solve u*x = y c do 40 kb = 1, n k = n + 1 - kb b(k) = b(k)/abd(m,k) lm = min0(k,m) - 1 la = m - lm lb = k - lm t = -b(k) call daxpy(lm,t,abd(la,k),1,b(lb),1) 40 continue go to 100 50 continue c c job = nonzero, solve trans(a) * x = b c first solve trans(u)*y = b c do 60 k = 1, n lm = min0(k,m) - 1 la = m - lm lb = k - lm t = ddot(lm,abd(la,k),1,b(lb),1) b(k) = (b(k) - t)/abd(m,k) 60 continue c c now solve trans(l)*x = y c if (ml .eq. 0) go to 90 if (nm1 .lt. 1) go to 90 do 80 kb = 1, nm1 k = n - kb lm = min0(ml,n-k) b(k) = b(k) + ddot(lm,abd(m+1,k),1,b(k+1),1) l = ipvt(k) if (l .eq. k) go to 70 t = b(l) b(l) = b(k) b(k) = t 70 continue 80 continue 90 continue 100 continue return end deSolve/src/opkdmain.f0000754000175100001440000125625313131751003014443 0ustar hornikusers*DECK DLSODE SUBROUTINE DLSODE (F, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, ITASK, 1 ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JAC, MF, 2 rpar, ipar) EXTERNAL F, JAC CKS: added rpar, ipar integer ipar(*) double precision rpar(*) INTEGER NEQ, ITOL, ITASK, ISTATE, IOPT, LRW, IWORK, LIW, MF DOUBLE PRECISION Y, T, TOUT, RTOL, ATOL, RWORK DIMENSION NEQ(*), Y(*), RTOL(*), ATOL(*), RWORK(LRW), IWORK(LIW) C***BEGIN PROLOGUE DLSODE C***PURPOSE Livermore Solver for Ordinary Differential Equations. C DLSODE solves the initial-value problem for stiff or C nonstiff systems of first-order ODE's, C dy/dt = f(t,y), or, in component form, C dy(i)/dt = f(i) = f(i,t,y(1),y(2),...,y(N)), i=1,...,N. C***CATEGORY I1A C***TYPE DOUBLE PRECISION (SLSODE-S, DLSODE-D) C***KEYWORDS ORDINARY DIFFERENTIAL EQUATIONS, INITIAL VALUE PROBLEM, C STIFF, NONSTIFF C***AUTHOR Hindmarsh, Alan C., (LLNL) C Center for Applied Scientific Computing, L-561 C Lawrence Livermore National Laboratory C Livermore, CA 94551. C***DESCRIPTION C C NOTE: The "Usage" and "Arguments" sections treat only a subset of C available options, in condensed fashion. The options C covered and the information supplied will support most C standard uses of DLSODE. C C For more sophisticated uses, full details on all options are C given in the concluding section, headed "Long Description." C A synopsis of the DLSODE Long Description is provided at the C beginning of that section; general topics covered are: C - Elements of the call sequence; optional input and output C - Optional supplemental routines in the DLSODE package C - internal COMMON block C C changes by Karline Soetaert. C NOTE for inclusion in R-package: the interface to F, Res and Jac has C been changed: now a double precision and an integer vector C rpar(*) and ipar(*) is also passed. This to allow output of C ordinary output variables. C These changes have been made consistently throughout the code C including subroutines in opkda1.f C *Usage: C Communication between the user and the DLSODE package, for normal C situations, is summarized here. This summary describes a subset C of the available options. See "Long Description" for complete C details, including optional communication, nonstandard options, C and instructions for special situations. C C A sample program is given in the "Examples" section. C C Refer to the argument descriptions for the definitions of the C quantities that appear in the following sample declarations. C C For MF = 10, C PARAMETER (LRW = 20 + 16*NEQ, LIW = 20) C For MF = 21 or 22, C PARAMETER (LRW = 22 + 9*NEQ + NEQ**2, LIW = 20 + NEQ) C For MF = 24 or 25, C PARAMETER (LRW = 22 + 10*NEQ + (2*ML+MU)*NEQ, C * LIW = 20 + NEQ) C C EXTERNAL F, JAC C INTEGER NEQ, ITOL, ITASK, ISTATE, IOPT, LRW, IWORK(LIW), C * LIW, MF C DOUBLE PRECISION Y(NEQ), T, TOUT, RTOL, ATOL(ntol), RWORK(LRW) C C CALL DLSODE (F, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, ITASK, C * ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JAC, MF) C C *Arguments: C F :EXT Name of subroutine for right-hand-side vector f. C This name must be declared EXTERNAL in calling C program. The form of F must be: C C SUBROUTINE F (NEQ, T, Y, YDOT) C INTEGER NEQ C DOUBLE PRECISION T, Y(*), YDOT(*) C C The inputs are NEQ, T, Y. F is to set C C YDOT(i) = f(i,T,Y(1),Y(2),...,Y(NEQ)), C i = 1, ..., NEQ . C C NEQ :IN Number of first-order ODE's. C C Y :INOUT Array of values of the y(t) vector, of length NEQ. C Input: For the first call, Y should contain the C values of y(t) at t = T. (Y is an input C variable only if ISTATE = 1.) C Output: On return, Y will contain the values at the C new t-value. C C T :INOUT Value of the independent variable. On return it C will be the current value of t (normally TOUT). C C TOUT :IN Next point where output is desired (.NE. T). C C ITOL :IN 1 or 2 according as ATOL (below) is a scalar or C an array. C C RTOL :IN Relative tolerance parameter (scalar). C C ATOL :IN Absolute tolerance parameter (scalar or array). C If ITOL = 1, ATOL need not be dimensioned. C If ITOL = 2, ATOL must be dimensioned at least NEQ. C C The estimated local error in Y(i) will be controlled C so as to be roughly less (in magnitude) than C C EWT(i) = RTOL*ABS(Y(i)) + ATOL if ITOL = 1, or C EWT(i) = RTOL*ABS(Y(i)) + ATOL(i) if ITOL = 2. C C Thus the local error test passes if, in each C component, either the absolute error is less than C ATOL (or ATOL(i)), or the relative error is less C than RTOL. C C Use RTOL = 0.0 for pure absolute error control, and C use ATOL = 0.0 (or ATOL(i) = 0.0) for pure relative C error control. Caution: Actual (global) errors may C exceed these local tolerances, so choose them C conservatively. C C ITASK :IN Flag indicating the task DLSODE is to perform. C Use ITASK = 1 for normal computation of output C values of y at t = TOUT. C C ISTATE:INOUT Index used for input and output to specify the state C of the calculation. C Input: C 1 This is the first call for a problem. C 2 This is a subsequent call. C Output: C 1 Nothing was done, because TOUT was equal to T. C 2 DLSODE was successful (otherwise, negative). C Note that ISTATE need not be modified after a C successful return. C -1 Excess work done on this call (perhaps wrong C MF). C -2 Excess accuracy requested (tolerances too C small). C -3 Illegal input detected (see printed message). C -4 Repeated error test failures (check all C inputs). C -5 Repeated convergence failures (perhaps bad C Jacobian supplied or wrong choice of MF or C tolerances). C -6 Error weight became zero during problem C (solution component i vanished, and ATOL or C ATOL(i) = 0.). C C IOPT :IN Flag indicating whether optional inputs are used: C 0 No. C 1 Yes. (See "Optional inputs" under "Long C Description," Part 1.) C C RWORK :WORK Real work array of length at least: C 20 + 16*NEQ for MF = 10, C 22 + 9*NEQ + NEQ**2 for MF = 21 or 22, C 22 + 10*NEQ + (2*ML + MU)*NEQ for MF = 24 or 25. C C LRW :IN Declared length of RWORK (in user's DIMENSION C statement). C C IWORK :WORK Integer work array of length at least: C 20 for MF = 10, C 20 + NEQ for MF = 21, 22, 24, or 25. C C If MF = 24 or 25, input in IWORK(1),IWORK(2) the C lower and upper Jacobian half-bandwidths ML,MU. C C On return, IWORK contains information that may be C of interest to the user: C C Name Location Meaning C ----- --------- ----------------------------------------- C NST IWORK(11) Number of steps taken for the problem so C far. C NFE IWORK(12) Number of f evaluations for the problem C so far. C NJE IWORK(13) Number of Jacobian evaluations (and of C matrix LU decompositions) for the problem C so far. C NQU IWORK(14) Method order last used (successfully). C LENRW IWORK(17) Length of RWORK actually required. This C is defined on normal returns and on an C illegal input return for insufficient C storage. C LENIW IWORK(18) Length of IWORK actually required. This C is defined on normal returns and on an C illegal input return for insufficient C storage. C C LIW :IN Declared length of IWORK (in user's DIMENSION C statement). C C JAC :EXT Name of subroutine for Jacobian matrix (MF = C 21 or 24). If used, this name must be declared C EXTERNAL in calling program. If not used, pass a C dummy name. The form of JAC must be: C C SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD) C INTEGER NEQ, ML, MU, NROWPD C DOUBLE PRECISION T, Y(*), PD(NROWPD,*) C C See item c, under "Description" below for more C information about JAC. C C MF :IN Method flag. Standard values are: C 10 Nonstiff (Adams) method, no Jacobian used. C 21 Stiff (BDF) method, user-supplied full Jacobian. C 22 Stiff method, internally generated full C Jacobian. C 24 Stiff method, user-supplied banded Jacobian. C 25 Stiff method, internally generated banded C Jacobian. C C *Description: C DLSODE solves the initial value problem for stiff or nonstiff C systems of first-order ODE's, C C dy/dt = f(t,y) , C C or, in component form, C C dy(i)/dt = f(i) = f(i,t,y(1),y(2),...,y(NEQ)) C (i = 1, ..., NEQ) . C C DLSODE is a package based on the GEAR and GEARB packages, and on C the October 23, 1978, version of the tentative ODEPACK user C interface standard, with minor modifications. C C The steps in solving such a problem are as follows. C C a. First write a subroutine of the form C C SUBROUTINE F (NEQ, T, Y, YDOT,rpar,ipar) C INTEGER NEQ,ipar(*) C DOUBLE PRECISION T, Y(*), YDOT(*),rpar(*) C C which supplies the vector function f by loading YDOT(i) with C f(i). C C b. Next determine (or guess) whether or not the problem is stiff. C Stiffness occurs when the Jacobian matrix df/dy has an C eigenvalue whose real part is negative and large in magnitude C compared to the reciprocal of the t span of interest. If the C problem is nonstiff, use method flag MF = 10. If it is stiff, C there are four standard choices for MF, and DLSODE requires the C Jacobian matrix in some form. This matrix is regarded either C as full (MF = 21 or 22), or banded (MF = 24 or 25). In the C banded case, DLSODE requires two half-bandwidth parameters ML C and MU. These are, respectively, the widths of the lower and C upper parts of the band, excluding the main diagonal. Thus the C band consists of the locations (i,j) with C C i - ML <= j <= i + MU , C C and the full bandwidth is ML + MU + 1 . C C c. If the problem is stiff, you are encouraged to supply the C Jacobian directly (MF = 21 or 24), but if this is not feasible, C DLSODE will compute it internally by difference quotients (MF = C 22 or 25). If you are supplying the Jacobian, write a C subroutine of the form C C SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD,rpar,ipar) C INTEGER NEQ, ML, MU, NRWOPD,ipar(*) C DOUBLE PRECISION T, Y(*), PD(NROWPD,*),rpar(*) C C which provides df/dy by loading PD as follows: C - For a full Jacobian (MF = 21), load PD(i,j) with df(i)/dy(j), C the partial derivative of f(i) with respect to y(j). (Ignore C the ML and MU arguments in this case.) C - For a banded Jacobian (MF = 24), load PD(i-j+MU+1,j) with C df(i)/dy(j); i.e., load the diagonal lines of df/dy into the C rows of PD from the top down. C - In either case, only nonzero elements need be loaded. C C d. Write a main program that calls subroutine DLSODE once for each C point at which answers are desired. This should also provide C for possible use of logical unit 6 for output of error messages C by DLSODE. C C Before the first call to DLSODE, set ISTATE = 1, set Y and T to C the initial values, and set TOUT to the first output point. To C continue the integration after a successful return, simply C reset TOUT and call DLSODE again. No other parameters need be C reset. C C *Examples: C The following is a simple example problem, with the coding needed C for its solution by DLSODE. The problem is from chemical kinetics, C and consists of the following three rate equations: C C dy1/dt = -.04*y1 + 1.E4*y2*y3 C dy2/dt = .04*y1 - 1.E4*y2*y3 - 3.E7*y2**2 C dy3/dt = 3.E7*y2**2 C C on the interval from t = 0.0 to t = 4.E10, with initial conditions C y1 = 1.0, y2 = y3 = 0. The problem is stiff. C C The following coding solves this problem with DLSODE, using C MF = 21 and printing results at t = .4, 4., ..., 4.E10. It uses C ITOL = 2 and ATOL much smaller for y2 than for y1 or y3 because y2 C has much smaller values. At the end of the run, statistical C quantities of interest are printed. C C EXTERNAL FEX, JEX C INTEGER IOPT, IOUT, ISTATE, ITASK, ITOL, IWORK(23), LIW, LRW, C * MF, NEQ C DOUBLE PRECISION ATOL(3), RTOL, RWORK(58), T, TOUT, Y(3) C NEQ = 3 C Y(1) = 1.D0 C Y(2) = 0.D0 C Y(3) = 0.D0 C T = 0.D0 C TOUT = .4D0 C ITOL = 2 C RTOL = 1.D-4 C ATOL(1) = 1.D-6 C ATOL(2) = 1.D-10 C ATOL(3) = 1.D-6 C ITASK = 1 C ISTATE = 1 C IOPT = 0 C LRW = 58 C LIW = 23 C MF = 21 C DO 40 IOUT = 1,12 C CALL DLSODE (FEX, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, ITASK, C * ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JEX, MF) C WRITE(6,20) T, Y(1), Y(2), Y(3) C 20 FORMAT(' At t =',D12.4,' y =',3D14.6) C IF (ISTATE .LT. 0) GO TO 80 C 40 TOUT = TOUT*10.D0 C WRITE(6,60) IWORK(11), IWORK(12), IWORK(13) C 60 FORMAT(/' No. steps =',i4,', No. f-s =',i4,', No. J-s =',i4) C STOP C 80 WRITE(6,90) ISTATE C 90 FORMAT(///' Error halt.. ISTATE =',I3) C STOP C END C C SUBROUTINE FEX (NEQ, T, Y, YDOT, rpar, ipar) C INTEGER NEQ, ipar(*) C DOUBLE PRECISION T, Y(3), YDOT(3), rpar(*) C YDOT(1) = -.04D0*Y(1) + 1.D4*Y(2)*Y(3) C YDOT(3) = 3.D7*Y(2)*Y(2) C YDOT(2) = -YDOT(1) - YDOT(3) C RETURN C END C C SUBROUTINE JEX (NEQ, T, Y, ML, MU, PD, NRPD, rpar, ipar) C INTEGER NEQ, ML, MU, NRPD, ipar(*) C DOUBLE PRECISION T, Y(3), PD(NRPD,3), rpar(*) C PD(1,1) = -.04D0 C PD(1,2) = 1.D4*Y(3) C PD(1,3) = 1.D4*Y(2) C PD(2,1) = .04D0 C PD(2,3) = -PD(1,3) C PD(3,2) = 6.D7*Y(2) C PD(2,2) = -PD(1,2) - PD(3,2) C RETURN C END C C The output from this program (on a Cray-1 in single precision) C is as follows. C C At t = 4.0000e-01 y = 9.851726e-01 3.386406e-05 1.479357e-02 C At t = 4.0000e+00 y = 9.055142e-01 2.240418e-05 9.446344e-02 C At t = 4.0000e+01 y = 7.158050e-01 9.184616e-06 2.841858e-01 C At t = 4.0000e+02 y = 4.504846e-01 3.222434e-06 5.495122e-01 C At t = 4.0000e+03 y = 1.831701e-01 8.940379e-07 8.168290e-01 C At t = 4.0000e+04 y = 3.897016e-02 1.621193e-07 9.610297e-01 C At t = 4.0000e+05 y = 4.935213e-03 1.983756e-08 9.950648e-01 C At t = 4.0000e+06 y = 5.159269e-04 2.064759e-09 9.994841e-01 C At t = 4.0000e+07 y = 5.306413e-05 2.122677e-10 9.999469e-01 C At t = 4.0000e+08 y = 5.494530e-06 2.197825e-11 9.999945e-01 C At t = 4.0000e+09 y = 5.129458e-07 2.051784e-12 9.999995e-01 C At t = 4.0000e+10 y = -7.170603e-08 -2.868241e-13 1.000000e+00 C C No. steps = 330, No. f-s = 405, No. J-s = 69 C C *Accuracy: C The accuracy of the solution depends on the choice of tolerances C RTOL and ATOL. Actual (global) errors may exceed these local C tolerances, so choose them conservatively. C C *Cautions: C The work arrays should not be altered between calls to DLSODE for C the same problem, except possibly for the conditional and optional C inputs. C C *Portability: C Since NEQ is dimensioned inside DLSODE, some compilers may object C to a call to DLSODE with NEQ a scalar variable. In this event, C use DIMENSION NEQ(1). Similar remarks apply to RTOL and ATOL. C C Note to Cray users: C For maximum efficiency, use the CFT77 compiler. Appropriate C compiler optimization directives have been inserted for CFT77. C C *Reference: C Alan C. Hindmarsh, "ODEPACK, A Systematized Collection of ODE C Solvers," in Scientific Computing, R. S. Stepleman, et al., Eds. C (North-Holland, Amsterdam, 1983), pp. 55-64. C C *Long Description: C The following complete description of the user interface to C DLSODE consists of four parts: C C 1. The call sequence to subroutine DLSODE, which is a driver C routine for the solver. This includes descriptions of both C the call sequence arguments and user-supplied routines. C Following these descriptions is a description of optional C inputs available through the call sequence, and then a C description of optional outputs in the work arrays. C C 2. Descriptions of other routines in the DLSODE package that may C be (optionally) called by the user. These provide the ability C to alter error message handling, save and restore the internal C COMMON, and obtain specified derivatives of the solution y(t). C C 3. Descriptions of COMMON block to be declared in overlay or C similar environments, or to be saved when doing an interrupt C of the problem and continued solution later. C C 4. Description of two routines in the DLSODE package, either of C which the user may replace with his own version, if desired. C These relate to the measurement of errors. C C C Part 1. Call Sequence C ---------------------- C C Arguments C --------- C The call sequence parameters used for input only are C C F, NEQ, TOUT, ITOL, RTOL, ATOL, ITASK, IOPT, LRW, LIW, JAC, MF, C C and those used for both input and output are C C Y, T, ISTATE. C C The work arrays RWORK and IWORK are also used for conditional and C optional inputs and optional outputs. (The term output here C refers to the return from subroutine DLSODE to the user's calling C program.) C C The legality of input parameters will be thoroughly checked on the C initial call for the problem, but not checked thereafter unless a C change in input parameters is flagged by ISTATE = 3 on input. C C The descriptions of the call arguments are as follows. C C F The name of the user-supplied subroutine defining the ODE C system. The system must be put in the first-order form C dy/dt = f(t,y), where f is a vector-valued function of C the scalar t and the vector y. Subroutine F is to compute C the function f. It is to have the form C C SUBROUTINE F (NEQ, T, Y, YDOT,rpar,ipar) C INTEGER NEQ,ipar(*) C DOUBLE PRECISION T, Y(*), YDOT(*),rpar(*) C C where NEQ, T, and Y are input, and the array YDOT = C f(T,Y) is output. Y and YDOT are arrays of length NEQ. C Subroutine F should not alter Y(1),...,Y(NEQ). F must be C declared EXTERNAL in the calling program. C C Subroutine F may access user-defined quantities in C NEQ(2),... and/or in Y(NEQ(1)+1),..., if NEQ is an array C (dimensioned in F) and/or Y has length exceeding NEQ(1). C See the descriptions of NEQ and Y below. C C If quantities computed in the F routine are needed C externally to DLSODE, an extra call to F should be made C for this purpose, for consistent and accurate results. C If only the derivative dy/dt is needed, use DINTDY C instead. C C NEQ The size of the ODE system (number of first-order C ordinary differential equations). Used only for input. C NEQ may be decreased, but not increased, during the C problem. If NEQ is decreased (with ISTATE = 3 on input), C the remaining components of Y should be left undisturbed, C if these are to be accessed in F and/or JAC. C C Normally, NEQ is a scalar, and it is generally referred C to as a scalar in this user interface description. C However, NEQ may be an array, with NEQ(1) set to the C system size. (The DLSODE package accesses only NEQ(1).) C In either case, this parameter is passed as the NEQ C argument in all calls to F and JAC. Hence, if it is an C array, locations NEQ(2),... may be used to store other C integer data and pass it to F and/or JAC. Subroutines C F and/or JAC must include NEQ in a DIMENSION statement C in that case. C C Y A real array for the vector of dependent variables, of C length NEQ or more. Used for both input and output on C the first call (ISTATE = 1), and only for output on C other calls. On the first call, Y must contain the C vector of initial values. On output, Y contains the C computed solution vector, evaluated at T. If desired, C the Y array may be used for other purposes between C calls to the solver. C C This array is passed as the Y argument in all calls to F C and JAC. Hence its length may exceed NEQ, and locations C Y(NEQ+1),... may be used to store other real data and C pass it to F and/or JAC. (The DLSODE package accesses C only Y(1),...,Y(NEQ).) C C T The independent variable. On input, T is used only on C the first call, as the initial point of the integration. C On output, after each call, T is the value at which a C computed solution Y is evaluated (usually the same as C TOUT). On an error return, T is the farthest point C reached. C C TOUT The next value of T at which a computed solution is C desired. Used only for input. C C When starting the problem (ISTATE = 1), TOUT may be equal C to T for one call, then should not equal T for the next C call. For the initial T, an input value of TOUT .NE. T C is used in order to determine the direction of the C integration (i.e., the algebraic sign of the step sizes) C and the rough scale of the problem. Integration in C either direction (forward or backward in T) is permitted. C C If ITASK = 2 or 5 (one-step modes), TOUT is ignored C after the first call (i.e., the first call with C TOUT .NE. T). Otherwise, TOUT is required on every call. C C If ITASK = 1, 3, or 4, the values of TOUT need not be C monotone, but a value of TOUT which backs up is limited C to the current internal T interval, whose endpoints are C TCUR - HU and TCUR. (See "Optional Outputs" below for C TCUR and HU.) C C C ITOL An indicator for the type of error control. See C description below under ATOL. Used only for input. C C RTOL A relative error tolerance parameter, either a scalar or C an array of length NEQ. See description below under C ATOL. Input only. C C ATOL An absolute error tolerance parameter, either a scalar or C an array of length NEQ. Input only. C C The input parameters ITOL, RTOL, and ATOL determine the C error control performed by the solver. The solver will C control the vector e = (e(i)) of estimated local errors C in Y, according to an inequality of the form C C rms-norm of ( e(i)/EWT(i) ) <= 1, C C where C C EWT(i) = RTOL(i)*ABS(Y(i)) + ATOL(i), C C and the rms-norm (root-mean-square norm) here is C C rms-norm(v) = SQRT(sum v(i)**2 / NEQ). C C Here EWT = (EWT(i)) is a vector of weights which must C always be positive, and the values of RTOL and ATOL C should all be nonnegative. The following table gives the C types (scalar/array) of RTOL and ATOL, and the C corresponding form of EWT(i). C C ITOL RTOL ATOL EWT(i) C ---- ------ ------ ----------------------------- C 1 scalar scalar RTOL*ABS(Y(i)) + ATOL C 2 scalar array RTOL*ABS(Y(i)) + ATOL(i) C 3 array scalar RTOL(i)*ABS(Y(i)) + ATOL C 4 array array RTOL(i)*ABS(Y(i)) + ATOL(i) C C When either of these parameters is a scalar, it need not C be dimensioned in the user's calling program. C C If none of the above choices (with ITOL, RTOL, and ATOL C fixed throughout the problem) is suitable, more general C error controls can be obtained by substituting C user-supplied routines for the setting of EWT and/or for C the norm calculation. See Part 4 below. C C If global errors are to be estimated by making a repeated C run on the same problem with smaller tolerances, then all C components of RTOL and ATOL (i.e., of EWT) should be C scaled down uniformly. C C ITASK An index specifying the task to be performed. Input C only. ITASK has the following values and meanings: C 1 Normal computation of output values of y(t) at C t = TOUT (by overshooting and interpolating). C 2 Take one step only and return. C 3 Stop at the first internal mesh point at or beyond C t = TOUT and return. C 4 Normal computation of output values of y(t) at C t = TOUT but without overshooting t = TCRIT. TCRIT C must be input as RWORK(1). TCRIT may be equal to or C beyond TOUT, but not behind it in the direction of C integration. This option is useful if the problem C has a singularity at or beyond t = TCRIT. C 5 Take one step, without passing TCRIT, and return. C TCRIT must be input as RWORK(1). C C Note: If ITASK = 4 or 5 and the solver reaches TCRIT C (within roundoff), it will return T = TCRIT (exactly) to C indicate this (unless ITASK = 4 and TOUT comes before C TCRIT, in which case answers at T = TOUT are returned C first). C C ISTATE An index used for input and output to specify the state C of the calculation. C C On input, the values of ISTATE are as follows: C 1 This is the first call for the problem C (initializations will be done). See "Note" below. C 2 This is not the first call, and the calculation is to C continue normally, with no change in any input C parameters except possibly TOUT and ITASK. (If ITOL, C RTOL, and/or ATOL are changed between calls with C ISTATE = 2, the new values will be used but not C tested for legality.) C 3 This is not the first call, and the calculation is to C continue normally, but with a change in input C parameters other than TOUT and ITASK. Changes are C allowed in NEQ, ITOL, RTOL, ATOL, IOPT, LRW, LIW, MF, C ML, MU, and any of the optional inputs except H0. C (See IWORK description for ML and MU.) C C Note: A preliminary call with TOUT = T is not counted as C a first call here, as no initialization or checking of C input is done. (Such a call is sometimes useful for the C purpose of outputting the initial conditions.) Thus the C first call for which TOUT .NE. T requires ISTATE = 1 on C input. C C On output, ISTATE has the following values and meanings: C 1 Nothing was done, as TOUT was equal to T with C ISTATE = 1 on input. C 2 The integration was performed successfully. C -1 An excessive amount of work (more than MXSTEP steps) C was done on this call, before completing the C requested task, but the integration was otherwise C successful as far as T. (MXSTEP is an optional input C and is normally 500.) To continue, the user may C simply reset ISTATE to a value >1 and call again (the C excess work step counter will be reset to 0). In C addition, the user may increase MXSTEP to avoid this C error return; see "Optional Inputs" below. C -2 Too much accuracy was requested for the precision of C the machine being used. This was detected before C completing the requested task, but the integration C was successful as far as T. To continue, the C tolerance parameters must be reset, and ISTATE must C be set to 3. The optional output TOLSF may be used C for this purpose. (Note: If this condition is C detected before taking any steps, then an illegal C input return (ISTATE = -3) occurs instead.) C -3 Illegal input was detected, before taking any C integration steps. See written message for details. C (Note: If the solver detects an infinite loop of C calls to the solver with illegal input, it will cause C the run to stop.) C -4 There were repeated error-test failures on one C attempted step, before completing the requested task, C but the integration was successful as far as T. The C problem may have a singularity, or the input may be C inappropriate. C -5 There were repeated convergence-test failures on one C attempted step, before completing the requested task, C but the integration was successful as far as T. This C may be caused by an inaccurate Jacobian matrix, if C one is being used. C -6 EWT(i) became zero for some i during the integration. C Pure relative error control (ATOL(i)=0.0) was C requested on a variable which has now vanished. The C integration was successful as far as T. C C Note: Since the normal output value of ISTATE is 2, it C does not need to be reset for normal continuation. Also, C since a negative input value of ISTATE will be regarded C as illegal, a negative output value requires the user to C change it, and possibly other inputs, before calling the C solver again. C C IOPT An integer flag to specify whether any optional inputs C are being used on this call. Input only. The optional C inputs are listed under a separate heading below. C 0 No optional inputs are being used. Default values C will be used in all cases. C 1 One or more optional inputs are being used. C C RWORK A real working array (double precision). The length of C RWORK must be at least C C 20 + NYH*(MAXORD + 1) + 3*NEQ + LWM C C where C NYH = the initial value of NEQ, C MAXORD = 12 (if METH = 1) or 5 (if METH = 2) (unless a C smaller value is given as an optional input), C LWM = 0 if MITER = 0, C LWM = NEQ**2 + 2 if MITER = 1 or 2, C LWM = NEQ + 2 if MITER = 3, and C LWM = (2*ML + MU + 1)*NEQ + 2 C if MITER = 4 or 5. C (See the MF description below for METH and MITER.) C C Thus if MAXORD has its default value and NEQ is constant, C this length is: C 20 + 16*NEQ for MF = 10, C 22 + 16*NEQ + NEQ**2 for MF = 11 or 12, C 22 + 17*NEQ for MF = 13, C 22 + 17*NEQ + (2*ML + MU)*NEQ for MF = 14 or 15, C 20 + 9*NEQ for MF = 20, C 22 + 9*NEQ + NEQ**2 for MF = 21 or 22, C 22 + 10*NEQ for MF = 23, C 22 + 10*NEQ + (2*ML + MU)*NEQ for MF = 24 or 25. C C The first 20 words of RWORK are reserved for conditional C and optional inputs and optional outputs. C C The following word in RWORK is a conditional input: C RWORK(1) = TCRIT, the critical value of t which the C solver is not to overshoot. Required if ITASK C is 4 or 5, and ignored otherwise. See ITASK. C C LRW The length of the array RWORK, as declared by the user. C (This will be checked by the solver.) C C IWORK An integer work array. Its length must be at least C 20 if MITER = 0 or 3 (MF = 10, 13, 20, 23), or C 20 + NEQ otherwise (MF = 11, 12, 14, 15, 21, 22, 24, 25). C (See the MF description below for MITER.) The first few C words of IWORK are used for conditional and optional C inputs and optional outputs. C C The following two words in IWORK are conditional inputs: C IWORK(1) = ML These are the lower and upper half- C IWORK(2) = MU bandwidths, respectively, of the banded C Jacobian, excluding the main diagonal. C The band is defined by the matrix locations C (i,j) with i - ML <= j <= i + MU. ML and MU C must satisfy 0 <= ML,MU <= NEQ - 1. These are C required if MITER is 4 or 5, and ignored C otherwise. ML and MU may in fact be the band C parameters for a matrix to which df/dy is only C approximately equal. C C LIW The length of the array IWORK, as declared by the user. C (This will be checked by the solver.) C C Note: The work arrays must not be altered between calls to DLSODE C for the same problem, except possibly for the conditional and C optional inputs, and except for the last 3*NEQ words of RWORK. C The latter space is used for internal scratch space, and so is C available for use by the user outside DLSODE between calls, if C desired (but not for use by F or JAC). C C JAC The name of the user-supplied routine (MITER = 1 or 4) to C compute the Jacobian matrix, df/dy, as a function of the C scalar t and the vector y. (See the MF description below C for MITER.) It is to have the form C C SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD, rpar, ipar) C integer ipar(*) C DOUBLE PRECISION T, Y(*), PD(NROWPD,*), rpar(*) C C where NEQ, T, Y, ML, MU, and NROWPD are input and the C array PD is to be loaded with partial derivatives C (elements of the Jacobian matrix) on output. PD must be C given a first dimension of NROWPD. T and Y have the same C meaning as in subroutine F. C C In the full matrix case (MITER = 1), ML and MU are C ignored, and the Jacobian is to be loaded into PD in C columnwise manner, with df(i)/dy(j) loaded into PD(i,j). C C In the band matrix case (MITER = 4), the elements within C the band are to be loaded into PD in columnwise manner, C with diagonal lines of df/dy loaded into the rows of PD. C Thus df(i)/dy(j) is to be loaded into PD(i-j+MU+1,j). ML C and MU are the half-bandwidth parameters (see IWORK). C The locations in PD in the two triangular areas which C correspond to nonexistent matrix elements can be ignored C or loaded arbitrarily, as they are overwritten by DLSODE. C C JAC need not provide df/dy exactly. A crude approximation C (possibly with a smaller bandwidth) will do. C C In either case, PD is preset to zero by the solver, so C that only the nonzero elements need be loaded by JAC. C Each call to JAC is preceded by a call to F with the same C arguments NEQ, T, and Y. Thus to gain some efficiency, C intermediate quantities shared by both calculations may C be saved in a user COMMON block by F and not recomputed C by JAC, if desired. Also, JAC may alter the Y array, if C desired. JAC must be declared EXTERNAL in the calling C program. C C Subroutine JAC may access user-defined quantities in C NEQ(2),... and/or in Y(NEQ(1)+1),... if NEQ is an array C (dimensioned in JAC) and/or Y has length exceeding C NEQ(1). See the descriptions of NEQ and Y above. C C MF The method flag. Used only for input. The legal values C of MF are 10, 11, 12, 13, 14, 15, 20, 21, 22, 23, 24, C and 25. MF has decimal digits METH and MITER: C MF = 10*METH + MITER . C C METH indicates the basic linear multistep method: C 1 Implicit Adams method. C 2 Method based on backward differentiation formulas C (BDF's). C C MITER indicates the corrector iteration method: C 0 Functional iteration (no Jacobian matrix is C involved). C 1 Chord iteration with a user-supplied full (NEQ by C NEQ) Jacobian. C 2 Chord iteration with an internally generated C (difference quotient) full Jacobian (using NEQ C extra calls to F per df/dy value). C 3 Chord iteration with an internally generated C diagonal Jacobian approximation (using one extra call C to F per df/dy evaluation). C 4 Chord iteration with a user-supplied banded Jacobian. C 5 Chord iteration with an internally generated banded C Jacobian (using ML + MU + 1 extra calls to F per C df/dy evaluation). C C If MITER = 1 or 4, the user must supply a subroutine JAC C (the name is arbitrary) as described above under JAC. C For other values of MITER, a dummy argument can be used. C C Optional Inputs C --------------- C The following is a list of the optional inputs provided for in the C call sequence. (See also Part 2.) For each such input variable, C this table lists its name as used in this documentation, its C location in the call sequence, its meaning, and the default value. C The use of any of these inputs requires IOPT = 1, and in that case C all of these inputs are examined. A value of zero for any of C these optional inputs will cause the default value to be used. C Thus to use a subset of the optional inputs, simply preload C locations 5 to 10 in RWORK and IWORK to 0.0 and 0 respectively, C and then set those of interest to nonzero values. C C Name Location Meaning and default value C ------ --------- ----------------------------------------------- C H0 RWORK(5) Step size to be attempted on the first step. C The default value is determined by the solver. C HMAX RWORK(6) Maximum absolute step size allowed. The C default value is infinite. C HMIN RWORK(7) Minimum absolute step size allowed. The C default value is 0. (This lower bound is not C enforced on the final step before reaching C TCRIT when ITASK = 4 or 5.) C MAXORD IWORK(5) Maximum order to be allowed. The default value C is 12 if METH = 1, and 5 if METH = 2. (See the C MF description above for METH.) If MAXORD C exceeds the default value, it will be reduced C to the default value. If MAXORD is changed C during the problem, it may cause the current C order to be reduced. C MXSTEP IWORK(6) Maximum number of (internally defined) steps C allowed during one call to the solver. The C default value is 500. C MXHNIL IWORK(7) Maximum number of messages printed (per C problem) warning that T + H = T on a step C (H = step size). This must be positive to C result in a nondefault value. The default C value is 10. C C Optional Outputs C ---------------- C As optional additional output from DLSODE, the variables listed C below are quantities related to the performance of DLSODE which C are available to the user. These are communicated by way of the C work arrays, but also have internal mnemonic names as shown. C Except where stated otherwise, all of these outputs are defined on C any successful return from DLSODE, and on any return with ISTATE = C -1, -2, -4, -5, or -6. On an illegal input return (ISTATE = -3), C they will be unchanged from their existing values (if any), except C possibly for TOLSF, LENRW, and LENIW. On any error return, C outputs relevant to the error will be defined, as noted below. C C Name Location Meaning C ----- --------- ------------------------------------------------ C HU RWORK(11) Step size in t last used (successfully). C HCUR RWORK(12) Step size to be attempted on the next step. C TCUR RWORK(13) Current value of the independent variable which C the solver has actually reached, i.e., the C current internal mesh point in t. On output, C TCUR will always be at least as far as the C argument T, but may be farther (if interpolation C was done). C TOLSF RWORK(14) Tolerance scale factor, greater than 1.0, C computed when a request for too much accuracy C was detected (ISTATE = -3 if detected at the C start of the problem, ISTATE = -2 otherwise). C If ITOL is left unaltered but RTOL and ATOL are C uniformly scaled up by a factor of TOLSF for the C next call, then the solver is deemed likely to C succeed. (The user may also ignore TOLSF and C alter the tolerance parameters in any other way C appropriate.) C NST IWORK(11) Number of steps taken for the problem so far. C NFE IWORK(12) Number of F evaluations for the problem so far. C NJE IWORK(13) Number of Jacobian evaluations (and of matrix LU C decompositions) for the problem so far. C NQU IWORK(14) Method order last used (successfully). C NQCUR IWORK(15) Order to be attempted on the next step. C IMXER IWORK(16) Index of the component of largest magnitude in C the weighted local error vector ( e(i)/EWT(i) ), C on an error return with ISTATE = -4 or -5. C LENRW IWORK(17) Length of RWORK actually required. This is C defined on normal returns and on an illegal C input return for insufficient storage. C LENIW IWORK(18) Length of IWORK actually required. This is C defined on normal returns and on an illegal C input return for insufficient storage. C C The following two arrays are segments of the RWORK array which may C also be of interest to the user as optional outputs. For each C array, the table below gives its internal name, its base address C in RWORK, and its description. C C Name Base address Description C ---- ------------ ---------------------------------------------- C YH 21 The Nordsieck history array, of size NYH by C (NQCUR + 1), where NYH is the initial value of C NEQ. For j = 0,1,...,NQCUR, column j + 1 of C YH contains HCUR**j/factorial(j) times the jth C derivative of the interpolating polynomial C currently representing the solution, evaluated C at t = TCUR. C ACOR LENRW-NEQ+1 Array of size NEQ used for the accumulated C corrections on each step, scaled on output to C represent the estimated local error in Y on C the last step. This is the vector e in the C description of the error control. It is C defined only on successful return from DLSODE. C C C Part 2. Other Callable Routines C -------------------------------- C C The following are optional calls which the user may make to gain C additional capabilities in conjunction with DLSODE. C C Form of call Function C ------------------------ ---------------------------------------- C CALL XSETUN(LUN) Set the logical unit number, LUN, for C output of messages from DLSODE, if the C default is not desired. The default C value of LUN is 6. This call may be made C at any time and will take effect C immediately. C CALL XSETF(MFLAG) Set a flag to control the printing of C messages by DLSODE. MFLAG = 0 means do C not print. (Danger: this risks losing C valuable information.) MFLAG = 1 means C print (the default). This call may be C made at any time and will take effect C immediately. C CALL DSRCOM(RSAV,ISAV,JOB) Saves and restores the contents of the C internal COMMON blocks used by DLSODE C (see Part 3 below). RSAV must be a C real array of length 218 or more, and C ISAV must be an integer array of length C 37 or more. JOB = 1 means save COMMON C into RSAV/ISAV. JOB = 2 means restore C COMMON from same. DSRCOM is useful if C one is interrupting a run and restarting C later, or alternating between two or C more problems solved with DLSODE. C CALL DINTDY(,,,,,) Provide derivatives of y, of various C (see below) orders, at a specified point t, if C desired. It may be called only after a C successful return from DLSODE. Detailed C instructions follow. C C Detailed instructions for using DINTDY C -------------------------------------- C The form of the CALL is: C C CALL DINTDY (T, K, RWORK(21), NYH, DKY, IFLAG) C C The input parameters are: C C T Value of independent variable where answers are C desired (normally the same as the T last returned by C DLSODE). For valid results, T must lie between C TCUR - HU and TCUR. (See "Optional Outputs" above C for TCUR and HU.) C K Integer order of the derivative desired. K must C satisfy 0 <= K <= NQCUR, where NQCUR is the current C order (see "Optional Outputs"). The capability C corresponding to K = 0, i.e., computing y(t), is C already provided by DLSODE directly. Since C NQCUR >= 1, the first derivative dy/dt is always C available with DINTDY. C RWORK(21) The base address of the history array YH. C NYH Column length of YH, equal to the initial value of NEQ. C C The output parameters are: C C DKY Real array of length NEQ containing the computed value C of the Kth derivative of y(t). C IFLAG Integer flag, returned as 0 if K and T were legal, C -1 if K was illegal, and -2 if T was illegal. C On an error return, a message is also written. C C C Part 3. Common Blocks C ---------------------- C C If DLSODE is to be used in an overlay situation, the user must C declare, in the primary overlay, the variables in: C (1) the call sequence to DLSODE, C (2) the internal COMMON block /DLS001/, of length 255 C (218 double precision words followed by 37 integer words). C C If DLSODE is used on a system in which the contents of internal C COMMON blocks are not preserved between calls, the user should C declare the above COMMON block in his main program to insure that C its contents are preserved. C C If the solution of a given problem by DLSODE is to be interrupted C and then later continued, as when restarting an interrupted run or C alternating between two or more problems, the user should save, C following the return from the last DLSODE call prior to the C interruption, the contents of the call sequence variables and the C internal COMMON block, and later restore these values before the C next DLSODE call for that problem. In addition, if XSETUN and/or C XSETF was called for non-default handling of error messages, then C these calls must be repeated. To save and restore the COMMON C block, use subroutine DSRCOM (see Part 2 above). C C C Part 4. Optionally Replaceable Solver Routines C ----------------------------------------------- C C Below are descriptions of two routines in the DLSODE package which C relate to the measurement of errors. Either routine can be C replaced by a user-supplied version, if desired. However, since C such a replacement may have a major impact on performance, it C should be done only when absolutely necessary, and only with great C caution. (Note: The means by which the package version of a C routine is superseded by the user's version may be system- C dependent.) C C DEWSET C ------ C The following subroutine is called just before each internal C integration step, and sets the array of error weights, EWT, as C described under ITOL/RTOL/ATOL above: C C SUBROUTINE DEWSET (NEQ, ITOL, RTOL, ATOL, YCUR, EWT) C C where NEQ, ITOL, RTOL, and ATOL are as in the DLSODE call C sequence, YCUR contains the current dependent variable vector, C and EWT is the array of weights set by DEWSET. C C If the user supplies this subroutine, it must return in EWT(i) C (i = 1,...,NEQ) a positive quantity suitable for comparing errors C in Y(i) to. The EWT array returned by DEWSET is passed to the C DVNORM routine (see below), and also used by DLSODE in the C computation of the optional output IMXER, the diagonal Jacobian C approximation, and the increments for difference quotient C Jacobians. C C In the user-supplied version of DEWSET, it may be desirable to use C the current values of derivatives of y. Derivatives up to order NQ C are available from the history array YH, described above under C optional outputs. In DEWSET, YH is identical to the YCUR array, C extended to NQ + 1 columns with a column length of NYH and scale C factors of H**j/factorial(j). On the first call for the problem, C given by NST = 0, NQ is 1 and H is temporarily set to 1.0. C NYH is the initial value of NEQ. The quantities NQ, H, and NST C can be obtained by including in SEWSET the statements: C DOUBLE PRECISION RLS C COMMON /DLS001/ RLS(218),ILS(37) C NQ = ILS(33) C NST = ILS(34) C H = RLS(212) C Thus, for example, the current value of dy/dt can be obtained as C YCUR(NYH+i)/H (i=1,...,NEQ) (and the division by H is unnecessary C when NST = 0). C C DVNORM C ------ C DVNORM is a real function routine which computes the weighted C root-mean-square norm of a vector v: C C d = DVNORM (n, v, w) C C where: C n = the length of the vector, C v = real array of length n containing the vector, C w = real array of length n containing weights, C d = SQRT( (1/n) * sum(v(i)*w(i))**2 ). C C DVNORM is called with n = NEQ and with w(i) = 1.0/EWT(i), where C EWT is as set by subroutine DEWSET. C C If the user supplies this function, it should return a nonnegative C value of DVNORM suitable for use in the error control in DLSODE. C None of the arguments should be altered by DVNORM. For example, a C user-supplied DVNORM routine might: C - Substitute a max-norm of (v(i)*w(i)) for the rms-norm, or C - Ignore some components of v in the norm, with the effect of C suppressing the error control on those components of Y. C --------------------------------------------------------------------- C***ROUTINES CALLED DEWSET, DINTDY, DUMACH, DSTODE, DVNORM, XERRWD C***COMMON BLOCKS DLS001 C***REVISION HISTORY (YYYYMMDD) C 19791129 DATE WRITTEN C 19791213 Minor changes to declarations; DELP init. in STODE. C 19800118 Treat NEQ as array; integer declarations added throughout; C minor changes to prologue. C 19800306 Corrected TESCO(1,NQP1) setting in CFODE. C 19800519 Corrected access of YH on forced order reduction; C numerous corrections to prologues and other comments. C 19800617 In main driver, added loading of SQRT(UROUND) in RWORK; C minor corrections to main prologue. C 19800923 Added zero initialization of HU and NQU. C 19801218 Revised XERRWD routine; minor corrections to main prologue. C 19810401 Minor changes to comments and an error message. C 19810814 Numerous revisions: replaced EWT by 1/EWT; used flags C JCUR, ICF, IERPJ, IERSL between STODE and subordinates; C added tuning parameters CCMAX, MAXCOR, MSBP, MXNCF; C reorganized returns from STODE; reorganized type decls.; C fixed message length in XERRWD; changed default LUNIT to 6; C changed Common lengths; changed comments throughout. C 19870330 Major update by ACH: corrected comments throughout; C removed TRET from Common; rewrote EWSET with 4 loops; C fixed t test in INTDY; added Cray directives in STODE; C in STODE, fixed DELP init. and logic around PJAC call; C combined routines to save/restore Common; C passed LEVEL = 0 in error message calls (except run abort). C 19890426 Modified prologue to SLATEC/LDOC format. (FNF) C 19890501 Many improvements to prologue. (FNF) C 19890503 A few final corrections to prologue. (FNF) C 19890504 Minor cosmetic changes. (FNF) C 19890510 Corrected description of Y in Arguments section. (FNF) C 19890517 Minor corrections to prologue. (FNF) C 19920514 Updated with prologue edited 891025 by G. Shaw for manual. C 19920515 Converted source lines to upper case. (FNF) C 19920603 Revised XERRWD calls using mixed upper-lower case. (ACH) C 19920616 Revised prologue comment regarding CFT. (ACH) C 19921116 Revised prologue comments regarding Common. (ACH). C 19930326 Added comment about non-reentrancy. (FNF) C 19930723 Changed D1MACH to DUMACH. (FNF) C 19930801 Removed ILLIN and NTREP from Common (affects driver logic); C minor changes to prologue and internal comments; C changed Hollerith strings to quoted strings; C changed internal comments to mixed case; C replaced XERRWD with new version using character type; C changed dummy dimensions from 1 to *. (ACH) C 19930809 Changed to generic intrinsic names; changed names of C subprograms and Common blocks to DLSODE etc. (ACH) C 19930929 Eliminated use of REAL intrinsic; other minor changes. (ACH) C 20010412 Removed all 'own' variables from Common block /DLS001/ C (affects declarations in 6 routines). (ACH) C 20010509 Minor corrections to prologue. (ACH) C 20031105 Restored 'own' variables to Common block /DLS001/, to C enable interrupt/restart feature. (ACH) C 20031112 Added SAVE statements for data-loaded constants. C C***END PROLOGUE DLSODE C C*Internal Notes: C C Other Routines in the DLSODE Package. C C In addition to Subroutine DLSODE, the DLSODE package includes the C following subroutines and function routines: C DINTDY computes an interpolated value of the y vector at t = TOUT. C DSTODE is the core integrator, which does one step of the C integration and the associated error control. C DCFODE sets all method coefficients and test constants. C DPREPJ computes and preprocesses the Jacobian matrix J = df/dy C and the Newton iteration matrix P = I - h*l0*J. C DSOLSY manages solution of linear system in chord iteration. C DEWSET sets the error weight vector EWT before each step. C DVNORM computes the weighted R.M.S. norm of a vector. C DSRCOM is a user-callable routine to save and restore C the contents of the internal Common block. C DGEFA and DGESL are routines from LINPACK for solving full C systems of linear algebraic equations. C DGBFA and DGBSL are routines from LINPACK for solving banded C linear systems. C DUMACH computes the unit roundoff in a machine-independent manner. C XERRWD, XSETUN, XSETF, IXSAV, IUMACH handle the printing of all C error messages and warnings. XERRWD is machine-dependent. C Note: DVNORM, DUMACH, IXSAV, and IUMACH are function routines. C All the others are subroutines. C C**End C C Declare externals. EXTERNAL DPREPJ, DSOLSY DOUBLE PRECISION DUMACH, DVNORM C C Declare all other variables. INTEGER INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, IOWNS, 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU INTEGER I, I1, I2, IFLAG, IMXER, KGO, LF0, 1 LENIW, LENRW, LENWM, ML, MORD, MU, MXHNL0, MXSTP0 DOUBLE PRECISION ROWNS, 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND DOUBLE PRECISION ATOLI, AYI, BIG, EWTI, H0, HMAX, HMX, RH, RTOLI, 1 TCRIT, TDIST, TNEXT, TOL, TOLSF, TP, SIZE, SUM, W0 DIMENSION MORD(2) LOGICAL IHIT CHARACTER(LEN=80) MSG SAVE MORD, MXSTP0, MXHNL0 C----------------------------------------------------------------------- C The following internal Common block contains C (a) variables which are local to any subroutine but whose values must C be preserved between calls to the routine ("own" variables), and C (b) variables which are communicated between subroutines. C The block DLS001 is declared in subroutines DLSODE, DINTDY, DSTODE, C DPREPJ, and DSOLSY. C Groups of variables are replaced by dummy arrays in the Common C declarations in routines where those variables are not used. C----------------------------------------------------------------------- COMMON /DLS001/ ROWNS(209), 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 2 INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, IOWNS(6), 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU C DATA MORD(1),MORD(2)/12,5/, MXSTP0/500/, MXHNL0/10/ C----------------------------------------------------------------------- C Block A. C This code block is executed on every call. C It tests ISTATE and ITASK for legality and branches appropriately. C If ISTATE .GT. 1 but the flag INIT shows that initialization has C not yet been done, an error return occurs. C If ISTATE = 1 and TOUT = T, return immediately. C----------------------------------------------------------------------- C C***FIRST EXECUTABLE STATEMENT DLSODE IF (ISTATE .LT. 1 .OR. ISTATE .GT. 3) GO TO 601 IF (ITASK .LT. 1 .OR. ITASK .GT. 5) GO TO 602 IF (ISTATE .EQ. 1) GO TO 10 IF (INIT .EQ. 0) GO TO 603 IF (ISTATE .EQ. 2) GO TO 200 GO TO 20 10 INIT = 0 IF (TOUT .EQ. T) RETURN C----------------------------------------------------------------------- C Block B. C The next code block is executed for the initial call (ISTATE = 1), C or for a continuation call with parameter changes (ISTATE = 3). C It contains checking of all inputs and various initializations. C C First check legality of the non-optional inputs NEQ, ITOL, IOPT, C MF, ML, and MU. C----------------------------------------------------------------------- 20 IF (NEQ(1) .LE. 0) GO TO 604 IF (ISTATE .EQ. 1) GO TO 25 IF (NEQ(1) .GT. N) GO TO 605 25 N = NEQ(1) IF (ITOL .LT. 1 .OR. ITOL .GT. 4) GO TO 606 IF (IOPT .LT. 0 .OR. IOPT .GT. 1) GO TO 607 METH = MF/10 MITER = MF - 10*METH IF (METH .LT. 1 .OR. METH .GT. 2) GO TO 608 IF (MITER .LT. 0 .OR. MITER .GT. 5) GO TO 608 IF (MITER .LE. 3) GO TO 30 ML = IWORK(1) MU = IWORK(2) IF (ML .LT. 0 .OR. ML .GE. N) GO TO 609 IF (MU .LT. 0 .OR. MU .GE. N) GO TO 610 30 CONTINUE C Next process and check the optional inputs. -------------------------- IF (IOPT .EQ. 1) GO TO 40 MAXORD = MORD(METH) MXSTEP = MXSTP0 MXHNIL = MXHNL0 IF (ISTATE .EQ. 1) H0 = 0.0D0 HMXI = 0.0D0 HMIN = 0.0D0 GO TO 60 40 MAXORD = IWORK(5) IF (MAXORD .LT. 0) GO TO 611 IF (MAXORD .EQ. 0) MAXORD = 100 MAXORD = MIN(MAXORD,MORD(METH)) MXSTEP = IWORK(6) IF (MXSTEP .LT. 0) GO TO 612 IF (MXSTEP .EQ. 0) MXSTEP = MXSTP0 MXHNIL = IWORK(7) IF (MXHNIL .LT. 0) GO TO 613 IF (MXHNIL .EQ. 0) MXHNIL = MXHNL0 IF (ISTATE .NE. 1) GO TO 50 H0 = RWORK(5) IF ((TOUT - T)*H0 .LT. 0.0D0) GO TO 614 50 HMAX = RWORK(6) IF (HMAX .LT. 0.0D0) GO TO 615 HMXI = 0.0D0 IF (HMAX .GT. 0.0D0) HMXI = 1.0D0/HMAX HMIN = RWORK(7) IF (HMIN .LT. 0.0D0) GO TO 616 C----------------------------------------------------------------------- C Set work array pointers and check lengths LRW and LIW. C Pointers to segments of RWORK and IWORK are named by prefixing L to C the name of the segment. E.g., the segment YH starts at RWORK(LYH). C Segments of RWORK (in order) are denoted YH, WM, EWT, SAVF, ACOR. C----------------------------------------------------------------------- 60 LYH = 21 IF (ISTATE .EQ. 1) NYH = N LWM = LYH + (MAXORD + 1)*NYH IF (MITER .EQ. 0) LENWM = 0 IF (MITER .EQ. 1 .OR. MITER .EQ. 2) LENWM = N*N + 2 IF (MITER .EQ. 3) LENWM = N + 2 IF (MITER .GE. 4) LENWM = (2*ML + MU + 1)*N + 2 LEWT = LWM + LENWM LSAVF = LEWT + N LACOR = LSAVF + N LENRW = LACOR + N - 1 IWORK(17) = LENRW LIWM = 1 LENIW = 20 + N IF (MITER .EQ. 0 .OR. MITER .EQ. 3) LENIW = 20 IWORK(18) = LENIW IF (LENRW .GT. LRW) GO TO 617 IF (LENIW .GT. LIW) GO TO 618 C Check RTOL and ATOL for legality. ------------------------------------ RTOLI = RTOL(1) ATOLI = ATOL(1) DO 70 I = 1,N IF (ITOL .GE. 3) RTOLI = RTOL(I) IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) IF (RTOLI .LT. 0.0D0) GO TO 619 IF (ATOLI .LT. 0.0D0) GO TO 620 70 CONTINUE IF (ISTATE .EQ. 1) GO TO 100 C If ISTATE = 3, set flag to signal parameter changes to DSTODE. ------- JSTART = -1 IF (NQ .LE. MAXORD) GO TO 90 C MAXORD was reduced below NQ. Copy YH(*,MAXORD+2) into SAVF. --------- DO 80 I = 1,N RWORK(I+LSAVF-1) = RWORK(I+LWM-1) 80 CONTINUE C Reload WM(1) = RWORK(LWM), since LWM may have changed. --------------- 90 IF (MITER .GT. 0) RWORK(LWM) = SQRT(UROUND) IF (N .EQ. NYH) GO TO 200 C NEQ was reduced. Zero part of YH to avoid undefined references. ----- I1 = LYH + L*NYH I2 = LYH + (MAXORD + 1)*NYH - 1 IF (I1 .GT. I2) GO TO 200 DO 95 I = I1,I2 RWORK(I) = 0.0D0 95 CONTINUE GO TO 200 C----------------------------------------------------------------------- C Block C. C The next block is for the initial call only (ISTATE = 1). C It contains all remaining initializations, the initial call to F, C and the calculation of the initial step size. C The error weights in EWT are inverted after being loaded. C----------------------------------------------------------------------- 100 UROUND = DUMACH() TN = T IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 110 TCRIT = RWORK(1) IF ((TCRIT - TOUT)*(TOUT - T) .LT. 0.0D0) GO TO 625 IF (H0 .NE. 0.0D0 .AND. (T + H0 - TCRIT)*H0 .GT. 0.0D0) 1 H0 = TCRIT - T 110 JSTART = 0 IF (MITER .GT. 0) RWORK(LWM) = SQRT(UROUND) NHNIL = 0 NST = 0 NJE = 0 NSLAST = 0 HU = 0.0D0 NQU = 0 CCMAX = 0.3D0 MAXCOR = 3 MSBP = 20 MXNCF = 10 C Initial call to F. (LF0 points to YH(*,2).) ------------------------- LF0 = LYH + NYH CALL F (NEQ, T, Y, RWORK(LF0), rpar, ipar) NFE = 1 C Load the initial value vector in YH. --------------------------------- DO 115 I = 1,N RWORK(I+LYH-1) = Y(I) 115 CONTINUE C Load and invert the EWT array. (H is temporarily set to 1.0.) ------- NQ = 1 H = 1.0D0 CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) DO 120 I = 1,N IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 621 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 120 CONTINUE C----------------------------------------------------------------------- C The coding below computes the step size, H0, to be attempted on the C first step, unless the user has supplied a value for this. C First check that TOUT - T differs significantly from zero. C A scalar tolerance quantity TOL is computed, as MAX(RTOL(I)) C if this is positive, or MAX(ATOL(I)/ABS(Y(I))) otherwise, adjusted C so as to be between 100*UROUND and 1.0E-3. C Then the computed value H0 is given by.. C NEQ C H0**2 = TOL / ( w0**-2 + (1/NEQ) * SUM ( f(i)/ywt(i) )**2 ) C 1 C where w0 = MAX ( ABS(T), ABS(TOUT) ), C f(i) = i-th component of initial value of f, C ywt(i) = EWT(i)/TOL (a weight for y(i)). C The sign of H0 is inferred from the initial values of TOUT and T. C----------------------------------------------------------------------- IF (H0 .NE. 0.0D0) GO TO 180 TDIST = ABS(TOUT - T) W0 = MAX(ABS(T),ABS(TOUT)) IF (TDIST .LT. 2.0D0*UROUND*W0) GO TO 622 TOL = RTOL(1) IF (ITOL .LE. 2) GO TO 140 DO 130 I = 1,N TOL = MAX(TOL,RTOL(I)) 130 CONTINUE 140 IF (TOL .GT. 0.0D0) GO TO 160 ATOLI = ATOL(1) DO 150 I = 1,N IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) AYI = ABS(Y(I)) IF (AYI .NE. 0.0D0) TOL = MAX(TOL,ATOLI/AYI) 150 CONTINUE 160 TOL = MAX(TOL,100.0D0*UROUND) TOL = MIN(TOL,0.001D0) SUM = DVNORM (N, RWORK(LF0), RWORK(LEWT)) SUM = 1.0D0/(TOL*W0*W0) + TOL*SUM**2 H0 = 1.0D0/SQRT(SUM) H0 = MIN(H0,TDIST) H0 = SIGN(H0,TOUT-T) C Adjust H0 if necessary to meet HMAX bound. --------------------------- 180 RH = ABS(H0)*HMXI IF (RH .GT. 1.0D0) H0 = H0/RH C Load H with H0 and scale YH(*,2) by H0. ------------------------------ H = H0 DO 190 I = 1,N RWORK(I+LF0-1) = H0*RWORK(I+LF0-1) 190 CONTINUE GO TO 270 C----------------------------------------------------------------------- C Block D. C The next code block is for continuation calls only (ISTATE = 2 or 3) C and is to check stop conditions before taking a step. C----------------------------------------------------------------------- 200 NSLAST = NST IF (ITASK .EQ. 1) THEN GOTO 210 ELSE IF (ITASK .EQ. 2) THEN GOTO 250 ELSE IF (ITASK .EQ. 3) THEN GOTO 220 ELSE IF (ITASK .EQ. 4) THEN GOTO 230 ELSE IF (ITASK .EQ. 5) THEN GOTO 240 ENDIF C GO TO (210, 250, 220, 230, 240), ITASK 210 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) IF (IFLAG .NE. 0) GO TO 627 T = TOUT GO TO 420 220 TP = TN - HU*(1.0D0 + 100.0D0*UROUND) IF ((TP - TOUT)*H .GT. 0.0D0) GO TO 623 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 GO TO 400 230 TCRIT = RWORK(1) IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 IF ((TCRIT - TOUT)*H .LT. 0.0D0) GO TO 625 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 245 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) IF (IFLAG .NE. 0) GO TO 627 T = TOUT GO TO 420 240 TCRIT = RWORK(1) IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 245 HMX = ABS(TN) + ABS(H) IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX IF (IHIT) GO TO 400 TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) IF (ISTATE .EQ. 2) JSTART = -2 C----------------------------------------------------------------------- C Block E. C The next block is normally executed for all calls and contains C the call to the one-step core integrator DSTODE. C C This is a looping point for the integration steps. C C First check for too many steps being taken, update EWT (if not at C start of problem), check for too much accuracy being requested, and C check for H below the roundoff level in T. C----------------------------------------------------------------------- 250 CONTINUE IF ((NST-NSLAST) .GE. MXSTEP) GO TO 500 CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) DO 260 I = 1,N IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 510 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 260 CONTINUE 270 TOLSF = UROUND*DVNORM (N, RWORK(LYH), RWORK(LEWT)) IF (TOLSF .LE. 1.0D0) GO TO 280 TOLSF = TOLSF*2.0D0 IF (NST .EQ. 0) GO TO 626 GO TO 520 280 IF ((TN + H) .NE. TN) GO TO 290 NHNIL = NHNIL + 1 IF (NHNIL .GT. MXHNIL) GO TO 290 MSG = 'DLSODE- Warning..internal T (=R1) and H (=R2) are' CALL XERRWD (MSG, 50, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' such that in the machine, T + H = T on the next step ' CALL XERRWD (MSG, 60, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' (H = step size). Solver will continue anyway' CALL XERRWD (MSG, 50, 101, 0, 0, 0, 0, 2, TN, H) IF (NHNIL .LT. MXHNIL) GO TO 290 MSG = 'DLSODE- Above warning has been issued I1 times. ' CALL XERRWD (MSG, 50, 102, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' It will not be issued again for this problem' CALL XERRWD (MSG, 50, 102, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0) 290 CONTINUE C----------------------------------------------------------------------- C CALL DSTODE(NEQ,Y,YH,NYH,YH,EWT,SAVF,ACOR,WM,IWM,F,JAC,DPREPJ,DSOLSY) C----------------------------------------------------------------------- CALL DSTODE (NEQ, Y, RWORK(LYH), NYH, RWORK(LYH), RWORK(LEWT), 1 RWORK(LSAVF), RWORK(LACOR), RWORK(LWM), IWORK(LIWM), 2 F, JAC, DPREPJ, DSOLSY, rpar,ipar) KGO = 1 - KFLAG IF (KGO .EQ. 1) THEN GOTO 300 ELSE IF (KGO .EQ. 2) THEN GOTO 530 ELSE IF (KGO .EQ. 3) THEN GOTO 540 ENDIF C GO TO (300, 530, 540), KGO C----------------------------------------------------------------------- C Block F. C The following block handles the case of a successful return from the C core integrator (KFLAG = 0). Test for stop conditions. C----------------------------------------------------------------------- 300 INIT = 1 IF (ITASK .EQ. 1) THEN GOTO 310 ELSE IF (ITASK .EQ. 2) THEN GOTO 400 ELSE IF (ITASK .EQ. 3) THEN GOTO 330 ELSE IF (ITASK .EQ. 4) THEN GOTO 340 ELSE IF (ITASK .EQ. 5) THEN GOTO 350 ENDIF C karline: change from C GO TO (310, 400, 330, 340, 350), ITASK C ITASK = 1. If TOUT has been reached, interpolate. ------------------- 310 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) T = TOUT GO TO 420 C ITASK = 3. Jump to exit if TOUT was reached. ------------------------ 330 IF ((TN - TOUT)*H .GE. 0.0D0) GO TO 400 GO TO 250 C ITASK = 4. See if TOUT or TCRIT was reached. Adjust H if necessary. 340 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 345 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) T = TOUT GO TO 420 345 HMX = ABS(TN) + ABS(H) IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX IF (IHIT) GO TO 400 TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) JSTART = -2 GO TO 250 C ITASK = 5. See if TCRIT was reached and jump to exit. --------------- 350 HMX = ABS(TN) + ABS(H) IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX C----------------------------------------------------------------------- C Block G. C The following block handles all successful returns from DLSODE. C If ITASK .NE. 1, Y is loaded from YH and T is set accordingly. C ISTATE is set to 2, and the optional outputs are loaded into the C work arrays before returning. C----------------------------------------------------------------------- 400 DO 410 I = 1,N Y(I) = RWORK(I+LYH-1) 410 CONTINUE T = TN IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 420 IF (IHIT) T = TCRIT 420 ISTATE = 2 RWORK(11) = HU RWORK(12) = H RWORK(13) = TN IWORK(11) = NST IWORK(12) = NFE IWORK(13) = NJE IWORK(14) = NQU IWORK(15) = NQ RETURN C----------------------------------------------------------------------- C Block H. C The following block handles all unsuccessful returns other than C those for illegal input. First the error message routine is called. C If there was an error test or convergence test failure, IMXER is set. C Then Y is loaded from YH and T is set to TN. The optional outputs C are loaded into the work arrays before returning. C----------------------------------------------------------------------- C The maximum number of steps was taken before reaching TOUT. ---------- 500 MSG = 'DLSODE- At current T (=R1), MXSTEP (=I1) steps ' CALL XERRWD (MSG, 50, 201, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' taken on this call before reaching TOUT ' CALL XERRWD (MSG, 50, 201, 0, 1, MXSTEP, 0, 1, TN, 0.0D0) ISTATE = -1 GO TO 580 C EWT(I) .LE. 0.0 for some I (not at start of problem). ---------------- 510 EWTI = RWORK(LEWT+I-1) MSG = 'DLSODE- At T (=R1), EWT(I1) has become R2 .LE. 0.' CALL XERRWD (MSG, 50, 202, 0, 1, I, 0, 2, TN, EWTI) ISTATE = -6 GO TO 580 C Too much accuracy requested for machine precision. ------------------- 520 MSG = 'DLSODE- At T (=R1), too much accuracy requested ' CALL XERRWD (MSG, 50, 203, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' for precision of machine.. see TOLSF (=R2) ' CALL XERRWD (MSG, 50, 203, 0, 0, 0, 0, 2, TN, TOLSF) RWORK(14) = TOLSF ISTATE = -2 GO TO 580 C KFLAG = -1. Error test failed repeatedly or with ABS(H) = HMIN. ----- 530 MSG = 'DLSODE- At T(=R1) and step size H(=R2), the error' CALL XERRWD (MSG, 50, 204, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' test failed repeatedly or with ABS(H) = HMIN' CALL XERRWD (MSG, 50, 204, 0, 0, 0, 0, 2, TN, H) ISTATE = -4 GO TO 560 C KFLAG = -2. Convergence failed repeatedly or with ABS(H) = HMIN. ---- 540 MSG = 'DLSODE- At T (=R1) and step size H (=R2), the ' CALL XERRWD (MSG, 50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' corrector convergence failed repeatedly ' CALL XERRWD (MSG, 50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' or with ABS(H) = HMIN ' CALL XERRWD (MSG, 30, 205, 0, 0, 0, 0, 2, TN, H) ISTATE = -5 C Compute IMXER if relevant. ------------------------------------------- 560 BIG = 0.0D0 IMXER = 1 DO 570 I = 1,N SIZE = ABS(RWORK(I+LACOR-1)*RWORK(I+LEWT-1)) IF (BIG .GE. SIZE) GO TO 570 BIG = SIZE IMXER = I 570 CONTINUE IWORK(16) = IMXER C Set Y vector, T, and optional outputs. ------------------------------- 580 DO 590 I = 1,N Y(I) = RWORK(I+LYH-1) 590 CONTINUE T = TN RWORK(11) = HU RWORK(12) = H RWORK(13) = TN IWORK(11) = NST IWORK(12) = NFE IWORK(13) = NJE IWORK(14) = NQU IWORK(15) = NQ RETURN C----------------------------------------------------------------------- C Block I. C The following block handles all error returns due to illegal input C (ISTATE = -3), as detected before calling the core integrator. C First the error message routine is called. If the illegal input C is a negative ISTATE, the run is aborted (apparent infinite loop). C----------------------------------------------------------------------- 601 MSG = 'DLSODE- ISTATE (=I1) illegal ' CALL XERRWD (MSG, 30, 1, 0, 1, ISTATE, 0, 0, 0.0D0, 0.0D0) IF (ISTATE .LT. 0) GO TO 800 GO TO 700 602 MSG = 'DLSODE- ITASK (=I1) illegal ' CALL XERRWD (MSG, 30, 2, 0, 1, ITASK, 0, 0, 0.0D0, 0.0D0) GO TO 700 603 MSG = 'DLSODE- ISTATE .GT. 1 but DLSODE not initialized ' CALL XERRWD (MSG, 50, 3, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) GO TO 700 604 MSG = 'DLSODE- NEQ (=I1) .LT. 1 ' CALL XERRWD (MSG, 30, 4, 0, 1, NEQ(1), 0, 0, 0.0D0, 0.0D0) GO TO 700 605 MSG = 'DLSODE- ISTATE = 3 and NEQ increased (I1 to I2) ' CALL XERRWD (MSG, 50, 5, 0, 2, N, NEQ(1), 0, 0.0D0, 0.0D0) GO TO 700 606 MSG = 'DLSODE- ITOL (=I1) illegal ' CALL XERRWD (MSG, 30, 6, 0, 1, ITOL, 0, 0, 0.0D0, 0.0D0) GO TO 700 607 MSG = 'DLSODE- IOPT (=I1) illegal ' CALL XERRWD (MSG, 30, 7, 0, 1, IOPT, 0, 0, 0.0D0, 0.0D0) GO TO 700 608 MSG = 'DLSODE- MF (=I1) illegal ' CALL XERRWD (MSG, 30, 8, 0, 1, MF, 0, 0, 0.0D0, 0.0D0) GO TO 700 609 MSG = 'DLSODE- ML (=I1) illegal.. .LT.0 or .GE.NEQ (=I2)' CALL XERRWD (MSG, 50, 9, 0, 2, ML, NEQ(1), 0, 0.0D0, 0.0D0) GO TO 700 610 MSG = 'DLSODE- MU (=I1) illegal.. .LT.0 or .GE.NEQ (=I2)' CALL XERRWD (MSG, 50, 10, 0, 2, MU, NEQ(1), 0, 0.0D0, 0.0D0) GO TO 700 611 MSG = 'DLSODE- MAXORD (=I1) .LT. 0 ' CALL XERRWD (MSG, 30, 11, 0, 1, MAXORD, 0, 0, 0.0D0, 0.0D0) GO TO 700 612 MSG = 'DLSODE- MXSTEP (=I1) .LT. 0 ' CALL XERRWD (MSG, 30, 12, 0, 1, MXSTEP, 0, 0, 0.0D0, 0.0D0) GO TO 700 613 MSG = 'DLSODE- MXHNIL (=I1) .LT. 0 ' CALL XERRWD (MSG, 30, 13, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0) GO TO 700 614 MSG = 'DLSODE- TOUT (=R1) behind T (=R2) ' CALL XERRWD (MSG, 40, 14, 0, 0, 0, 0, 2, TOUT, T) MSG = ' Integration direction is given by H0 (=R1) ' CALL XERRWD (MSG, 50, 14, 0, 0, 0, 0, 1, H0, 0.0D0) GO TO 700 615 MSG = 'DLSODE- HMAX (=R1) .LT. 0.0 ' CALL XERRWD (MSG, 30, 15, 0, 0, 0, 0, 1, HMAX, 0.0D0) GO TO 700 616 MSG = 'DLSODE- HMIN (=R1) .LT. 0.0 ' CALL XERRWD (MSG, 30, 16, 0, 0, 0, 0, 1, HMIN, 0.0D0) GO TO 700 617 CONTINUE MSG='DLSODE- RWORK length needed, LENRW (=I1), exceeds LRW (=I2)' CALL XERRWD (MSG, 60, 17, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) GO TO 700 618 CONTINUE MSG='DLSODE- IWORK length needed, LENIW (=I1), exceeds LIW (=I2)' CALL XERRWD (MSG, 60, 18, 0, 2, LENIW, LIW, 0, 0.0D0, 0.0D0) GO TO 700 619 MSG = 'DLSODE- RTOL(I1) is R1 .LT. 0.0 ' CALL XERRWD (MSG, 40, 19, 0, 1, I, 0, 1, RTOLI, 0.0D0) GO TO 700 620 MSG = 'DLSODE- ATOL(I1) is R1 .LT. 0.0 ' CALL XERRWD (MSG, 40, 20, 0, 1, I, 0, 1, ATOLI, 0.0D0) GO TO 700 621 EWTI = RWORK(LEWT+I-1) MSG = 'DLSODE- EWT(I1) is R1 .LE. 0.0 ' CALL XERRWD (MSG, 40, 21, 0, 1, I, 0, 1, EWTI, 0.0D0) GO TO 700 622 CONTINUE MSG='DLSODE- TOUT (=R1) too close to T(=R2) to start integration' CALL XERRWD (MSG, 60, 22, 0, 0, 0, 0, 2, TOUT, T) GO TO 700 623 CONTINUE MSG='DLSODE- ITASK = I1 and TOUT (=R1) behind TCUR - HU (= R2) ' CALL XERRWD (MSG, 60, 23, 0, 1, ITASK, 0, 2, TOUT, TP) GO TO 700 624 CONTINUE MSG='DLSODE- ITASK = 4 OR 5 and TCRIT (=R1) behind TCUR (=R2) ' CALL XERRWD (MSG, 60, 24, 0, 0, 0, 0, 2, TCRIT, TN) GO TO 700 625 CONTINUE MSG='DLSODE- ITASK = 4 or 5 and TCRIT (=R1) behind TOUT (=R2) ' CALL XERRWD (MSG, 60, 25, 0, 0, 0, 0, 2, TCRIT, TOUT) GO TO 700 626 MSG = 'DLSODE- At start of problem, too much accuracy ' CALL XERRWD (MSG, 50, 26, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' requested for precision of machine.. See TOLSF (=R1) ' CALL XERRWD (MSG, 60, 26, 0, 0, 0, 0, 1, TOLSF, 0.0D0) RWORK(14) = TOLSF GO TO 700 627 MSG = 'DLSODE- Trouble in DINTDY. ITASK = I1, TOUT = R1' CALL XERRWD (MSG, 50, 27, 0, 1, ITASK, 0, 1, TOUT, 0.0D0) C 700 ISTATE = -3 RETURN C 800 MSG = 'DLSODE- Run aborted.. apparent infinite loop ' CALL XERRWD (MSG, 50, 303, 2, 0, 0, 0, 0, 0.0D0, 0.0D0) RETURN C----------------------- END OF SUBROUTINE DLSODE ---------------------- END *DECK DLSODES SUBROUTINE DLSODES (F, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, ITASK, 1 ISTATE, IOPT, RWORK, LRW, IWORK, LIW,IWK, JAC, MF, rpar, 2 ipar) EXTERNAL F, JAC CKS: added rpar, ipar integer ipar(*) double precision rpar(*) INTEGER NEQ, ITOL, ITASK, ISTATE, IOPT, LRW, IWORK, LIW, MF DOUBLE PRECISION Y, T, TOUT, RTOL, ATOL, RWORK INTEGER IWK(2*LRW) DIMENSION NEQ(*), Y(*), RTOL(*), ATOL(*), RWORK(LRW), IWORK(LIW) C----------------------------------------------------------------------- C This is the 12 November 2003 version of C DLSODES: Livermore Solver for Ordinary Differential Equations C with general Sparse Jacobian matrix. C C This version is in double precision. C C DLSODES solves the initial value problem for stiff or nonstiff C systems of first order ODEs, C dy/dt = f(t,y) , or, in component form, C dy(i)/dt = f(i) = f(i,t,y(1),y(2),...,y(NEQ)) (i = 1,...,NEQ). C DLSODES is a variant of the DLSODE package, and is intended for C problems in which the Jacobian matrix df/dy has an arbitrary C sparse structure (when the problem is stiff). C C Authors: Alan C. Hindmarsh C Center for Applied Scientific Computing, L-561 C Lawrence Livermore National Laboratory C Livermore, CA 94551 C and C Andrew H. Sherman C J. S. Nolen and Associates C Houston, TX 77084 C----------------------------------------------------------------------- C References: C 1. Alan C. Hindmarsh, ODEPACK, A Systematized Collection of ODE C Solvers, in Scientific Computing, R. S. Stepleman et al. (Eds.), C North-Holland, Amsterdam, 1983, pp. 55-64. C C 2. S. C. Eisenstat, M. C. Gursky, M. H. Schultz, and A. H. Sherman, C Yale Sparse Matrix Package: I. The Symmetric Codes, C Int. J. Num. Meth. Eng., 18 (1982), pp. 1145-1151. C C 3. S. C. Eisenstat, M. C. Gursky, M. H. Schultz, and A. H. Sherman, C Yale Sparse Matrix Package: II. The Nonsymmetric Codes, C Research Report No. 114, Dept. of Computer Sciences, Yale C University, 1977. C----------------------------------------------------------------------- C Summary of Usage. C C Communication between the user and the DLSODES package, for normal C situations, is summarized here. This summary describes only a subset C of the full set of options available. See the full description for C details, including optional communication, nonstandard options, C and instructions for special situations. See also the example C problem (with program and output) following this summary. C C A. First provide a subroutine of the form: C SUBROUTINE F (NEQ, T, Y, YDOT,rpar,ipar) C INTEGER NEQ,ipar(*) C DOUBLE PRECISION T, Y(*), YDOT(*),rpar(*) C which supplies the vector function f by loading YDOT(i) with f(i). C C B. Next determine (or guess) whether or not the problem is stiff. C Stiffness occurs when the Jacobian matrix df/dy has an eigenvalue C whose real part is negative and large in magnitude, compared to the C reciprocal of the t span of interest. If the problem is nonstiff, C use a method flag MF = 10. If it is stiff, there are two standard C choices for the method flag, MF = 121 and MF = 222. In both cases, C DLSODES requires the Jacobian matrix in some form, and it treats this C matrix in general sparse form, with sparsity structure determined C internally. (For options where the user supplies the sparsity C structure, see the full description of MF below.) C C C. If the problem is stiff, you are encouraged to supply the Jacobian C directly (MF = 121), but if this is not feasible, DLSODES will C compute it internally by difference quotients (MF = 222). C If you are supplying the Jacobian, provide a subroutine of the form: C SUBROUTINE JAC (NEQ, T, Y, J, IAN, JAN, PDJ, rpar,ipar) C DOUBLE PRECISION T, Y(*), IAN(*), JAN(*), PDJ(*),rpar(*) C Here NEQ, T, Y, and J are input arguments, and the JAC routine is to C load the array PDJ (of length NEQ) with the J-th column of df/dy. C I.e., load PDJ(i) with df(i)/dy(J) for all relevant values of i. C The arguments IAN and JAN should be ignored for normal situations. C DLSODES will call the JAC routine with J = 1,2,...,NEQ. C Only nonzero elements need be loaded. Usually, a crude approximation C to df/dy, possibly with fewer nonzero elements, will suffice. C C D. Write a main program which calls Subroutine DLSODES once for C each point at which answers are desired. This should also provide C for possible use of logical unit 6 for output of error messages by C DLSODES. On the first call to DLSODES, supply arguments as follows: C F = name of subroutine for right-hand side vector f. C This name must be declared External in calling program. C NEQ = number of first order ODEs. C Y = array of initial values, of length NEQ. C T = the initial value of the independent variable t. C TOUT = first point where output is desired (.ne. T). C ITOL = 1 or 2 according as ATOL (below) is a scalar or array. C RTOL = relative tolerance parameter (scalar). C ATOL = absolute tolerance parameter (scalar or array). C The estimated local error in Y(i) will be controlled so as C to be roughly less (in magnitude) than C EWT(i) = RTOL*ABS(Y(i)) + ATOL if ITOL = 1, or C EWT(i) = RTOL*ABS(Y(i)) + ATOL(i) if ITOL = 2. C Thus the local error test passes if, in each component, C either the absolute error is less than ATOL (or ATOL(i)), C or the relative error is less than RTOL. C Use RTOL = 0.0 for pure absolute error control, and C use ATOL = 0.0 (or ATOL(i) = 0.0) for pure relative error C control. Caution: actual (global) errors may exceed these C local tolerances, so choose them conservatively. C ITASK = 1 for normal computation of output values of Y at t = TOUT. C ISTATE = integer flag (input and output). Set ISTATE = 1. C IOPT = 0 to indicate no optional inputs used. C RWORK = real work array of length at least: C 20 + 16*NEQ for MF = 10, C 20 + (2 + 1./LENRAT)*NNZ + (11 + 9./LENRAT)*NEQ C for MF = 121 or 222, C where: C NNZ = the number of nonzero elements in the sparse C Jacobian (if this is unknown, use an estimate), and C LENRAT = the real to integer wordlength ratio (usually 1 in C single precision and 2 in double precision). C In any case, the required size of RWORK cannot generally C be predicted in advance if MF = 121 or 222, and the value C above is a rough estimate of a crude lower bound. Some C experimentation with this size may be necessary. C (When known, the correct required length is an optional C output, available in IWORK(17).) C LRW = declared length of RWORK (in user dimension). C IWORK = integer work array of length at least 30. C LIW = declared length of IWORK (in user dimension). C JAC = name of subroutine for Jacobian matrix (MF = 121). C If used, this name must be declared External in calling C program. If not used, pass a dummy name. C MF = method flag. Standard values are: C 10 for nonstiff (Adams) method, no Jacobian used C 121 for stiff (BDF) method, user-supplied sparse Jacobian C 222 for stiff method, internally generated sparse Jacobian C Note that the main program must declare arrays Y, RWORK, IWORK, C and possibly ATOL. C C E. The output from the first call (or any call) is: C Y = array of computed values of y(t) vector. C T = corresponding value of independent variable (normally TOUT). C ISTATE = 2 if DLSODES was successful, negative otherwise. C -1 means excess work done on this call (perhaps wrong MF). C -2 means excess accuracy requested (tolerances too small). C -3 means illegal input detected (see printed message). C -4 means repeated error test failures (check all inputs). C -5 means repeated convergence failures (perhaps bad Jacobian C supplied or wrong choice of MF or tolerances). C -6 means error weight became zero during problem. (Solution C component i vanished, and ATOL or ATOL(i) = 0.) C -7 means a fatal error return flag came from sparse solver C CDRV by way of DPRJS or DSOLSS. Should never happen. C A return with ISTATE = -1, -4, or -5 may result from using C an inappropriate sparsity structure, one that is quite C different from the initial structure. Consider calling C DLSODES again with ISTATE = 3 to force the structure to be C reevaluated. See the full description of ISTATE below. C C F. To continue the integration after a successful return, simply C reset TOUT and call DLSODES again. No other parameters need be reset. C C----------------------------------------------------------------------- C Example Problem. C C The following is a simple example problem, with the coding C needed for its solution by DLSODES. The problem is from chemical C kinetics, and consists of the following 12 rate equations: C dy1/dt = -rk1*y1 C dy2/dt = rk1*y1 + rk11*rk14*y4 + rk19*rk14*y5 C - rk3*y2*y3 - rk15*y2*y12 - rk2*y2 C dy3/dt = rk2*y2 - rk5*y3 - rk3*y2*y3 - rk7*y10*y3 C + rk11*rk14*y4 + rk12*rk14*y6 C dy4/dt = rk3*y2*y3 - rk11*rk14*y4 - rk4*y4 C dy5/dt = rk15*y2*y12 - rk19*rk14*y5 - rk16*y5 C dy6/dt = rk7*y10*y3 - rk12*rk14*y6 - rk8*y6 C dy7/dt = rk17*y10*y12 - rk20*rk14*y7 - rk18*y7 C dy8/dt = rk9*y10 - rk13*rk14*y8 - rk10*y8 C dy9/dt = rk4*y4 + rk16*y5 + rk8*y6 + rk18*y7 C dy10/dt = rk5*y3 + rk12*rk14*y6 + rk20*rk14*y7 C + rk13*rk14*y8 - rk7*y10*y3 - rk17*y10*y12 C - rk6*y10 - rk9*y10 C dy11/dt = rk10*y8 C dy12/dt = rk6*y10 + rk19*rk14*y5 + rk20*rk14*y7 C - rk15*y2*y12 - rk17*y10*y12 C C with rk1 = rk5 = 0.1, rk4 = rk8 = rk16 = rk18 = 2.5, C rk10 = 5.0, rk2 = rk6 = 10.0, rk14 = 30.0, C rk3 = rk7 = rk9 = rk11 = rk12 = rk13 = rk19 = rk20 = 50.0, C rk15 = rk17 = 100.0. C C The t interval is from 0 to 1000, and the initial conditions C are y1 = 1, y2 = y3 = ... = y12 = 0. The problem is stiff. C C The following coding solves this problem with DLSODES, using MF = 121 C and printing results at t = .1, 1., 10., 100., 1000. It uses C ITOL = 1 and mixed relative/absolute tolerance controls. C During the run and at the end, statistical quantities of interest C are printed (see optional outputs in the full description below). C C EXTERNAL FEX, JEX C DOUBLE PRECISION ATOL, RTOL, RWORK, T, TOUT, Y C DIMENSION Y(12), RWORK(500), IWORK(30) C DATA LRW/500/, LIW/30/ C NEQ = 12 C DO 10 I = 1,NEQ C 10 Y(I) = 0.0D0 C Y(1) = 1.0D0 C T = 0.0D0 C TOUT = 0.1D0 C ITOL = 1 C RTOL = 1.0D-4 C ATOL = 1.0D-6 C ITASK = 1 C ISTATE = 1 C IOPT = 0 C MF = 121 C DO 40 IOUT = 1,5 C CALL DLSODES (FEX, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, C 1 ITASK, ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JEX, MF) C WRITE(6,30)T,IWORK(11),RWORK(11),(Y(I),I=1,NEQ) C 30 FORMAT(//' At t =',D11.3,4X, C 1 ' No. steps =',I5,4X,' Last step =',D11.3/ C 2 ' Y array = ',4D14.5/13X,4D14.5/13X,4D14.5) C IF (ISTATE .LT. 0) GO TO 80 C TOUT = TOUT*10.0D0 C 40 CONTINUE C LENRW = IWORK(17) C LENIW = IWORK(18) C NST = IWORK(11) C NFE = IWORK(12) C NJE = IWORK(13) C NLU = IWORK(21) C NNZ = IWORK(19) C NNZLU = IWORK(25) + IWORK(26) + NEQ C WRITE (6,70) LENRW,LENIW,NST,NFE,NJE,NLU,NNZ,NNZLU C 70 FORMAT(//' Required RWORK size =',I4,' IWORK size =',I4/ C 1 ' No. steps =',I4,' No. f-s =',I4,' No. J-s =',I4, C 2 ' No. LU-s =',I4/' No. of nonzeros in J =',I5, C 3 ' No. of nonzeros in LU =',I5) C STOP C 80 WRITE(6,90)ISTATE C 90 FORMAT(///' Error halt.. ISTATE =',I3) C STOP C END C C SUBROUTINE FEX (NEQ, T, Y, YDOT,rpar,ipar) C DOUBLE PRECISION T, Y, YDOT,rpar(*) C DOUBLE PRECISION RK1, RK2, RK3, RK4, RK5, RK6, RK7, RK8, RK9, C 1 RK10, RK11, RK12, RK13, RK14, RK15, RK16, RK17 C DIMENSION Y(12), YDOT(12) C DATA RK1/0.1D0/, RK2/10.0D0/, RK3/50.0D0/, RK4/2.5D0/, RK5/0.1D0/, C 1 RK6/10.0D0/, RK7/50.0D0/, RK8/2.5D0/, RK9/50.0D0/, RK10/5.0D0/, C 2 RK11/50.0D0/, RK12/50.0D0/, RK13/50.0D0/, RK14/30.0D0/, C 3 RK15/100.0D0/, RK16/2.5D0/, RK17/100.0D0/, RK18/2.5D0/, C 4 RK19/50.0D0/, RK20/50.0D0/ C YDOT(1) = -RK1*Y(1) C YDOT(2) = RK1*Y(1) + RK11*RK14*Y(4) + RK19*RK14*Y(5) C 1 - RK3*Y(2)*Y(3) - RK15*Y(2)*Y(12) - RK2*Y(2) C YDOT(3) = RK2*Y(2) - RK5*Y(3) - RK3*Y(2)*Y(3) - RK7*Y(10)*Y(3) C 1 + RK11*RK14*Y(4) + RK12*RK14*Y(6) C YDOT(4) = RK3*Y(2)*Y(3) - RK11*RK14*Y(4) - RK4*Y(4) C YDOT(5) = RK15*Y(2)*Y(12) - RK19*RK14*Y(5) - RK16*Y(5) C YDOT(6) = RK7*Y(10)*Y(3) - RK12*RK14*Y(6) - RK8*Y(6) C YDOT(7) = RK17*Y(10)*Y(12) - RK20*RK14*Y(7) - RK18*Y(7) C YDOT(8) = RK9*Y(10) - RK13*RK14*Y(8) - RK10*Y(8) C YDOT(9) = RK4*Y(4) + RK16*Y(5) + RK8*Y(6) + RK18*Y(7) C YDOT(10) = RK5*Y(3) + RK12*RK14*Y(6) + RK20*RK14*Y(7) C 1 + RK13*RK14*Y(8) - RK7*Y(10)*Y(3) - RK17*Y(10)*Y(12) C 2 - RK6*Y(10) - RK9*Y(10) C YDOT(11) = RK10*Y(8) C YDOT(12) = RK6*Y(10) + RK19*RK14*Y(5) + RK20*RK14*Y(7) C 1 - RK15*Y(2)*Y(12) - RK17*Y(10)*Y(12) C RETURN C END C C SUBROUTINE JEX (NEQ, T, Y, J, IA, JA, PDJ,rpar,ipar) C DOUBLE PRECISION T, Y, PDJ,rpar(*) C DOUBLE PRECISION RK1, RK2, RK3, RK4, RK5, RK6, RK7, RK8, RK9, C 1 RK10, RK11, RK12, RK13, RK14, RK15, RK16, RK17 C DIMENSION Y(12), IA(*), JA(*), PDJ(12) C DATA RK1/0.1D0/, RK2/10.0D0/, RK3/50.0D0/, RK4/2.5D0/, RK5/0.1D0/, C 1 RK6/10.0D0/, RK7/50.0D0/, RK8/2.5D0/, RK9/50.0D0/, RK10/5.0D0/, C 2 RK11/50.0D0/, RK12/50.0D0/, RK13/50.0D0/, RK14/30.0D0/, C 3 RK15/100.0D0/, RK16/2.5D0/, RK17/100.0D0/, RK18/2.5D0/, C 4 RK19/50.0D0/, RK20/50.0D0/ C GO TO (1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12), J C 1 PDJ(1) = -RK1 C PDJ(2) = RK1 C RETURN C 2 PDJ(2) = -RK3*Y(3) - RK15*Y(12) - RK2 C PDJ(3) = RK2 - RK3*Y(3) C PDJ(4) = RK3*Y(3) C PDJ(5) = RK15*Y(12) C PDJ(12) = -RK15*Y(12) C RETURN C 3 PDJ(2) = -RK3*Y(2) C PDJ(3) = -RK5 - RK3*Y(2) - RK7*Y(10) C PDJ(4) = RK3*Y(2) C PDJ(6) = RK7*Y(10) C PDJ(10) = RK5 - RK7*Y(10) C RETURN C 4 PDJ(2) = RK11*RK14 C PDJ(3) = RK11*RK14 C PDJ(4) = -RK11*RK14 - RK4 C PDJ(9) = RK4 C RETURN C 5 PDJ(2) = RK19*RK14 C PDJ(5) = -RK19*RK14 - RK16 C PDJ(9) = RK16 C PDJ(12) = RK19*RK14 C RETURN C 6 PDJ(3) = RK12*RK14 C PDJ(6) = -RK12*RK14 - RK8 C PDJ(9) = RK8 C PDJ(10) = RK12*RK14 C RETURN C 7 PDJ(7) = -RK20*RK14 - RK18 C PDJ(9) = RK18 C PDJ(10) = RK20*RK14 C PDJ(12) = RK20*RK14 C RETURN C 8 PDJ(8) = -RK13*RK14 - RK10 C PDJ(10) = RK13*RK14 C PDJ(11) = RK10 C 9 RETURN C 10 PDJ(3) = -RK7*Y(3) C PDJ(6) = RK7*Y(3) C PDJ(7) = RK17*Y(12) C PDJ(8) = RK9 C PDJ(10) = -RK7*Y(3) - RK17*Y(12) - RK6 - RK9 C PDJ(12) = RK6 - RK17*Y(12) C 11 RETURN C 12 PDJ(2) = -RK15*Y(2) C PDJ(5) = RK15*Y(2) C PDJ(7) = RK17*Y(10) C PDJ(10) = -RK17*Y(10) C PDJ(12) = -RK15*Y(2) - RK17*Y(10) C RETURN C END C C The output of this program (on a Cray-1 in single precision) C is as follows: C C C At t = 1.000e-01 No. steps = 12 Last step = 1.515e-02 C Y array = 9.90050e-01 6.28228e-03 3.65313e-03 7.51934e-07 C 1.12167e-09 1.18458e-09 1.77291e-12 3.26476e-07 C 5.46720e-08 9.99500e-06 4.48483e-08 2.76398e-06 C C C At t = 1.000e+00 No. steps = 33 Last step = 7.880e-02 C Y array = 9.04837e-01 9.13105e-03 8.20622e-02 2.49177e-05 C 1.85055e-06 1.96797e-06 1.46157e-07 2.39557e-05 C 3.26306e-05 7.21621e-04 5.06433e-05 3.05010e-03 C C C At t = 1.000e+01 No. steps = 48 Last step = 1.239e+00 C Y array = 3.67876e-01 3.68958e-03 3.65133e-01 4.48325e-05 C 6.10798e-05 4.33148e-05 5.90211e-05 1.18449e-04 C 3.15235e-03 3.56531e-03 4.15520e-03 2.48741e-01 C C C At t = 1.000e+02 No. steps = 91 Last step = 3.764e+00 C Y array = 4.44981e-05 4.42666e-07 4.47273e-04 -3.53257e-11 C 2.81577e-08 -9.67741e-11 2.77615e-07 1.45322e-07 C 1.56230e-02 4.37394e-06 1.60104e-02 9.52246e-01 C C C At t = 1.000e+03 No. steps = 111 Last step = 4.156e+02 C Y array = -2.65492e-13 2.60539e-14 -8.59563e-12 6.29355e-14 C -1.78066e-13 5.71471e-13 -1.47561e-12 4.58078e-15 C 1.56314e-02 1.37878e-13 1.60184e-02 9.52719e-01 C C C Required RWORK size = 442 IWORK size = 30 C No. steps = 111 No. f-s = 142 No. J-s = 2 No. LU-s = 20 C No. of nonzeros in J = 44 No. of nonzeros in LU = 50 C C----------------------------------------------------------------------- C Full Description of User Interface to DLSODES. C C The user interface to DLSODES consists of the following parts. C C 1. The call sequence to Subroutine DLSODES, which is a driver C routine for the solver. This includes descriptions of both C the call sequence arguments and of user-supplied routines. C Following these descriptions is a description of C optional inputs available through the call sequence, and then C a description of optional outputs (in the work arrays). C C 2. Descriptions of other routines in the DLSODES package that may be C (optionally) called by the user. These provide the ability to C alter error message handling, save and restore the internal C Common, and obtain specified derivatives of the solution y(t). C C 3. Descriptions of Common blocks to be declared in overlay C or similar environments, or to be saved when doing an interrupt C of the problem and continued solution later. C C 4. Description of two routines in the DLSODES package, either of C which the user may replace with his/her own version, if desired. C These relate to the measurement of errors. C C----------------------------------------------------------------------- C Part 1. Call Sequence. C C The call sequence parameters used for input only are C F, NEQ, TOUT, ITOL, RTOL, ATOL, ITASK, IOPT, LRW, LIW, JAC, MF, C and those used for both input and output are C Y, T, ISTATE. C The work arrays RWORK and IWORK are also used for conditional and C optional inputs and optional outputs. (The term output here refers C to the return from Subroutine DLSODES to the user's calling program.) C C The legality of input parameters will be thoroughly checked on the C initial call for the problem, but not checked thereafter unless a C change in input parameters is flagged by ISTATE = 3 on input. C C The descriptions of the call arguments are as follows. C C F = the name of the user-supplied subroutine defining the C ODE system. The system must be put in the first-order C form dy/dt = f(t,y), where f is a vector-valued function C of the scalar t and the vector y. Subroutine F is to C compute the function f. It is to have the form C SUBROUTINE F (NEQ, T, Y, YDOT,rpar,ipar) C INTEGER NEQ,ipar(*) C DOUBLE PRECISION T, Y(*), YDOT(*),rpar(*) C where NEQ, T, and Y are input, and the array YDOT = f(t,y) C is output. Y and YDOT are arrays of length NEQ. C Subroutine F should not alter y(1),...,y(NEQ). C F must be declared External in the calling program. C C Subroutine F may access user-defined quantities in C NEQ(2),... and/or in Y(NEQ(1)+1),... if NEQ is an array C (dimensioned in F) and/or Y has length exceeding NEQ(1). C See the descriptions of NEQ and Y below. C C If quantities computed in the F routine are needed C externally to DLSODES, an extra call to F should be made C for this purpose, for consistent and accurate results. C If only the derivative dy/dt is needed, use DINTDY instead. C C NEQ = the size of the ODE system (number of first order C ordinary differential equations). Used only for input. C NEQ may be decreased, but not increased, during the problem. C If NEQ is decreased (with ISTATE = 3 on input), the C remaining components of Y should be left undisturbed, if C these are to be accessed in F and/or JAC. C C Normally, NEQ is a scalar, and it is generally referred to C as a scalar in this user interface description. However, C NEQ may be an array, with NEQ(1) set to the system size. C (The DLSODES package accesses only NEQ(1).) In either case, C this parameter is passed as the NEQ argument in all calls C to F and JAC. Hence, if it is an array, locations C NEQ(2),... may be used to store other integer data and pass C it to F and/or JAC. Subroutines F and/or JAC must include C NEQ in a Dimension statement in that case. C C Y = a real array for the vector of dependent variables, of C length NEQ or more. Used for both input and output on the C first call (ISTATE = 1), and only for output on other calls. C on the first call, Y must contain the vector of initial C values. On output, Y contains the computed solution vector, C evaluated at T. If desired, the Y array may be used C for other purposes between calls to the solver. C C This array is passed as the Y argument in all calls to C F and JAC. Hence its length may exceed NEQ, and locations C Y(NEQ+1),... may be used to store other real data and C pass it to F and/or JAC. (The DLSODES package accesses only C Y(1),...,Y(NEQ).) C C T = the independent variable. On input, T is used only on the C first call, as the initial point of the integration. C on output, after each call, T is the value at which a C computed solution Y is evaluated (usually the same as TOUT). C On an error return, T is the farthest point reached. C C TOUT = the next value of t at which a computed solution is desired. C Used only for input. C C When starting the problem (ISTATE = 1), TOUT may be equal C to T for one call, then should .ne. T for the next call. C For the initial T, an input value of TOUT .ne. T is used C in order to determine the direction of the integration C (i.e. the algebraic sign of the step sizes) and the rough C scale of the problem. Integration in either direction C (forward or backward in t) is permitted. C C If ITASK = 2 or 5 (one-step modes), TOUT is ignored after C the first call (i.e. the first call with TOUT .ne. T). C Otherwise, TOUT is required on every call. C C If ITASK = 1, 3, or 4, the values of TOUT need not be C monotone, but a value of TOUT which backs up is limited C to the current internal T interval, whose endpoints are C TCUR - HU and TCUR (see optional outputs, below, for C TCUR and HU). C C ITOL = an indicator for the type of error control. See C description below under ATOL. Used only for input. C C RTOL = a relative error tolerance parameter, either a scalar or C an array of length NEQ. See description below under ATOL. C Input only. C C ATOL = an absolute error tolerance parameter, either a scalar or C an array of length NEQ. Input only. C C The input parameters ITOL, RTOL, and ATOL determine C the error control performed by the solver. The solver will C control the vector E = (E(i)) of estimated local errors C in y, according to an inequality of the form C RMS-norm of ( E(i)/EWT(i) ) .le. 1, C where EWT(i) = RTOL(i)*ABS(Y(i)) + ATOL(i), C and the RMS-norm (root-mean-square norm) here is C RMS-norm(v) = SQRT(sum v(i)**2 / NEQ). Here EWT = (EWT(i)) C is a vector of weights which must always be positive, and C the values of RTOL and ATOL should all be non-negative. C The following table gives the types (scalar/array) of C RTOL and ATOL, and the corresponding form of EWT(i). C C ITOL RTOL ATOL EWT(i) C 1 scalar scalar RTOL*ABS(Y(i)) + ATOL C 2 scalar array RTOL*ABS(Y(i)) + ATOL(i) C 3 array scalar RTOL(i)*ABS(Y(i)) + ATOL C 4 array array RTOL(i)*ABS(Y(i)) + ATOL(i) C C When either of these parameters is a scalar, it need not C be dimensioned in the user's calling program. C C If none of the above choices (with ITOL, RTOL, and ATOL C fixed throughout the problem) is suitable, more general C error controls can be obtained by substituting C user-supplied routines for the setting of EWT and/or for C the norm calculation. See Part 4 below. C C If global errors are to be estimated by making a repeated C run on the same problem with smaller tolerances, then all C components of RTOL and ATOL (i.e. of EWT) should be scaled C down uniformly. C C ITASK = an index specifying the task to be performed. C Input only. ITASK has the following values and meanings. C 1 means normal computation of output values of y(t) at C t = TOUT (by overshooting and interpolating). C 2 means take one step only and return. C 3 means stop at the first internal mesh point at or C beyond t = TOUT and return. C 4 means normal computation of output values of y(t) at C t = TOUT but without overshooting t = TCRIT. C TCRIT must be input as RWORK(1). TCRIT may be equal to C or beyond TOUT, but not behind it in the direction of C integration. This option is useful if the problem C has a singularity at or beyond t = TCRIT. C 5 means take one step, without passing TCRIT, and return. C TCRIT must be input as RWORK(1). C C Note: If ITASK = 4 or 5 and the solver reaches TCRIT C (within roundoff), it will return T = TCRIT (exactly) to C indicate this (unless ITASK = 4 and TOUT comes before TCRIT, C in which case answers at t = TOUT are returned first). C C ISTATE = an index used for input and output to specify the C the state of the calculation. C C On input, the values of ISTATE are as follows. C 1 means this is the first call for the problem C (initializations will be done). See note below. C 2 means this is not the first call, and the calculation C is to continue normally, with no change in any input C parameters except possibly TOUT and ITASK. C (If ITOL, RTOL, and/or ATOL are changed between calls C with ISTATE = 2, the new values will be used but not C tested for legality.) C 3 means this is not the first call, and the C calculation is to continue normally, but with C a change in input parameters other than C TOUT and ITASK. Changes are allowed in C NEQ, ITOL, RTOL, ATOL, IOPT, LRW, LIW, MF, C the conditional inputs IA and JA, C and any of the optional inputs except H0. C In particular, if MITER = 1 or 2, a call with ISTATE = 3 C will cause the sparsity structure of the problem to be C recomputed (or reread from IA and JA if MOSS = 0). C Note: a preliminary call with TOUT = T is not counted C as a first call here, as no initialization or checking of C input is done. (Such a call is sometimes useful for the C purpose of outputting the initial conditions.) C Thus the first call for which TOUT .ne. T requires C ISTATE = 1 on input. C C On output, ISTATE has the following values and meanings. C 1 means nothing was done; TOUT = T and ISTATE = 1 on input. C 2 means the integration was performed successfully. C -1 means an excessive amount of work (more than MXSTEP C steps) was done on this call, before completing the C requested task, but the integration was otherwise C successful as far as T. (MXSTEP is an optional input C and is normally 500.) To continue, the user may C simply reset ISTATE to a value .gt. 1 and call again C (the excess work step counter will be reset to 0). C In addition, the user may increase MXSTEP to avoid C this error return (see below on optional inputs). C -2 means too much accuracy was requested for the precision C of the machine being used. This was detected before C completing the requested task, but the integration C was successful as far as T. To continue, the tolerance C parameters must be reset, and ISTATE must be set C to 3. The optional output TOLSF may be used for this C purpose. (Note: If this condition is detected before C taking any steps, then an illegal input return C (ISTATE = -3) occurs instead.) C -3 means illegal input was detected, before taking any C integration steps. See written message for details. C Note: If the solver detects an infinite loop of calls C to the solver with illegal input, it will cause C the run to stop. C -4 means there were repeated error test failures on C one attempted step, before completing the requested C task, but the integration was successful as far as T. C The problem may have a singularity, or the input C may be inappropriate. C -5 means there were repeated convergence test failures on C one attempted step, before completing the requested C task, but the integration was successful as far as T. C This may be caused by an inaccurate Jacobian matrix, C if one is being used. C -6 means EWT(i) became zero for some i during the C integration. Pure relative error control (ATOL(i)=0.0) C was requested on a variable which has now vanished. C The integration was successful as far as T. C -7 means a fatal error return flag came from the sparse C solver CDRV by way of DPRJS or DSOLSS (numerical C factorization or backsolve). This should never happen. C The integration was successful as far as T. C C Note: an error return with ISTATE = -1, -4, or -5 and with C MITER = 1 or 2 may mean that the sparsity structure of the C problem has changed significantly since it was last C determined (or input). In that case, one can attempt to C complete the integration by setting ISTATE = 3 on the next C call, so that a new structure determination is done. C C Note: since the normal output value of ISTATE is 2, C it does not need to be reset for normal continuation. C Also, since a negative input value of ISTATE will be C regarded as illegal, a negative output value requires the C user to change it, and possibly other inputs, before C calling the solver again. C C IOPT = an integer flag to specify whether or not any optional C inputs are being used on this call. Input only. C The optional inputs are listed separately below. C IOPT = 0 means no optional inputs are being used. C Default values will be used in all cases. C IOPT = 1 means one or more optional inputs are being used. C C RWORK = a work array used for a mixture of real (double precision) C and integer work space. C The length of RWORK (in real words) must be at least C 20 + NYH*(MAXORD + 1) + 3*NEQ + LWM where C NYH = the initial value of NEQ, C MAXORD = 12 (if METH = 1) or 5 (if METH = 2) (unless a C smaller value is given as an optional input), C LWM = 0 if MITER = 0, C LWM = 2*NNZ + 2*NEQ + (NNZ+9*NEQ)/LENRAT if MITER = 1, C LWM = 2*NNZ + 2*NEQ + (NNZ+10*NEQ)/LENRAT if MITER = 2, C LWM = NEQ + 2 if MITER = 3. C In the above formulas, C NNZ = number of nonzero elements in the Jacobian matrix. C LENRAT = the real to integer wordlength ratio (usually 1 in C single precision and 2 in double precision). C (See the MF description for METH and MITER.) C Thus if MAXORD has its default value and NEQ is constant, C the minimum length of RWORK is: C 20 + 16*NEQ for MF = 10, C 20 + 16*NEQ + LWM for MF = 11, 111, 211, 12, 112, 212, C 22 + 17*NEQ for MF = 13, C 20 + 9*NEQ for MF = 20, C 20 + 9*NEQ + LWM for MF = 21, 121, 221, 22, 122, 222, C 22 + 10*NEQ for MF = 23. C If MITER = 1 or 2, the above formula for LWM is only a C crude lower bound. The required length of RWORK cannot C be readily predicted in general, as it depends on the C sparsity structure of the problem. Some experimentation C may be necessary. C C The first 20 words of RWORK are reserved for conditional C and optional inputs and optional outputs. C C The following word in RWORK is a conditional input: C RWORK(1) = TCRIT = critical value of t which the solver C is not to overshoot. Required if ITASK is C 4 or 5, and ignored otherwise. (See ITASK.) C C LRW = the length of the array RWORK, as declared by the user. C (This will be checked by the solver.) C C IWORK = an integer work array. The length of IWORK must be at least C 31 + NEQ + NNZ if MOSS = 0 and MITER = 1 or 2, or C 30 otherwise. C (NNZ is the number of nonzero elements in df/dy.) C C In DLSODES, IWORK is used only for conditional and C optional inputs and optional outputs. C C The following two blocks of words in IWORK are conditional C inputs, required if MOSS = 0 and MITER = 1 or 2, but not C otherwise (see the description of MF for MOSS). C IWORK(30+j) = IA(j) (j=1,...,NEQ+1) C IWORK(31+NEQ+k) = JA(k) (k=1,...,NNZ) C The two arrays IA and JA describe the sparsity structure C to be assumed for the Jacobian matrix. JA contains the row C indices where nonzero elements occur, reading in columnwise C order, and IA contains the starting locations in JA of the C descriptions of columns 1,...,NEQ, in that order, with C IA(1) = 1. Thus, for each column index j = 1,...,NEQ, the C values of the row index i in column j where a nonzero C element may occur are given by C i = JA(k), where IA(j) .le. k .lt. IA(j+1). C If NNZ is the total number of nonzero locations assumed, C then the length of the JA array is NNZ, and IA(NEQ+1) must C be NNZ + 1. Duplicate entries are not allowed. C C LIW = the length of the array IWORK, as declared by the user. C (This will be checked by the solver.) C C Note: The work arrays must not be altered between calls to DLSODES C for the same problem, except possibly for the conditional and C optional inputs, and except for the last 3*NEQ words of RWORK. C The latter space is used for internal scratch space, and so is C available for use by the user outside DLSODES between calls, if C desired (but not for use by F or JAC). C C JAC = name of user-supplied routine (MITER = 1 or MOSS = 1) to C compute the Jacobian matrix, df/dy, as a function of C the scalar t and the vector y. It is to have the form C SUBROUTINE JAC (NEQ, T, Y, J, IAN, JAN, PDJ,rpar,ipar) C DOUBLE PRECISION T, Y(*), IAN(*), JAN(*), PDJ(*),rpar(*) C where NEQ, T, Y, J, IAN, and JAN are input, and the array C PDJ, of length NEQ, is to be loaded with column J C of the Jacobian on output. Thus df(i)/dy(J) is to be C loaded into PDJ(i) for all relevant values of i. C Here T and Y have the same meaning as in Subroutine F, C and J is a column index (1 to NEQ). IAN and JAN are C undefined in calls to JAC for structure determination C (MOSS = 1). otherwise, IAN and JAN are structure C descriptors, as defined under optional outputs below, and C so can be used to determine the relevant row indices i, if C desired. C JAC need not provide df/dy exactly. A crude C approximation (possibly with greater sparsity) will do. C In any case, PDJ is preset to zero by the solver, C so that only the nonzero elements need be loaded by JAC. C Calls to JAC are made with J = 1,...,NEQ, in that order, and C each such set of calls is preceded by a call to F with the C same arguments NEQ, T, and Y. Thus to gain some efficiency, C intermediate quantities shared by both calculations may be C saved in a user Common block by F and not recomputed by JAC, C if desired. JAC must not alter its input arguments. C JAC must be declared External in the calling program. C Subroutine JAC may access user-defined quantities in C NEQ(2),... and/or in Y(NEQ(1)+1),... if NEQ is an array C (dimensioned in JAC) and/or Y has length exceeding NEQ(1). C See the descriptions of NEQ and Y above. C C MF = the method flag. Used only for input. C MF has three decimal digits-- MOSS, METH, MITER-- C MF = 100*MOSS + 10*METH + MITER. C MOSS indicates the method to be used to obtain the sparsity C structure of the Jacobian matrix if MITER = 1 or 2: C MOSS = 0 means the user has supplied IA and JA C (see descriptions under IWORK above). C MOSS = 1 means the user has supplied JAC (see below) C and the structure will be obtained from NEQ C initial calls to JAC. C MOSS = 2 means the structure will be obtained from NEQ+1 C initial calls to F. C METH indicates the basic linear multistep method: C METH = 1 means the implicit Adams method. C METH = 2 means the method based on Backward C Differentiation Formulas (BDFs). C MITER indicates the corrector iteration method: C MITER = 0 means functional iteration (no Jacobian matrix C is involved). C MITER = 1 means chord iteration with a user-supplied C sparse Jacobian, given by Subroutine JAC. C MITER = 2 means chord iteration with an internally C generated (difference quotient) sparse Jacobian C (using NGP extra calls to F per df/dy value, C where NGP is an optional output described below.) C MITER = 3 means chord iteration with an internally C generated diagonal Jacobian approximation C (using 1 extra call to F per df/dy evaluation). C If MITER = 1 or MOSS = 1, the user must supply a Subroutine C JAC (the name is arbitrary) as described above under JAC. C Otherwise, a dummy argument can be used. C C The standard choices for MF are: C MF = 10 for a nonstiff problem, C MF = 21 or 22 for a stiff problem with IA/JA supplied C (21 if JAC is supplied, 22 if not), C MF = 121 for a stiff problem with JAC supplied, C but not IA/JA, C MF = 222 for a stiff problem with neither IA/JA nor C JAC supplied. C The sparseness structure can be changed during the C problem by making a call to DLSODES with ISTATE = 3. C----------------------------------------------------------------------- C Optional Inputs. C C The following is a list of the optional inputs provided for in the C call sequence. (See also Part 2.) For each such input variable, C this table lists its name as used in this documentation, its C location in the call sequence, its meaning, and the default value. C The use of any of these inputs requires IOPT = 1, and in that C case all of these inputs are examined. A value of zero for any C of these optional inputs will cause the default value to be used. C Thus to use a subset of the optional inputs, simply preload C locations 5 to 10 in RWORK and IWORK to 0.0 and 0 respectively, and C then set those of interest to nonzero values. C C Name Location Meaning and Default Value C C H0 RWORK(5) the step size to be attempted on the first step. C The default value is determined by the solver. C C HMAX RWORK(6) the maximum absolute step size allowed. C The default value is infinite. C C HMIN RWORK(7) the minimum absolute step size allowed. C The default value is 0. (This lower bound is not C enforced on the final step before reaching TCRIT C when ITASK = 4 or 5.) C C SETH RWORK(8) the element threshhold for sparsity determination C when MOSS = 1 or 2. If the absolute value of C an estimated Jacobian element is .le. SETH, it C will be assumed to be absent in the structure. C The default value of SETH is 0. C C MAXORD IWORK(5) the maximum order to be allowed. The default C value is 12 if METH = 1, and 5 if METH = 2. C If MAXORD exceeds the default value, it will C be reduced to the default value. C If MAXORD is changed during the problem, it may C cause the current order to be reduced. C C MXSTEP IWORK(6) maximum number of (internally defined) steps C allowed during one call to the solver. C The default value is 500. C C MXHNIL IWORK(7) maximum number of messages printed (per problem) C warning that T + H = T on a step (H = step size). C This must be positive to result in a non-default C value. The default value is 10. C----------------------------------------------------------------------- C Optional Outputs. C C As optional additional output from DLSODES, the variables listed C below are quantities related to the performance of DLSODES C which are available to the user. These are communicated by way of C the work arrays, but also have internal mnemonic names as shown. C Except where stated otherwise, all of these outputs are defined C on any successful return from DLSODES, and on any return with C ISTATE = -1, -2, -4, -5, or -6. On an illegal input return C (ISTATE = -3), they will be unchanged from their existing values C (if any), except possibly for TOLSF, LENRW, and LENIW. C On any error return, outputs relevant to the error will be defined, C as noted below. C C Name Location Meaning C C HU RWORK(11) the step size in t last used (successfully). C C HCUR RWORK(12) the step size to be attempted on the next step. C C TCUR RWORK(13) the current value of the independent variable C which the solver has actually reached, i.e. the C current internal mesh point in t. On output, TCUR C will always be at least as far as the argument C T, but may be farther (if interpolation was done). C C TOLSF RWORK(14) a tolerance scale factor, greater than 1.0, C computed when a request for too much accuracy was C detected (ISTATE = -3 if detected at the start of C the problem, ISTATE = -2 otherwise). If ITOL is C left unaltered but RTOL and ATOL are uniformly C scaled up by a factor of TOLSF for the next call, C then the solver is deemed likely to succeed. C (The user may also ignore TOLSF and alter the C tolerance parameters in any other way appropriate.) C C NST IWORK(11) the number of steps taken for the problem so far. C C NFE IWORK(12) the number of f evaluations for the problem so far, C excluding those for structure determination C (MOSS = 2). C C NJE IWORK(13) the number of Jacobian evaluations for the problem C so far, excluding those for structure determination C (MOSS = 1). C C NQU IWORK(14) the method order last used (successfully). C C NQCUR IWORK(15) the order to be attempted on the next step. C C IMXER IWORK(16) the index of the component of largest magnitude in C the weighted local error vector ( E(i)/EWT(i) ), C on an error return with ISTATE = -4 or -5. C C LENRW IWORK(17) the length of RWORK actually required. C This is defined on normal returns and on an illegal C input return for insufficient storage. C C LENIW IWORK(18) the length of IWORK actually required. C This is defined on normal returns and on an illegal C input return for insufficient storage. C C NNZ IWORK(19) the number of nonzero elements in the Jacobian C matrix, including the diagonal (MITER = 1 or 2). C (This may differ from that given by IA(NEQ+1)-1 C if MOSS = 0, because of added diagonal entries.) C C NGP IWORK(20) the number of groups of column indices, used in C difference quotient Jacobian aproximations if C MITER = 2. This is also the number of extra f C evaluations needed for each Jacobian evaluation. C C NLU IWORK(21) the number of sparse LU decompositions for the C problem so far. C C LYH IWORK(22) the base address in RWORK of the history array YH, C described below in this list. C C IPIAN IWORK(23) the base address of the structure descriptor array C IAN, described below in this list. C C IPJAN IWORK(24) the base address of the structure descriptor array C JAN, described below in this list. C C NZL IWORK(25) the number of nonzero elements in the strict lower C triangle of the LU factorization used in the chord C iteration (MITER = 1 or 2). C C NZU IWORK(26) the number of nonzero elements in the strict upper C triangle of the LU factorization used in the chord C iteration (MITER = 1 or 2). C The total number of nonzeros in the factorization C is therefore NZL + NZU + NEQ. C C The following four arrays are segments of the RWORK array which C may also be of interest to the user as optional outputs. C For each array, the table below gives its internal name, C its base address, and its description. C For YH and ACOR, the base addresses are in RWORK (a real array). C The integer arrays IAN and JAN are to be obtained by declaring an C integer array IWK and identifying IWK(1) with RWORK(21), using either C an equivalence statement or a subroutine call. Then the base C addresses IPIAN (of IAN) and IPJAN (of JAN) in IWK are to be obtained C as optional outputs IWORK(23) and IWORK(24), respectively. C Thus IAN(1) is IWK(IPIAN), etc. C C Name Base Address Description C C IAN IPIAN (in IWK) structure descriptor array of size NEQ + 1. C JAN IPJAN (in IWK) structure descriptor array of size NNZ. C (see above) IAN and JAN together describe the sparsity C structure of the Jacobian matrix, as used by C DLSODES when MITER = 1 or 2. C JAN contains the row indices of the nonzero C locations, reading in columnwise order, and C IAN contains the starting locations in JAN of C the descriptions of columns 1,...,NEQ, in C that order, with IAN(1) = 1. Thus for each C j = 1,...,NEQ, the row indices i of the C nonzero locations in column j are C i = JAN(k), IAN(j) .le. k .lt. IAN(j+1). C Note that IAN(NEQ+1) = NNZ + 1. C (If MOSS = 0, IAN/JAN may differ from the C input IA/JA because of a different ordering C in each column, and added diagonal entries.) C C YH LYH the Nordsieck history array, of size NYH by C (optional (NQCUR + 1), where NYH is the initial value C output) of NEQ. For j = 0,1,...,NQCUR, column j+1 C of YH contains HCUR**j/factorial(j) times C the j-th derivative of the interpolating C polynomial currently representing the solution, C evaluated at t = TCUR. The base address LYH C is another optional output, listed above. C C ACOR LENRW-NEQ+1 array of size NEQ used for the accumulated C corrections on each step, scaled on output C to represent the estimated local error in y C on the last step. This is the vector E in C the description of the error control. It is C defined only on a successful return from C DLSODES. C C----------------------------------------------------------------------- C Part 2. Other Routines Callable. C C The following are optional calls which the user may make to C gain additional capabilities in conjunction with DLSODES. C (The routines XSETUN and XSETF are designed to conform to the C SLATEC error handling package.) C C Form of Call Function C CALL XSETUN(LUN) Set the logical unit number, LUN, for C output of messages from DLSODES, if C the default is not desired. C The default value of LUN is 6. C C CALL XSETF(MFLAG) Set a flag to control the printing of C messages by DLSODES. C MFLAG = 0 means do not print. (Danger: C This risks losing valuable information.) C MFLAG = 1 means print (the default). C C Either of the above calls may be made at C any time and will take effect immediately. C C CALL DSRCMS(RSAV,ISAV,JOB) saves and restores the contents of C the internal Common blocks used by C DLSODES (see Part 3 below). C RSAV must be a real array of length 224 C or more, and ISAV must be an integer C array of length 71 or more. C JOB=1 means save Common into RSAV/ISAV. C JOB=2 means restore Common from RSAV/ISAV. C DSRCMS is useful if one is C interrupting a run and restarting C later, or alternating between two or C more problems solved with DLSODES. C C CALL DINTDY(,,,,,) Provide derivatives of y, of various C (see below) orders, at a specified point t, if C desired. It may be called only after C a successful return from DLSODES. C C The detailed instructions for using DINTDY are as follows. C The form of the call is: C C LYH = IWORK(22) C CALL DINTDY (T, K, RWORK(LYH), NYH, DKY, IFLAG) C C The input parameters are: C C T = value of independent variable where answers are desired C (normally the same as the T last returned by DLSODES). C For valid results, T must lie between TCUR - HU and TCUR. C (See optional outputs for TCUR and HU.) C K = integer order of the derivative desired. K must satisfy C 0 .le. K .le. NQCUR, where NQCUR is the current order C (See optional outputs). The capability corresponding C to K = 0, i.e. computing y(T), is already provided C by DLSODES directly. Since NQCUR .ge. 1, the first C derivative dy/dt is always available with DINTDY. C LYH = the base address of the history array YH, obtained C as an optional output as shown above. C NYH = column length of YH, equal to the initial value of NEQ. C C The output parameters are: C C DKY = a real array of length NEQ containing the computed value C of the K-th derivative of y(t). C IFLAG = integer flag, returned as 0 if K and T were legal, C -1 if K was illegal, and -2 if T was illegal. C On an error return, a message is also written. C----------------------------------------------------------------------- C Part 3. Common Blocks. C C If DLSODES is to be used in an overlay situation, the user C must declare, in the primary overlay, the variables in: C (1) the call sequence to DLSODES, and C (2) the two internal Common blocks C /DLS001/ of length 255 (218 double precision words C followed by 37 integer words), C /DLSS01/ of length 40 (6 double precision words C followed by 34 integer words), C C If DLSODES is used on a system in which the contents of internal C Common blocks are not preserved between calls, the user should C declare the above Common blocks in the calling program to insure C that their contents are preserved. C C If the solution of a given problem by DLSODES is to be interrupted C and then later continued, such as when restarting an interrupted run C or alternating between two or more problems, the user should save, C following the return from the last DLSODES call prior to the C interruption, the contents of the call sequence variables and the C internal Common blocks, and later restore these values before the C next DLSODES call for that problem. To save and restore the Common C blocks, use Subroutine DSRCMS (see Part 2 above). C C----------------------------------------------------------------------- C Part 4. Optionally Replaceable Solver Routines. C C Below are descriptions of two routines in the DLSODES package which C relate to the measurement of errors. Either routine can be C replaced by a user-supplied version, if desired. However, since such C a replacement may have a major impact on performance, it should be C done only when absolutely necessary, and only with great caution. C (Note: The means by which the package version of a routine is C superseded by the user's version may be system-dependent.) C C (a) DEWSET. C The following subroutine is called just before each internal C integration step, and sets the array of error weights, EWT, as C described under ITOL/RTOL/ATOL above: C Subroutine DEWSET (NEQ, ITOL, RTOL, ATOL, YCUR, EWT) C where NEQ, ITOL, RTOL, and ATOL are as in the DLSODES call sequence, C YCUR contains the current dependent variable vector, and C EWT is the array of weights set by DEWSET. C C If the user supplies this subroutine, it must return in EWT(i) C (i = 1,...,NEQ) a positive quantity suitable for comparing errors C in y(i) to. The EWT array returned by DEWSET is passed to the DVNORM C routine (see below), and also used by DLSODES in the computation C of the optional output IMXER, the diagonal Jacobian approximation, C and the increments for difference quotient Jacobians. C C In the user-supplied version of DEWSET, it may be desirable to use C the current values of derivatives of y. Derivatives up to order NQ C are available from the history array YH, described above under C optional outputs. In DEWSET, YH is identical to the YCUR array, C extended to NQ + 1 columns with a column length of NYH and scale C factors of H**j/factorial(j). On the first call for the problem, C given by NST = 0, NQ is 1 and H is temporarily set to 1.0. C NYH is the initial value of NEQ. The quantities NQ, H, and NST C can be obtained by including in DEWSET the statements: C DOUBLE PRECISION RLS C COMMON /DLS001/ RLS(218),ILS(37) C NQ = ILS(33) C NST = ILS(34) C H = RLS(212) C Thus, for example, the current value of dy/dt can be obtained as C YCUR(NYH+i)/H (i=1,...,NEQ) (and the division by H is C unnecessary when NST = 0). C C (b) DVNORM. C The following is a real function routine which computes the weighted C root-mean-square norm of a vector v: C D = DVNORM (N, V, W) C where C N = the length of the vector, C V = real array of length N containing the vector, C W = real array of length N containing weights, C D = SQRT( (1/N) * sum(V(i)*W(i))**2 ). C DVNORM is called with N = NEQ and with W(i) = 1.0/EWT(i), where C EWT is as set by Subroutine DEWSET. C C If the user supplies this function, it should return a non-negative C value of DVNORM suitable for use in the error control in DLSODES. C None of the arguments should be altered by DVNORM. C For example, a user-supplied DVNORM routine might: C -substitute a max-norm of (V(i)*W(i)) for the RMS-norm, or C -ignore some components of V in the norm, with the effect of C suppressing the error control on those components of y. C----------------------------------------------------------------------- C C***REVISION HISTORY (YYYYMMDD) C 19810120 DATE WRITTEN C 19820315 Upgraded MDI in ODRV package: operates on M + M-transpose. C 19820426 Numerous revisions in use of work arrays; C use wordlength ratio LENRAT; added IPISP & LRAT to Common; C added optional outputs IPIAN/IPJAN; C numerous corrections to comments. C 19830503 Added routine CNTNZU; added NZL and NZU to /LSS001/; C changed ADJLR call logic; added optional outputs NZL & NZU; C revised counter initializations; revised PREP stmt. numbers; C corrections to comments throughout. C 19870320 Corrected jump on test of umax in CDRV routine; C added ISTATE = -7 return. C 19870330 Major update: corrected comments throughout; C removed TRET from Common; rewrote EWSET with 4 loops; C fixed t test in INTDY; added Cray directives in STODE; C in STODE, fixed DELP init. and logic around PJAC call; C combined routines to save/restore Common; C passed LEVEL = 0 in error message calls (except run abort). C 20010425 Major update: convert source lines to upper case; C added *DECK lines; changed from 1 to * in dummy dimensions; C changed names R1MACH/D1MACH to RUMACH/DUMACH; C renamed routines for uniqueness across single/double prec.; C converted intrinsic names to generic form; C removed ILLIN and NTREP (data loaded) from Common; C removed all 'own' variables from Common; C changed error messages to quoted strings; C replaced XERRWV/XERRWD with 1993 revised version; C converted prologues, comments, error messages to mixed case; C converted arithmetic IF statements to logical IF statements; C numerous corrections to prologues and internal comments. C 20010507 Converted single precision source to double precision. C 20020502 Corrected declarations in descriptions of user routines. C 20031105 Restored 'own' variables to Common blocks, to enable C interrupt/restart feature. C 20031112 Added SAVE statements for data-loaded constants. C C----------------------------------------------------------------------- C Other routines in the DLSODES package. C C In addition to Subroutine DLSODES, the DLSODES package includes the C following subroutines and function routines: C DIPREP acts as an iterface between DLSODES and DPREP, and also does C adjusting of work space pointers and work arrays. C DPREP is called by DIPREP to compute sparsity and do sparse matrix C preprocessing if MITER = 1 or 2. C JGROUP is called by DPREP to compute groups of Jacobian column C indices for use when MITER = 2. C ADJLR adjusts the length of required sparse matrix work space. C It is called by DPREP. C CNTNZU is called by DPREP and counts the nonzero elements in the C strict upper triangle of J + J-transpose, where J = df/dy. C DINTDY computes an interpolated value of the y vector at t = TOUT. C DSTODE is the core integrator, which does one step of the C integration and the associated error control. C DCFODE sets all method coefficients and test constants. C DPRJS computes and preprocesses the Jacobian matrix J = df/dy C and the Newton iteration matrix P = I - h*l0*J. C DSOLSS manages solution of linear system in chord iteration. C DEWSET sets the error weight vector EWT before each step. C DVNORM computes the weighted RMS-norm of a vector. C DSRCMS is a user-callable routine to save and restore C the contents of the internal Common blocks. C ODRV constructs a reordering of the rows and columns of C a matrix by the minimum degree algorithm. ODRV is a C driver routine which calls Subroutines MD, MDI, MDM, C MDP, MDU, and SRO. See Ref. 2 for details. (The ODRV C module has been modified since Ref. 2, however.) C CDRV performs reordering, symbolic factorization, numerical C factorization, or linear system solution operations, C depending on a path argument ipath. CDRV is a C driver routine which calls Subroutines NROC, NSFC, C NNFC, NNSC, and NNTC. See Ref. 3 for details. C DLSODES uses CDRV to solve linear systems in which the C coefficient matrix is P = I - con*J, where I is the C identity, con is a scalar, and J is an approximation to C the Jacobian df/dy. Because CDRV deals with rowwise C sparsity descriptions, CDRV works with P-transpose, not P. C DUMACH computes the unit roundoff in a machine-independent manner. C XERRWD, XSETUN, XSETF, IXSAV, and IUMACH handle the printing of all C error messages and warnings. XERRWD is machine-dependent. C Note: DVNORM, DUMACH, IXSAV, and IUMACH are function routines. C All the others are subroutines. C C----------------------------------------------------------------------- EXTERNAL DPRJS, DSOLSS DOUBLE PRECISION DUMACH, DVNORM INTEGER INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, IOWNS, 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU INTEGER IPLOST, IESP, ISTATC, IYS, IBA, IBIAN, IBJAN, IBJGP, 1 IPIAN, IPJAN, IPJGP, IPIGP, IPR, IPC, IPIC, IPISP, IPRSP, IPA, 2 LENYH, LENYHM, LENWK, LREQ, LRAT, LREST, LWMIN, MOSS, MSBJ, 3 NSLJ, NGP, NLU, NNZ, NSP, NZL, NZU INTEGER I, I1, I2, IFLAG, IMAX, IMUL, IMXER, IPFLAG, IPGO, IREM, 1 J, KGO, LENRAT, LENYHT, LENIW, LENRW, LF0, LIA, LJA, 2 LRTEM, LWTEM, LYHD, LYHN, MF1, MORD, MXHNL0, MXSTP0, NCOLM DOUBLE PRECISION ROWNS, 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND DOUBLE PRECISION CON0, CONMIN, CCMXJ, PSMALL, RBIG, SETH DOUBLE PRECISION ATOLI, AYI, BIG, EWTI, H0, HMAX, HMX, RH, RTOLI, 1 TCRIT, TDIST, TNEXT, TOL, TOLSF, TP, SIZE, SUM, W0 DIMENSION MORD(2) LOGICAL IHIT CHARACTER(LEN=80) MSG SAVE LENRAT, MORD, MXSTP0, MXHNL0 C----------------------------------------------------------------------- C The following two internal Common blocks contain C (a) variables which are local to any subroutine but whose values must C be preserved between calls to the routine ("own" variables), and C (b) variables which are communicated between subroutines. C The block DLS001 is declared in subroutines DLSODES, DIPREP, DPREP, C DINTDY, DSTODE, DPRJS, and DSOLSS. C The block DLSS01 is declared in subroutines DLSODES, DIPREP, DPREP, C DPRJS, and DSOLSS. C Groups of variables are replaced by dummy arrays in the Common C declarations in routines where those variables are not used. C----------------------------------------------------------------------- COMMON /DLS001/ ROWNS(209), 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 2 INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, IOWNS(6), 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU C COMMON /DLSS01/ CON0, CONMIN, CCMXJ, PSMALL, RBIG, SETH, 1 IPLOST, IESP, ISTATC, IYS, IBA, IBIAN, IBJAN, IBJGP, 2 IPIAN, IPJAN, IPJGP, IPIGP, IPR, IPC, IPIC, IPISP, IPRSP, IPA, 3 LENYH, LENYHM, LENWK, LREQ, LRAT, LREST, LWMIN, MOSS, MSBJ, 4 NSLJ, NGP, NLU, NNZ, NSP, NZL, NZU C DATA MORD(1),MORD(2)/12,5/, MXSTP0/500/, MXHNL0/10/ C----------------------------------------------------------------------- C In the Data statement below, set LENRAT equal to the ratio of C the wordlength for a real number to that for an integer. Usually, C LENRAT = 1 for single precision and 2 for double precision. If the C true ratio is not an integer, use the next smaller integer (.ge. 1). C----------------------------------------------------------------------- DATA LENRAT/2/ C----------------------------------------------------------------------- C Block A. C This code block is executed on every call. C It tests ISTATE and ITASK for legality and branches appropriately. C If ISTATE .gt. 1 but the flag INIT shows that initialization has C not yet been done, an error return occurs. C If ISTATE = 1 and TOUT = T, return immediately. C----------------------------------------------------------------------- IF (ISTATE .LT. 1 .OR. ISTATE .GT. 3) GO TO 601 IF (ITASK .LT. 1 .OR. ITASK .GT. 5) GO TO 602 IF (ISTATE .EQ. 1) GO TO 10 IF (INIT .EQ. 0) GO TO 603 IF (ISTATE .EQ. 2) GO TO 200 GO TO 20 10 INIT = 0 IF (TOUT .EQ. T) RETURN C----------------------------------------------------------------------- C Block B. C The next code block is executed for the initial call (ISTATE = 1), C or for a continuation call with parameter changes (ISTATE = 3). C It contains checking of all inputs and various initializations. C If ISTATE = 1, the final setting of work space pointers, the matrix C preprocessing, and other initializations are done in Block C. C C First check legality of the non-optional inputs NEQ, ITOL, IOPT, C MF, ML, and MU. C----------------------------------------------------------------------- 20 IF (NEQ(1) .LE. 0) GO TO 604 IF (ISTATE .EQ. 1) GO TO 25 IF (NEQ(1) .GT. N) GO TO 605 25 N = NEQ(1) IF (ITOL .LT. 1 .OR. ITOL .GT. 4) GO TO 606 IF (IOPT .LT. 0 .OR. IOPT .GT. 1) GO TO 607 MOSS = MF/100 MF1 = MF - 100*MOSS METH = MF1/10 MITER = MF1 - 10*METH IF (MOSS .LT. 0 .OR. MOSS .GT. 2) GO TO 608 IF (METH .LT. 1 .OR. METH .GT. 2) GO TO 608 IF (MITER .LT. 0 .OR. MITER .GT. 3) GO TO 608 IF (MITER .EQ. 0 .OR. MITER .EQ. 3) MOSS = 0 C Next process and check the optional inputs. -------------------------- IF (IOPT .EQ. 1) GO TO 40 MAXORD = MORD(METH) MXSTEP = MXSTP0 MXHNIL = MXHNL0 IF (ISTATE .EQ. 1) H0 = 0.0D0 HMXI = 0.0D0 HMIN = 0.0D0 SETH = 0.0D0 GO TO 60 40 MAXORD = IWORK(5) IF (MAXORD .LT. 0) GO TO 611 IF (MAXORD .EQ. 0) MAXORD = 100 MAXORD = MIN(MAXORD,MORD(METH)) MXSTEP = IWORK(6) IF (MXSTEP .LT. 0) GO TO 612 IF (MXSTEP .EQ. 0) MXSTEP = MXSTP0 MXHNIL = IWORK(7) IF (MXHNIL .LT. 0) GO TO 613 IF (MXHNIL .EQ. 0) MXHNIL = MXHNL0 IF (ISTATE .NE. 1) GO TO 50 H0 = RWORK(5) IF ((TOUT - T)*H0 .LT. 0.0D0) GO TO 614 50 HMAX = RWORK(6) IF (HMAX .LT. 0.0D0) GO TO 615 HMXI = 0.0D0 IF (HMAX .GT. 0.0D0) HMXI = 1.0D0/HMAX HMIN = RWORK(7) IF (HMIN .LT. 0.0D0) GO TO 616 SETH = RWORK(8) IF (SETH .LT. 0.0D0) GO TO 609 C Check RTOL and ATOL for legality. ------------------------------------ 60 RTOLI = RTOL(1) ATOLI = ATOL(1) DO 65 I = 1,N IF (ITOL .GE. 3) RTOLI = RTOL(I) IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) IF (RTOLI .LT. 0.0D0) GO TO 619 IF (ATOLI .LT. 0.0D0) GO TO 620 65 CONTINUE C----------------------------------------------------------------------- C Compute required work array lengths, as far as possible, and test C these against LRW and LIW. Then set tentative pointers for work C arrays. Pointers to RWORK/IWORK segments are named by prefixing L to C the name of the segment. E.g., the segment YH starts at RWORK(LYH). C Segments of RWORK (in order) are denoted WM, YH, SAVF, EWT, ACOR. C If MITER = 1 or 2, the required length of the matrix work space WM C is not yet known, and so a crude minimum value is used for the C initial tests of LRW and LIW, and YH is temporarily stored as far C to the right in RWORK as possible, to leave the maximum amount C of space for WM for matrix preprocessing. Thus if MITER = 1 or 2 C and MOSS .ne. 2, some of the segments of RWORK are temporarily C omitted, as they are not needed in the preprocessing. These C omitted segments are: ACOR if ISTATE = 1, EWT and ACOR if ISTATE = 3 C and MOSS = 1, and SAVF, EWT, and ACOR if ISTATE = 3 and MOSS = 0. C----------------------------------------------------------------------- LRAT = LENRAT IF (ISTATE .EQ. 1) NYH = N LWMIN = 0 IF (MITER .EQ. 1) LWMIN = 4*N + 10*N/LRAT IF (MITER .EQ. 2) LWMIN = 4*N + 11*N/LRAT IF (MITER .EQ. 3) LWMIN = N + 2 LENYH = (MAXORD+1)*NYH LREST = LENYH + 3*N LENRW = 20 + LWMIN + LREST IWORK(17) = LENRW LENIW = 30 IF (MOSS .EQ. 0 .AND. MITER .NE. 0 .AND. MITER .NE. 3) 1 LENIW = LENIW + N + 1 IWORK(18) = LENIW IF (LENRW .GT. LRW) GO TO 617 IF (LENIW .GT. LIW) GO TO 618 LIA = 31 IF (MOSS .EQ. 0 .AND. MITER .NE. 0 .AND. MITER .NE. 3) 1 LENIW = LENIW + IWORK(LIA+N) - 1 IWORK(18) = LENIW IF (LENIW .GT. LIW) GO TO 618 LJA = LIA + N + 1 LIA = MIN(LIA,LIW) LJA = MIN(LJA,LIW) LWM = 21 IF (ISTATE .EQ. 1) NQ = 1 NCOLM = MIN(NQ+1,MAXORD+2) LENYHM = NCOLM*NYH LENYHT = LENYH IF (MITER .EQ. 1 .OR. MITER .EQ. 2) LENYHT = LENYHM IMUL = 2 IF (ISTATE .EQ. 3) IMUL = MOSS IF (MOSS .EQ. 2) IMUL = 3 LRTEM = LENYHT + IMUL*N LWTEM = LWMIN IF (MITER .EQ. 1 .OR. MITER .EQ. 2) LWTEM = LRW - 20 - LRTEM LENWK = LWTEM LYHN = LWM + LWTEM LSAVF = LYHN + LENYHT LEWT = LSAVF + N LACOR = LEWT + N ISTATC = ISTATE IF (ISTATE .EQ. 1) GO TO 100 C----------------------------------------------------------------------- C ISTATE = 3. Move YH to its new location. C Note that only the part of YH needed for the next step, namely C MIN(NQ+1,MAXORD+2) columns, is actually moved. C A temporary error weight array EWT is loaded if MOSS = 2. C Sparse matrix processing is done in DIPREP/DPREP if MITER = 1 or 2. C If MAXORD was reduced below NQ, then the pointers are finally set C so that SAVF is identical to YH(*,MAXORD+2). C----------------------------------------------------------------------- LYHD = LYH - LYHN IMAX = LYHN - 1 + LENYHM C Move YH. Move right if LYHD < 0; move left if LYHD > 0. ------------- IF (LYHD .LT. 0) THEN DO 72 I = LYHN,IMAX J = IMAX + LYHN - I RWORK(J) = RWORK(J+LYHD) 72 CONTINUE ENDIF IF (LYHD .GT. 0) THEN DO 76 I = LYHN,IMAX RWORK(I) = RWORK(I+LYHD) 76 CONTINUE ENDIF LYH = LYHN IWORK(22) = LYH IF (MITER .EQ. 0 .OR. MITER .EQ. 3) GO TO 92 IF (MOSS .NE. 2) GO TO 85 C Temporarily load EWT if MITER = 1 or 2 and MOSS = 2. ----------------- CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) DO 82 I = 1,N IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 621 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 82 CONTINUE 85 CONTINUE C DIPREP and DPREP do sparse matrix preprocessing if MITER = 1 or 2. --- LSAVF = MIN(LSAVF,LRW) LEWT = MIN(LEWT,LRW) LACOR = MIN(LACOR,LRW) CKS CALL DIPREP (NEQ,Y,RWORK,IWK,IWORK(LIA),IWORK(LJA),IPFLAG,F,JAC, & rpar, ipar ) LENRW = LWM - 1 + LENWK + LREST IWORK(17) = LENRW IF (IPFLAG .NE. -1) IWORK(23) = IPIAN IF (IPFLAG .NE. -1) IWORK(24) = IPJAN IPGO = -IPFLAG + 1 IF (IPGO .EQ. 1) THEN GOTO 90 ELSE IF (IPGO .EQ. 2) THEN GOTO 628 ELSE IF (IPGO .EQ. 3) THEN GOTO 629 ELSE IF (IPGO .EQ. 4) THEN GOTO 630 ELSE IF (IPGO .EQ. 5) THEN GOTO 631 ELSE IF (IPGO .EQ. 6) THEN GOTO 632 ELSE IF (IPGO .EQ. 7) THEN GOTO 633 ENDIF C GO TO (90, 628, 629, 630, 631, 632, 633), IPGO 90 IWORK(22) = LYH IF (LENRW .GT. LRW) GO TO 617 C Set flag to signal parameter changes to DSTODE. ---------------------- 92 JSTART = -1 IF (N .EQ. NYH) GO TO 200 C NEQ was reduced. Zero part of YH to avoid undefined references. ----- I1 = LYH + L*NYH I2 = LYH + (MAXORD + 1)*NYH - 1 IF (I1 .GT. I2) GO TO 200 DO 95 I = I1,I2 RWORK(I) = 0.0D0 95 CONTINUE GO TO 200 C----------------------------------------------------------------------- C Block C. C The next block is for the initial call only (ISTATE = 1). C It contains all remaining initializations, the initial call to F, C the sparse matrix preprocessing (MITER = 1 or 2), and the C calculation of the initial step size. C The error weights in EWT are inverted after being loaded. C----------------------------------------------------------------------- 100 CONTINUE LYH = LYHN IWORK(22) = LYH TN = T NST = 0 H = 1.0D0 NNZ = 0 NGP = 0 NZL = 0 NZU = 0 C Load the initial value vector in YH. --------------------------------- DO 105 I = 1,N RWORK(I+LYH-1) = Y(I) 105 CONTINUE C Initial call to F. (LF0 points to YH(*,2).) ------------------------- LF0 = LYH + NYH CALL F (NEQ, T, Y, RWORK(LF0), rpar, ipar) NFE = 1 C Load and invert the EWT array. (H is temporarily set to 1.0.) ------- CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) DO 110 I = 1,N IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 621 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 110 CONTINUE IF (MITER .EQ. 0 .OR. MITER .EQ. 3) GO TO 120 C DIPREP and DPREP do sparse matrix preprocessing if MITER = 1 or 2. --- LACOR = MIN(LACOR,LRW) CALL DIPREP (NEQ,Y,RWORK,IWK,IWORK(LIA),IWORK(LJA),IPFLAG,F,JAC, & rpar, ipar) LENRW = LWM - 1 + LENWK + LREST IWORK(17) = LENRW IF (IPFLAG .NE. -1) IWORK(23) = IPIAN IF (IPFLAG .NE. -1) IWORK(24) = IPJAN IPGO = -IPFLAG + 1 IF (IPGO .EQ. 1) THEN GOTO 115 ELSE IF (IPGO .EQ. 2) THEN GOTO 628 ELSE IF (IPGO .EQ. 3) THEN GOTO 629 ELSE IF (IPGO .EQ. 4) THEN GOTO 630 ELSE IF (IPGO .EQ. 5) THEN GOTO 631 ELSE IF (IPGO .EQ. 6) THEN GOTO 632 ELSE IF (IPGO .EQ. 7) THEN GOTO 633 ENDIF C karline: change from C GO TO (115, 628, 629, 630, 631, 632, 633), IPGO 115 IWORK(22) = LYH IF (LENRW .GT. LRW) GO TO 617 C Check TCRIT for legality (ITASK = 4 or 5). --------------------------- 120 CONTINUE IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 125 TCRIT = RWORK(1) IF ((TCRIT - TOUT)*(TOUT - T) .LT. 0.0D0) GO TO 625 IF (H0 .NE. 0.0D0 .AND. (T + H0 - TCRIT)*H0 .GT. 0.0D0) 1 H0 = TCRIT - T C Initialize all remaining parameters. --------------------------------- 125 UROUND = DUMACH() JSTART = 0 IF (MITER .NE. 0) RWORK(LWM) = SQRT(UROUND) MSBJ = 50 NSLJ = 0 CCMXJ = 0.2D0 PSMALL = 1000.0D0*UROUND RBIG = 0.01D0/PSMALL NHNIL = 0 NJE = 0 NLU = 0 NSLAST = 0 HU = 0.0D0 NQU = 0 CCMAX = 0.3D0 MAXCOR = 3 MSBP = 20 MXNCF = 10 C----------------------------------------------------------------------- C The coding below computes the step size, H0, to be attempted on the C first step, unless the user has supplied a value for this. C First check that TOUT - T differs significantly from zero. C A scalar tolerance quantity TOL is computed, as MAX(RTOL(i)) C if this is positive, or MAX(ATOL(i)/ABS(Y(i))) otherwise, adjusted C so as to be between 100*UROUND and 1.0E-3. C Then the computed value H0 is given by.. C NEQ C H0**2 = TOL / ( w0**-2 + (1/NEQ) * Sum ( f(i)/ywt(i) )**2 ) C 1 C where w0 = MAX ( ABS(T), ABS(TOUT) ), C f(i) = i-th component of initial value of f, C ywt(i) = EWT(i)/TOL (a weight for y(i)). C The sign of H0 is inferred from the initial values of TOUT and T. C ABS(H0) is made .le. ABS(TOUT-T) in any case. C----------------------------------------------------------------------- LF0 = LYH + NYH IF (H0 .NE. 0.0D0) GO TO 180 TDIST = ABS(TOUT - T) W0 = MAX(ABS(T),ABS(TOUT)) IF (TDIST .LT. 2.0D0*UROUND*W0) GO TO 622 TOL = RTOL(1) IF (ITOL .LE. 2) GO TO 140 DO 130 I = 1,N TOL = MAX(TOL,RTOL(I)) 130 CONTINUE 140 IF (TOL .GT. 0.0D0) GO TO 160 ATOLI = ATOL(1) DO 150 I = 1,N IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) AYI = ABS(Y(I)) IF (AYI .NE. 0.0D0) TOL = MAX(TOL,ATOLI/AYI) 150 CONTINUE 160 TOL = MAX(TOL,100.0D0*UROUND) TOL = MIN(TOL,0.001D0) SUM = DVNORM (N, RWORK(LF0), RWORK(LEWT)) SUM = 1.0D0/(TOL*W0*W0) + TOL*SUM**2 H0 = 1.0D0/SQRT(SUM) H0 = MIN(H0,TDIST) H0 = SIGN(H0,TOUT-T) C Adjust H0 if necessary to meet HMAX bound. --------------------------- 180 RH = ABS(H0)*HMXI IF (RH .GT. 1.0D0) H0 = H0/RH C Load H with H0 and scale YH(*,2) by H0. ------------------------------ H = H0 DO 190 I = 1,N RWORK(I+LF0-1) = H0*RWORK(I+LF0-1) 190 CONTINUE GO TO 270 C----------------------------------------------------------------------- C Block D. C The next code block is for continuation calls only (ISTATE = 2 or 3) C and is to check stop conditions before taking a step. C----------------------------------------------------------------------- 200 NSLAST = NST IF (ITASK .EQ. 1) THEN GOTO 210 ELSE IF (ITASK .EQ. 2) THEN GOTO 250 ELSE IF (ITASK .EQ. 3) THEN GOTO 220 ELSE IF (ITASK .EQ. 4) THEN GOTO 230 ELSE IF (ITASK .EQ. 5) THEN GOTO 240 ENDIF C GO TO (210, 250, 220, 230, 240), ITASK 210 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) IF (IFLAG .NE. 0) GO TO 627 T = TOUT GO TO 420 220 TP = TN - HU*(1.0D0 + 100.0D0*UROUND) IF ((TP - TOUT)*H .GT. 0.0D0) GO TO 623 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 GO TO 400 230 TCRIT = RWORK(1) IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 IF ((TCRIT - TOUT)*H .LT. 0.0D0) GO TO 625 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 245 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) IF (IFLAG .NE. 0) GO TO 627 T = TOUT GO TO 420 240 TCRIT = RWORK(1) IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 245 HMX = ABS(TN) + ABS(H) IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX IF (IHIT) GO TO 400 TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) IF (ISTATE .EQ. 2) JSTART = -2 C----------------------------------------------------------------------- C Block E. C The next block is normally executed for all calls and contains C the call to the one-step core integrator DSTODE. C C This is a looping point for the integration steps. C C First check for too many steps being taken, update EWT (if not at C start of problem), check for too much accuracy being requested, and C check for H below the roundoff level in T. C----------------------------------------------------------------------- 250 CONTINUE IF ((NST-NSLAST) .GE. MXSTEP) GO TO 500 CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) DO 260 I = 1,N IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 510 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 260 CONTINUE 270 TOLSF = UROUND*DVNORM (N, RWORK(LYH), RWORK(LEWT)) IF (TOLSF .LE. 1.0D0) GO TO 280 TOLSF = TOLSF*2.0D0 IF (NST .EQ. 0) GO TO 626 GO TO 520 280 IF ((TN + H) .NE. TN) GO TO 290 NHNIL = NHNIL + 1 IF (NHNIL .GT. MXHNIL) GO TO 290 MSG = 'DLSODES- Warning..Internal T (=R1) and H (=R2) are' CALL XERRWD (MSG, 50, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' such that in the machine, T + H = T on the next step ' CALL XERRWD (MSG, 60, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' (H = step size). Solver will continue anyway.' CALL XERRWD (MSG, 50, 101, 0, 0, 0, 0, 2, TN, H) IF (NHNIL .LT. MXHNIL) GO TO 290 MSG = 'DLSODES- Above warning has been issued I1 times. ' CALL XERRWD (MSG, 50, 102, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' It will not be issued again for this problem.' CALL XERRWD (MSG, 50, 102, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0) 290 CONTINUE C----------------------------------------------------------------------- C CALL DSTODE(NEQ,Y,YH,NYH,YH,EWT,SAVF,ACOR,WM,WM,F,JAC,DPRJS,DSOLSS) C----------------------------------------------------------------------- CALL DSTODE (NEQ, Y, RWORK(LYH), NYH, RWORK(LYH), RWORK(LEWT), 1 RWORK(LSAVF), RWORK(LACOR), RWORK(LWM), IWK(2*LWM-1), 2 F, JAC, DPRJS, DSOLSS, rpar,ipar) KGO = 1 - KFLAG IF (KGO .EQ. 1) THEN GOTO 300 ELSE IF (KGO .EQ. 2) THEN GOTO 530 ELSE IF (KGO .EQ. 3) THEN GOTO 540 ELSE IF (KGO .EQ. 4) THEN GOTO 550 ENDIF C GO TO (300, 530, 540, 550), KGO C----------------------------------------------------------------------- C Block F. C The following block handles the case of a successful return from the C core integrator (KFLAG = 0). Test for stop conditions. C----------------------------------------------------------------------- 300 INIT = 1 IF (ITASK .EQ. 1) THEN GOTO 310 ELSE IF (ITASK .EQ. 2) THEN GOTO 400 ELSE IF (ITASK .EQ. 3) THEN GOTO 330 ELSE IF (ITASK .EQ. 4) THEN GOTO 340 ELSE IF (ITASK .EQ. 5) THEN GOTO 350 ENDIF C karline: changed from C GO TO (310, 400, 330, 340, 350), ITASK C ITASK = 1. if TOUT has been reached, interpolate. ------------------- 310 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) T = TOUT GO TO 420 C ITASK = 3. Jump to exit if TOUT was reached. ------------------------ 330 IF ((TN - TOUT)*H .GE. 0.0D0) GO TO 400 GO TO 250 C ITASK = 4. See if TOUT or TCRIT was reached. Adjust H if necessary. 340 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 345 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) T = TOUT GO TO 420 345 HMX = ABS(TN) + ABS(H) IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX IF (IHIT) GO TO 400 TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) JSTART = -2 GO TO 250 C ITASK = 5. See if TCRIT was reached and jump to exit. --------------- 350 HMX = ABS(TN) + ABS(H) IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX C----------------------------------------------------------------------- C Block G. C The following block handles all successful returns from DLSODES. C If ITASK .ne. 1, Y is loaded from YH and T is set accordingly. C ISTATE is set to 2, and the optional outputs are loaded into the C work arrays before returning. C----------------------------------------------------------------------- 400 DO 410 I = 1,N Y(I) = RWORK(I+LYH-1) 410 CONTINUE T = TN IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 420 IF (IHIT) T = TCRIT 420 ISTATE = 2 RWORK(11) = HU RWORK(12) = H RWORK(13) = TN IWORK(11) = NST IWORK(12) = NFE IWORK(13) = NJE IWORK(14) = NQU IWORK(15) = NQ IWORK(19) = NNZ IWORK(20) = NGP IWORK(21) = NLU IWORK(25) = NZL IWORK(26) = NZU RETURN C----------------------------------------------------------------------- C Block H. C The following block handles all unsuccessful returns other than C those for illegal input. First the error message routine is called. C If there was an error test or convergence test failure, IMXER is set. C Then Y is loaded from YH and T is set to TN. C The optional outputs are loaded into the work arrays before returning. C----------------------------------------------------------------------- C The maximum number of steps was taken before reaching TOUT. ---------- 500 MSG = 'DLSODES- At current T (=R1), MXSTEP (=I1) steps ' CALL XERRWD (MSG, 50, 201, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' taken on this call before reaching TOUT ' CALL XERRWD (MSG, 50, 201, 0, 1, MXSTEP, 0, 1, TN, 0.0D0) ISTATE = -1 GO TO 580 C EWT(i) .le. 0.0 for some i (not at start of problem). ---------------- 510 EWTI = RWORK(LEWT+I-1) MSG = 'DLSODES- At T (=R1), EWT(I1) has become R2 .le. 0.' CALL XERRWD (MSG, 50, 202, 0, 1, I, 0, 2, TN, EWTI) ISTATE = -6 GO TO 580 C Too much accuracy requested for machine precision. ------------------- 520 MSG = 'DLSODES- At T (=R1), too much accuracy requested ' CALL XERRWD (MSG, 50, 203, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' for precision of machine.. See TOLSF (=R2) ' CALL XERRWD (MSG, 50, 203, 0, 0, 0, 0, 2, TN, TOLSF) RWORK(14) = TOLSF ISTATE = -2 GO TO 580 C KFLAG = -1. Error test failed repeatedly or with ABS(H) = HMIN. ----- 530 MSG = 'DLSODES- At T(=R1) and step size H(=R2), the error' CALL XERRWD (MSG, 50, 204, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' test failed repeatedly or with ABS(H) = HMIN' CALL XERRWD (MSG, 50, 204, 0, 0, 0, 0, 2, TN, H) ISTATE = -4 GO TO 560 C KFLAG = -2. Convergence failed repeatedly or with ABS(H) = HMIN. ---- 540 MSG = 'DLSODES- At T (=R1) and step size H (=R2), the ' CALL XERRWD (MSG, 50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' corrector convergence failed repeatedly ' CALL XERRWD (MSG, 50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' or with ABS(H) = HMIN ' CALL XERRWD (MSG, 30, 205, 0, 0, 0, 0, 2, TN, H) ISTATE = -5 GO TO 560 C KFLAG = -3. Fatal error flag returned by DPRJS or DSOLSS (CDRV). ---- 550 MSG = 'DLSODES- At T (=R1) and step size H (=R2), a fatal' CALL XERRWD (MSG, 50, 207, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' error flag was returned by CDRV (by way of ' CALL XERRWD (MSG, 50, 207, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' Subroutine DPRJS or DSOLSS) ' CALL XERRWD (MSG, 40, 207, 0, 0, 0, 0, 2, TN, H) ISTATE = -7 GO TO 580 C Compute IMXER if relevant. ------------------------------------------- 560 BIG = 0.0D0 IMXER = 1 DO 570 I = 1,N SIZE = ABS(RWORK(I+LACOR-1)*RWORK(I+LEWT-1)) IF (BIG .GE. SIZE) GO TO 570 BIG = SIZE IMXER = I 570 CONTINUE IWORK(16) = IMXER C Set Y vector, T, and optional outputs. ------------------------------- 580 DO 590 I = 1,N Y(I) = RWORK(I+LYH-1) 590 CONTINUE T = TN RWORK(11) = HU RWORK(12) = H RWORK(13) = TN IWORK(11) = NST IWORK(12) = NFE IWORK(13) = NJE IWORK(14) = NQU IWORK(15) = NQ IWORK(19) = NNZ IWORK(20) = NGP IWORK(21) = NLU IWORK(25) = NZL IWORK(26) = NZU RETURN C----------------------------------------------------------------------- C Block I. C The following block handles all error returns due to illegal input C (ISTATE = -3), as detected before calling the core integrator. C First the error message routine is called. If the illegal input C is a negative ISTATE, the run is aborted (apparent infinite loop). C----------------------------------------------------------------------- 601 MSG = 'DLSODES- ISTATE (=I1) illegal.' CALL XERRWD (MSG, 30, 1, 0, 1, ISTATE, 0, 0, 0.0D0, 0.0D0) IF (ISTATE .LT. 0) GO TO 800 GO TO 700 602 MSG = 'DLSODES- ITASK (=I1) illegal. ' CALL XERRWD (MSG, 30, 2, 0, 1, ITASK, 0, 0, 0.0D0, 0.0D0) GO TO 700 603 MSG = 'DLSODES- ISTATE.gt.1 but DLSODES not initialized. ' CALL XERRWD (MSG, 50, 3, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) GO TO 700 604 MSG = 'DLSODES- NEQ (=I1) .lt. 1 ' CALL XERRWD (MSG, 30, 4, 0, 1, NEQ(1), 0, 0, 0.0D0, 0.0D0) GO TO 700 605 MSG = 'DLSODES- ISTATE = 3 and NEQ increased (I1 to I2). ' CALL XERRWD (MSG, 50, 5, 0, 2, N, NEQ(1), 0, 0.0D0, 0.0D0) GO TO 700 606 MSG = 'DLSODES- ITOL (=I1) illegal. ' CALL XERRWD (MSG, 30, 6, 0, 1, ITOL, 0, 0, 0.0D0, 0.0D0) GO TO 700 607 MSG = 'DLSODES- IOPT (=I1) illegal. ' CALL XERRWD (MSG, 30, 7, 0, 1, IOPT, 0, 0, 0.0D0, 0.0D0) GO TO 700 608 MSG = 'DLSODES- MF (=I1) illegal. ' CALL XERRWD (MSG, 30, 8, 0, 1, MF, 0, 0, 0.0D0, 0.0D0) GO TO 700 609 MSG = 'DLSODES- SETH (=R1) .lt. 0.0 ' CALL XERRWD (MSG, 30, 9, 0, 0, 0, 0, 1, SETH, 0.0D0) GO TO 700 611 MSG = 'DLSODES- MAXORD (=I1) .lt. 0 ' CALL XERRWD (MSG, 30, 11, 0, 1, MAXORD, 0, 0, 0.0D0, 0.0D0) GO TO 700 612 MSG = 'DLSODES- MXSTEP (=I1) .lt. 0 ' CALL XERRWD (MSG, 30, 12, 0, 1, MXSTEP, 0, 0, 0.0D0, 0.0D0) GO TO 700 613 MSG = 'DLSODES- MXHNIL (=I1) .lt. 0 ' CALL XERRWD (MSG, 30, 13, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0) GO TO 700 614 MSG = 'DLSODES- TOUT (=R1) behind T (=R2) ' CALL XERRWD (MSG, 40, 14, 0, 0, 0, 0, 2, TOUT, T) MSG = ' Integration direction is given by H0 (=R1) ' CALL XERRWD (MSG, 50, 14, 0, 0, 0, 0, 1, H0, 0.0D0) GO TO 700 615 MSG = 'DLSODES- HMAX (=R1) .lt. 0.0 ' CALL XERRWD (MSG, 30, 15, 0, 0, 0, 0, 1, HMAX, 0.0D0) GO TO 700 616 MSG = 'DLSODES- HMIN (=R1) .lt. 0.0 ' CALL XERRWD (MSG, 30, 16, 0, 0, 0, 0, 1, HMIN, 0.0D0) GO TO 700 617 MSG = 'DLSODES- RWORK length is insufficient to proceed. ' CALL XERRWD (MSG, 50, 17, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' set argument lrw larger than LENRW (=I1), is now: LRW (=I2)' CALL XERRWD (MSG, 60, 17, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) GO TO 700 618 MSG = 'DLSODES- IWORK length is insufficient to proceed. ' CALL XERRWD (MSG, 50, 18, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' Length needed is .ge. LENIW (=I1), exceeds LIW (=I2)' CALL XERRWD (MSG, 60, 18, 0, 2, LENIW, LIW, 0, 0.0D0, 0.0D0) GO TO 700 619 MSG = 'DLSODES- RTOL(I1) is R1 .lt. 0.0 ' CALL XERRWD (MSG, 40, 19, 0, 1, I, 0, 1, RTOLI, 0.0D0) GO TO 700 620 MSG = 'DLSODES- ATOL(I1) is R1 .lt. 0.0 ' CALL XERRWD (MSG, 40, 20, 0, 1, I, 0, 1, ATOLI, 0.0D0) GO TO 700 621 EWTI = RWORK(LEWT+I-1) MSG = 'DLSODES- EWT(I1) is R1 .le. 0.0 ' CALL XERRWD (MSG, 40, 21, 0, 1, I, 0, 1, EWTI, 0.0D0) GO TO 700 622 MSG='DLSODES- TOUT(=R1) too close to T(=R2) to start integration.' CALL XERRWD (MSG, 60, 22, 0, 0, 0, 0, 2, TOUT, T) GO TO 700 623 MSG='DLSODES- ITASK = I1 and TOUT (=R1) behind TCUR - HU (= R2) ' CALL XERRWD (MSG, 60, 23, 0, 1, ITASK, 0, 2, TOUT, TP) GO TO 700 624 MSG='DLSODES- ITASK = 4 or 5 and TCRIT (=R1) behind TCUR (=R2) ' CALL XERRWD (MSG, 60, 24, 0, 0, 0, 0, 2, TCRIT, TN) GO TO 700 625 MSG='DLSODES- ITASK = 4 or 5 and TCRIT (=R1) behind TOUT (=R2) ' CALL XERRWD (MSG, 60, 25, 0, 0, 0, 0, 2, TCRIT, TOUT) GO TO 700 626 MSG = 'DLSODES- At start of problem, too much accuracy ' CALL XERRWD (MSG, 50, 26, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' requested for precision of machine.. See TOLSF (=R1) ' CALL XERRWD (MSG, 60, 26, 0, 0, 0, 0, 1, TOLSF, 0.0D0) RWORK(14) = TOLSF GO TO 700 627 MSG = 'DLSODES- Trouble in DINTDY. ITASK = I1, TOUT = R1' CALL XERRWD (MSG, 50, 27, 0, 1, ITASK, 0, 1, TOUT, 0.0D0) GO TO 700 628 MSG='DLSODES- RWORK length insufficient (for Subroutine DPREP). ' CALL XERRWD (MSG, 60, 28, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' Length needed is .ge. LENRW (=I1), exceeds LRW (=I2)' CALL XERRWD (MSG, 60, 28, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) GO TO 700 629 MSG='DLSODES- RWORK length insufficient (for Subroutine JGROUP). ' CALL XERRWD (MSG, 60, 29, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' Length needed is .ge. LENRW (=I1), exceeds LRW (=I2)' CALL XERRWD (MSG, 60, 29, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) GO TO 700 630 MSG='DLSODES- RWORK length insufficient (for Subroutine ODRV). ' CALL XERRWD (MSG, 60, 30, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' Length needed is .ge. LENRW (=I1), exceeds LRW (=I2)' CALL XERRWD (MSG, 60, 30, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) GO TO 700 631 MSG='DLSODES- Error from ODRV in Yale Sparse Matrix Package. ' CALL XERRWD (MSG, 60, 31, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) IMUL = (IYS - 1)/N IREM = IYS - IMUL*N MSG=' At T (=R1), ODRV returned error flag = I1*NEQ + I2. ' CALL XERRWD (MSG, 60, 31, 0, 2, IMUL, IREM, 1, TN, 0.0D0) GO TO 700 632 MSG='DLSODES- RWORK length insufficient (for Subroutine CDRV). ' CALL XERRWD (MSG, 60, 32, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' Length needed is .ge. LENRW (=I1), exceeds LRW (=I2)' CALL XERRWD (MSG, 60, 32, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) GO TO 700 633 MSG='DLSODES- Error from CDRV in Yale Sparse Matrix Package. ' CALL XERRWD (MSG, 60, 33, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) IMUL = (IYS - 1)/N IREM = IYS - IMUL*N MSG=' At T (=R1), CDRV returned error flag = I1*NEQ + I2. ' CALL XERRWD (MSG, 60, 33, 0, 2, IMUL, IREM, 1, TN, 0.0D0) IF (IMUL .EQ. 2) THEN MSG=' Duplicate entry in sparsity structure descriptors. ' CALL XERRWD (MSG, 60, 33, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) ENDIF IF (IMUL .EQ. 3 .OR. IMUL .EQ. 6) THEN MSG=' Insufficient storage for NSFC (called by CDRV). ' CALL XERRWD (MSG, 60, 33, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) ENDIF C 700 ISTATE = -3 RETURN C 800 MSG = 'DLSODES- Run aborted.. apparent infinite loop. ' CALL XERRWD (MSG, 50, 303, 2, 0, 0, 0, 0, 0.0D0, 0.0D0) RETURN C----------------------- End of Subroutine DLSODES --------------------- END *DECK DLSODA SUBROUTINE DLSODA (F, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, ITASK, 1 ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JAC, JT, 2 rpar, ipar) EXTERNAL F, JAC CKS: added rpar, ipar integer ipar(*) double precision rpar(*) INTEGER NEQ, ITOL, ITASK, ISTATE, IOPT, LRW, IWORK, LIW, JT DOUBLE PRECISION Y, T, TOUT, RTOL, ATOL, RWORK DIMENSION NEQ(*), Y(*), RTOL(*), ATOL(*), RWORK(LRW), IWORK(LIW) C----------------------------------------------------------------------- C This is the 12 November 2003 version of C DLSODA: Livermore Solver for Ordinary Differential Equations, with C Automatic method switching for stiff and nonstiff problems. C C This version is in double precision. C C DLSODA solves the initial value problem for stiff or nonstiff C systems of first order ODEs, C dy/dt = f(t,y) , or, in component form, C dy(i)/dt = f(i) = f(i,t,y(1),y(2),...,y(NEQ)) (i = 1,...,NEQ). C C This a variant version of the DLSODE package. C It switches automatically between stiff and nonstiff methods. C This means that the user does not have to determine whether the C problem is stiff or not, and the solver will automatically choose the C appropriate method. It always starts with the nonstiff method. C C Authors: Alan C. Hindmarsh C Center for Applied Scientific Computing, L-561 C Lawrence Livermore National Laboratory C Livermore, CA 94551 C and C Linda R. Petzold C Univ. of California at Santa Barbara C Dept. of Computer Science C Santa Barbara, CA 93106 C C References: C 1. Alan C. Hindmarsh, ODEPACK, A Systematized Collection of ODE C Solvers, in Scientific Computing, R. S. Stepleman et al. (Eds.), C North-Holland, Amsterdam, 1983, pp. 55-64. C 2. Linda R. Petzold, Automatic Selection of Methods for Solving C Stiff and Nonstiff Systems of Ordinary Differential Equations, C Siam J. Sci. Stat. Comput. 4 (1983), pp. 136-148. C----------------------------------------------------------------------- C Summary of Usage. C C Communication between the user and the DLSODA package, for normal C situations, is summarized here. This summary describes only a subset C of the full set of options available. See the full description for C details, including alternative treatment of the Jacobian matrix, C optional inputs and outputs, nonstandard options, and C instructions for special situations. See also the example C problem (with program and output) following this summary. C C A. First provide a subroutine of the form: C SUBROUTINE F (NEQ, T, Y, YDOT,rpar,ipar) C INTEGER NEQ,ipar(*) C DOUBLE PRECISION T, Y(*), YDOT(*),rpar(*) C which supplies the vector function f by loading YDOT(i) with f(i). C C B. Write a main program which calls Subroutine DLSODA once for C each point at which answers are desired. This should also provide C for possible use of logical unit 6 for output of error messages C by DLSODA. On the first call to DLSODA, supply arguments as follows: C F = name of subroutine for right-hand side vector f. C This name must be declared External in calling program. C NEQ = number of first order ODEs. C Y = array of initial values, of length NEQ. C T = the initial value of the independent variable. C TOUT = first point where output is desired (.ne. T). C ITOL = 1 or 2 according as ATOL (below) is a scalar or array. C RTOL = relative tolerance parameter (scalar). C ATOL = absolute tolerance parameter (scalar or array). C the estimated local error in y(i) will be controlled so as C to be less than C EWT(i) = RTOL*ABS(Y(i)) + ATOL if ITOL = 1, or C EWT(i) = RTOL*ABS(Y(i)) + ATOL(i) if ITOL = 2. C Thus the local error test passes if, in each component, C either the absolute error is less than ATOL (or ATOL(i)), C or the relative error is less than RTOL. C Use RTOL = 0.0 for pure absolute error control, and C use ATOL = 0.0 (or ATOL(i) = 0.0) for pure relative error C control. Caution: actual (global) errors may exceed these C local tolerances, so choose them conservatively. C ITASK = 1 for normal computation of output values of y at t = TOUT. C ISTATE = integer flag (input and output). Set ISTATE = 1. C IOPT = 0 to indicate no optional inputs used. C RWORK = real work array of length at least: C 22 + NEQ * MAX(16, NEQ + 9). C See also Paragraph E below. C LRW = declared length of RWORK (in user's dimension). C IWORK = integer work array of length at least 20 + NEQ. C LIW = declared length of IWORK (in user's dimension). C JAC = name of subroutine for Jacobian matrix. C Use a dummy name. See also Paragraph E below. C JT = Jacobian type indicator. Set JT = 2. C See also Paragraph E below. C Note that the main program must declare arrays Y, RWORK, IWORK, C and possibly ATOL. C C C. The output from the first call (or any call) is: C Y = array of computed values of y(t) vector. C T = corresponding value of independent variable (normally TOUT). C ISTATE = 2 if DLSODA was successful, negative otherwise. C -1 means excess work done on this call (perhaps wrong JT). C -2 means excess accuracy requested (tolerances too small). C -3 means illegal input detected (see printed message). C -4 means repeated error test failures (check all inputs). C -5 means repeated convergence failures (perhaps bad Jacobian C supplied or wrong choice of JT or tolerances). C -6 means error weight became zero during problem. (Solution C component i vanished, and ATOL or ATOL(i) = 0.) C -7 means work space insufficient to finish (see messages). C C D. To continue the integration after a successful return, simply C reset TOUT and call DLSODA again. No other parameters need be reset. C C E. Note: If and when DLSODA regards the problem as stiff, and C switches methods accordingly, it must make use of the NEQ by NEQ C Jacobian matrix, J = df/dy. For the sake of simplicity, the C inputs to DLSODA recommended in Paragraph B above cause DLSODA to C treat J as a full matrix, and to approximate it internally by C difference quotients. Alternatively, J can be treated as a band C matrix (with great potential reduction in the size of the RWORK C array). Also, in either the full or banded case, the user can supply C J in closed form, with a routine whose name is passed as the JAC C argument. These alternatives are described in the paragraphs on C RWORK, JAC, and JT in the full description of the call sequence below. C C----------------------------------------------------------------------- C Example Problem. C C The following is a simple example problem, with the coding C needed for its solution by DLSODA. The problem is from chemical C kinetics, and consists of the following three rate equations: C dy1/dt = -.04*y1 + 1.e4*y2*y3 C dy2/dt = .04*y1 - 1.e4*y2*y3 - 3.e7*y2**2 C dy3/dt = 3.e7*y2**2 C on the interval from t = 0.0 to t = 4.e10, with initial conditions C y1 = 1.0, y2 = y3 = 0. The problem is stiff. C C The following coding solves this problem with DLSODA, C printing results at t = .4, 4., ..., 4.e10. It uses C ITOL = 2 and ATOL much smaller for y2 than y1 or y3 because C y2 has much smaller values. C At the end of the run, statistical quantities of interest are C printed (see optional outputs in the full description below). C C EXTERNAL FEX C DOUBLE PRECISION ATOL, RTOL, RWORK, T, TOUT, Y C DIMENSION Y(3), ATOL(3), RWORK(70), IWORK(23) C NEQ = 3 C Y(1) = 1. C Y(2) = 0. C Y(3) = 0. C T = 0. C TOUT = .4 C ITOL = 2 C RTOL = 1.D-4 C ATOL(1) = 1.D-6 C ATOL(2) = 1.D-10 C ATOL(3) = 1.D-6 C ITASK = 1 C ISTATE = 1 C IOPT = 0 C LRW = 70 C LIW = 23 C JT = 2 C DO 40 IOUT = 1,12 C CALL DLSODA(FEX,NEQ,Y,T,TOUT,ITOL,RTOL,ATOL,ITASK,ISTATE, C 1 IOPT,RWORK,LRW,IWORK,LIW,JDUM,JT) C WRITE(6,20)T,Y(1),Y(2),Y(3) C 20 FORMAT(' At t =',D12.4,' Y =',3D14.6) C IF (ISTATE .LT. 0) GO TO 80 C 40 TOUT = TOUT*10. C WRITE(6,60)IWORK(11),IWORK(12),IWORK(13),IWORK(19),RWORK(15) C 60 FORMAT(/' No. steps =',I4,' No. f-s =',I4,' No. J-s =',I4/ C 1 ' Method last used =',I2,' Last switch was at t =',D12.4) C STOP C 80 WRITE(6,90)ISTATE C 90 FORMAT(///' Error halt.. ISTATE =',I3) C STOP C END C C SUBROUTINE FEX (NEQ, T, Y, YDOT,rpar,ipar) C DOUBLE PRECISION T, Y, YDOT,rpar(*) C DIMENSION Y(3), YDOT(3) C YDOT(1) = -.04*Y(1) + 1.D4*Y(2)*Y(3) C YDOT(3) = 3.D7*Y(2)*Y(2) C YDOT(2) = -YDOT(1) - YDOT(3) C RETURN C END C C The output of this program (on a CDC-7600 in single precision) C is as follows: C C At t = 4.0000e-01 y = 9.851712e-01 3.386380e-05 1.479493e-02 C At t = 4.0000e+00 Y = 9.055333e-01 2.240655e-05 9.444430e-02 C At t = 4.0000e+01 Y = 7.158403e-01 9.186334e-06 2.841505e-01 C At t = 4.0000e+02 Y = 4.505250e-01 3.222964e-06 5.494717e-01 C At t = 4.0000e+03 Y = 1.831975e-01 8.941774e-07 8.168016e-01 C At t = 4.0000e+04 Y = 3.898730e-02 1.621940e-07 9.610125e-01 C At t = 4.0000e+05 Y = 4.936363e-03 1.984221e-08 9.950636e-01 C At t = 4.0000e+06 Y = 5.161831e-04 2.065786e-09 9.994838e-01 C At t = 4.0000e+07 Y = 5.179817e-05 2.072032e-10 9.999482e-01 C At t = 4.0000e+08 Y = 5.283401e-06 2.113371e-11 9.999947e-01 C At t = 4.0000e+09 Y = 4.659031e-07 1.863613e-12 9.999995e-01 C At t = 4.0000e+10 Y = 1.404280e-08 5.617126e-14 1.000000e+00 C C No. steps = 361 No. f-s = 693 No. J-s = 64 C Method last used = 2 Last switch was at t = 6.0092e-03 C----------------------------------------------------------------------- C Full description of user interface to DLSODA. C C The user interface to DLSODA consists of the following parts. C C 1. The call sequence to Subroutine DLSODA, which is a driver C routine for the solver. This includes descriptions of both C the call sequence arguments and of user-supplied routines. C following these descriptions is a description of C optional inputs available through the call sequence, and then C a description of optional outputs (in the work arrays). C C 2. Descriptions of other routines in the DLSODA package that may be C (optionally) called by the user. These provide the ability to C alter error message handling, save and restore the internal C Common, and obtain specified derivatives of the solution y(t). C C 3. Descriptions of Common blocks to be declared in overlay C or similar environments, or to be saved when doing an interrupt C of the problem and continued solution later. C C 4. Description of a subroutine in the DLSODA package, C which the user may replace with his/her own version, if desired. C this relates to the measurement of errors. C C----------------------------------------------------------------------- C Part 1. Call Sequence. C C The call sequence parameters used for input only are C F, NEQ, TOUT, ITOL, RTOL, ATOL, ITASK, IOPT, LRW, LIW, JAC, JT, C and those used for both input and output are C Y, T, ISTATE. C The work arrays RWORK and IWORK are also used for conditional and C optional inputs and optional outputs. (The term output here refers C to the return from Subroutine DLSODA to the user's calling program.) C C The legality of input parameters will be thoroughly checked on the C initial call for the problem, but not checked thereafter unless a C change in input parameters is flagged by ISTATE = 3 on input. C C The descriptions of the call arguments are as follows. C C F = the name of the user-supplied subroutine defining the C ODE system. The system must be put in the first-order C form dy/dt = f(t,y), where f is a vector-valued function C of the scalar t and the vector y. Subroutine F is to C compute the function f. It is to have the form C SUBROUTINE F (NEQ, T, Y, YDOT,rpar,ipar) C INTEGER NEQ,ipar(*) C DOUBLE PRECISION T, Y(*), YDOT(*),rpar(*) C where NEQ, T, and Y are input, and the array YDOT = f(t,y) C is output. Y and YDOT are arrays of length NEQ. C Subroutine F should not alter Y(1),...,Y(NEQ). C F must be declared External in the calling program. C C Subroutine F may access user-defined quantities in C NEQ(2),... and/or in Y(NEQ(1)+1),... if NEQ is an array C (dimensioned in F) and/or Y has length exceeding NEQ(1). C See the descriptions of NEQ and Y below. C C If quantities computed in the F routine are needed C externally to DLSODA, an extra call to F should be made C for this purpose, for consistent and accurate results. C If only the derivative dy/dt is needed, use DINTDY instead. C C NEQ = the size of the ODE system (number of first order C ordinary differential equations). Used only for input. C NEQ may be decreased, but not increased, during the problem. C If NEQ is decreased (with ISTATE = 3 on input), the C remaining components of Y should be left undisturbed, if C these are to be accessed in F and/or JAC. C C Normally, NEQ is a scalar, and it is generally referred to C as a scalar in this user interface description. However, C NEQ may be an array, with NEQ(1) set to the system size. C (The DLSODA package accesses only NEQ(1).) In either case, C this parameter is passed as the NEQ argument in all calls C to F and JAC. Hence, if it is an array, locations C NEQ(2),... may be used to store other integer data and pass C it to F and/or JAC. Subroutines F and/or JAC must include C NEQ in a Dimension statement in that case. C C Y = a real array for the vector of dependent variables, of C length NEQ or more. Used for both input and output on the C first call (ISTATE = 1), and only for output on other calls. C On the first call, Y must contain the vector of initial C values. On output, Y contains the computed solution vector, C evaluated at T. If desired, the Y array may be used C for other purposes between calls to the solver. C C This array is passed as the Y argument in all calls to C F and JAC. Hence its length may exceed NEQ, and locations C Y(NEQ+1),... may be used to store other real data and C pass it to F and/or JAC. (The DLSODA package accesses only C Y(1),...,Y(NEQ).) C C T = the independent variable. On input, T is used only on the C first call, as the initial point of the integration. C on output, after each call, T is the value at which a C computed solution Y is evaluated (usually the same as TOUT). C on an error return, T is the farthest point reached. C C TOUT = the next value of t at which a computed solution is desired. C Used only for input. C C When starting the problem (ISTATE = 1), TOUT may be equal C to T for one call, then should .ne. T for the next call. C For the initial t, an input value of TOUT .ne. T is used C in order to determine the direction of the integration C (i.e. the algebraic sign of the step sizes) and the rough C scale of the problem. Integration in either direction C (forward or backward in t) is permitted. C C If ITASK = 2 or 5 (one-step modes), TOUT is ignored after C the first call (i.e. the first call with TOUT .ne. T). C Otherwise, TOUT is required on every call. C C If ITASK = 1, 3, or 4, the values of TOUT need not be C monotone, but a value of TOUT which backs up is limited C to the current internal T interval, whose endpoints are C TCUR - HU and TCUR (see optional outputs, below, for C TCUR and HU). C C ITOL = an indicator for the type of error control. See C description below under ATOL. Used only for input. C C RTOL = a relative error tolerance parameter, either a scalar or C an array of length NEQ. See description below under ATOL. C Input only. C C ATOL = an absolute error tolerance parameter, either a scalar or C an array of length NEQ. Input only. C C The input parameters ITOL, RTOL, and ATOL determine C the error control performed by the solver. The solver will C control the vector E = (E(i)) of estimated local errors C in y, according to an inequality of the form C max-norm of ( E(i)/EWT(i) ) .le. 1, C where EWT = (EWT(i)) is a vector of positive error weights. C The values of RTOL and ATOL should all be non-negative. C The following table gives the types (scalar/array) of C RTOL and ATOL, and the corresponding form of EWT(i). C C ITOL RTOL ATOL EWT(i) C 1 scalar scalar RTOL*ABS(Y(i)) + ATOL C 2 scalar array RTOL*ABS(Y(i)) + ATOL(i) C 3 array scalar RTOL(i)*ABS(Y(i)) + ATOL C 4 array array RTOL(i)*ABS(Y(i)) + ATOL(i) C C When either of these parameters is a scalar, it need not C be dimensioned in the user's calling program. C C If none of the above choices (with ITOL, RTOL, and ATOL C fixed throughout the problem) is suitable, more general C error controls can be obtained by substituting a C user-supplied routine for the setting of EWT. C See Part 4 below. C C If global errors are to be estimated by making a repeated C run on the same problem with smaller tolerances, then all C components of RTOL and ATOL (i.e. of EWT) should be scaled C down uniformly. C C ITASK = an index specifying the task to be performed. C Input only. ITASK has the following values and meanings. C 1 means normal computation of output values of y(t) at C t = TOUT (by overshooting and interpolating). C 2 means take one step only and return. C 3 means stop at the first internal mesh point at or C beyond t = TOUT and return. C 4 means normal computation of output values of y(t) at C t = TOUT but without overshooting t = TCRIT. C TCRIT must be input as RWORK(1). TCRIT may be equal to C or beyond TOUT, but not behind it in the direction of C integration. This option is useful if the problem C has a singularity at or beyond t = TCRIT. C 5 means take one step, without passing TCRIT, and return. C TCRIT must be input as RWORK(1). C C Note: If ITASK = 4 or 5 and the solver reaches TCRIT C (within roundoff), it will return T = TCRIT (exactly) to C indicate this (unless ITASK = 4 and TOUT comes before TCRIT, C in which case answers at t = TOUT are returned first). C C ISTATE = an index used for input and output to specify the C the state of the calculation. C C On input, the values of ISTATE are as follows. C 1 means this is the first call for the problem C (initializations will be done). See note below. C 2 means this is not the first call, and the calculation C is to continue normally, with no change in any input C parameters except possibly TOUT and ITASK. C (If ITOL, RTOL, and/or ATOL are changed between calls C with ISTATE = 2, the new values will be used but not C tested for legality.) C 3 means this is not the first call, and the C calculation is to continue normally, but with C a change in input parameters other than C TOUT and ITASK. Changes are allowed in C NEQ, ITOL, RTOL, ATOL, IOPT, LRW, LIW, JT, ML, MU, C and any optional inputs except H0, MXORDN, and MXORDS. C (See IWORK description for ML and MU.) C Note: A preliminary call with TOUT = T is not counted C as a first call here, as no initialization or checking of C input is done. (Such a call is sometimes useful for the C purpose of outputting the initial conditions.) C Thus the first call for which TOUT .ne. T requires C ISTATE = 1 on input. C C On output, ISTATE has the following values and meanings. C 1 means nothing was done; TOUT = T and ISTATE = 1 on input. C 2 means the integration was performed successfully. C -1 means an excessive amount of work (more than MXSTEP C steps) was done on this call, before completing the C requested task, but the integration was otherwise C successful as far as T. (MXSTEP is an optional input C and is normally 500.) To continue, the user may C simply reset ISTATE to a value .gt. 1 and call again C (the excess work step counter will be reset to 0). C In addition, the user may increase MXSTEP to avoid C this error return (see below on optional inputs). C -2 means too much accuracy was requested for the precision C of the machine being used. This was detected before C completing the requested task, but the integration C was successful as far as T. To continue, the tolerance C parameters must be reset, and ISTATE must be set C to 3. The optional output TOLSF may be used for this C purpose. (Note: If this condition is detected before C taking any steps, then an illegal input return C (ISTATE = -3) occurs instead.) C -3 means illegal input was detected, before taking any C integration steps. See written message for details. C Note: If the solver detects an infinite loop of calls C to the solver with illegal input, it will cause C the run to stop. C -4 means there were repeated error test failures on C one attempted step, before completing the requested C task, but the integration was successful as far as T. C The problem may have a singularity, or the input C may be inappropriate. C -5 means there were repeated convergence test failures on C one attempted step, before completing the requested C task, but the integration was successful as far as T. C This may be caused by an inaccurate Jacobian matrix, C if one is being used. C -6 means EWT(i) became zero for some i during the C integration. Pure relative error control (ATOL(i)=0.0) C was requested on a variable which has now vanished. C The integration was successful as far as T. C -7 means the length of RWORK and/or IWORK was too small to C proceed, but the integration was successful as far as T. C This happens when DLSODA chooses to switch methods C but LRW and/or LIW is too small for the new method. C C Note: Since the normal output value of ISTATE is 2, C it does not need to be reset for normal continuation. C Also, since a negative input value of ISTATE will be C regarded as illegal, a negative output value requires the C user to change it, and possibly other inputs, before C calling the solver again. C C IOPT = an integer flag to specify whether or not any optional C inputs are being used on this call. Input only. C The optional inputs are listed separately below. C IOPT = 0 means no optional inputs are being used. C default values will be used in all cases. C IOPT = 1 means one or more optional inputs are being used. C C RWORK = a real array (double precision) for work space, and (in the C first 20 words) for conditional and optional inputs and C optional outputs. C As DLSODA switches automatically between stiff and nonstiff C methods, the required length of RWORK can change during the C problem. Thus the RWORK array passed to DLSODA can either C have a static (fixed) length large enough for both methods, C or have a dynamic (changing) length altered by the calling C program in response to output from DLSODA. C C --- Fixed Length Case --- C If the RWORK length is to be fixed, it should be at least C MAX (LRN, LRS), C where LRN and LRS are the RWORK lengths required when the C current method is nonstiff or stiff, respectively. C C The separate RWORK length requirements LRN and LRS are C as follows: C IF NEQ is constant and the maximum method orders have C their default values, then C LRN = 20 + 16*NEQ, C LRS = 22 + 9*NEQ + NEQ**2 if JT = 1 or 2, C LRS = 22 + 10*NEQ + (2*ML+MU)*NEQ if JT = 4 or 5. C Under any other conditions, LRN and LRS are given by: C LRN = 20 + NYH*(MXORDN+1) + 3*NEQ, C LRS = 20 + NYH*(MXORDS+1) + 3*NEQ + LMAT, C where C NYH = the initial value of NEQ, C MXORDN = 12, unless a smaller value is given as an C optional input, C MXORDS = 5, unless a smaller value is given as an C optional input, C LMAT = length of matrix work space: C LMAT = NEQ**2 + 2 if JT = 1 or 2, C LMAT = (2*ML + MU + 1)*NEQ + 2 if JT = 4 or 5. C C --- Dynamic Length Case --- C If the length of RWORK is to be dynamic, then it should C be at least LRN or LRS, as defined above, depending on the C current method. Initially, it must be at least LRN (since C DLSODA starts with the nonstiff method). On any return C from DLSODA, the optional output MCUR indicates the current C method. If MCUR differs from the value it had on the C previous return, or if there has only been one call to C DLSODA and MCUR is now 2, then DLSODA has switched C methods during the last call, and the length of RWORK C should be reset (to LRN if MCUR = 1, or to LRS if C MCUR = 2). (An increase in the RWORK length is required C if DLSODA returned ISTATE = -7, but not otherwise.) C After resetting the length, call DLSODA with ISTATE = 3 C to signal that change. C C LRW = the length of the array RWORK, as declared by the user. C (This will be checked by the solver.) C C IWORK = an integer array for work space. C As DLSODA switches automatically between stiff and nonstiff C methods, the required length of IWORK can change during C problem, between C LIS = 20 + NEQ and LIN = 20, C respectively. Thus the IWORK array passed to DLSODA can C either have a fixed length of at least 20 + NEQ, or have a C dynamic length of at least LIN or LIS, depending on the C current method. The comments on dynamic length under C RWORK above apply here. Initially, this length need C only be at least LIN = 20. C C The first few words of IWORK are used for conditional and C optional inputs and optional outputs. C C The following 2 words in IWORK are conditional inputs: C IWORK(1) = ML these are the lower and upper C IWORK(2) = MU half-bandwidths, respectively, of the C banded Jacobian, excluding the main diagonal. C The band is defined by the matrix locations C (i,j) with i-ML .le. j .le. i+MU. ML and MU C must satisfy 0 .le. ML,MU .le. NEQ-1. C These are required if JT is 4 or 5, and C ignored otherwise. ML and MU may in fact be C the band parameters for a matrix to which C df/dy is only approximately equal. C C LIW = the length of the array IWORK, as declared by the user. C (This will be checked by the solver.) C C Note: The base addresses of the work arrays must not be C altered between calls to DLSODA for the same problem. C The contents of the work arrays must not be altered C between calls, except possibly for the conditional and C optional inputs, and except for the last 3*NEQ words of RWORK. C The latter space is used for internal scratch space, and so is C available for use by the user outside DLSODA between calls, if C desired (but not for use by F or JAC). C C JAC = the name of the user-supplied routine to compute the C Jacobian matrix, df/dy, if JT = 1 or 4. The JAC routine C is optional, but if the problem is expected to be stiff much C of the time, you are encouraged to supply JAC, for the sake C of efficiency. (Alternatively, set JT = 2 or 5 to have C DLSODA compute df/dy internally by difference quotients.) C If and when DLSODA uses df/dy, it treats this NEQ by NEQ C matrix either as full (JT = 1 or 2), or as banded (JT = C 4 or 5) with half-bandwidths ML and MU (discussed under C IWORK above). In either case, if JT = 1 or 4, the JAC C routine must compute df/dy as a function of the scalar t C and the vector y. It is to have the form C SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD,rpar,ipar) C DOUBLE PRECISION T, Y(*), PD(NROWPD,*),rpar(*) C where NEQ, T, Y, ML, MU, and NROWPD are input and the array C PD is to be loaded with partial derivatives (elements of C the Jacobian matrix) on output. PD must be given a first C dimension of NROWPD. T and Y have the same meaning as in C Subroutine F. C In the full matrix case (JT = 1), ML and MU are C ignored, and the Jacobian is to be loaded into PD in C columnwise manner, with df(i)/dy(j) loaded into PD(i,j). C In the band matrix case (JT = 4), the elements C within the band are to be loaded into PD in columnwise C manner, with diagonal lines of df/dy loaded into the rows C of PD. Thus df(i)/dy(j) is to be loaded into PD(i-j+MU+1,j). C ML and MU are the half-bandwidth parameters (see IWORK). C The locations in PD in the two triangular areas which C correspond to nonexistent matrix elements can be ignored C or loaded arbitrarily, as they are overwritten by DLSODA. C JAC need not provide df/dy exactly. A crude C approximation (possibly with a smaller bandwidth) will do. C In either case, PD is preset to zero by the solver, C so that only the nonzero elements need be loaded by JAC. C Each call to JAC is preceded by a call to F with the same C arguments NEQ, T, and Y. Thus to gain some efficiency, C intermediate quantities shared by both calculations may be C saved in a user Common block by F and not recomputed by JAC, C if desired. Also, JAC may alter the Y array, if desired. C JAC must be declared External in the calling program. C Subroutine JAC may access user-defined quantities in C NEQ(2),... and/or in Y(NEQ(1)+1),... if NEQ is an array C (dimensioned in JAC) and/or Y has length exceeding NEQ(1). C See the descriptions of NEQ and Y above. C C JT = Jacobian type indicator. Used only for input. C JT specifies how the Jacobian matrix df/dy will be C treated, if and when DLSODA requires this matrix. C JT has the following values and meanings: C 1 means a user-supplied full (NEQ by NEQ) Jacobian. C 2 means an internally generated (difference quotient) full C Jacobian (using NEQ extra calls to F per df/dy value). C 4 means a user-supplied banded Jacobian. C 5 means an internally generated banded Jacobian (using C ML+MU+1 extra calls to F per df/dy evaluation). C If JT = 1 or 4, the user must supply a Subroutine JAC C (the name is arbitrary) as described above under JAC. C If JT = 2 or 5, a dummy argument can be used. C----------------------------------------------------------------------- C Optional Inputs. C C The following is a list of the optional inputs provided for in the C call sequence. (See also Part 2.) For each such input variable, C this table lists its name as used in this documentation, its C location in the call sequence, its meaning, and the default value. C The use of any of these inputs requires IOPT = 1, and in that C case all of these inputs are examined. A value of zero for any C of these optional inputs will cause the default value to be used. C Thus to use a subset of the optional inputs, simply preload C locations 5 to 10 in RWORK and IWORK to 0.0 and 0 respectively, and C then set those of interest to nonzero values. C C Name Location Meaning and Default Value C C H0 RWORK(5) the step size to be attempted on the first step. C The default value is determined by the solver. C C HMAX RWORK(6) the maximum absolute step size allowed. C The default value is infinite. C C HMIN RWORK(7) the minimum absolute step size allowed. C The default value is 0. (This lower bound is not C enforced on the final step before reaching TCRIT C when ITASK = 4 or 5.) C C IXPR IWORK(5) flag to generate extra printing at method switches. C IXPR = 0 means no extra printing (the default). C IXPR = 1 means print data on each switch. C T, H, and NST will be printed on the same logical C unit as used for error messages. C C MXSTEP IWORK(6) maximum number of (internally defined) steps C allowed during one call to the solver. C The default value is 500. C C MXHNIL IWORK(7) maximum number of messages printed (per problem) C warning that T + H = T on a step (H = step size). C This must be positive to result in a non-default C value. The default value is 10. C C MXORDN IWORK(8) the maximum order to be allowed for the nonstiff C (Adams) method. the default value is 12. C if MXORDN exceeds the default value, it will C be reduced to the default value. C MXORDN is held constant during the problem. C C MXORDS IWORK(9) the maximum order to be allowed for the stiff C (BDF) method. The default value is 5. C If MXORDS exceeds the default value, it will C be reduced to the default value. C MXORDS is held constant during the problem. C----------------------------------------------------------------------- C Optional Outputs. C C As optional additional output from DLSODA, the variables listed C below are quantities related to the performance of DLSODA C which are available to the user. These are communicated by way of C the work arrays, but also have internal mnemonic names as shown. C except where stated otherwise, all of these outputs are defined C on any successful return from DLSODA, and on any return with C ISTATE = -1, -2, -4, -5, or -6. On an illegal input return C (ISTATE = -3), they will be unchanged from their existing values C (if any), except possibly for TOLSF, LENRW, and LENIW. C On any error return, outputs relevant to the error will be defined, C as noted below. C C Name Location Meaning C C HU RWORK(11) the step size in t last used (successfully). C C HCUR RWORK(12) the step size to be attempted on the next step. C C TCUR RWORK(13) the current value of the independent variable C which the solver has actually reached, i.e. the C current internal mesh point in t. On output, TCUR C will always be at least as far as the argument C T, but may be farther (if interpolation was done). C C TOLSF RWORK(14) a tolerance scale factor, greater than 1.0, C computed when a request for too much accuracy was C detected (ISTATE = -3 if detected at the start of C the problem, ISTATE = -2 otherwise). If ITOL is C left unaltered but RTOL and ATOL are uniformly C scaled up by a factor of TOLSF for the next call, C then the solver is deemed likely to succeed. C (The user may also ignore TOLSF and alter the C tolerance parameters in any other way appropriate.) C C TSW RWORK(15) the value of t at the time of the last method C switch, if any. C C NST IWORK(11) the number of steps taken for the problem so far. C C NFE IWORK(12) the number of f evaluations for the problem so far. C C NJE IWORK(13) the number of Jacobian evaluations (and of matrix C LU decompositions) for the problem so far. C C NQU IWORK(14) the method order last used (successfully). C C NQCUR IWORK(15) the order to be attempted on the next step. C C IMXER IWORK(16) the index of the component of largest magnitude in C the weighted local error vector ( E(i)/EWT(i) ), C on an error return with ISTATE = -4 or -5. C C LENRW IWORK(17) the length of RWORK actually required, assuming C that the length of RWORK is to be fixed for the C rest of the problem, and that switching may occur. C This is defined on normal returns and on an illegal C input return for insufficient storage. C C LENIW IWORK(18) the length of IWORK actually required, assuming C that the length of IWORK is to be fixed for the C rest of the problem, and that switching may occur. C This is defined on normal returns and on an illegal C input return for insufficient storage. C C MUSED IWORK(19) the method indicator for the last successful step: C 1 means Adams (nonstiff), 2 means BDF (stiff). C C MCUR IWORK(20) the current method indicator: C 1 means Adams (nonstiff), 2 means BDF (stiff). C This is the method to be attempted C on the next step. Thus it differs from MUSED C only if a method switch has just been made. C C The following two arrays are segments of the RWORK array which C may also be of interest to the user as optional outputs. C For each array, the table below gives its internal name, C its base address in RWORK, and its description. C C Name Base Address Description C C YH 21 the Nordsieck history array, of size NYH by C (NQCUR + 1), where NYH is the initial value C of NEQ. For j = 0,1,...,NQCUR, column j+1 C of YH contains HCUR**j/factorial(j) times C the j-th derivative of the interpolating C polynomial currently representing the solution, C evaluated at T = TCUR. C C ACOR LACOR array of size NEQ used for the accumulated C (from Common corrections on each step, scaled on output C as noted) to represent the estimated local error in y C on the last step. This is the vector E in C the description of the error control. It is C defined only on a successful return from C DLSODA. The base address LACOR is obtained by C including in the user's program the C following 2 lines: C COMMON /DLS001/ RLS(218), ILS(37) C LACOR = ILS(22) C C----------------------------------------------------------------------- C Part 2. Other Routines Callable. C C The following are optional calls which the user may make to C gain additional capabilities in conjunction with DLSODA. C (The routines XSETUN and XSETF are designed to conform to the C SLATEC error handling package.) C C Form of Call Function C CALL XSETUN(LUN) set the logical unit number, LUN, for C output of messages from DLSODA, if C the default is not desired. C The default value of LUN is 6. C C CALL XSETF(MFLAG) set a flag to control the printing of C messages by DLSODA. C MFLAG = 0 means do not print. (Danger: C This risks losing valuable information.) C MFLAG = 1 means print (the default). C C Either of the above calls may be made at C any time and will take effect immediately. C C CALL DSRCMA(RSAV,ISAV,JOB) saves and restores the contents of C the internal Common blocks used by C DLSODA (see Part 3 below). C RSAV must be a real array of length 240 C or more, and ISAV must be an integer C array of length 46 or more. C JOB=1 means save Common into RSAV/ISAV. C JOB=2 means restore Common from RSAV/ISAV. C DSRCMA is useful if one is C interrupting a run and restarting C later, or alternating between two or C more problems solved with DLSODA. C C CALL DINTDY(,,,,,) provide derivatives of y, of various C (see below) orders, at a specified point t, if C desired. It may be called only after C a successful return from DLSODA. C C The detailed instructions for using DINTDY are as follows. C The form of the call is: C C CALL DINTDY (T, K, RWORK(21), NYH, DKY, IFLAG) C C The input parameters are: C C T = value of independent variable where answers are desired C (normally the same as the T last returned by DLSODA). C For valid results, T must lie between TCUR - HU and TCUR. C (See optional outputs for TCUR and HU.) C K = integer order of the derivative desired. K must satisfy C 0 .le. K .le. NQCUR, where NQCUR is the current order C (see optional outputs). The capability corresponding C to K = 0, i.e. computing y(T), is already provided C by DLSODA directly. Since NQCUR .ge. 1, the first C derivative dy/dt is always available with DINTDY. C RWORK(21) = the base address of the history array YH. C NYH = column length of YH, equal to the initial value of NEQ. C C The output parameters are: C C DKY = a real array of length NEQ containing the computed value C of the K-th derivative of y(t). C IFLAG = integer flag, returned as 0 if K and T were legal, C -1 if K was illegal, and -2 if T was illegal. C On an error return, a message is also written. C----------------------------------------------------------------------- C Part 3. Common Blocks. C C If DLSODA is to be used in an overlay situation, the user C must declare, in the primary overlay, the variables in: C (1) the call sequence to DLSODA, and C (2) the two internal Common blocks C /DLS001/ of length 255 (218 double precision words C followed by 37 integer words), C /DLSA01/ of length 31 (22 double precision words C followed by 9 integer words). C C If DLSODA is used on a system in which the contents of internal C Common blocks are not preserved between calls, the user should C declare the above Common blocks in the calling program to insure C that their contents are preserved. C C If the solution of a given problem by DLSODA is to be interrupted C and then later continued, such as when restarting an interrupted run C or alternating between two or more problems, the user should save, C following the return from the last DLSODA call prior to the C interruption, the contents of the call sequence variables and the C internal Common blocks, and later restore these values before the C next DLSODA call for that problem. To save and restore the Common C blocks, use Subroutine DSRCMA (see Part 2 above). C C----------------------------------------------------------------------- C Part 4. Optionally Replaceable Solver Routines. C C Below is a description of a routine in the DLSODA package which C relates to the measurement of errors, and can be C replaced by a user-supplied version, if desired. However, since such C a replacement may have a major impact on performance, it should be C done only when absolutely necessary, and only with great caution. C (Note: The means by which the package version of a routine is C superseded by the user's version may be system-dependent.) C C (a) DEWSET. C The following subroutine is called just before each internal C integration step, and sets the array of error weights, EWT, as C described under ITOL/RTOL/ATOL above: C Subroutine DEWSET (NEQ, ITOL, RTOL, ATOL, YCUR, EWT) C where NEQ, ITOL, RTOL, and ATOL are as in the DLSODA call sequence, C YCUR contains the current dependent variable vector, and C EWT is the array of weights set by DEWSET. C C If the user supplies this subroutine, it must return in EWT(i) C (i = 1,...,NEQ) a positive quantity suitable for comparing errors C in y(i) to. The EWT array returned by DEWSET is passed to the C DMNORM routine, and also used by DLSODA in the computation C of the optional output IMXER, and the increments for difference C quotient Jacobians. C C In the user-supplied version of DEWSET, it may be desirable to use C the current values of derivatives of y. Derivatives up to order NQ C are available from the history array YH, described above under C optional outputs. In DEWSET, YH is identical to the YCUR array, C extended to NQ + 1 columns with a column length of NYH and scale C factors of H**j/factorial(j). On the first call for the problem, C given by NST = 0, NQ is 1 and H is temporarily set to 1.0. C NYH is the initial value of NEQ. The quantities NQ, H, and NST C can be obtained by including in DEWSET the statements: C DOUBLE PRECISION RLS C COMMON /DLS001/ RLS(218),ILS(37) C NQ = ILS(33) C NST = ILS(34) C H = RLS(212) C Thus, for example, the current value of dy/dt can be obtained as C YCUR(NYH+i)/H (i=1,...,NEQ) (and the division by H is C unnecessary when NST = 0). C----------------------------------------------------------------------- C C***REVISION HISTORY (YYYYMMDD) C 19811102 DATE WRITTEN C 19820126 Fixed bug in tests of work space lengths; C minor corrections in main prologue and comments. C 19870330 Major update: corrected comments throughout; C removed TRET from Common; rewrote EWSET with 4 loops; C fixed t test in INTDY; added Cray directives in STODA; C in STODA, fixed DELP init. and logic around PJAC call; C combined routines to save/restore Common; C passed LEVEL = 0 in error message calls (except run abort). C 19970225 Fixed lines setting JSTART = -2 in Subroutine LSODA. C 20010425 Major update: convert source lines to upper case; C added *DECK lines; changed from 1 to * in dummy dimensions; C changed names R1MACH/D1MACH to RUMACH/DUMACH; C renamed routines for uniqueness across single/double prec.; C converted intrinsic names to generic form; C removed ILLIN and NTREP (data loaded) from Common; C removed all 'own' variables from Common; C changed error messages to quoted strings; C replaced XERRWV/XERRWD with 1993 revised version; C converted prologues, comments, error messages to mixed case; C numerous corrections to prologues and internal comments. C 20010507 Converted single precision source to double precision. C 20010613 Revised excess accuracy test (to match rest of ODEPACK). C 20010808 Fixed bug in DPRJA (matrix in DBNORM call). C 20020502 Corrected declarations in descriptions of user routines. C 20031105 Restored 'own' variables to Common blocks, to enable C interrupt/restart feature. C 20031112 Added SAVE statements for data-loaded constants. C C----------------------------------------------------------------------- C Other routines in the DLSODA package. C C In addition to Subroutine DLSODA, the DLSODA package includes the C following subroutines and function routines: C DINTDY computes an interpolated value of the y vector at t = TOUT. C DSTODA is the core integrator, which does one step of the C integration and the associated error control. C DCFODE sets all method coefficients and test constants. C DPRJA computes and preprocesses the Jacobian matrix J = df/dy C and the Newton iteration matrix P = I - h*l0*J. C DSOLSY manages solution of linear system in chord iteration. C DEWSET sets the error weight vector EWT before each step. C DMNORM computes the weighted max-norm of a vector. C DFNORM computes the norm of a full matrix consistent with the C weighted max-norm on vectors. C DBNORM computes the norm of a band matrix consistent with the C weighted max-norm on vectors. C DSRCMA is a user-callable routine to save and restore C the contents of the internal Common blocks. C DGEFA and DGESL are routines from LINPACK for solving full C systems of linear algebraic equations. C DGBFA and DGBSL are routines from LINPACK for solving banded C linear systems. C DUMACH computes the unit roundoff in a machine-independent manner. C XERRWD, XSETUN, XSETF, IXSAV, and IUMACH handle the printing of all C error messages and warnings. XERRWD is machine-dependent. C Note: DMNORM, DFNORM, DBNORM, DUMACH, IXSAV, and IUMACH are C function routines. All the others are subroutines. C C----------------------------------------------------------------------- EXTERNAL DPRJA, DSOLSY DOUBLE PRECISION DUMACH, DMNORM INTEGER INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, IOWNS, 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU INTEGER INSUFR, INSUFI, IXPR, IOWNS2, JTYP, MUSED, MXORDN, MXORDS INTEGER I, I1, I2, IFLAG, IMXER, KGO, LF0, 1 LENIW, LENRW, LENWM, ML, MORD, MU, MXHNL0, MXSTP0 INTEGER LEN1, LEN1C, LEN1N, LEN1S, LEN2, LENIWC, LENRWC DOUBLE PRECISION ROWNS, 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND DOUBLE PRECISION TSW, ROWNS2, PDNORM DOUBLE PRECISION ATOLI, AYI, BIG, EWTI, H0, HMAX, HMX, RH, RTOLI, 1 TCRIT, TDIST, TNEXT, TOL, TOLSF, TP, SIZE, SUM, W0 DIMENSION MORD(2) LOGICAL IHIT CHARACTER(LEN=80) MSG SAVE MORD, MXSTP0, MXHNL0 C----------------------------------------------------------------------- C The following two internal Common blocks contain C (a) variables which are local to any subroutine but whose values must C be preserved between calls to the routine ("own" variables), and C (b) variables which are communicated between subroutines. C The block DLS001 is declared in subroutines DLSODA, DINTDY, DSTODA, C DPRJA, and DSOLSY. C The block DLSA01 is declared in subroutines DLSODA, DSTODA, and DPRJA. C Groups of variables are replaced by dummy arrays in the Common C declarations in routines where those variables are not used. C----------------------------------------------------------------------- COMMON /DLS001/ ROWNS(209), 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 2 INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, IOWNS(6), 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU C COMMON /DLSA01/ TSW, ROWNS2(20), PDNORM, 1 INSUFR, INSUFI, IXPR, IOWNS2(2), JTYP, MUSED, MXORDN, MXORDS C DATA MORD(1),MORD(2)/12,5/, MXSTP0/500/, MXHNL0/10/ C----------------------------------------------------------------------- C Block A. C This code block is executed on every call. C It tests ISTATE and ITASK for legality and branches appropriately. C If ISTATE .gt. 1 but the flag INIT shows that initialization has C not yet been done, an error return occurs. C If ISTATE = 1 and TOUT = T, return immediately. C----------------------------------------------------------------------- IF (ISTATE .LT. 1 .OR. ISTATE .GT. 3) GO TO 601 IF (ITASK .LT. 1 .OR. ITASK .GT. 5) GO TO 602 IF (ISTATE .EQ. 1) GO TO 10 IF (INIT .EQ. 0) GO TO 603 IF (ISTATE .EQ. 2) GO TO 200 GO TO 20 10 INIT = 0 IF (TOUT .EQ. T) RETURN C----------------------------------------------------------------------- C Block B. C The next code block is executed for the initial call (ISTATE = 1), C or for a continuation call with parameter changes (ISTATE = 3). C It contains checking of all inputs and various initializations. C C First check legality of the non-optional inputs NEQ, ITOL, IOPT, C JT, ML, and MU. C----------------------------------------------------------------------- 20 IF (NEQ(1) .LE. 0) GO TO 604 IF (ISTATE .EQ. 1) GO TO 25 IF (NEQ(1) .GT. N) GO TO 605 25 N = NEQ(1) IF (ITOL .LT. 1 .OR. ITOL .GT. 4) GO TO 606 IF (IOPT .LT. 0 .OR. IOPT .GT. 1) GO TO 607 IF (JT .EQ. 3 .OR. JT .LT. 1 .OR. JT .GT. 5) GO TO 608 JTYP = JT IF (JT .LE. 2) GO TO 30 ML = IWORK(1) MU = IWORK(2) IF (ML .LT. 0 .OR. ML .GE. N) GO TO 609 IF (MU .LT. 0 .OR. MU .GE. N) GO TO 610 30 CONTINUE C Next process and check the optional inputs. -------------------------- IF (IOPT .EQ. 1) GO TO 40 IXPR = 0 MXSTEP = MXSTP0 MXHNIL = MXHNL0 HMXI = 0.0D0 HMIN = 0.0D0 IF (ISTATE .NE. 1) GO TO 60 H0 = 0.0D0 MXORDN = MORD(1) MXORDS = MORD(2) GO TO 60 40 IXPR = IWORK(5) IF (IXPR .LT. 0 .OR. IXPR .GT. 1) GO TO 611 MXSTEP = IWORK(6) IF (MXSTEP .LT. 0) GO TO 612 IF (MXSTEP .EQ. 0) MXSTEP = MXSTP0 MXHNIL = IWORK(7) IF (MXHNIL .LT. 0) GO TO 613 IF (MXHNIL .EQ. 0) MXHNIL = MXHNL0 IF (ISTATE .NE. 1) GO TO 50 H0 = RWORK(5) MXORDN = IWORK(8) IF (MXORDN .LT. 0) GO TO 628 IF (MXORDN .EQ. 0) MXORDN = 100 MXORDN = MIN(MXORDN,MORD(1)) MXORDS = IWORK(9) IF (MXORDS .LT. 0) GO TO 629 IF (MXORDS .EQ. 0) MXORDS = 100 MXORDS = MIN(MXORDS,MORD(2)) IF ((TOUT - T)*H0 .LT. 0.0D0) GO TO 614 50 HMAX = RWORK(6) IF (HMAX .LT. 0.0D0) GO TO 615 HMXI = 0.0D0 IF (HMAX .GT. 0.0D0) HMXI = 1.0D0/HMAX HMIN = RWORK(7) IF (HMIN .LT. 0.0D0) GO TO 616 C----------------------------------------------------------------------- C Set work array pointers and check lengths LRW and LIW. C If ISTATE = 1, METH is initialized to 1 here to facilitate the C checking of work space lengths. C Pointers to segments of RWORK and IWORK are named by prefixing L to C the name of the segment. E.g., the segment YH starts at RWORK(LYH). C Segments of RWORK (in order) are denoted YH, WM, EWT, SAVF, ACOR. C If the lengths provided are insufficient for the current method, C an error return occurs. This is treated as illegal input on the C first call, but as a problem interruption with ISTATE = -7 on a C continuation call. If the lengths are sufficient for the current C method but not for both methods, a warning message is sent. C----------------------------------------------------------------------- 60 IF (ISTATE .EQ. 1) METH = 1 IF (ISTATE .EQ. 1) NYH = N LYH = 21 LEN1N = 20 + (MXORDN + 1)*NYH LEN1S = 20 + (MXORDS + 1)*NYH LWM = LEN1S + 1 IF (JT .LE. 2) LENWM = N*N + 2 IF (JT .GE. 4) LENWM = (2*ML + MU + 1)*N + 2 LEN1S = LEN1S + LENWM LEN1C = LEN1N IF (METH .EQ. 2) LEN1C = LEN1S LEN1 = MAX(LEN1N,LEN1S) LEN2 = 3*N LENRW = LEN1 + LEN2 LENRWC = LEN1C + LEN2 IWORK(17) = LENRW LIWM = 1 LENIW = 20 + N LENIWC = 20 IF (METH .EQ. 2) LENIWC = LENIW IWORK(18) = LENIW IF (ISTATE .EQ. 1 .AND. LRW .LT. LENRWC) GO TO 617 IF (ISTATE .EQ. 1 .AND. LIW .LT. LENIWC) GO TO 618 IF (ISTATE .EQ. 3 .AND. LRW .LT. LENRWC) GO TO 550 IF (ISTATE .EQ. 3 .AND. LIW .LT. LENIWC) GO TO 555 LEWT = LEN1 + 1 INSUFR = 0 IF (LRW .GE. LENRW) GO TO 65 INSUFR = 2 LEWT = LEN1C + 1 MSG='DLSODA- Warning.. RWORK length is sufficient for now, but ' CALL XERRWD (MSG, 60, 103, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' may not be later. Integration will proceed anyway. ' CALL XERRWD (MSG, 60, 103, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' Length needed is LENRW = I1, while LRW = I2.' CALL XERRWD (MSG, 50, 103, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) 65 LSAVF = LEWT + N LACOR = LSAVF + N INSUFI = 0 IF (LIW .GE. LENIW) GO TO 70 INSUFI = 2 MSG='DLSODA- Warning.. IWORK length is sufficient for now, but ' CALL XERRWD (MSG, 60, 104, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' may not be later. Integration will proceed anyway. ' CALL XERRWD (MSG, 60, 104, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' Length needed is LENIW = I1, while LIW = I2.' CALL XERRWD (MSG, 50, 104, 0, 2, LENIW, LIW, 0, 0.0D0, 0.0D0) 70 CONTINUE C Check RTOL and ATOL for legality. ------------------------------------ RTOLI = RTOL(1) ATOLI = ATOL(1) DO 75 I = 1,N IF (ITOL .GE. 3) RTOLI = RTOL(I) IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) IF (RTOLI .LT. 0.0D0) GO TO 619 IF (ATOLI .LT. 0.0D0) GO TO 620 75 CONTINUE IF (ISTATE .EQ. 1) GO TO 100 C If ISTATE = 3, set flag to signal parameter changes to DSTODA. ------- JSTART = -1 IF (N .EQ. NYH) GO TO 200 C NEQ was reduced. Zero part of YH to avoid undefined references. ----- I1 = LYH + L*NYH I2 = LYH + (MAXORD + 1)*NYH - 1 IF (I1 .GT. I2) GO TO 200 DO 95 I = I1,I2 RWORK(I) = 0.0D0 95 CONTINUE GO TO 200 C----------------------------------------------------------------------- C Block C. C The next block is for the initial call only (ISTATE = 1). C It contains all remaining initializations, the initial call to F, C and the calculation of the initial step size. C The error weights in EWT are inverted after being loaded. C----------------------------------------------------------------------- 100 UROUND = DUMACH() TN = T TSW = T MAXORD = MXORDN IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 110 TCRIT = RWORK(1) IF ((TCRIT - TOUT)*(TOUT - T) .LT. 0.0D0) GO TO 625 IF (H0 .NE. 0.0D0 .AND. (T + H0 - TCRIT)*H0 .GT. 0.0D0) 1 H0 = TCRIT - T 110 JSTART = 0 NHNIL = 0 NST = 0 NJE = 0 NSLAST = 0 HU = 0.0D0 NQU = 0 MUSED = 0 MITER = 0 CCMAX = 0.3D0 MAXCOR = 3 MSBP = 20 MXNCF = 10 C Initial call to F. (LF0 points to YH(*,2).) ------------------------- LF0 = LYH + NYH CALL F (NEQ, T, Y, RWORK(LF0), rpar, ipar) NFE = 1 C Load the initial value vector in YH. --------------------------------- DO 115 I = 1,N RWORK(I+LYH-1) = Y(I) 115 CONTINUE C Load and invert the EWT array. (H is temporarily set to 1.0.) ------- NQ = 1 H = 1.0D0 CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) DO 120 I = 1,N IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 621 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 120 CONTINUE C----------------------------------------------------------------------- C The coding below computes the step size, H0, to be attempted on the C first step, unless the user has supplied a value for this. C First check that TOUT - T differs significantly from zero. C A scalar tolerance quantity TOL is computed, as MAX(RTOL(i)) C if this is positive, or MAX(ATOL(i)/ABS(Y(i))) otherwise, adjusted C so as to be between 100*UROUND and 1.0E-3. C Then the computed value H0 is given by: C C H0**(-2) = 1./(TOL * w0**2) + TOL * (norm(F))**2 C C where w0 = MAX ( ABS(T), ABS(TOUT) ), C F = the initial value of the vector f(t,y), and C norm() = the weighted vector norm used throughout, given by C the DMNORM function routine, and weighted by the C tolerances initially loaded into the EWT array. C The sign of H0 is inferred from the initial values of TOUT and T. C ABS(H0) is made .le. ABS(TOUT-T) in any case. C----------------------------------------------------------------------- IF (H0 .NE. 0.0D0) GO TO 180 TDIST = ABS(TOUT - T) W0 = MAX(ABS(T),ABS(TOUT)) IF (TDIST .LT. 2.0D0*UROUND*W0) GO TO 622 TOL = RTOL(1) IF (ITOL .LE. 2) GO TO 140 DO 130 I = 1,N TOL = MAX(TOL,RTOL(I)) 130 CONTINUE 140 IF (TOL .GT. 0.0D0) GO TO 160 ATOLI = ATOL(1) DO 150 I = 1,N IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) AYI = ABS(Y(I)) IF (AYI .NE. 0.0D0) TOL = MAX(TOL,ATOLI/AYI) 150 CONTINUE 160 TOL = MAX(TOL,100.0D0*UROUND) TOL = MIN(TOL,0.001D0) SUM = DMNORM (N, RWORK(LF0), RWORK(LEWT)) SUM = 1.0D0/(TOL*W0*W0) + TOL*SUM**2 H0 = 1.0D0/SQRT(SUM) H0 = MIN(H0,TDIST) H0 = SIGN(H0,TOUT-T) C Adjust H0 if necessary to meet HMAX bound. --------------------------- 180 RH = ABS(H0)*HMXI IF (RH .GT. 1.0D0) H0 = H0/RH C Load H with H0 and scale YH(*,2) by H0. ------------------------------ H = H0 DO 190 I = 1,N RWORK(I+LF0-1) = H0*RWORK(I+LF0-1) 190 CONTINUE GO TO 270 C----------------------------------------------------------------------- C Block D. C The next code block is for continuation calls only (ISTATE = 2 or 3) C and is to check stop conditions before taking a step. C----------------------------------------------------------------------- 200 NSLAST = NST IF (ITASK .EQ. 1) THEN GOTO 210 ELSE IF (ITASK .EQ. 2) THEN GOTO 250 ELSE IF (ITASK .EQ. 3) THEN GOTO 220 ELSE IF (ITASK .EQ. 4) THEN GOTO 230 ELSE IF (ITASK .EQ. 5) THEN GOTO 240 ENDIF C karline: changed from C GO TO (210, 250, 220, 230, 240), ITASK 210 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) IF (IFLAG .NE. 0) GO TO 627 T = TOUT GO TO 420 220 TP = TN - HU*(1.0D0 + 100.0D0*UROUND) IF ((TP - TOUT)*H .GT. 0.0D0) GO TO 623 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 T = TN GO TO 400 230 TCRIT = RWORK(1) IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 IF ((TCRIT - TOUT)*H .LT. 0.0D0) GO TO 625 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 245 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) IF (IFLAG .NE. 0) GO TO 627 T = TOUT GO TO 420 240 TCRIT = RWORK(1) IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 245 HMX = ABS(TN) + ABS(H) IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX IF (IHIT) T = TCRIT IF (IHIT) GO TO 400 TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) IF (ISTATE .EQ. 2 .AND. JSTART .GE. 0) JSTART = -2 C----------------------------------------------------------------------- C Block E. C The next block is normally executed for all calls and contains C the call to the one-step core integrator DSTODA. C C This is a looping point for the integration steps. C C First check for too many steps being taken, update EWT (if not at C start of problem), check for too much accuracy being requested, and C check for H below the roundoff level in T. C----------------------------------------------------------------------- 250 CONTINUE IF (METH .EQ. MUSED) GO TO 255 IF (INSUFR .EQ. 1) GO TO 550 IF (INSUFI .EQ. 1) GO TO 555 255 IF ((NST-NSLAST) .GE. MXSTEP) GO TO 500 CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) DO 260 I = 1,N IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 510 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 260 CONTINUE 270 TOLSF = UROUND*DMNORM (N, RWORK(LYH), RWORK(LEWT)) IF (TOLSF .LE. 1.0D0) GO TO 280 TOLSF = TOLSF*2.0D0 IF (NST .EQ. 0) GO TO 626 GO TO 520 280 IF ((TN + H) .NE. TN) GO TO 290 NHNIL = NHNIL + 1 IF (NHNIL .GT. MXHNIL) GO TO 290 MSG = 'DLSODA- Warning..Internal T (=R1) and H (=R2) are' CALL XERRWD (MSG, 50, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' such that in the machine, T + H = T on the next step ' CALL XERRWD (MSG, 60, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' (H = step size). Solver will continue anyway.' CALL XERRWD (MSG, 50, 101, 0, 0, 0, 0, 2, TN, H) IF (NHNIL .LT. MXHNIL) GO TO 290 MSG = 'DLSODA- Above warning has been issued I1 times. ' CALL XERRWD (MSG, 50, 102, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' It will not be issued again for this problem.' CALL XERRWD (MSG, 50, 102, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0) 290 CONTINUE C----------------------------------------------------------------------- C CALL DSTODA(NEQ,Y,YH,NYH,YH,EWT,SAVF,ACOR,WM,IWM,F,JAC,DPRJA,DSOLSY) C----------------------------------------------------------------------- CALL DSTODA (NEQ, Y, RWORK(LYH), NYH, RWORK(LYH), RWORK(LEWT), 1 RWORK(LSAVF), RWORK(LACOR), RWORK(LWM), IWORK(LIWM), 2 F, JAC, DPRJA, DSOLSY, rpar,ipar) KGO = 1 - KFLAG IF (KGO .EQ. 1) THEN GOTO 300 ELSE IF (KGO .EQ. 2) THEN GOTO 530 ELSE IF (KGO .EQ. 3) THEN GOTO 540 ENDIF C karline: changed from C GO TO (300, 530, 540), KGO C----------------------------------------------------------------------- C Block F. C The following block handles the case of a successful return from the C core integrator (KFLAG = 0). C If a method switch was just made, record TSW, reset MAXORD, C set JSTART to -1 to signal DSTODA to complete the switch, C and do extra printing of data if IXPR = 1. C Then, in any case, check for stop conditions. C----------------------------------------------------------------------- 300 INIT = 1 IF (METH .EQ. MUSED) GO TO 310 TSW = TN MAXORD = MXORDN IF (METH .EQ. 2) MAXORD = MXORDS IF (METH .EQ. 2) RWORK(LWM) = SQRT(UROUND) INSUFR = MIN(INSUFR,1) INSUFI = MIN(INSUFI,1) JSTART = -1 IF (IXPR .EQ. 0) GO TO 310 IF (METH .EQ. 2) THEN MSG = 'Switch to BDF at T (=R1), new step (=R2): %g, %g' CALL rprintfd2(MSG // char(0), TN, H) ENDIF IF (METH .EQ. 1) THEN C MSG='DLSODA- A switch to the Adams (nonstiff) method has occurred' C KS CALL XERRWD (MSG, 60, 106, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) C CALL DBLEPR(MSG, 60, 0, 0) MSG = 'Switch to Adams at T (=R1), new step (=R2): %g, %g' CALL rprintfd2(MSG // char(0), TN, H) ENDIF c write(msg,'(A4,D18.10,A9,D18.10)') c & 'at T',TN,' new step', H C KS CALL XERRWD (MSG, 60, 107, 0, 1, NST, 0, 2, TN, H) c CALL DBLEPR(MSG, 60, 0, 0) 310 CONTINUE IF (ITASK .EQ. 1) THEN GOTO 320 ELSE IF (ITASK .EQ. 2) THEN GOTO 400 ELSE IF (ITASK .EQ. 3) THEN GOTO 330 ELSE IF (ITASK .EQ. 4) THEN GOTO 340 ELSE IF (ITASK .EQ. 5) THEN GOTO 350 ENDIF C Karline: changed from C GO TO (320, 400, 330, 340, 350), ITASK C ITASK = 1. If TOUT has been reached, interpolate. ------------------- 320 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) T = TOUT GO TO 420 C ITASK = 3. Jump to exit if TOUT was reached. ------------------------ 330 IF ((TN - TOUT)*H .GE. 0.0D0) GO TO 400 GO TO 250 C ITASK = 4. See if TOUT or TCRIT was reached. Adjust H if necessary. 340 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 345 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) T = TOUT GO TO 420 345 HMX = ABS(TN) + ABS(H) IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX IF (IHIT) GO TO 400 TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) IF (JSTART .GE. 0) JSTART = -2 GO TO 250 C ITASK = 5. See if TCRIT was reached and jump to exit. --------------- 350 HMX = ABS(TN) + ABS(H) IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX C----------------------------------------------------------------------- C Block G. C The following block handles all successful returns from DLSODA. C If ITASK .ne. 1, Y is loaded from YH and T is set accordingly. C ISTATE is set to 2, and the optional outputs are loaded into the C work arrays before returning. C----------------------------------------------------------------------- 400 DO 410 I = 1,N Y(I) = RWORK(I+LYH-1) 410 CONTINUE T = TN IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 420 IF (IHIT) T = TCRIT 420 ISTATE = 2 RWORK(11) = HU RWORK(12) = H RWORK(13) = TN RWORK(15) = TSW IWORK(11) = NST IWORK(12) = NFE IWORK(13) = NJE IWORK(14) = NQU IWORK(15) = NQ IWORK(19) = MUSED IWORK(20) = METH RETURN C----------------------------------------------------------------------- C Block H. C The following block handles all unsuccessful returns other than C those for illegal input. First the error message routine is called. C If there was an error test or convergence test failure, IMXER is set. C Then Y is loaded from YH and T is set to TN. C The optional outputs are loaded into the work arrays before returning. C----------------------------------------------------------------------- C The maximum number of steps was taken before reaching TOUT. ---------- 500 MSG = 'DLSODA- At current T (=R1), MXSTEP (=I1) steps ' CALL XERRWD (MSG, 50, 201, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' taken on this call before reaching TOUT ' CALL XERRWD (MSG, 50, 201, 0, 1, MXSTEP, 0, 1, TN, 0.0D0) ISTATE = -1 GO TO 580 C EWT(i) .le. 0.0 for some i (not at start of problem). ---------------- 510 EWTI = RWORK(LEWT+I-1) MSG = 'DLSODA- At T (=R1), EWT(I1) has become R2 .le. 0.' CALL XERRWD (MSG, 50, 202, 0, 1, I, 0, 2, TN, EWTI) ISTATE = -6 GO TO 580 C Too much accuracy requested for machine precision. ------------------- 520 MSG = 'DLSODA- At T (=R1), too much accuracy requested ' CALL XERRWD (MSG, 50, 203, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' for precision of machine.. See TOLSF (=R2) ' CALL XERRWD (MSG, 50, 203, 0, 0, 0, 0, 2, TN, TOLSF) RWORK(14) = TOLSF ISTATE = -2 GO TO 580 C KFLAG = -1. Error test failed repeatedly or with ABS(H) = HMIN. ----- 530 MSG = 'DLSODA- At T(=R1) and step size H(=R2), the error' CALL XERRWD (MSG, 50, 204, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' test failed repeatedly or with ABS(H) = HMIN' CALL XERRWD (MSG, 50, 204, 0, 0, 0, 0, 2, TN, H) ISTATE = -4 GO TO 560 C KFLAG = -2. Convergence failed repeatedly or with ABS(H) = HMIN. ---- 540 MSG = 'DLSODA- At T (=R1) and step size H (=R2), the ' CALL XERRWD (MSG, 50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' corrector convergence failed repeatedly ' CALL XERRWD (MSG, 50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' or with ABS(H) = HMIN ' CALL XERRWD (MSG, 30, 205, 0, 0, 0, 0, 2, TN, H) ISTATE = -5 GO TO 560 C RWORK length too small to proceed. ----------------------------------- 550 MSG = 'DLSODA- At current T(=R1), RWORK length too small' CALL XERRWD (MSG, 50, 206, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' to proceed. The integration was otherwise successful.' CALL XERRWD (MSG, 60, 206, 0, 0, 0, 0, 1, TN, 0.0D0) ISTATE = -7 GO TO 580 C IWORK length too small to proceed. ----------------------------------- 555 MSG = 'DLSODA- At current T(=R1), IWORK length too small' CALL XERRWD (MSG, 50, 207, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' to proceed. The integration was otherwise successful.' CALL XERRWD (MSG, 60, 207, 0, 0, 0, 0, 1, TN, 0.0D0) ISTATE = -7 GO TO 580 C Compute IMXER if relevant. ------------------------------------------- 560 BIG = 0.0D0 IMXER = 1 DO 570 I = 1,N SIZE = ABS(RWORK(I+LACOR-1)*RWORK(I+LEWT-1)) IF (BIG .GE. SIZE) GO TO 570 BIG = SIZE IMXER = I 570 CONTINUE IWORK(16) = IMXER C Set Y vector, T, and optional outputs. ------------------------------- 580 DO 590 I = 1,N Y(I) = RWORK(I+LYH-1) 590 CONTINUE T = TN RWORK(11) = HU RWORK(12) = H RWORK(13) = TN RWORK(15) = TSW IWORK(11) = NST IWORK(12) = NFE IWORK(13) = NJE IWORK(14) = NQU IWORK(15) = NQ IWORK(19) = MUSED IWORK(20) = METH RETURN C----------------------------------------------------------------------- C Block I. C The following block handles all error returns due to illegal input C (ISTATE = -3), as detected before calling the core integrator. C First the error message routine is called. If the illegal input C is a negative ISTATE, the run is aborted (apparent infinite loop). C----------------------------------------------------------------------- 601 MSG = 'DLSODA- ISTATE (=I1) illegal.' CALL XERRWD (MSG, 30, 1, 0, 1, ISTATE, 0, 0, 0.0D0, 0.0D0) IF (ISTATE .LT. 0) GO TO 800 GO TO 700 602 MSG = 'DLSODA- ITASK (=I1) illegal. ' CALL XERRWD (MSG, 30, 2, 0, 1, ITASK, 0, 0, 0.0D0, 0.0D0) GO TO 700 603 MSG = 'DLSODA- ISTATE .gt. 1 but DLSODA not initialized.' CALL XERRWD (MSG, 50, 3, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) GO TO 700 604 MSG = 'DLSODA- NEQ (=I1) .lt. 1 ' CALL XERRWD (MSG, 30, 4, 0, 1, NEQ(1), 0, 0, 0.0D0, 0.0D0) GO TO 700 605 MSG = 'DLSODA- ISTATE = 3 and NEQ increased (I1 to I2). ' CALL XERRWD (MSG, 50, 5, 0, 2, N, NEQ(1), 0, 0.0D0, 0.0D0) GO TO 700 606 MSG = 'DLSODA- ITOL (=I1) illegal. ' CALL XERRWD (MSG, 30, 6, 0, 1, ITOL, 0, 0, 0.0D0, 0.0D0) GO TO 700 607 MSG = 'DLSODA- IOPT (=I1) illegal. ' CALL XERRWD (MSG, 30, 7, 0, 1, IOPT, 0, 0, 0.0D0, 0.0D0) GO TO 700 608 MSG = 'DLSODA- JT (=I1) illegal. ' CALL XERRWD (MSG, 30, 8, 0, 1, JT, 0, 0, 0.0D0, 0.0D0) GO TO 700 609 MSG = 'DLSODA- ML (=I1) illegal: .lt.0 or .ge.NEQ (=I2) ' CALL XERRWD (MSG, 50, 9, 0, 2, ML, NEQ(1), 0, 0.0D0, 0.0D0) GO TO 700 610 MSG = 'DLSODA- MU (=I1) illegal: .lt.0 or .ge.NEQ (=I2) ' CALL XERRWD (MSG, 50, 10, 0, 2, MU, NEQ(1), 0, 0.0D0, 0.0D0) GO TO 700 611 MSG = 'DLSODA- IXPR (=I1) illegal. ' CALL XERRWD (MSG, 30, 11, 0, 1, IXPR, 0, 0, 0.0D0, 0.0D0) GO TO 700 612 MSG = 'DLSODA- MXSTEP (=I1) .lt. 0 ' CALL XERRWD (MSG, 30, 12, 0, 1, MXSTEP, 0, 0, 0.0D0, 0.0D0) GO TO 700 613 MSG = 'DLSODA- MXHNIL (=I1) .lt. 0 ' CALL XERRWD (MSG, 30, 13, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0) GO TO 700 614 MSG = 'DLSODA- TOUT (=R1) behind T (=R2) ' CALL XERRWD (MSG, 40, 14, 0, 0, 0, 0, 2, TOUT, T) MSG = ' Integration direction is given by H0 (=R1) ' CALL XERRWD (MSG, 50, 14, 0, 0, 0, 0, 1, H0, 0.0D0) GO TO 700 615 MSG = 'DLSODA- HMAX (=R1) .lt. 0.0 ' CALL XERRWD (MSG, 30, 15, 0, 0, 0, 0, 1, HMAX, 0.0D0) GO TO 700 616 MSG = 'DLSODA- HMIN (=R1) .lt. 0.0 ' CALL XERRWD (MSG, 30, 16, 0, 0, 0, 0, 1, HMIN, 0.0D0) GO TO 700 617 MSG='DLSODA- RWORK length needed, LENRW (=I1), exceeds LRW (=I2)' CALL XERRWD (MSG, 60, 17, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) GO TO 700 618 MSG='DLSODA- IWORK length needed, LENIW (=I1), exceeds LIW (=I2)' CALL XERRWD (MSG, 60, 18, 0, 2, LENIW, LIW, 0, 0.0D0, 0.0D0) GO TO 700 619 MSG = 'DLSODA- RTOL(I1) is R1 .lt. 0.0 ' CALL XERRWD (MSG, 40, 19, 0, 1, I, 0, 1, RTOLI, 0.0D0) GO TO 700 620 MSG = 'DLSODA- ATOL(I1) is R1 .lt. 0.0 ' CALL XERRWD (MSG, 40, 20, 0, 1, I, 0, 1, ATOLI, 0.0D0) GO TO 700 621 EWTI = RWORK(LEWT+I-1) MSG = 'DLSODA- EWT(I1) is R1 .le. 0.0 ' CALL XERRWD (MSG, 40, 21, 0, 1, I, 0, 1, EWTI, 0.0D0) GO TO 700 622 MSG='DLSODA- TOUT(=R1) too close to T(=R2) to start integration.' CALL XERRWD (MSG, 60, 22, 0, 0, 0, 0, 2, TOUT, T) GO TO 700 623 MSG='DLSODA- ITASK = I1 and TOUT (=R1) behind TCUR - HU (= R2) ' CALL XERRWD (MSG, 60, 23, 0, 1, ITASK, 0, 2, TOUT, TP) GO TO 700 624 MSG='DLSODA- ITASK = 4 or 5 and TCRIT (=R1) behind TCUR (=R2) ' CALL XERRWD (MSG, 60, 24, 0, 0, 0, 0, 2, TCRIT, TN) GO TO 700 625 MSG='DLSODA- ITASK = 4 or 5 and TCRIT (=R1) behind TOUT (=R2) ' CALL XERRWD (MSG, 60, 25, 0, 0, 0, 0, 2, TCRIT, TOUT) GO TO 700 626 MSG = 'DLSODA- At start of problem, too much accuracy ' CALL XERRWD (MSG, 50, 26, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' requested for precision of machine.. See TOLSF (=R1) ' CALL XERRWD (MSG, 60, 26, 0, 0, 0, 0, 1, TOLSF, 0.0D0) RWORK(14) = TOLSF GO TO 700 627 MSG = 'DLSODA- Trouble in DINTDY. ITASK = I1, TOUT = R1' CALL XERRWD (MSG, 50, 27, 0, 1, ITASK, 0, 1, TOUT, 0.0D0) GO TO 700 628 MSG = 'DLSODA- MXORDN (=I1) .lt. 0 ' CALL XERRWD (MSG, 30, 28, 0, 1, MXORDN, 0, 0, 0.0D0, 0.0D0) GO TO 700 629 MSG = 'DLSODA- MXORDS (=I1) .lt. 0 ' CALL XERRWD (MSG, 30, 29, 0, 1, MXORDS, 0, 0, 0.0D0, 0.0D0) C 700 ISTATE = -3 RETURN C 800 MSG = 'DLSODA- Run aborted.. apparent infinite loop. ' CALL XERRWD (MSG, 50, 303, 2, 0, 0, 0, 0, 0.0D0, 0.0D0) RETURN C----------------------- End of Subroutine DLSODA ---------------------- END *DECK DLSODAR SUBROUTINE DLSODAR (F, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, ITASK, 1 ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JAC, JT, 2 G, NG, JROOT, rpar, ipar) EXTERNAL F, JAC, G CKS: added rpar, ipar integer ipar(*) double precision rpar(*) INTEGER NEQ, ITOL, ITASK, ISTATE, IOPT, LRW, IWORK, LIW, JT, 1 NG, JROOT DOUBLE PRECISION Y, T, TOUT, RTOL, ATOL, RWORK DIMENSION NEQ(*), Y(*), RTOL(*), ATOL(*), RWORK(LRW), IWORK(LIW), 1 JROOT(NG) C----------------------------------------------------------------------- C This is the 12 November 2003 version of C DLSODAR: Livermore Solver for Ordinary Differential Equations, with C Automatic method switching for stiff and nonstiff problems, C and with Root-finding. C C This version is in double precision. C C DLSODAR solves the initial value problem for stiff or nonstiff C systems of first order ODEs, C dy/dt = f(t,y) , or, in component form, C dy(i)/dt = f(i) = f(i,t,y(1),y(2),...,y(NEQ)) (i = 1,...,NEQ). C At the same time, it locates the roots of any of a set of functions C g(i) = g(i,t,y(1),...,y(NEQ)) (i = 1,...,ng). C C This a variant version of the DLSODE package. It differs from it C in two ways: C (a) It switches automatically between stiff and nonstiff methods. C This means that the user does not have to determine whether the C problem is stiff or not, and the solver will automatically choose the C appropriate method. It always starts with the nonstiff method. C (b) It finds the root of at least one of a set of constraint C functions g(i) of the independent and dependent variables. C It finds only those roots for which some g(i), as a function C of t, changes sign in the interval of integration. C It then returns the solution at the root, if that occurs C sooner than the specified stop condition, and otherwise returns C the solution according the specified stop condition. C C Authors: Alan C. Hindmarsh, C Center for Applied Scientific Computing, L-561 C Lawrence Livermore National Laboratory C Livermore, CA 94551 C and C Linda R. Petzold C Univ. of California at Santa Barbara C Dept. of Computer Science C Santa Barbara, CA 93106 C C References: C 1. Alan C. Hindmarsh, ODEPACK, A Systematized Collection of ODE C Solvers, in Scientific Computing, R. S. Stepleman et al. (Eds.), C North-Holland, Amsterdam, 1983, pp. 55-64. C 2. Linda R. Petzold, Automatic Selection of Methods for Solving C Stiff and Nonstiff Systems of Ordinary Differential Equations, C Siam J. Sci. Stat. Comput. 4 (1983), pp. 136-148. C 3. Kathie L. Hiebert and Lawrence F. Shampine, Implicitly Defined C Output Points for Solutions of ODEs, Sandia Report SAND80-0180, C February 1980. C----------------------------------------------------------------------- C Summary of Usage. C C Communication between the user and the DLSODAR package, for normal C situations, is summarized here. This summary describes only a subset C of the full set of options available. See the full description for C details, including alternative treatment of the Jacobian matrix, C optional inputs and outputs, nonstandard options, and C instructions for special situations. See also the example C problem (with program and output) following this summary. C C A. First provide a subroutine of the form: C SUBROUTINE F (NEQ, T, Y, YDOT,rpar,ipar) C INTEGER NEQ,ipar(*) C DOUBLE PRECISION T, Y(*), YDOT(*),rpar(*) C which supplies the vector function f by loading YDOT(i) with f(i). C C B. Provide a subroutine of the form: C SUBROUTINE G (NEQ, T, Y, NG, GOUT, rpar, ipar) C DOUBLE PRECISION T, Y(*), GOUT(NG), rpar(*) C which supplies the vector function g by loading GOUT(i) with C g(i), the i-th constraint function whose root is sought. C C C. Write a main program which calls Subroutine DLSODAR once for C each point at which answers are desired. This should also provide C for possible use of logical unit 6 for output of error messages by C DLSODAR. On the first call to DLSODAR, supply arguments as follows: C F = name of subroutine for right-hand side vector f. C This name must be declared External in calling program. C NEQ = number of first order ODEs. C Y = array of initial values, of length NEQ. C T = the initial value of the independent variable. C TOUT = first point where output is desired (.ne. T). C ITOL = 1 or 2 according as ATOL (below) is a scalar or array. C RTOL = relative tolerance parameter (scalar). C ATOL = absolute tolerance parameter (scalar or array). C the estimated local error in y(i) will be controlled so as C to be less than C EWT(i) = RTOL*ABS(Y(i)) + ATOL if ITOL = 1, or C EWT(i) = RTOL*ABS(Y(i)) + ATOL(i) if ITOL = 2. C Thus the local error test passes if, in each component, C either the absolute error is less than ATOL (or ATOL(i)), C or the relative error is less than RTOL. C Use RTOL = 0.0 for pure absolute error control, and C use ATOL = 0.0 (or ATOL(i) = 0.0) for pure relative error C control. Caution: actual (global) errors may exceed these C local tolerances, so choose them conservatively. C ITASK = 1 for normal computation of output values of y at t = TOUT. C ISTATE = integer flag (input and output). Set ISTATE = 1. C IOPT = 0 to indicate no optional inputs used. C RWORK = real work array of length at least: C 22 + NEQ * MAX(16, NEQ + 9) + 3*NG. C See also Paragraph F below. C LRW = declared length of RWORK (in user's dimension). C IWORK = integer work array of length at least 20 + NEQ. C LIW = declared length of IWORK (in user's dimension). C JAC = name of subroutine for Jacobian matrix. C Use a dummy name. See also Paragraph F below. C JT = Jacobian type indicator. Set JT = 2. C See also Paragraph F below. C G = name of subroutine for constraint functions, whose C roots are desired during the integration. C This name must be declared External in calling program. C NG = number of constraint functions g(i). If there are none, C set NG = 0, and pass a dummy name for G. C JROOT = integer array of length NG for output of root information. C See next paragraph. C Note that the main program must declare arrays Y, RWORK, IWORK, C JROOT, and possibly ATOL. C C D. The output from the first call (or any call) is: C Y = array of computed values of y(t) vector. C T = corresponding value of independent variable. This is C TOUT if ISTATE = 2, or the root location if ISTATE = 3, C or the farthest point reached if DLSODAR was unsuccessful. C ISTATE = 2 or 3 if DLSODAR was successful, negative otherwise. C 2 means no root was found, and TOUT was reached as desired. C 3 means a root was found prior to reaching TOUT. C -1 means excess work done on this call (perhaps wrong JT). C -2 means excess accuracy requested (tolerances too small). C -3 means illegal input detected (see printed message). C -4 means repeated error test failures (check all inputs). C -5 means repeated convergence failures (perhaps bad Jacobian C supplied or wrong choice of JT or tolerances). C -6 means error weight became zero during problem. (Solution C component i vanished, and ATOL or ATOL(i) = 0.) C -7 means work space insufficient to finish (see messages). C JROOT = array showing roots found if ISTATE = 3 on return. C JROOT(i) = 1 if g(i) has a root at t, or 0 otherwise. C C E. To continue the integration after a successful return, proceed C as follows: C (a) If ISTATE = 2 on return, reset TOUT and call DLSODAR again. C (b) If ISTATE = 3 on return, reset ISTATE to 2, call DLSODAR again. C In either case, no other parameters need be reset. C C F. Note: If and when DLSODAR regards the problem as stiff, and C switches methods accordingly, it must make use of the NEQ by NEQ C Jacobian matrix, J = df/dy. For the sake of simplicity, the C inputs to DLSODAR recommended in Paragraph C above cause DLSODAR to C treat J as a full matrix, and to approximate it internally by C difference quotients. Alternatively, J can be treated as a band C matrix (with great potential reduction in the size of the RWORK C array). Also, in either the full or banded case, the user can supply C J in closed form, with a routine whose name is passed as the JAC C argument. These alternatives are described in the paragraphs on C RWORK, JAC, and JT in the full description of the call sequence below. C C----------------------------------------------------------------------- C Example Problem. C C The following is a simple example problem, with the coding C needed for its solution by DLSODAR. The problem is from chemical C kinetics, and consists of the following three rate equations: C dy1/dt = -.04*y1 + 1.e4*y2*y3 C dy2/dt = .04*y1 - 1.e4*y2*y3 - 3.e7*y2**2 C dy3/dt = 3.e7*y2**2 C on the interval from t = 0.0 to t = 4.e10, with initial conditions C y1 = 1.0, y2 = y3 = 0. The problem is stiff. C In addition, we want to find the values of t, y1, y2, and y3 at which C (1) y1 reaches the value 1.e-4, and C (2) y3 reaches the value 1.e-2. C C The following coding solves this problem with DLSODAR, C printing results at t = .4, 4., ..., 4.e10, and at the computed C roots. It uses ITOL = 2 and ATOL much smaller for y2 than y1 or y3 C because y2 has much smaller values. C At the end of the run, statistical quantities of interest are C printed (see optional outputs in the full description below). C C EXTERNAL FEX, GEX C DOUBLE PRECISION ATOL, RTOL, RWORK, T, TOUT, Y C DIMENSION Y(3), ATOL(3), RWORK(76), IWORK(23), JROOT(2) C NEQ = 3 C Y(1) = 1. C Y(2) = 0. C Y(3) = 0. C T = 0. C TOUT = .4 C ITOL = 2 C RTOL = 1.D-4 C ATOL(1) = 1.D-6 C ATOL(2) = 1.D-10 C ATOL(3) = 1.D-6 C ITASK = 1 C ISTATE = 1 C IOPT = 0 C LRW = 76 C LIW = 23 C JT = 2 C NG = 2 C DO 40 IOUT = 1,12 C 10 CALL DLSODAR(FEX,NEQ,Y,T,TOUT,ITOL,RTOL,ATOL,ITASK,ISTATE, C 1 IOPT,RWORK,LRW,IWORK,LIW,JDUM,JT,GEX,NG,JROOT) C WRITE(6,20)T,Y(1),Y(2),Y(3) C 20 FORMAT(' At t =',D12.4,' Y =',3D14.6) C IF (ISTATE .LT. 0) GO TO 80 C IF (ISTATE .EQ. 2) GO TO 40 C WRITE(6,30)JROOT(1),JROOT(2) C 30 FORMAT(5X,' The above line is a root, JROOT =',2I5) C ISTATE = 2 C GO TO 10 C 40 TOUT = TOUT*10. C WRITE(6,60)IWORK(11),IWORK(12),IWORK(13),IWORK(10), C 1 IWORK(19),RWORK(15) C 60 FORMAT(/' No. steps =',I4,' No. f-s =',I4,' No. J-s =',I4, C 1 ' No. g-s =',I4/ C 2 ' Method last used =',I2,' Last switch was at t =',D12.4) C STOP C 80 WRITE(6,90)ISTATE C 90 FORMAT(///' Error halt.. ISTATE =',I3) C STOP C END C C SUBROUTINE FEX (NEQ, T, Y, YDOT,rpar,ipar) C DOUBLE PRECISION T, Y, YDOT,rpar(*) C DIMENSION Y(3), YDOT(3) C YDOT(1) = -.04*Y(1) + 1.D4*Y(2)*Y(3) C YDOT(3) = 3.D7*Y(2)*Y(2) C YDOT(2) = -YDOT(1) - YDOT(3) C RETURN C END C C SUBROUTINE GEX (NEQ, T, Y, NG, GOUT) C DOUBLE PRECISION T, Y, GOUT C DIMENSION Y(3), GOUT(2) C GOUT(1) = Y(1) - 1.D-4 C GOUT(2) = Y(3) - 1.D-2 C RETURN C END C C The output of this program (on a CDC-7600 in single precision) C is as follows: C C At t = 2.6400e-01 y = 9.899653e-01 3.470563e-05 1.000000e-02 C The above line is a root, JROOT = 0 1 C At t = 4.0000e-01 Y = 9.851712e-01 3.386380e-05 1.479493e-02 C At t = 4.0000e+00 Y = 9.055333e-01 2.240655e-05 9.444430e-02 C At t = 4.0000e+01 Y = 7.158403e-01 9.186334e-06 2.841505e-01 C At t = 4.0000e+02 Y = 4.505250e-01 3.222964e-06 5.494717e-01 C At t = 4.0000e+03 Y = 1.831975e-01 8.941774e-07 8.168016e-01 C At t = 4.0000e+04 Y = 3.898730e-02 1.621940e-07 9.610125e-01 C At t = 4.0000e+05 Y = 4.936363e-03 1.984221e-08 9.950636e-01 C At t = 4.0000e+06 Y = 5.161831e-04 2.065786e-09 9.994838e-01 C At t = 2.0745e+07 Y = 1.000000e-04 4.000395e-10 9.999000e-01 C The above line is a root, JROOT = 1 0 C At t = 4.0000e+07 Y = 5.179817e-05 2.072032e-10 9.999482e-01 C At t = 4.0000e+08 Y = 5.283401e-06 2.113371e-11 9.999947e-01 C At t = 4.0000e+09 Y = 4.659031e-07 1.863613e-12 9.999995e-01 C At t = 4.0000e+10 Y = 1.404280e-08 5.617126e-14 1.000000e+00 C C No. steps = 361 No. f-s = 693 No. J-s = 64 No. g-s = 390 C Method last used = 2 Last switch was at t = 6.0092e-03 C C----------------------------------------------------------------------- C Full Description of User Interface to DLSODAR. C C The user interface to DLSODAR consists of the following parts. C C 1. The call sequence to Subroutine DLSODAR, which is a driver C routine for the solver. This includes descriptions of both C the call sequence arguments and of user-supplied routines. C Following these descriptions is a description of C optional inputs available through the call sequence, and then C a description of optional outputs (in the work arrays). C C 2. Descriptions of other routines in the DLSODAR package that may be C (optionally) called by the user. These provide the ability to C alter error message handling, save and restore the internal C Common, and obtain specified derivatives of the solution y(t). C C 3. Descriptions of Common blocks to be declared in overlay C or similar environments, or to be saved when doing an interrupt C of the problem and continued solution later. C C 4. Description of a subroutine in the DLSODAR package, C which the user may replace with his/her own version, if desired. C this relates to the measurement of errors. C C----------------------------------------------------------------------- C Part 1. Call Sequence. C C The call sequence parameters used for input only are C F, NEQ, TOUT, ITOL, RTOL, ATOL, ITASK, IOPT, LRW, LIW, JAC, C JT, G, and NG, C that used only for output is JROOT, C and those used for both input and output are C Y, T, ISTATE. C The work arrays RWORK and IWORK are also used for conditional and C optional inputs and optional outputs. (The term output here refers C to the return from Subroutine DLSODAR to the user's calling program.) C C The legality of input parameters will be thoroughly checked on the C initial call for the problem, but not checked thereafter unless a C change in input parameters is flagged by ISTATE = 3 on input. C C The descriptions of the call arguments are as follows. C C F = the name of the user-supplied subroutine defining the C ODE system. The system must be put in the first-order C form dy/dt = f(t,y), where f is a vector-valued function C of the scalar t and the vector y. Subroutine F is to C compute the function f. It is to have the form C SUBROUTINE F (NEQ, T, Y, YDOT,rpar,ipar) C INTEGER NEQ,ipar(*) C DOUBLE PRECISION T, Y(*), YDOT(*),rpar(*) C where NEQ, T, and Y are input, and the array YDOT = f(t,y) C is output. Y and YDOT are arrays of length NEQ. C Subroutine F should not alter Y(1),...,Y(NEQ). C F must be declared External in the calling program. C C Subroutine F may access user-defined quantities in C NEQ(2),... and/or in Y(NEQ(1)+1),... if NEQ is an array C (dimensioned in F) and/or Y has length exceeding NEQ(1). C See the descriptions of NEQ and Y below. C C If quantities computed in the F routine are needed C externally to DLSODAR, an extra call to F should be made C for this purpose, for consistent and accurate results. C If only the derivative dy/dt is needed, use DINTDY instead. C C NEQ = the size of the ODE system (number of first order C ordinary differential equations). Used only for input. C NEQ may be decreased, but not increased, during the problem. C If NEQ is decreased (with ISTATE = 3 on input), the C remaining components of Y should be left undisturbed, if C these are to be accessed in F and/or JAC. C C Normally, NEQ is a scalar, and it is generally referred to C as a scalar in this user interface description. However, C NEQ may be an array, with NEQ(1) set to the system size. C (The DLSODAR package accesses only NEQ(1).) In either case, C this parameter is passed as the NEQ argument in all calls C to F, JAC, and G. Hence, if it is an array, locations C NEQ(2),... may be used to store other integer data and pass C it to F, JAC, and G. Each such subroutine must include C NEQ in a Dimension statement in that case. C C Y = a real array for the vector of dependent variables, of C length NEQ or more. Used for both input and output on the C first call (ISTATE = 1), and only for output on other calls. C On the first call, Y must contain the vector of initial C values. On output, Y contains the computed solution vector, C evaluated at T. If desired, the Y array may be used C for other purposes between calls to the solver. C C This array is passed as the Y argument in all calls to F, C JAC, and G. Hence its length may exceed NEQ, and locations C Y(NEQ+1),... may be used to store other real data and C pass it to F, JAC, and G. (The DLSODAR package accesses only C Y(1),...,Y(NEQ).) C C T = the independent variable. On input, T is used only on the C first call, as the initial point of the integration. C On output, after each call, T is the value at which a C computed solution y is evaluated (usually the same as TOUT). C If a root was found, T is the computed location of the C root reached first, on output. C On an error return, T is the farthest point reached. C C TOUT = the next value of t at which a computed solution is desired. C Used only for input. C C When starting the problem (ISTATE = 1), TOUT may be equal C to T for one call, then should .ne. T for the next call. C For the initial T, an input value of TOUT .ne. T is used C in order to determine the direction of the integration C (i.e. the algebraic sign of the step sizes) and the rough C scale of the problem. Integration in either direction C (forward or backward in t) is permitted. C C If ITASK = 2 or 5 (one-step modes), TOUT is ignored after C the first call (i.e. the first call with TOUT .ne. T). C Otherwise, TOUT is required on every call. C C If ITASK = 1, 3, or 4, the values of TOUT need not be C monotone, but a value of TOUT which backs up is limited C to the current internal T interval, whose endpoints are C TCUR - HU and TCUR (see optional outputs, below, for C TCUR and HU). C C ITOL = an indicator for the type of error control. See C description below under ATOL. Used only for input. C C RTOL = a relative error tolerance parameter, either a scalar or C an array of length NEQ. See description below under ATOL. C Input only. C C ATOL = an absolute error tolerance parameter, either a scalar or C an array of length NEQ. Input only. C C The input parameters ITOL, RTOL, and ATOL determine C the error control performed by the solver. The solver will C control the vector E = (E(i)) of estimated local errors C in y, according to an inequality of the form C max-norm of ( E(i)/EWT(i) ) .le. 1, C where EWT = (EWT(i)) is a vector of positive error weights. C The values of RTOL and ATOL should all be non-negative. C The following table gives the types (scalar/array) of C RTOL and ATOL, and the corresponding form of EWT(i). C C ITOL RTOL ATOL EWT(i) C 1 scalar scalar RTOL*ABS(Y(i)) + ATOL C 2 scalar array RTOL*ABS(Y(i)) + ATOL(i) C 3 array scalar RTOL(i)*ABS(Y(i)) + ATOL C 4 array array RTOL(i)*ABS(Y(i)) + ATOL(i) C C When either of these parameters is a scalar, it need not C be dimensioned in the user's calling program. C C If none of the above choices (with ITOL, RTOL, and ATOL C fixed throughout the problem) is suitable, more general C error controls can be obtained by substituting a C user-supplied routine for the setting of EWT. C See Part 4 below. C C If global errors are to be estimated by making a repeated C run on the same problem with smaller tolerances, then all C components of RTOL and ATOL (i.e. of EWT) should be scaled C down uniformly. C C ITASK = an index specifying the task to be performed. C input only. ITASK has the following values and meanings. C 1 means normal computation of output values of y(t) at C t = TOUT (by overshooting and interpolating). C 2 means take one step only and return. C 3 means stop at the first internal mesh point at or C beyond t = TOUT and return. C 4 means normal computation of output values of y(t) at C t = TOUT but without overshooting t = TCRIT. C TCRIT must be input as RWORK(1). TCRIT may be equal to C or beyond TOUT, but not behind it in the direction of C integration. This option is useful if the problem C has a singularity at or beyond t = TCRIT. C 5 means take one step, without passing TCRIT, and return. C TCRIT must be input as RWORK(1). C C Note: If ITASK = 4 or 5 and the solver reaches TCRIT C (within roundoff), it will return T = TCRIT (exactly) to C indicate this (unless ITASK = 4 and TOUT comes before TCRIT, C in which case answers at t = TOUT are returned first). C C ISTATE = an index used for input and output to specify the C the state of the calculation. C C On input, the values of ISTATE are as follows. C 1 means this is the first call for the problem C (initializations will be done). See note below. C 2 means this is not the first call, and the calculation C is to continue normally, with no change in any input C parameters except possibly TOUT and ITASK. C (If ITOL, RTOL, and/or ATOL are changed between calls C with ISTATE = 2, the new values will be used but not C tested for legality.) C 3 means this is not the first call, and the C calculation is to continue normally, but with C a change in input parameters other than C TOUT and ITASK. Changes are allowed in C NEQ, ITOL, RTOL, ATOL, IOPT, LRW, LIW, JT, ML, MU, C and any optional inputs except H0, MXORDN, and MXORDS. C (See IWORK description for ML and MU.) C In addition, immediately following a return with C ISTATE = 3 (root found), NG and G may be changed. C (But changing NG from 0 to .gt. 0 is not allowed.) C Note: A preliminary call with TOUT = T is not counted C as a first call here, as no initialization or checking of C input is done. (Such a call is sometimes useful for the C purpose of outputting the initial conditions.) C Thus the first call for which TOUT .ne. T requires C ISTATE = 1 on input. C C On output, ISTATE has the following values and meanings. C 1 means nothing was done; TOUT = t and ISTATE = 1 on input. C 2 means the integration was performed successfully, and C no roots were found. C 3 means the integration was successful, and one or more C roots were found before satisfying the stop condition C specified by ITASK. See JROOT. C -1 means an excessive amount of work (more than MXSTEP C steps) was done on this call, before completing the C requested task, but the integration was otherwise C successful as far as T. (MXSTEP is an optional input C and is normally 500.) To continue, the user may C simply reset ISTATE to a value .gt. 1 and call again C (the excess work step counter will be reset to 0). C In addition, the user may increase MXSTEP to avoid C this error return (see below on optional inputs). C -2 means too much accuracy was requested for the precision C of the machine being used. This was detected before C completing the requested task, but the integration C was successful as far as T. To continue, the tolerance C parameters must be reset, and ISTATE must be set C to 3. The optional output TOLSF may be used for this C purpose. (Note: If this condition is detected before C taking any steps, then an illegal input return C (ISTATE = -3) occurs instead.) C -3 means illegal input was detected, before taking any C integration steps. See written message for details. C Note: If the solver detects an infinite loop of calls C to the solver with illegal input, it will cause C the run to stop. C -4 means there were repeated error test failures on C one attempted step, before completing the requested C task, but the integration was successful as far as T. C The problem may have a singularity, or the input C may be inappropriate. C -5 means there were repeated convergence test failures on C one attempted step, before completing the requested C task, but the integration was successful as far as T. C This may be caused by an inaccurate Jacobian matrix, C if one is being used. C -6 means EWT(i) became zero for some i during the C integration. Pure relative error control (ATOL(i)=0.0) C was requested on a variable which has now vanished. C The integration was successful as far as T. C -7 means the length of RWORK and/or IWORK was too small to C proceed, but the integration was successful as far as T. C This happens when DLSODAR chooses to switch methods C but LRW and/or LIW is too small for the new method. C C Note: Since the normal output value of ISTATE is 2, C it does not need to be reset for normal continuation. C Also, since a negative input value of ISTATE will be C regarded as illegal, a negative output value requires the C user to change it, and possibly other inputs, before C calling the solver again. C C IOPT = an integer flag to specify whether or not any optional C inputs are being used on this call. Input only. C The optional inputs are listed separately below. C IOPT = 0 means no optional inputs are being used. C Default values will be used in all cases. C IOPT = 1 means one or more optional inputs are being used. C C RWORK = a real array (double precision) for work space, and (in the C first 20 words) for conditional and optional inputs and C optional outputs. C As DLSODAR switches automatically between stiff and nonstiff C methods, the required length of RWORK can change during the C problem. Thus the RWORK array passed to DLSODAR can either C have a static (fixed) length large enough for both methods, C or have a dynamic (changing) length altered by the calling C program in response to output from DLSODAR. C C --- Fixed Length Case --- C If the RWORK length is to be fixed, it should be at least C max (LRN, LRS), C where LRN and LRS are the RWORK lengths required when the C current method is nonstiff or stiff, respectively. C C The separate RWORK length requirements LRN and LRS are C as follows: C If NEQ is constant and the maximum method orders have C their default values, then C LRN = 20 + 16*NEQ + 3*NG, C LRS = 22 + 9*NEQ + NEQ**2 + 3*NG (JT = 1 or 2), C LRS = 22 + 10*NEQ + (2*ML+MU)*NEQ + 3*NG (JT = 4 or 5). C Under any other conditions, LRN and LRS are given by: C LRN = 20 + NYH*(MXORDN+1) + 3*NEQ + 3*NG, C LRS = 20 + NYH*(MXORDS+1) + 3*NEQ + LMAT + 3*NG, C where C NYH = the initial value of NEQ, C MXORDN = 12, unless a smaller value is given as an C optional input, C MXORDS = 5, unless a smaller value is given as an C optional input, C LMAT = length of matrix work space: C LMAT = NEQ**2 + 2 if JT = 1 or 2, C LMAT = (2*ML + MU + 1)*NEQ + 2 if JT = 4 or 5. C C --- Dynamic Length Case --- C If the length of RWORK is to be dynamic, then it should C be at least LRN or LRS, as defined above, depending on the C current method. Initially, it must be at least LRN (since C DLSODAR starts with the nonstiff method). On any return C from DLSODAR, the optional output MCUR indicates the current C method. If MCUR differs from the value it had on the C previous return, or if there has only been one call to C DLSODAR and MCUR is now 2, then DLSODAR has switched C methods during the last call, and the length of RWORK C should be reset (to LRN if MCUR = 1, or to LRS if C MCUR = 2). (An increase in the RWORK length is required C if DLSODAR returned ISTATE = -7, but not otherwise.) C After resetting the length, call DLSODAR with ISTATE = 3 C to signal that change. C C LRW = the length of the array RWORK, as declared by the user. C (This will be checked by the solver.) C C IWORK = an integer array for work space. C As DLSODAR switches automatically between stiff and nonstiff C methods, the required length of IWORK can change during C problem, between C LIS = 20 + NEQ and LIN = 20, C respectively. Thus the IWORK array passed to DLSODAR can C either have a fixed length of at least 20 + NEQ, or have a C dynamic length of at least LIN or LIS, depending on the C current method. The comments on dynamic length under C RWORK above apply here. Initially, this length need C only be at least LIN = 20. C C The first few words of IWORK are used for conditional and C optional inputs and optional outputs. C C The following 2 words in IWORK are conditional inputs: C IWORK(1) = ML These are the lower and upper C IWORK(2) = MU half-bandwidths, respectively, of the C banded Jacobian, excluding the main diagonal. C The band is defined by the matrix locations C (i,j) with i-ML .le. j .le. i+MU. ML and MU C must satisfy 0 .le. ML,MU .le. NEQ-1. C These are required if JT is 4 or 5, and C ignored otherwise. ML and MU may in fact be C the band parameters for a matrix to which C df/dy is only approximately equal. C C LIW = the length of the array IWORK, as declared by the user. C (This will be checked by the solver.) C C Note: The base addresses of the work arrays must not be C altered between calls to DLSODAR for the same problem. C The contents of the work arrays must not be altered C between calls, except possibly for the conditional and C optional inputs, and except for the last 3*NEQ words of RWORK. C The latter space is used for internal scratch space, and so is C available for use by the user outside DLSODAR between calls, if C desired (but not for use by F, JAC, or G). C C JAC = the name of the user-supplied routine to compute the C Jacobian matrix, df/dy, if JT = 1 or 4. The JAC routine C is optional, but if the problem is expected to be stiff much C of the time, you are encouraged to supply JAC, for the sake C of efficiency. (Alternatively, set JT = 2 or 5 to have C DLSODAR compute df/dy internally by difference quotients.) C If and when DLSODAR uses df/dy, it treats this NEQ by NEQ C matrix either as full (JT = 1 or 2), or as banded (JT = C 4 or 5) with half-bandwidths ML and MU (discussed under C IWORK above). In either case, if JT = 1 or 4, the JAC C routine must compute df/dy as a function of the scalar t C and the vector y. It is to have the form C SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD,rpar,ipar) C DOUBLE PRECISION T, Y(*), PD(NROWPD,*),rpar(*) C where NEQ, T, Y, ML, MU, and NROWPD are input and the array C PD is to be loaded with partial derivatives (elements of C the Jacobian matrix) on output. PD must be given a first C dimension of NROWPD. T and Y have the same meaning as in C Subroutine F. C In the full matrix case (JT = 1), ML and MU are C ignored, and the Jacobian is to be loaded into PD in C columnwise manner, with df(i)/dy(j) loaded into pd(i,j). C In the band matrix case (JT = 4), the elements C within the band are to be loaded into PD in columnwise C manner, with diagonal lines of df/dy loaded into the rows C of PD. Thus df(i)/dy(j) is to be loaded into PD(i-j+MU+1,j). C ML and MU are the half-bandwidth parameters (see IWORK). C The locations in PD in the two triangular areas which C correspond to nonexistent matrix elements can be ignored C or loaded arbitrarily, as they are overwritten by DLSODAR. C JAC need not provide df/dy exactly. A crude C approximation (possibly with a smaller bandwidth) will do. C In either case, PD is preset to zero by the solver, C so that only the nonzero elements need be loaded by JAC. C Each call to JAC is preceded by a call to F with the same C arguments NEQ, T, and Y. Thus to gain some efficiency, C intermediate quantities shared by both calculations may be C saved in a user Common block by F and not recomputed by JAC, C if desired. Also, JAC may alter the Y array, if desired. C JAC must be declared External in the calling program. C Subroutine JAC may access user-defined quantities in C NEQ(2),... and/or in Y(NEQ(1)+1),... if NEQ is an array C (dimensioned in JAC) and/or Y has length exceeding NEQ(1). C See the descriptions of NEQ and Y above. C C JT = Jacobian type indicator. Used only for input. C JT specifies how the Jacobian matrix df/dy will be C treated, if and when DLSODAR requires this matrix. C JT has the following values and meanings: C 1 means a user-supplied full (NEQ by NEQ) Jacobian. C 2 means an internally generated (difference quotient) full C Jacobian (using NEQ extra calls to F per df/dy value). C 4 means a user-supplied banded Jacobian. C 5 means an internally generated banded Jacobian (using C ML+MU+1 extra calls to F per df/dy evaluation). C If JT = 1 or 4, the user must supply a Subroutine JAC C (the name is arbitrary) as described above under JAC. C If JT = 2 or 5, a dummy argument can be used. C C G = the name of subroutine for constraint functions, whose C roots are desired during the integration. It is to have C the form C SUBROUTINE G (NEQ, T, Y, NG, GOUT, rpar, ipar) C DOUBLE PRECISION T, Y(*), GOUT(NG), rpar(*) C where NEQ, T, Y, and NG are input, and the array GOUT C is output. NEQ, T, and Y have the same meaning as in C the F routine, and GOUT is an array of length NG. C For i = 1,...,NG, this routine is to load into GOUT(i) C the value at (T,Y) of the i-th constraint function g(i). C DLSODAR will find roots of the g(i) of odd multiplicity C (i.e. sign changes) as they occur during the integration. C G must be declared External in the calling program. C C Caution: Because of numerical errors in the functions C g(i) due to roundoff and integration error, DLSODAR may C return false roots, or return the same root at two or more C nearly equal values of t. If such false roots are C suspected, the user should consider smaller error tolerances C and/or higher precision in the evaluation of the g(i). C C If a root of some g(i) defines the end of the problem, C the input to DLSODAR should nevertheless allow integration C to a point slightly past that root, so that DLSODAR can C locate the root by interpolation. C C Subroutine G may access user-defined quantities in C NEQ(2),... and Y(NEQ(1)+1),... if NEQ is an array C (dimensioned in G) and/or Y has length exceeding NEQ(1). C See the descriptions of NEQ and Y above. C C NG = number of constraint functions g(i). If there are none, C set NG = 0, and pass a dummy name for G. C C JROOT = integer array of length NG. Used only for output. C On a return with ISTATE = 3 (one or more roots found), C JROOT(i) = 1 if g(i) has a root at T, or JROOT(i) = 0 if not. C----------------------------------------------------------------------- C Optional Inputs. C C The following is a list of the optional inputs provided for in the C call sequence. (See also Part 2.) For each such input variable, C this table lists its name as used in this documentation, its C location in the call sequence, its meaning, and the default value. C The use of any of these inputs requires IOPT = 1, and in that C case all of these inputs are examined. A value of zero for any C of these optional inputs will cause the default value to be used. C Thus to use a subset of the optional inputs, simply preload C locations 5 to 10 in RWORK and IWORK to 0.0 and 0 respectively, and C then set those of interest to nonzero values. C C Name Location Meaning and Default Value C C H0 RWORK(5) the step size to be attempted on the first step. C The default value is determined by the solver. C C HMAX RWORK(6) the maximum absolute step size allowed. C The default value is infinite. C C HMIN RWORK(7) the minimum absolute step size allowed. C The default value is 0. (This lower bound is not C enforced on the final step before reaching TCRIT C when ITASK = 4 or 5.) C C IXPR IWORK(5) flag to generate extra printing at method switches. C IXPR = 0 means no extra printing (the default). C IXPR = 1 means print data on each switch. C T, H, and NST will be printed on the same logical C unit as used for error messages. C C MXSTEP IWORK(6) maximum number of (internally defined) steps C allowed during one call to the solver. C The default value is 500. C C MXHNIL IWORK(7) maximum number of messages printed (per problem) C warning that T + H = T on a step (H = step size). C This must be positive to result in a non-default C value. The default value is 10. C C MXORDN IWORK(8) the maximum order to be allowed for the nonstiff C (Adams) method. The default value is 12. C If MXORDN exceeds the default value, it will C be reduced to the default value. C MXORDN is held constant during the problem. C C MXORDS IWORK(9) the maximum order to be allowed for the stiff C (BDF) method. The default value is 5. C If MXORDS exceeds the default value, it will C be reduced to the default value. C MXORDS is held constant during the problem. C----------------------------------------------------------------------- C Optional Outputs. C C As optional additional output from DLSODAR, the variables listed C below are quantities related to the performance of DLSODAR C which are available to the user. These are communicated by way of C the work arrays, but also have internal mnemonic names as shown. C Except where stated otherwise, all of these outputs are defined C on any successful return from DLSODAR, and on any return with C ISTATE = -1, -2, -4, -5, or -6. On an illegal input return C (ISTATE = -3), they will be unchanged from their existing values C (if any), except possibly for TOLSF, LENRW, and LENIW. C On any error return, outputs relevant to the error will be defined, C as noted below. C C Name Location Meaning C C HU RWORK(11) the step size in t last used (successfully). C C HCUR RWORK(12) the step size to be attempted on the next step. C C TCUR RWORK(13) the current value of the independent variable C which the solver has actually reached, i.e. the C current internal mesh point in t. On output, TCUR C will always be at least as far as the argument C T, but may be farther (if interpolation was done). C C TOLSF RWORK(14) a tolerance scale factor, greater than 1.0, C computed when a request for too much accuracy was C detected (ISTATE = -3 if detected at the start of C the problem, ISTATE = -2 otherwise). If ITOL is C left unaltered but RTOL and ATOL are uniformly C scaled up by a factor of TOLSF for the next call, C then the solver is deemed likely to succeed. C (The user may also ignore TOLSF and alter the C tolerance parameters in any other way appropriate.) C C TSW RWORK(15) the value of t at the time of the last method C switch, if any. C C NGE IWORK(10) the number of g evaluations for the problem so far. C C NST IWORK(11) the number of steps taken for the problem so far. C C NFE IWORK(12) the number of f evaluations for the problem so far. C C NJE IWORK(13) the number of Jacobian evaluations (and of matrix C LU decompositions) for the problem so far. C C NQU IWORK(14) the method order last used (successfully). C C NQCUR IWORK(15) the order to be attempted on the next step. C C IMXER IWORK(16) the index of the component of largest magnitude in C the weighted local error vector ( E(i)/EWT(i) ), C on an error return with ISTATE = -4 or -5. C C LENRW IWORK(17) the length of RWORK actually required, assuming C that the length of RWORK is to be fixed for the C rest of the problem, and that switching may occur. C This is defined on normal returns and on an illegal C input return for insufficient storage. C C LENIW IWORK(18) the length of IWORK actually required, assuming C that the length of IWORK is to be fixed for the C rest of the problem, and that switching may occur. C This is defined on normal returns and on an illegal C input return for insufficient storage. C C MUSED IWORK(19) the method indicator for the last successful step: C 1 means Adams (nonstiff), 2 means BDF (stiff). C C MCUR IWORK(20) the current method indicator: C 1 means Adams (nonstiff), 2 means BDF (stiff). C This is the method to be attempted C on the next step. Thus it differs from MUSED C only if a method switch has just been made. C C The following two arrays are segments of the RWORK array which C may also be of interest to the user as optional outputs. C For each array, the table below gives its internal name, C its base address in RWORK, and its description. C C Name Base Address Description C C YH 21 + 3*NG the Nordsieck history array, of size NYH by C (NQCUR + 1), where NYH is the initial value C of NEQ. For j = 0,1,...,NQCUR, column j+1 C of YH contains HCUR**j/factorial(j) times C the j-th derivative of the interpolating C polynomial currently representing the solution, C evaluated at t = TCUR. C C ACOR LACOR array of size NEQ used for the accumulated C (from Common corrections on each step, scaled on output C as noted) to represent the estimated local error in y C on the last step. This is the vector E in C the description of the error control. It is C defined only on a successful return from C DLSODAR. The base address LACOR is obtained by C including in the user's program the C following 2 lines: C COMMON /DLS001/ RLS(218), ILS(37) C LACOR = ILS(22) C C----------------------------------------------------------------------- C Part 2. Other Routines Callable. C C The following are optional calls which the user may make to C gain additional capabilities in conjunction with DLSODAR. C (The routines XSETUN and XSETF are designed to conform to the C SLATEC error handling package.) C C Form of Call Function C CALL XSETUN(LUN) Set the logical unit number, LUN, for C output of messages from DLSODAR, if C the default is not desired. C The default value of LUN is 6. C C CALL XSETF(MFLAG) Set a flag to control the printing of C messages by DLSODAR. C MFLAG = 0 means do not print. (Danger: C This risks losing valuable information.) C MFLAG = 1 means print (the default). C C Either of the above calls may be made at C any time and will take effect immediately. C C CALL DSRCAR(RSAV,ISAV,JOB) saves and restores the contents of C the internal Common blocks used by C DLSODAR (see Part 3 below). C RSAV must be a real array of length 245 C or more, and ISAV must be an integer C array of length 55 or more. C JOB=1 means save Common into RSAV/ISAV. C JOB=2 means restore Common from RSAV/ISAV. C DSRCAR is useful if one is C interrupting a run and restarting C later, or alternating between two or C more problems solved with DLSODAR. C C CALL DINTDY(,,,,,) Provide derivatives of y, of various C (see below) orders, at a specified point t, if C desired. It may be called only after C a successful return from DLSODAR. C C The detailed instructions for using DINTDY are as follows. C The form of the call is: C C LYH = 21 + 3*NG C CALL DINTDY (T, K, RWORK(LYH), NYH, DKY, IFLAG) C C The input parameters are: C C T = value of independent variable where answers are desired C (normally the same as the T last returned by DLSODAR). C For valid results, T must lie between TCUR - HU and TCUR. C (See optional outputs for TCUR and HU.) C K = integer order of the derivative desired. K must satisfy C 0 .le. K .le. NQCUR, where NQCUR is the current order C (see optional outputs). The capability corresponding C to K = 0, i.e. computing y(t), is already provided C by DLSODAR directly. Since NQCUR .ge. 1, the first C derivative dy/dt is always available with DINTDY. C LYH = 21 + 3*NG = base address in RWORK of the history array YH. C NYH = column length of YH, equal to the initial value of NEQ. C C The output parameters are: C C DKY = a real array of length NEQ containing the computed value C of the K-th derivative of y(t). C IFLAG = integer flag, returned as 0 if K and T were legal, C -1 if K was illegal, and -2 if T was illegal. C On an error return, a message is also written. C----------------------------------------------------------------------- C Part 3. Common Blocks. C C If DLSODAR is to be used in an overlay situation, the user C must declare, in the primary overlay, the variables in: C (1) the call sequence to DLSODAR, and C (2) the three internal Common blocks C /DLS001/ of length 255 (218 double precision words C followed by 37 integer words), C /DLSA01/ of length 31 (22 double precision words C followed by 9 integer words). C /DLSR01/ of length 7 (3 double precision words C followed by 4 integer words). C C If DLSODAR is used on a system in which the contents of internal C Common blocks are not preserved between calls, the user should C declare the above Common blocks in the calling program to insure C that their contents are preserved. C C If the solution of a given problem by DLSODAR is to be interrupted C and then later continued, such as when restarting an interrupted run C or alternating between two or more problems, the user should save, C following the return from the last DLSODAR call prior to the C interruption, the contents of the call sequence variables and the C internal Common blocks, and later restore these values before the C next DLSODAR call for that problem. To save and restore the Common C blocks, use Subroutine DSRCAR (see Part 2 above). C C----------------------------------------------------------------------- C Part 4. Optionally Replaceable Solver Routines. C C Below is a description of a routine in the DLSODAR package which C relates to the measurement of errors, and can be C replaced by a user-supplied version, if desired. However, since such C a replacement may have a major impact on performance, it should be C done only when absolutely necessary, and only with great caution. C (Note: The means by which the package version of a routine is C superseded by the user's version may be system-dependent.) C C (a) DEWSET. C The following subroutine is called just before each internal C integration step, and sets the array of error weights, EWT, as C described under ITOL/RTOL/ATOL above: C Subroutine DEWSET (NEQ, ITOL, RTOL, ATOL, YCUR, EWT) C where NEQ, ITOL, RTOL, and ATOL are as in the DLSODAR call sequence, C YCUR contains the current dependent variable vector, and C EWT is the array of weights set by DEWSET. C C If the user supplies this subroutine, it must return in EWT(i) C (i = 1,...,NEQ) a positive quantity suitable for comparing errors C in y(i) to. The EWT array returned by DEWSET is passed to the C DMNORM routine, and also used by DLSODAR in the computation C of the optional output IMXER, and the increments for difference C quotient Jacobians. C C In the user-supplied version of DEWSET, it may be desirable to use C the current values of derivatives of y. Derivatives up to order NQ C are available from the history array YH, described above under C optional outputs. In DEWSET, YH is identical to the YCUR array, C extended to NQ + 1 columns with a column length of NYH and scale C factors of H**j/factorial(j). On the first call for the problem, C given by NST = 0, NQ is 1 and H is temporarily set to 1.0. C NYH is the initial value of NEQ. The quantities NQ, H, and NST C can be obtained by including in DEWSET the statements: C DOUBLE PRECISION RLS C COMMON /DLS001/ RLS(218),ILS(37) C NQ = ILS(33) C NST = ILS(34) C H = RLS(212) C Thus, for example, the current value of dy/dt can be obtained as C YCUR(NYH+i)/H (i=1,...,NEQ) (and the division by H is C unnecessary when NST = 0). C----------------------------------------------------------------------- C C***REVISION HISTORY (YYYYMMDD) C 19811102 DATE WRITTEN C 19820126 Fixed bug in tests of work space lengths; C minor corrections in main prologue and comments. C 19820507 Fixed bug in RCHEK in setting HMING. C 19870330 Major update: corrected comments throughout; C removed TRET from Common; rewrote EWSET with 4 loops; C fixed t test in INTDY; added Cray directives in STODA; C in STODA, fixed DELP init. and logic around PJAC call; C combined routines to save/restore Common; C passed LEVEL = 0 in error message calls (except run abort). C 19970225 Fixed lines setting JSTART = -2 in Subroutine LSODAR. C 20010425 Major update: convert source lines to upper case; C added *DECK lines; changed from 1 to * in dummy dimensions; C changed names R1MACH/D1MACH to RUMACH/DUMACH; C renamed routines for uniqueness across single/double prec.; C converted intrinsic names to generic form; C removed ILLIN and NTREP (data loaded) from Common; C removed all 'own' variables from Common; C changed error messages to quoted strings; C replaced XERRWV/XERRWD with 1993 revised version; C converted prologues, comments, error messages to mixed case; C numerous corrections to prologues and internal comments. C 20010507 Converted single precision source to double precision. C 20010613 Revised excess accuracy test (to match rest of ODEPACK). C 20010808 Fixed bug in DPRJA (matrix in DBNORM call). C 20020502 Corrected declarations in descriptions of user routines. C 20031105 Restored 'own' variables to Common blocks, to enable C interrupt/restart feature. C 20031112 Added SAVE statements for data-loaded constants. C C----------------------------------------------------------------------- C Other routines in the DLSODAR package. C C In addition to Subroutine DLSODAR, the DLSODAR package includes the C following subroutines and function routines: C DRCHEK does preliminary checking for roots, and serves as an C interface between Subroutine DLSODAR and Subroutine DROOTS. C DROOTS finds the leftmost root of a set of functions. C DINTDY computes an interpolated value of the y vector at t = TOUT. C DSTODA is the core integrator, which does one step of the C integration and the associated error control. C DCFODE sets all method coefficients and test constants. C DPRJA computes and preprocesses the Jacobian matrix J = df/dy C and the Newton iteration matrix P = I - h*l0*J. C DSOLSY manages solution of linear system in chord iteration. C DEWSET sets the error weight vector EWT before each step. C DMNORM computes the weighted max-norm of a vector. C DFNORM computes the norm of a full matrix consistent with the C weighted max-norm on vectors. C DBNORM computes the norm of a band matrix consistent with the C weighted max-norm on vectors. C DSRCAR is a user-callable routine to save and restore C the contents of the internal Common blocks. C DGEFA and DGESL are routines from LINPACK for solving full C systems of linear algebraic equations. C DGBFA and DGBSL are routines from LINPACK for solving banded C linear systems. C DCOPY is one of the basic linear algebra modules (BLAS). C DUMACH computes the unit roundoff in a machine-independent manner. C XERRWD, XSETUN, XSETF, IXSAV, and IUMACH handle the printing of all C error messages and warnings. XERRWD is machine-dependent. C Note: DMNORM, DFNORM, DBNORM, DUMACH, IXSAV, and IUMACH are C function routines. All the others are subroutines. C C----------------------------------------------------------------------- EXTERNAL DPRJA, DSOLSY DOUBLE PRECISION DUMACH, DMNORM INTEGER INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, IOWNS, 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU INTEGER INSUFR, INSUFI, IXPR, IOWNS2, JTYP, MUSED, MXORDN, MXORDS INTEGER LG0, LG1, LGX, IOWNR3, IRFND, ITASKC, NGC, NGE INTEGER I, I1, I2, IFLAG, IMXER, KGO, LENIW, 1 LENRW, LENWM, LF0, ML, MORD, MU, MXHNL0, MXSTP0 INTEGER LEN1, LEN1C, LEN1N, LEN1S, LEN2, LENIWC, LENRWC INTEGER IRFP, IRT, LENYH, LYHNEW DOUBLE PRECISION ROWNS, 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND DOUBLE PRECISION TSW, ROWNS2, PDNORM DOUBLE PRECISION ROWNR3, T0, TLAST, TOUTC DOUBLE PRECISION ATOLI, AYI, BIG, EWTI, H0, HMAX, HMX, RH, RTOLI, 1 TCRIT, TDIST, TNEXT, TOL, TOLSF, TP, SIZE, SUM, W0 DIMENSION MORD(2) LOGICAL IHIT CHARACTER(LEN=60) MSG SAVE MORD, MXSTP0, MXHNL0 C----------------------------------------------------------------------- C The following three internal Common blocks contain C (a) variables which are local to any subroutine but whose values must C be preserved between calls to the routine ("own" variables), and C (b) variables which are communicated between subroutines. C The block DLS001 is declared in subroutines DLSODAR, DINTDY, DSTODA, C DPRJA, and DSOLSY. C The block DLSA01 is declared in subroutines DLSODAR, DSTODA, DPRJA. C The block DLSR01 is declared in subroutines DLSODAR, DRCHEK, DROOTS. C Groups of variables are replaced by dummy arrays in the Common C declarations in routines where those variables are not used. C----------------------------------------------------------------------- COMMON /DLS001/ ROWNS(209), 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 2 INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, IOWNS(6), 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU C COMMON /DLSA01/ TSW, ROWNS2(20), PDNORM, 1 INSUFR, INSUFI, IXPR, IOWNS2(2), JTYP, MUSED, MXORDN, MXORDS C COMMON /DLSR01/ ROWNR3(2), T0, TLAST, TOUTC, 1 LG0, LG1, LGX, IOWNR3(2), IRFND, ITASKC, NGC, NGE C DATA MORD(1),MORD(2)/12,5/, MXSTP0/500/, MXHNL0/10/ C----------------------------------------------------------------------- C Block A. C This code block is executed on every call. C It tests ISTATE and ITASK for legality and branches appropriately. C If ISTATE .gt. 1 but the flag INIT shows that initialization has C not yet been done, an error return occurs. C If ISTATE = 1 and TOUT = T, return immediately. C----------------------------------------------------------------------- IF (ISTATE .LT. 1 .OR. ISTATE .GT. 3) GO TO 601 IF (ITASK .LT. 1 .OR. ITASK .GT. 5) GO TO 602 ITASKC = ITASK IF (ISTATE .EQ. 1) GO TO 10 IF (INIT .EQ. 0) GO TO 603 IF (ISTATE .EQ. 2) GO TO 200 GO TO 20 10 INIT = 0 IF (TOUT .EQ. T) RETURN C----------------------------------------------------------------------- C Block B. C The next code block is executed for the initial call (ISTATE = 1), C or for a continuation call with parameter changes (ISTATE = 3). C It contains checking of all inputs and various initializations. C C First check legality of the non-optional inputs NEQ, ITOL, IOPT, C JT, ML, MU, and NG. C----------------------------------------------------------------------- 20 IF (NEQ(1) .LE. 0) GO TO 604 IF (ISTATE .EQ. 1) GO TO 25 IF (NEQ(1) .GT. N) GO TO 605 25 N = NEQ(1) IF (ITOL .LT. 1 .OR. ITOL .GT. 4) GO TO 606 IF (IOPT .LT. 0 .OR. IOPT .GT. 1) GO TO 607 IF (JT .EQ. 3 .OR. JT .LT. 1 .OR. JT .GT. 5) GO TO 608 JTYP = JT IF (JT .LE. 2) GO TO 30 ML = IWORK(1) MU = IWORK(2) IF (ML .LT. 0 .OR. ML .GE. N) GO TO 609 IF (MU .LT. 0 .OR. MU .GE. N) GO TO 610 30 CONTINUE IF (NG .LT. 0) GO TO 630 IF (ISTATE .EQ. 1) GO TO 35 IF (IRFND .EQ. 0 .AND. NG .NE. NGC) GO TO 631 35 NGC = NG C Next process and check the optional inputs. -------------------------- IF (IOPT .EQ. 1) GO TO 40 IXPR = 0 MXSTEP = MXSTP0 MXHNIL = MXHNL0 HMXI = 0.0D0 HMIN = 0.0D0 IF (ISTATE .NE. 1) GO TO 60 H0 = 0.0D0 MXORDN = MORD(1) MXORDS = MORD(2) GO TO 60 40 IXPR = IWORK(5) IF (IXPR .LT. 0 .OR. IXPR .GT. 1) GO TO 611 MXSTEP = IWORK(6) IF (MXSTEP .LT. 0) GO TO 612 IF (MXSTEP .EQ. 0) MXSTEP = MXSTP0 MXHNIL = IWORK(7) IF (MXHNIL .LT. 0) GO TO 613 IF (MXHNIL .EQ. 0) MXHNIL = MXHNL0 IF (ISTATE .NE. 1) GO TO 50 H0 = RWORK(5) MXORDN = IWORK(8) IF (MXORDN .LT. 0) GO TO 628 IF (MXORDN .EQ. 0) MXORDN = 100 MXORDN = MIN(MXORDN,MORD(1)) MXORDS = IWORK(9) IF (MXORDS .LT. 0) GO TO 629 IF (MXORDS .EQ. 0) MXORDS = 100 MXORDS = MIN(MXORDS,MORD(2)) IF ((TOUT - T)*H0 .LT. 0.0D0) GO TO 614 50 HMAX = RWORK(6) IF (HMAX .LT. 0.0D0) GO TO 615 HMXI = 0.0D0 IF (HMAX .GT. 0.0D0) HMXI = 1.0D0/HMAX HMIN = RWORK(7) IF (HMIN .LT. 0.0D0) GO TO 616 C----------------------------------------------------------------------- C Set work array pointers and check lengths LRW and LIW. C If ISTATE = 1, METH is initialized to 1 here to facilitate the C checking of work space lengths. C Pointers to segments of RWORK and IWORK are named by prefixing L to C the name of the segment. E.g., the segment YH starts at RWORK(LYH). C Segments of RWORK (in order) are denoted G0, G1, GX, YH, WM, C EWT, SAVF, ACOR. C If the lengths provided are insufficient for the current method, C an error return occurs. This is treated as illegal input on the C first call, but as a problem interruption with ISTATE = -7 on a C continuation call. If the lengths are sufficient for the current C method but not for both methods, a warning message is sent. C----------------------------------------------------------------------- 60 IF (ISTATE .EQ. 1) METH = 1 IF (ISTATE .EQ. 1) NYH = N LG0 = 21 LG1 = LG0 + NG LGX = LG1 + NG LYHNEW = LGX + NG IF (ISTATE .EQ. 1) LYH = LYHNEW IF (LYHNEW .EQ. LYH) GO TO 62 C If ISTATE = 3 and NG was changed, shift YH to its new location. ------ LENYH = L*NYH IF (LRW .LT. LYHNEW-1+LENYH) GO TO 62 I1 = 1 IF (LYHNEW .GT. LYH) I1 = -1 CALL DCOPY (LENYH, RWORK(LYH), I1, RWORK(LYHNEW), I1) LYH = LYHNEW 62 CONTINUE LEN1N = LYHNEW - 1 + (MXORDN + 1)*NYH LEN1S = LYHNEW - 1 + (MXORDS + 1)*NYH LWM = LEN1S + 1 IF (JT .LE. 2) LENWM = N*N + 2 IF (JT .GE. 4) LENWM = (2*ML + MU + 1)*N + 2 LEN1S = LEN1S + LENWM LEN1C = LEN1N IF (METH .EQ. 2) LEN1C = LEN1S LEN1 = MAX(LEN1N,LEN1S) LEN2 = 3*N LENRW = LEN1 + LEN2 LENRWC = LEN1C + LEN2 IWORK(17) = LENRW LIWM = 1 LENIW = 20 + N LENIWC = 20 IF (METH .EQ. 2) LENIWC = LENIW IWORK(18) = LENIW IF (ISTATE .EQ. 1 .AND. LRW .LT. LENRWC) GO TO 617 IF (ISTATE .EQ. 1 .AND. LIW .LT. LENIWC) GO TO 618 IF (ISTATE .EQ. 3 .AND. LRW .LT. LENRWC) GO TO 550 IF (ISTATE .EQ. 3 .AND. LIW .LT. LENIWC) GO TO 555 LEWT = LEN1 + 1 INSUFR = 0 IF (LRW .GE. LENRW) GO TO 65 INSUFR = 2 LEWT = LEN1C + 1 MSG='DLSODAR- Warning.. RWORK length is sufficient for now, but ' CALL XERRWD (MSG, 60, 103, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' may not be later. Integration will proceed anyway. ' CALL XERRWD (MSG, 60, 103, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' Length needed is LENRW = I1, while LRW = I2.' CALL XERRWD (MSG, 50, 103, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) 65 LSAVF = LEWT + N LACOR = LSAVF + N INSUFI = 0 IF (LIW .GE. LENIW) GO TO 70 INSUFI = 2 MSG='DLSODAR- Warning.. IWORK length is sufficient for now, but ' CALL XERRWD (MSG, 60, 104, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' may not be later. Integration will proceed anyway. ' CALL XERRWD (MSG, 60, 104, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' Length needed is LENIW = I1, while LIW = I2.' CALL XERRWD (MSG, 50, 104, 0, 2, LENIW, LIW, 0, 0.0D0, 0.0D0) 70 CONTINUE C Check RTOL and ATOL for legality. ------------------------------------ RTOLI = RTOL(1) ATOLI = ATOL(1) DO 75 I = 1,N IF (ITOL .GE. 3) RTOLI = RTOL(I) IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) IF (RTOLI .LT. 0.0D0) GO TO 619 IF (ATOLI .LT. 0.0D0) GO TO 620 75 CONTINUE IF (ISTATE .EQ. 1) GO TO 100 C if ISTATE = 3, set flag to signal parameter changes to DSTODA. ------- JSTART = -1 IF (N .EQ. NYH) GO TO 200 C NEQ was reduced. zero part of yh to avoid undefined references. ----- I1 = LYH + L*NYH I2 = LYH + (MAXORD + 1)*NYH - 1 IF (I1 .GT. I2) GO TO 200 DO 95 I = I1,I2 RWORK(I) = 0.0D0 95 CONTINUE GO TO 200 C----------------------------------------------------------------------- C Block C. C The next block is for the initial call only (ISTATE = 1). C It contains all remaining initializations, the initial call to F, C and the calculation of the initial step size. C The error weights in EWT are inverted after being loaded. C----------------------------------------------------------------------- 100 UROUND = DUMACH() TN = T TSW = T MAXORD = MXORDN IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 110 TCRIT = RWORK(1) IF ((TCRIT - TOUT)*(TOUT - T) .LT. 0.0D0) GO TO 625 IF (H0 .NE. 0.0D0 .AND. (T + H0 - TCRIT)*H0 .GT. 0.0D0) 1 H0 = TCRIT - T 110 JSTART = 0 NHNIL = 0 NST = 0 NJE = 0 NSLAST = 0 HU = 0.0D0 NQU = 0 MUSED = 0 MITER = 0 CCMAX = 0.3D0 MAXCOR = 3 MSBP = 20 MXNCF = 10 C Initial call to F. (LF0 points to YH(*,2).) ------------------------- LF0 = LYH + NYH CALL F (NEQ, T, Y, RWORK(LF0), rpar, ipar) NFE = 1 C Load the initial value vector in YH. --------------------------------- DO 115 I = 1,N RWORK(I+LYH-1) = Y(I) 115 CONTINUE C Load and invert the EWT array. (H is temporarily set to 1.0.) ------- NQ = 1 H = 1.0D0 CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) DO 120 I = 1,N IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 621 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 120 CONTINUE C----------------------------------------------------------------------- C The coding below computes the step size, H0, to be attempted on the C first step, unless the user has supplied a value for this. C First check that TOUT - T differs significantly from zero. C A scalar tolerance quantity TOL is computed, as MAX(RTOL(i)) C if this is positive, or MAX(ATOL(i)/ABS(Y(i))) otherwise, adjusted C so as to be between 100*UROUND and 1.0E-3. C Then the computed value H0 is given by: C C H0**(-2) = 1./(TOL * w0**2) + TOL * (norm(F))**2 C C where w0 = MAX ( ABS(T), ABS(TOUT) ), C F = the initial value of the vector f(t,y), and C norm() = the weighted vector norm used throughout, given by C the DMNORM function routine, and weighted by the C tolerances initially loaded into the EWT array. C The sign of H0 is inferred from the initial values of TOUT and T. C ABS(H0) is made .le. ABS(TOUT-T) in any case. C----------------------------------------------------------------------- IF (H0 .NE. 0.0D0) GO TO 180 TDIST = ABS(TOUT - T) W0 = MAX(ABS(T),ABS(TOUT)) IF (TDIST .LT. 2.0D0*UROUND*W0) GO TO 622 TOL = RTOL(1) IF (ITOL .LE. 2) GO TO 140 DO 130 I = 1,N TOL = MAX(TOL,RTOL(I)) 130 CONTINUE 140 IF (TOL .GT. 0.0D0) GO TO 160 ATOLI = ATOL(1) DO 150 I = 1,N IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) AYI = ABS(Y(I)) IF (AYI .NE. 0.0D0) TOL = MAX(TOL,ATOLI/AYI) 150 CONTINUE 160 TOL = MAX(TOL,100.0D0*UROUND) TOL = MIN(TOL,0.001D0) SUM = DMNORM (N, RWORK(LF0), RWORK(LEWT)) SUM = 1.0D0/(TOL*W0*W0) + TOL*SUM**2 H0 = 1.0D0/SQRT(SUM) H0 = MIN(H0,TDIST) H0 = SIGN(H0,TOUT-T) C Adjust H0 if necessary to meet HMAX bound. --------------------------- 180 RH = ABS(H0)*HMXI IF (RH .GT. 1.0D0) H0 = H0/RH C Load H with H0 and scale YH(*,2) by H0. ------------------------------ H = H0 DO 190 I = 1,N RWORK(I+LF0-1) = H0*RWORK(I+LF0-1) 190 CONTINUE C C Check for a zero of g at T. ------------------------------------------ IRFND = 0 TOUTC = TOUT IF (NGC .EQ. 0) GO TO 270 CALL DRCHEK (1, G, NEQ, Y, RWORK(LYH), NYH, 1 RWORK(LG0), RWORK(LG1), RWORK(LGX), JROOT, IRT, rpar, ipar) IF (IRT .EQ. 0) GO TO 270 GO TO 632 C----------------------------------------------------------------------- C Block D. C The next code block is for continuation calls only (ISTATE = 2 or 3) C and is to check stop conditions before taking a step. C First, DRCHEK is called to check for a root within the last step C taken, other than the last root found there, if any. C If ITASK = 2 or 5, and y(TN) has not yet been returned to the user C because of an intervening root, return through Block G. C----------------------------------------------------------------------- 200 NSLAST = NST C IRFP = IRFND IF (NGC .EQ. 0) GO TO 205 IF (ITASK .EQ. 1 .OR. ITASK .EQ. 4) TOUTC = TOUT CALL DRCHEK (2, G, NEQ, Y, RWORK(LYH), NYH, 1 RWORK(LG0), RWORK(LG1), RWORK(LGX), JROOT, IRT, rpar, ipar) IF (IRT .NE. 1) GO TO 205 IRFND = 1 ISTATE = 3 T = T0 GO TO 425 205 CONTINUE IRFND = 0 IF (IRFP .EQ. 1 .AND. TLAST .NE. TN .AND. ITASK .EQ. 2) GO TO 400 C IF (ITASK .EQ. 1) THEN GOTO 210 ELSE IF (ITASK .EQ. 2) THEN GOTO 250 ELSE IF (ITASK .EQ. 3) THEN GOTO 220 ELSE IF (ITASK .EQ. 4) THEN GOTO 230 ELSE IF (ITASK .EQ. 5) THEN GOTO 240 ENDIF C GO TO (210, 250, 220, 230, 240), ITASK 210 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) IF (IFLAG .NE. 0) GO TO 627 T = TOUT GO TO 420 220 TP = TN - HU*(1.0D0 + 100.0D0*UROUND) IF ((TP - TOUT)*H .GT. 0.0D0) GO TO 623 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 T = TN GO TO 400 230 TCRIT = RWORK(1) IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 IF ((TCRIT - TOUT)*H .LT. 0.0D0) GO TO 625 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 245 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) IF (IFLAG .NE. 0) GO TO 627 T = TOUT GO TO 420 240 TCRIT = RWORK(1) IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 245 HMX = ABS(TN) + ABS(H) IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX IF (IHIT) T = TCRIT IF (IRFP .EQ. 1 .AND. TLAST .NE. TN .AND. ITASK .EQ. 5) GO TO 400 IF (IHIT) GO TO 400 TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) IF (ISTATE .EQ. 2 .AND. JSTART .GE. 0) JSTART = -2 C----------------------------------------------------------------------- C Block E. C The next block is normally executed for all calls and contains C the call to the one-step core integrator DSTODA. C C This is a looping point for the integration steps. C C First check for too many steps being taken, update EWT (if not at C start of problem), check for too much accuracy being requested, and C check for H below the roundoff level in T. C----------------------------------------------------------------------- 250 CONTINUE IF (METH .EQ. MUSED) GO TO 255 IF (INSUFR .EQ. 1) GO TO 550 IF (INSUFI .EQ. 1) GO TO 555 255 IF ((NST-NSLAST) .GE. MXSTEP) GO TO 500 CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) DO 260 I = 1,N IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 510 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 260 CONTINUE 270 TOLSF = UROUND*DMNORM (N, RWORK(LYH), RWORK(LEWT)) IF (TOLSF .LE. 1.0D0) GO TO 280 TOLSF = TOLSF*2.0D0 IF (NST .EQ. 0) GO TO 626 GO TO 520 280 IF ((TN + H) .NE. TN) GO TO 290 NHNIL = NHNIL + 1 IF (NHNIL .GT. MXHNIL) GO TO 290 MSG = 'DLSODAR- Warning..Internal T(=R1) and H(=R2) are ' CALL XERRWD (MSG, 50, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' such that in the machine, T + H = T on the next step ' CALL XERRWD (MSG, 60, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' (H = step size). Solver will continue anyway.' CALL XERRWD (MSG, 50, 101, 0, 0, 0, 0, 2, TN, H) IF (NHNIL .LT. MXHNIL) GO TO 290 MSG = 'DLSODAR- Above warning has been issued I1 times. ' CALL XERRWD (MSG, 50, 102, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' It will not be issued again for this problem.' CALL XERRWD (MSG, 50, 102, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0) 290 CONTINUE C----------------------------------------------------------------------- C CALL DSTODA(NEQ,Y,YH,NYH,YH,EWT,SAVF,ACOR,WM,IWM,F,JAC,DPRJA,DSOLSY) C----------------------------------------------------------------------- CALL DSTODA (NEQ, Y, RWORK(LYH), NYH, RWORK(LYH), RWORK(LEWT), 1 RWORK(LSAVF), RWORK(LACOR), RWORK(LWM), IWORK(LIWM), 2 F, JAC, DPRJA, DSOLSY, rpar, ipar) KGO = 1 - KFLAG IF (KGO .EQ. 1) THEN GOTO 300 ELSE IF (KGO .EQ. 2) THEN GOTO 530 ELSE IF (KGO .EQ. 3) THEN GOTO 540 ENDIF C GO TO (300, 530, 540), KGO C----------------------------------------------------------------------- C Block F. C The following block handles the case of a successful return from the C core integrator (KFLAG = 0). C If a method switch was just made, record TSW, reset MAXORD, C set JSTART to -1 to signal DSTODA to complete the switch, C and do extra printing of data if IXPR = 1. C Then call DRCHEK to check for a root within the last step. C Then, if no root was found, check for stop conditions. C----------------------------------------------------------------------- 300 INIT = 1 IF (METH .EQ. MUSED) GO TO 310 TSW = TN MAXORD = MXORDN IF (METH .EQ. 2) MAXORD = MXORDS IF (METH .EQ. 2) RWORK(LWM) = SQRT(UROUND) INSUFR = MIN(INSUFR,1) INSUFI = MIN(INSUFI,1) JSTART = -1 IF (IXPR .EQ. 0) GO TO 310 IF (METH .EQ. 2) THEN MSG='DLSODAR- A switch to the BDF (stiff) method has occurred' C KS CALL XERRWD (MSG, 60, 105, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) C CALL DBLEPR(MSG, 60, 0, 0) CALL rprintf(MSG // char(0)) ENDIF IF (METH .EQ. 1) THEN MSG='DLSODAR- A switch to the Adams (nonstiff) method occurred' C CALL XERRWD (MSG, 60, 106, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) C CALL DBLEPR(MSG, 60, 0, 0) CALL rprintf(MSG // char(0)) ENDIF MSG = 'at T (R1), the new step size is (R2): %g, %g ' call rprintfd2 (MSG // char(0), TN, H) 310 CONTINUE C IF (NGC .EQ. 0) GO TO 315 CALL DRCHEK (3, G, NEQ, Y, RWORK(LYH), NYH, 1 RWORK(LG0), RWORK(LG1), RWORK(LGX), JROOT, IRT, rpar, ipar) IF (IRT .NE. 1) GO TO 315 IRFND = 1 ISTATE = 3 T = T0 GO TO 425 315 CONTINUE C IF (ITASK .EQ. 1) THEN GOTO 320 ELSE IF (ITASK .EQ. 2) THEN GOTO 400 ELSE IF (ITASK .EQ. 3) THEN GOTO 330 ELSE IF (ITASK .EQ. 4) THEN GOTO 340 ELSE IF (ITASK .EQ. 5) THEN GOTO 350 ENDIF C karline: changed from C GO TO (320, 400, 330, 340, 350), ITASK C ITASK = 1. If TOUT has been reached, interpolate. ------------------- 320 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) T = TOUT GO TO 420 C ITASK = 3. Jump to exit if TOUT was reached. ------------------------ 330 IF ((TN - TOUT)*H .GE. 0.0D0) GO TO 400 GO TO 250 C ITASK = 4. See if TOUT or TCRIT was reached. Adjust H if necessary. 340 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 345 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) T = TOUT GO TO 420 345 HMX = ABS(TN) + ABS(H) IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX IF (IHIT) GO TO 400 TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) IF (JSTART .GE. 0) JSTART = -2 GO TO 250 C ITASK = 5. See if TCRIT was reached and jump to exit. --------------- 350 HMX = ABS(TN) + ABS(H) IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX C----------------------------------------------------------------------- C Block G. C The following block handles all successful returns from DLSODAR. C If ITASK .ne. 1, Y is loaded from YH and T is set accordingly. C ISTATE is set to 2, and the optional outputs are loaded into the C work arrays before returning. C----------------------------------------------------------------------- 400 DO 410 I = 1,N Y(I) = RWORK(I+LYH-1) 410 CONTINUE T = TN IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 420 IF (IHIT) T = TCRIT 420 ISTATE = 2 425 CONTINUE RWORK(11) = HU RWORK(12) = H RWORK(13) = TN RWORK(15) = TSW IWORK(11) = NST IWORK(12) = NFE IWORK(13) = NJE IWORK(14) = NQU IWORK(15) = NQ IWORK(19) = MUSED IWORK(20) = METH IWORK(10) = NGE TLAST = T RETURN C----------------------------------------------------------------------- C Block H. C The following block handles all unsuccessful returns other than C those for illegal input. First the error message routine is called. C If there was an error test or convergence test failure, IMXER is set. C Then Y is loaded from YH and T is set to TN. C The optional outputs are loaded into the work arrays before returning. C----------------------------------------------------------------------- C The maximum number of steps was taken before reaching TOUT. ---------- 500 MSG = 'DLSODAR- At current T (=R1), MXSTEP (=I1) steps ' CALL XERRWD (MSG, 50, 201, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' taken on this call before reaching TOUT ' CALL XERRWD (MSG, 50, 201, 0, 1, MXSTEP, 0, 1, TN, 0.0D0) ISTATE = -1 GO TO 580 C EWT(i) .le. 0.0 for some i (not at start of problem). ---------------- 510 EWTI = RWORK(LEWT+I-1) MSG = 'DLSODAR- At T(=R1), EWT(I1) has become R2 .le. 0.' CALL XERRWD (MSG, 50, 202, 0, 1, I, 0, 2, TN, EWTI) ISTATE = -6 GO TO 580 C Too much accuracy requested for machine precision. ------------------- 520 MSG = 'DLSODAR- At T (=R1), too much accuracy requested ' CALL XERRWD (MSG, 50, 203, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' for precision of machine.. See TOLSF (=R2) ' CALL XERRWD (MSG, 50, 203, 0, 0, 0, 0, 2, TN, TOLSF) RWORK(14) = TOLSF ISTATE = -2 GO TO 580 C KFLAG = -1. Error test failed repeatedly or with ABS(H) = HMIN. ----- 530 MSG = 'DLSODAR- At T(=R1), step size H(=R2), the error ' CALL XERRWD (MSG, 50, 204, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' test failed repeatedly or with ABS(H) = HMIN' CALL XERRWD (MSG, 50, 204, 0, 0, 0, 0, 2, TN, H) ISTATE = -4 GO TO 560 C KFLAG = -2. Convergence failed repeatedly or with ABS(H) = HMIN. ---- 540 MSG = 'DLSODAR- At T (=R1) and step size H (=R2), the ' CALL XERRWD (MSG, 50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' corrector convergence failed repeatedly ' CALL XERRWD (MSG, 50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' or with ABS(H) = HMIN ' CALL XERRWD (MSG, 30, 205, 0, 0, 0, 0, 2, TN, H) ISTATE = -5 GO TO 560 C RWORK length too small to proceed. ----------------------------------- 550 MSG = 'DLSODAR- At current T(=R1), RWORK length too small' CALL XERRWD (MSG, 50, 206, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' to proceed. The integration was otherwise successful.' CALL XERRWD (MSG, 60, 206, 0, 0, 0, 0, 1, TN, 0.0D0) ISTATE = -7 GO TO 580 C IWORK length too small to proceed. ----------------------------------- 555 MSG = 'DLSODAR- At current T(=R1), IWORK length too small' CALL XERRWD (MSG, 50, 207, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' to proceed. The integration was otherwise successful.' CALL XERRWD (MSG, 60, 207, 0, 0, 0, 0, 1, TN, 0.0D0) ISTATE = -7 GO TO 580 C Compute IMXER if relevant. ------------------------------------------- 560 BIG = 0.0D0 IMXER = 1 DO 570 I = 1,N SIZE = ABS(RWORK(I+LACOR-1)*RWORK(I+LEWT-1)) IF (BIG .GE. SIZE) GO TO 570 BIG = SIZE IMXER = I 570 CONTINUE IWORK(16) = IMXER C Set Y vector, T, and optional outputs. ------------------------------- 580 DO 590 I = 1,N Y(I) = RWORK(I+LYH-1) 590 CONTINUE T = TN RWORK(11) = HU RWORK(12) = H RWORK(13) = TN RWORK(15) = TSW IWORK(11) = NST IWORK(12) = NFE IWORK(13) = NJE IWORK(14) = NQU IWORK(15) = NQ IWORK(19) = MUSED IWORK(20) = METH IWORK(10) = NGE TLAST = T RETURN C----------------------------------------------------------------------- C Block I. C The following block handles all error returns due to illegal input C (ISTATE = -3), as detected before calling the core integrator. C First the error message routine is called. If the illegal input C is a negative ISTATE, the run is aborted (apparent infinite loop). C----------------------------------------------------------------------- 601 MSG = 'DLSODAR- ISTATE(=I1) illegal.' CALL XERRWD (MSG, 30, 1, 0, 1, ISTATE, 0, 0, 0.0D0, 0.0D0) IF (ISTATE .LT. 0) GO TO 800 GO TO 700 602 MSG = 'DLSODAR- ITASK (=I1) illegal.' CALL XERRWD (MSG, 30, 2, 0, 1, ITASK, 0, 0, 0.0D0, 0.0D0) GO TO 700 603 MSG = 'DLSODAR- ISTATE.gt.1 but DLSODAR not initialized.' CALL XERRWD (MSG, 50, 3, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) GO TO 700 604 MSG = 'DLSODAR- NEQ (=I1) .lt. 1 ' CALL XERRWD (MSG, 30, 4, 0, 1, NEQ(1), 0, 0, 0.0D0, 0.0D0) GO TO 700 605 MSG = 'DLSODAR- ISTATE = 3 and NEQ increased (I1 to I2).' CALL XERRWD (MSG, 50, 5, 0, 2, N, NEQ(1), 0, 0.0D0, 0.0D0) GO TO 700 606 MSG = 'DLSODAR- ITOL (=I1) illegal. ' CALL XERRWD (MSG, 30, 6, 0, 1, ITOL, 0, 0, 0.0D0, 0.0D0) GO TO 700 607 MSG = 'DLSODAR- IOPT (=I1) illegal. ' CALL XERRWD (MSG, 30, 7, 0, 1, IOPT, 0, 0, 0.0D0, 0.0D0) GO TO 700 608 MSG = 'DLSODAR- JT (=I1) illegal. ' CALL XERRWD (MSG, 30, 8, 0, 1, JT, 0, 0, 0.0D0, 0.0D0) GO TO 700 609 MSG = 'DLSODAR- ML (=I1) illegal: .lt.0 or .ge.NEQ (=I2)' CALL XERRWD (MSG, 50, 9, 0, 2, ML, NEQ(1), 0, 0.0D0, 0.0D0) GO TO 700 610 MSG = 'DLSODAR- MU (=I1) illegal: .lt.0 or .ge.NEQ (=I2)' CALL XERRWD (MSG, 50, 10, 0, 2, MU, NEQ(1), 0, 0.0D0, 0.0D0) GO TO 700 611 MSG = 'DLSODAR- IXPR (=I1) illegal. ' CALL XERRWD (MSG, 30, 11, 0, 1, IXPR, 0, 0, 0.0D0, 0.0D0) GO TO 700 612 MSG = 'DLSODAR- MXSTEP (=I1) .lt. 0 ' CALL XERRWD (MSG, 30, 12, 0, 1, MXSTEP, 0, 0, 0.0D0, 0.0D0) GO TO 700 613 MSG = 'DLSODAR- MXHNIL (=I1) .lt. 0 ' CALL XERRWD (MSG, 30, 13, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0) GO TO 700 614 MSG = 'DLSODAR- TOUT (=R1) behind T (=R2) ' CALL XERRWD (MSG, 40, 14, 0, 0, 0, 0, 2, TOUT, T) MSG = ' Integration direction is given by H0 (=R1) ' CALL XERRWD (MSG, 50, 14, 0, 0, 0, 0, 1, H0, 0.0D0) GO TO 700 615 MSG = 'DLSODAR- HMAX (=R1) .lt. 0.0 ' CALL XERRWD (MSG, 30, 15, 0, 0, 0, 0, 1, HMAX, 0.0D0) GO TO 700 616 MSG = 'DLSODAR- HMIN (=R1) .lt. 0.0 ' CALL XERRWD (MSG, 30, 16, 0, 0, 0, 0, 1, HMIN, 0.0D0) GO TO 700 617 MSG='DLSODAR- RWORK length needed, LENRW(=I1), exceeds LRW(=I2) ' CALL XERRWD (MSG, 60, 17, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) GO TO 700 618 MSG='DLSODAR- IWORK length needed, LENIW(=I1), exceeds LIW(=I2) ' CALL XERRWD (MSG, 60, 18, 0, 2, LENIW, LIW, 0, 0.0D0, 0.0D0) GO TO 700 619 MSG = 'DLSODAR- RTOL(I1) is R1 .lt. 0.0 ' CALL XERRWD (MSG, 40, 19, 0, 1, I, 0, 1, RTOLI, 0.0D0) GO TO 700 620 MSG = 'DLSODAR- ATOL(I1) is R1 .lt. 0.0 ' CALL XERRWD (MSG, 40, 20, 0, 1, I, 0, 1, ATOLI, 0.0D0) GO TO 700 621 EWTI = RWORK(LEWT+I-1) MSG = 'DLSODAR- EWT(I1) is R1 .le. 0.0 ' CALL XERRWD (MSG, 40, 21, 0, 1, I, 0, 1, EWTI, 0.0D0) GO TO 700 622 MSG='DLSODAR- TOUT(=R1) too close to T(=R2) to start integration.' CALL XERRWD (MSG, 60, 22, 0, 0, 0, 0, 2, TOUT, T) GO TO 700 623 MSG='DLSODAR- ITASK = I1 and TOUT (=R1) behind TCUR - HU (= R2) ' CALL XERRWD (MSG, 60, 23, 0, 1, ITASK, 0, 2, TOUT, TP) GO TO 700 624 MSG='DLSODAR- ITASK = 4 or 5 and TCRIT (=R1) behind TCUR (=R2) ' CALL XERRWD (MSG, 60, 24, 0, 0, 0, 0, 2, TCRIT, TN) GO TO 700 625 MSG='DLSODAR- ITASK = 4 or 5 and TCRIT (=R1) behind TOUT (=R2) ' CALL XERRWD (MSG, 60, 25, 0, 0, 0, 0, 2, TCRIT, TOUT) GO TO 700 626 MSG = 'DLSODAR- At start of problem, too much accuracy ' CALL XERRWD (MSG, 50, 26, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' requested for precision of machine.. See TOLSF (=R1) ' CALL XERRWD (MSG, 60, 26, 0, 0, 0, 0, 1, TOLSF, 0.0D0) RWORK(14) = TOLSF GO TO 700 627 MSG = 'DLSODAR- Trouble in DINTDY. ITASK = I1, TOUT = R1' CALL XERRWD (MSG, 50, 27, 0, 1, ITASK, 0, 1, TOUT, 0.0D0) GO TO 700 628 MSG = 'DLSODAR- MXORDN (=I1) .lt. 0 ' CALL XERRWD (MSG, 30, 28, 0, 1, MXORDN, 0, 0, 0.0D0, 0.0D0) GO TO 700 629 MSG = 'DLSODAR- MXORDS (=I1) .lt. 0 ' CALL XERRWD (MSG, 30, 29, 0, 1, MXORDS, 0, 0, 0.0D0, 0.0D0) GO TO 700 630 MSG = 'DLSODAR- NG (=I1) .lt. 0 ' CALL XERRWD (MSG, 30, 30, 0, 1, NG, 0, 0, 0.0D0, 0.0D0) GO TO 700 631 MSG = 'DLSODAR- NG changed (from I1 to I2) illegally, ' CALL XERRWD (MSG, 50, 31, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' i.e. not immediately after a root was found.' CALL XERRWD (MSG, 50, 31, 0, 2, NGC, NG, 0, 0.0D0, 0.0D0) GO TO 700 632 MSG = 'DLSODAR- One or more components of g has a root ' CALL XERRWD (MSG, 50, 32, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' too near to the initial point. ' CALL XERRWD (MSG, 40, 32, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) C 700 ISTATE = -3 RETURN C 800 MSG = 'DLSODAR- Run aborted.. apparent infinite loop. ' CALL XERRWD (MSG, 50, 303, 2, 0, 0, 0, 0, 0.0D0, 0.0D0) RETURN C----------------------- End of Subroutine DLSODAR --------------------- END *DECK DLSODPK *DECK DLSODKR *DECK DLSODI *DECK DLSOIBT *DECK DLSODIS deSolve/src/dvode.f0000754000175100001440000031700013131751003013725 0ustar hornikusersC********************************************************************* C MAIN VODE DRIVER C********************************************************************* SUBROUTINE DVODE (F, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, ITASK, & & ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JAC, MF, & & RPAR, IPAR) EXTERNAL F, JAC DOUBLE PRECISION Y, T, TOUT, RTOL, ATOL, RWORK, RPAR INTEGER NEQ, ITOL, ITASK, ISTATE, IOPT, LRW, IWORK, LIW, & & MF, IPAR C KARLINE: CHANGED RTOL(1),ATOL(1) : was: RTOL(LRW),ATOL(LIW)!!! C Thomas: changed (1) to (*) DIMENSION Y(NEQ), RTOL(*), ATOL(*), RWORK(LRW), IWORK(LIW), & & RPAR(*), IPAR(*) C----------------------------------------------------------------------- C Revision History (YYMMDD) C 890615 Date Written C 890922 Added interrupt/restart ability, minor changes throughout. C 910228 Minor revisions in line format, prologue, etc. C 920227 Modifications by D. Pang: C (1) Applied subgennam to get generic intrinsic names. C (2) Changed intrinsic names to generic in comments. C (3) Added *DECK lines before each routine. C 920721 Names of routines and labeled Common blocks changed, so as C to be unique in combined single/double precision code (ACH). C 920722 Minor revisions to prologue (ACH). C 920831 Conversion to double precision done (ACH). C----------------------------------------------------------------------- C References.. C C 1. P. N. Brown, G. D. Byrne, and A. C. Hindmarsh, "VODE: A Variable C Coefficient ODE Solver," SIAM J. Sci. Stat. Comput., 10 (1989), C pp. 1038-1051. Also, LLNL Report UCRL-98412, June 1988. C 2. G. D. Byrne and A. C. Hindmarsh, "A Polyalgorithm for the C Numerical Solution of Ordinary Differential Equations," C ACM Trans. Math. Software, 1 (1975), pp. 71-96. C 3. A. C. Hindmarsh and G. D. Byrne, "EPISODE: An Effective Package C for the Integration of Systems of Ordinary Differential C Equations," LLNL Report UCID-30112, Rev. 1, April 1977. C 4. G. D. Byrne and A. C. Hindmarsh, "EPISODEB: An Experimental C Package for the Integration of Systems of Ordinary Differential C Equations with Banded Jacobians," LLNL Report UCID-30132, April C 1976. C 5. A. C. Hindmarsh, "ODEPACK, a Systematized Collection of ODE C Solvers," in Scientific Computing, R. S. Stepleman et al., eds., C North-Holland, Amsterdam, 1983, pp. 55-64. C 6. K. R. Jackson and R. Sacks-Davis, "An Alternative Implementation C of Variable Step-Size Multistep Formulas for Stiff ODEs," ACM C Trans. Math. Software, 6 (1980), pp. 295-318. C----------------------------------------------------------------------- C Authors.. C C Peter N. Brown and Alan C. Hindmarsh C Computing and Mathematics Research Division, L-316 C Lawrence Livermore National Laboratory C Livermore, CA 94550 C and C George D. Byrne C Exxon Research and Engineering Co. C Clinton Township C Route 22 East C Annandale, NJ 08801 C----------------------------------------------------------------------- C Summary of usage. C C Communication between the user and the DVODE package, for normal C situations, is summarized here. This summary describes only a subset C of the full set of options available. See the full description for C details, including optional communication, nonstandard options, C and instructions for special situations. See also the example C problem (with program and output) following this summary. C C A. First provide a subroutine of the form.. C C SUBROUTINE F (NEQ, T, Y, YDOT, RPAR, IPAR) C DOUBLE PRECISION T, Y, YDOT, RPAR C DIMENSION Y(NEQ), YDOT(NEQ) C C which supplies the vector function f by loading YDOT(i) with f(i). C C B. Next determine (or guess) whether or not the problem is stiff. C Stiffness occurs when the Jacobian matrix df/dy has an eigenvalue C whose real part is negative and large in magnitude, compared to the C reciprocal of the t span of interest. If the problem is nonstiff, C use a method flag MF = 10. If it is stiff, there are four standard C choices for MF (21, 22, 24, 25), and DVODE requires the Jacobian C matrix in some form. In these cases (MF .gt. 0), DVODE will use a C saved copy of the Jacobian matrix. If this is undesirable because of C storage limitations, set MF to the corresponding negative value C (-21, -22, -24, -25). (See full description of MF below.) C The Jacobian matrix is regarded either as full (MF = 21 or 22), C or banded (MF = 24 or 25). In the banded case, DVODE requires two C half-bandwidth parameters ML and MU. These are, respectively, the C widths of the lower and upper parts of the band, excluding the main C diagonal. Thus the band consists of the locations (i,j) with C i-ML .le. j .le. i+MU, and the full bandwidth is ML+MU+1. C C C. If the problem is stiff, you are encouraged to supply the Jacobian C directly (MF = 21 or 24), but if this is not feasible, DVODE will C compute it internally by difference quotients (MF = 22 or 25). C If you are supplying the Jacobian, provide a subroutine of the form.. C C SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD, RPAR, IPAR) C DOUBLE PRECISION T, Y, PD, RPAR C DIMENSION Y(NEQ), PD(NROWPD,NEQ) C C which supplies df/dy by loading PD as follows.. C For a full Jacobian (MF = 21), load PD(i,j) with df(i)/dy(j), C the partial derivative of f(i) with respect to y(j). (Ignore the C ML and MU arguments in this case.) C For a banded Jacobian (MF = 24), load PD(i-j+MU+1,j) with C df(i)/dy(j), i.e. load the diagonal lines of df/dy into the rows of C PD from the top down. C In either case, only nonzero elements need be loaded. C C D. Write a main program which calls subroutine DVODE once for C each point at which answers are desired. This should also provide C for possible use of logical unit 6 for output of error messages C by DVODE. On the first call to DVODE, supply arguments as follows.. C F = Name of subroutine for right-hand side vector f. C This name must be declared external in calling program. C NEQ = Number of first order ODE-s. C Y = Array of initial values, of length NEQ. C T = The initial value of the independent variable. C TOUT = First point where output is desired (.ne. T). C ITOL = 1 or 2 according as ATOL (below) is a scalar or array. C RTOL = Relative tolerance parameter (scalar). C ATOL = Absolute tolerance parameter (scalar or array). C The estimated local error in Y(i) will be controlled so as C to be roughly less (in magnitude) than C EWT(i) = RTOL*abs(Y(i)) + ATOL if ITOL = 1, or C EWT(i) = RTOL*abs(Y(i)) + ATOL(i) if ITOL = 2. C Thus the local error test passes if, in each component, C either the absolute error is less than ATOL (or ATOL(i)), C or the relative error is less than RTOL. C Use RTOL = 0.0 for pure absolute error control, and C use ATOL = 0.0 (or ATOL(i) = 0.0) for pure relative error C control. Caution.. Actual (global) errors may exceed these C local tolerances, so choose them conservatively. C ITASK = 1 for normal computation of output values of Y at t = TOUT. C ISTATE = Integer flag (input and output). Set ISTATE = 1. C IOPT = 0 to indicate no optional input used. C RWORK = Real work array of length at least.. C 20 + 16*NEQ for MF = 10, C 22 + 9*NEQ + 2*NEQ**2 for MF = 21 or 22, C 22 + 11*NEQ + (3*ML + 2*MU)*NEQ for MF = 24 or 25. C LRW = Declared length of RWORK (in user's DIMENSION statement). C IWORK = Integer work array of length at least.. C 30 for MF = 10, C 30 + NEQ for MF = 21, 22, 24, or 25. C If MF = 24 or 25, input in IWORK(1),IWORK(2) the lower C and upper half-bandwidths ML,MU. C LIW = Declared length of IWORK (in user's DIMENSION). C JAC = Name of subroutine for Jacobian matrix (MF = 21 or 24). C If used, this name must be declared external in calling C program. If not used, pass a dummy name. C MF = Method flag. Standard values are.. C 10 for nonstiff (Adams) method, no Jacobian used. C 21 for stiff (BDF) method, user-supplied full Jacobian. C 22 for stiff method, internally generated full Jacobian. C 24 for stiff method, user-supplied banded Jacobian. C 25 for stiff method, internally generated banded Jacobian. C RPAR,IPAR = user-defined real and integer arrays passed to F and JAC. C Note that the main program must declare arrays Y, RWORK, IWORK, C and possibly ATOL, RPAR, and IPAR. C C E. The output from the first call (or any call) is.. C Y = Array of computed values of y(t) vector. C T = Corresponding value of independent variable (normally TOUT). C ISTATE = 2 if DVODE was successful, negative otherwise. C -1 means excess work done on this call. (Perhaps wrong MF.) C -2 means excess accuracy requested. (Tolerances too small.) C -3 means illegal input detected. (See printed message.) C -4 means repeated error test failures. (Check all input.) C -5 means repeated convergence failures. (Perhaps bad C Jacobian supplied or wrong choice of MF or tolerances.) C -6 means error weight became zero during problem. (Solution C component i vanished, and ATOL or ATOL(i) = 0.) C C F. To continue the integration after a successful return, simply C reset TOUT and call DVODE again. No other parameters need be reset. C C----------------------------------------------------------------------- C Other Routines in the DVODE Package. C C In addition to subroutine DVODE, the DVODE package includes the C following subroutines and function routines.. C DVHIN computes an approximate step size for the initial step. C DVINDY computes an interpolated value of the y vector at t = TOUT. C DVSTEP is the core integrator, which does one step of the C integration and the associated error control. C DVSET sets all method coefficients and test constants. C DVNLSD solves the underlying nonlinear system -- the corrector. C DVJAC computes and preprocesses the Jacobian matrix J = df/dy C and the Newton iteration matrix P = I - (h/l1)*J. C DVSOL manages solution of linear system in chord iteration. C DVJUST adjusts the history array on a change of order. C DEWSET sets the error weight vector EWT before each step. C DVNORM computes the weighted r.m.s. norm of a vector. C DVSRCO is a user-callable routines to save and restore C the contents of the internal COMMON blocks. C DACOPY is a routine to copy one two-dimensional array to another. C DGEFA and DGESL are routines from LINPACK for solving full C systems of linear algebraic equations. C DGBFA and DGBSL are routines from LINPACK for solving banded C linear systems. C DAXPY, DSCAL, and DCOPY are basic linear algebra modules (BLAS). C D1MACH sets the unit roundoff of the machine. C XERRWD, LUNSAV, and MFLGSV handle the printing of all C error messages and warnings. XERRWD is machine-dependent. C Note.. DVNORM, D1MACH, LUNSAV, and MFLGSV are function routines. C All the others are subroutines. C C The intrinsic and external routines used by the DVODE package are.. C ABS, MAX, MIN, REAL, SIGN, SQRT, and WRITE. C C----------------------------------------------------------------------- C C Type declarations for labeled COMMON block DVOD01 -------------------- C DOUBLE PRECISION ACNRM, CCMXJ, CONP, CRATE, DRC, EL, & & ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, & & RC, RL1, TAU, TQ, TN, UROUND INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, & & L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, & & LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, & & N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, & & NSLP, NYH C C Type declarations for labeled COMMON block DVOD02 -------------------- C DOUBLE PRECISION HU INTEGER NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST C C Type declarations for local variables -------------------------------- C EXTERNAL DVNLSD LOGICAL IHIT DOUBLE PRECISION ATOLI, BIG, EWTI, FOUR, H0, HMAX, HMX, HUN, ONE, & & PT2, RH, RTOLI, SIZE, TCRIT, TNEXT, TOLSF, TP, TWO, ZERO INTEGER I, IER, IFLAG, IMXER, JCO, KGO, LENIW, LENJ, LENP, LENRW, & & LENWM, LF0, MBAND, MFA, ML, MORD, MU, MXHNL0, MXSTP0, NITER, & & NSLAST C C Type declaration for function subroutines called --------------------- C DOUBLE PRECISION D1MACH, DVNORM C DIMENSION MORD(2) SAVE MORD, MXHNL0, MXSTP0 SAVE ZERO, ONE, TWO, FOUR, PT2, HUN COMMON /DVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), & & ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, & & RC, RL1, TAU(13), TQ(5), TN, UROUND, & & ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, & & L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, & & LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, & & N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, & & NSLP, NYH COMMON /DVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST C DATA MORD(1) /12/, MORD(2) /5/, MXSTP0 /500/, MXHNL0 /10/ DATA ZERO /0.0D0/, ONE /1.0D0/, TWO /2.0D0/, FOUR /4.0D0/, & & PT2 /0.2D0/, HUN /100.0D0/ C----------------------------------------------------------------------- C Block A. C This code block is executed on every call. C It tests ISTATE and ITASK for legality and branches appropriately. C If ISTATE .gt. 1 but the flag INIT shows that initialization has C not yet been done, an error return occurs. C If ISTATE = 1 and TOUT = T, return immediately. C----------------------------------------------------------------------- IF (ISTATE .LT. 1 .OR. ISTATE .GT. 3) GO TO 601 IF (ITASK .LT. 1 .OR. ITASK .GT. 5) GO TO 602 IF (ISTATE .EQ. 1) GO TO 10 IF (INIT .NE. 1) GO TO 603 IF (ISTATE .EQ. 2) GO TO 200 GO TO 20 10 INIT = 0 IF (TOUT .EQ. T) RETURN C----------------------------------------------------------------------- C Block B. C The next code block is executed for the initial call (ISTATE = 1), C or for a continuation call with parameter changes (ISTATE = 3). C It contains checking of all input and various initializations. C C First check legality of the non-optional input NEQ, ITOL, IOPT, C MF, ML, and MU. C----------------------------------------------------------------------- 20 IF (NEQ .LE. 0) GO TO 604 IF (ISTATE .EQ. 1) GO TO 25 IF (NEQ .GT. N) GO TO 605 25 N = NEQ IF (ITOL .LT. 1 .OR. ITOL .GT. 4) GO TO 606 IF (IOPT .LT. 0 .OR. IOPT .GT. 1) GO TO 607 JSV = SIGN(1,MF) C Karline: applied changes from 941222 MFA = ABS(MF) METH = MFA/10 MITER = MFA - 10*METH IF (METH .LT. 1 .OR. METH .GT. 2) GO TO 608 IF (MITER .LT. 0 .OR. MITER .GT. 5) GO TO 608 IF (MITER .LE. 3) GO TO 30 ML = IWORK(1) MU = IWORK(2) IF (ML .LT. 0 .OR. ML .GE. N) GO TO 609 IF (MU .LT. 0 .OR. MU .GE. N) GO TO 610 30 CONTINUE C Next process and check the optional input. --------------------------- IF (IOPT .EQ. 1) GO TO 40 MAXORD = MORD(METH) MXSTEP = MXSTP0 MXHNIL = MXHNL0 IF (ISTATE .EQ. 1) H0 = ZERO HMXI = ZERO HMIN = ZERO GO TO 60 40 MAXORD = IWORK(5) IF (MAXORD .LT. 0) GO TO 611 IF (MAXORD .EQ. 0) MAXORD = 100 MAXORD = MIN(MAXORD,MORD(METH)) MXSTEP = IWORK(6) IF (MXSTEP .LT. 0) GO TO 612 IF (MXSTEP .EQ. 0) MXSTEP = MXSTP0 MXHNIL = IWORK(7) IF (MXHNIL .LT. 0) GO TO 613 IF (MXHNIL .EQ. 0) MXHNIL = MXHNL0 IF (ISTATE .NE. 1) GO TO 50 H0 = RWORK(5) IF ((TOUT - T)*H0 .LT. ZERO) GO TO 614 50 HMAX = RWORK(6) IF (HMAX .LT. ZERO) GO TO 615 HMXI = ZERO IF (HMAX .GT. ZERO) HMXI = ONE/HMAX HMIN = RWORK(7) IF (HMIN .LT. ZERO) GO TO 616 C----------------------------------------------------------------------- C Set work array pointers and check lengths LRW and LIW. C Pointers to segments of RWORK and IWORK are named by prefixing L to C the name of the segment. E.g., the segment YH starts at RWORK(LYH). C Segments of RWORK (in order) are denoted YH, WM, EWT, SAVF, ACOR. C Within WM, LOCJS is the location of the saved Jacobian (JSV .gt. 0). C----------------------------------------------------------------------- 60 LYH = 21 IF (ISTATE .EQ. 1) NYH = N LWM = LYH + (MAXORD + 1)*NYH JCO = MAX(0,JSV) IF (MITER .EQ. 0) LENWM = 0 IF (MITER .EQ. 1 .OR. MITER .EQ. 2) THEN LENWM = 2 + (1 + JCO)*N*N LOCJS = N*N + 3 ENDIF IF (MITER .EQ. 3) LENWM = 2 + N IF (MITER .EQ. 4 .OR. MITER .EQ. 5) THEN MBAND = ML + MU + 1 LENP = (MBAND + ML)*N LENJ = MBAND*N LENWM = 2 + LENP + JCO*LENJ LOCJS = LENP + 3 ENDIF LEWT = LWM + LENWM LSAVF = LEWT + N LACOR = LSAVF + N LENRW = LACOR + N - 1 IWORK(17) = LENRW LIWM = 1 LENIW = 30 + N IF (MITER .EQ. 0 .OR. MITER .EQ. 3) LENIW = 30 IWORK(18) = LENIW IF (LENRW .GT. LRW) GO TO 617 IF (LENIW .GT. LIW) GO TO 618 C Check RTOL and ATOL for legality. ------------------------------------ RTOLI = RTOL(1) ATOLI = ATOL(1) DO 70 I = 1,N IF (ITOL .GE. 3) RTOLI = RTOL(I) IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) IF (RTOLI .LT. ZERO) GO TO 619 IF (ATOLI .LT. ZERO) GO TO 620 70 CONTINUE IF (ISTATE .EQ. 1) GO TO 100 C If ISTATE = 3, set flag to signal parameter changes to DVSTEP. ------- JSTART = -1 IF (NQ .LE. MAXORD) GO TO 90 C MAXORD was reduced below NQ. Copy YH(*,MAXORD+2) into SAVF. --------- CALL DCOPY (N, RWORK(LWM), 1, RWORK(LSAVF), 1) C Reload WM(1) = RWORK(LWM), since LWM may have changed. --------------- 90 IF (MITER .GT. 0) RWORK(LWM) = SQRT(UROUND) GO TO 200 C Karline: correction 19981111 added C----------------------------------------------------------------------- C Block C. C The next block is for the initial call only (ISTATE = 1). C It contains all remaining initializations, the initial call to F, C and the calculation of the initial step size. C The error weights in EWT are inverted after being loaded. C----------------------------------------------------------------------- 100 UROUND = D1MACH(4) TN = T IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 110 TCRIT = RWORK(1) IF ((TCRIT - TOUT)*(TOUT - T) .LT. ZERO) GO TO 625 IF (H0 .NE. ZERO .AND. (T + H0 - TCRIT)*H0 .GT. ZERO) & & H0 = TCRIT - T 110 JSTART = 0 IF (MITER .GT. 0) RWORK(LWM) = SQRT(UROUND) CCMXJ = PT2 MSBJ = 50 NHNIL = 0 NST = 0 NJE = 0 NNI = 0 NCFN = 0 NETF = 0 NLU = 0 NSLJ = 0 NSLAST = 0 HU = ZERO NQU = 0 C Initial call to F. (LF0 points to YH(*,2).) ------------------------- LF0 = LYH + NYH CALL F (N, T, Y, RWORK(LF0), RPAR, IPAR) NFE = 1 C Load the initial value vector in YH. --------------------------------- CALL DCOPY (N, Y, 1, RWORK(LYH), 1) C Load and invert the EWT array. (H is temporarily set to 1.0.) ------- NQ = 1 H = ONE CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) DO 120 I = 1,N IF (RWORK(I+LEWT-1) .LE. ZERO) GO TO 621 RWORK(I+LEWT-1) = ONE/RWORK(I+LEWT-1) 120 CONTINUE IF (H0 .NE. ZERO) GO TO 180 C Call DVHIN to set initial step size H0 to be attempted. -------------- CALL DVHIN (N, T, RWORK(LYH), RWORK(LF0), F, RPAR, IPAR, TOUT, & & UROUND, RWORK(LEWT), ITOL, ATOL, Y, RWORK(LACOR), H0, & & NITER, IER) NFE = NFE + NITER IF (IER .NE. 0) GO TO 622 C Adjust H0 if necessary to meet HMAX bound. --------------------------- 180 RH = ABS(H0)*HMXI IF (RH .GT. ONE) H0 = H0/RH C Load H with H0 and scale YH(*,2) by H0. ------------------------------ H = H0 CALL DSCAL (N, H0, RWORK(LF0), 1) GO TO 270 C----------------------------------------------------------------------- C Block D. C The next code block is for continuation calls only (ISTATE = 2 or 3) C and is to check stop conditions before taking a step. C----------------------------------------------------------------------- 200 NSLAST = NST KUTH = 0 C GO TO (210, 250, 220, 230, 240), ITASK SELECT CASE (ITASK) CASE (1) GOTO 210 CASE (2) GOTO 250 CASE (3) GOTO 220 CASE (4) GOTO 230 CASE (5) GOTO 240 END SELECT 210 IF ((TN - TOUT)*H .LT. ZERO) GO TO 250 CALL DVINDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) IF (IFLAG .NE. 0) GO TO 627 T = TOUT GO TO 420 220 TP = TN - HU*(ONE + HUN*UROUND) IF ((TP - TOUT)*H .GT. ZERO) GO TO 623 IF ((TN - TOUT)*H .LT. ZERO) GO TO 250 GO TO 400 230 TCRIT = RWORK(1) IF ((TN - TCRIT)*H .GT. ZERO) GO TO 624 IF ((TCRIT - TOUT)*H .LT. ZERO) GO TO 625 IF ((TN - TOUT)*H .LT. ZERO) GO TO 245 CALL DVINDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) IF (IFLAG .NE. 0) GO TO 627 T = TOUT GO TO 420 240 TCRIT = RWORK(1) IF ((TN - TCRIT)*H .GT. ZERO) GO TO 624 245 HMX = ABS(TN) + ABS(H) IHIT = ABS(TN - TCRIT) .LE. HUN*UROUND*HMX IF (IHIT) GO TO 400 TNEXT = TN + HNEW*(ONE + FOUR*UROUND) IF ((TNEXT - TCRIT)*H .LE. ZERO) GO TO 250 H = (TCRIT - TN)*(ONE - FOUR*UROUND) KUTH = 1 C----------------------------------------------------------------------- C Block E. C The next block is normally executed for all calls and contains C the call to the one-step core integrator DVSTEP. C C This is a looping point for the integration steps. C C First check for too many steps being taken, update EWT (if not at C start of problem), check for too much accuracy being requested, and C check for H below the roundoff level in T. C----------------------------------------------------------------------- 250 CONTINUE IF ((NST-NSLAST) .GE. MXSTEP) GO TO 500 CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) DO 260 I = 1,N IF (RWORK(I+LEWT-1) .LE. ZERO) GO TO 510 RWORK(I+LEWT-1) = ONE/RWORK(I+LEWT-1) 260 CONTINUE 270 TOLSF = UROUND*DVNORM (N, RWORK(LYH), RWORK(LEWT)) IF (TOLSF .LE. ONE) GO TO 280 TOLSF = TOLSF*TWO IF (NST .EQ. 0) GO TO 626 GO TO 520 280 IF ((TN + H) .NE. TN) GO TO 290 NHNIL = NHNIL + 1 IF (NHNIL .GT. MXHNIL) GO TO 290 call rprintf( & 'dvode -- Warning.. Internal T (=R1) and H (=R2) are' // char(0)) call rprintf( & ' such that in the machine, T + H = T on the next step' & // char(0)) call rprintf( & ' (H = step size). Solver will continue anyway.' & // char(0)) call rprintfd2('In above message, R1 = %g, R2 = %g' // char(0), & TN, H) IF (NHNIL .LT. MXHNIL) GO TO 290 call rprintf( & 'dvode -- Above warning has been issued I1 times. ') call rprintf( & ' it will not be issued again for this problem.' & // char(0)) call rprintfi1('In above message, I1 = %i' // char(0), MXHNIL) 290 CONTINUE C----------------------------------------------------------------------- C CALL DVSTEP (Y, YH, NYH, YH, EWT, SAVF, VSAV, ACOR, C WM, IWM, F, JAC, F, DVNLSD, RPAR, IPAR) C----------------------------------------------------------------------- CALL DVSTEP (Y, RWORK(LYH), NYH, RWORK(LYH), RWORK(LEWT), & & RWORK(LSAVF), Y, RWORK(LACOR), RWORK(LWM), IWORK(LIWM), & & F, JAC, F, DVNLSD, RPAR, IPAR) KGO = 1 - KFLAG C Branch on KFLAG. Note..In this version, KFLAG can not be set to -3. C KFLAG .eq. 0, -1, -2 C GO TO (300, 530, 540), KGO SELECT CASE(KGO) CASE(1) GOTO 300 CASE(2) GOTO 530 CASE(3) GOTO 540 END SELECT C----------------------------------------------------------------------- C Block F. C The following block handles the case of a successful return from the C core integrator (KFLAG = 0). Test for stop conditions. C----------------------------------------------------------------------- 300 INIT = 1 KUTH = 0 C GO TO (310, 400, 330, 340, 350), ITASK SELECT CASE(ITASK) CASE(1) GOTO 310 CASE(2) GOTO 400 CASE(3) GOTO 330 CASE(4) GOTO 340 CASE(5) GOTO 350 END SELECT C ITASK = 1. If TOUT has been reached, interpolate. ------------------- 310 IF ((TN - TOUT)*H .LT. ZERO) GO TO 250 CALL DVINDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) T = TOUT GO TO 420 C ITASK = 3. Jump to exit if TOUT was reached. ------------------------ 330 IF ((TN - TOUT)*H .GE. ZERO) GO TO 400 GO TO 250 C ITASK = 4. See if TOUT or TCRIT was reached. Adjust H if necessary. 340 IF ((TN - TOUT)*H .LT. ZERO) GO TO 345 CALL DVINDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) T = TOUT GO TO 420 345 HMX = ABS(TN) + ABS(H) IHIT = ABS(TN - TCRIT) .LE. HUN*UROUND*HMX IF (IHIT) GO TO 400 TNEXT = TN + HNEW*(ONE + FOUR*UROUND) IF ((TNEXT - TCRIT)*H .LE. ZERO) GO TO 250 H = (TCRIT - TN)*(ONE - FOUR*UROUND) KUTH = 1 GO TO 250 C ITASK = 5. See if TCRIT was reached and jump to exit. --------------- 350 HMX = ABS(TN) + ABS(H) IHIT = ABS(TN - TCRIT) .LE. HUN*UROUND*HMX C----------------------------------------------------------------------- C Block G. C The following block handles all successful returns from DVODE. C If ITASK .ne. 1, Y is loaded from YH and T is set accordingly. C ISTATE is set to 2, and the optional output is loaded into the work C arrays before returning. C----------------------------------------------------------------------- 400 CONTINUE CALL DCOPY (N, RWORK(LYH), 1, Y, 1) T = TN IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 420 IF (IHIT) T = TCRIT 420 ISTATE = 2 RWORK(11) = HU RWORK(12) = HNEW RWORK(13) = TN IWORK(11) = NST IWORK(12) = NFE IWORK(13) = NJE IWORK(14) = NQU IWORK(15) = NEWQ IWORK(19) = NLU IWORK(20) = NNI IWORK(21) = NCFN IWORK(22) = NETF RETURN C----------------------------------------------------------------------- C Block H. C The following block handles all unsuccessful returns other than C those for illegal input. First the error message routine is called. C if there was an error test or convergence test failure, IMXER is set. C Then Y is loaded from YH, T is set to TN, and the illegal input C The optional output is loaded into the work arrays before returning. C----------------------------------------------------------------------- C The maximum number of steps was taken before reaching TOUT. ---------- 500 call rprintf( 1 'dvode -- At current T (=R1), MXSTEP (=I1) steps' // char(0)) call rprintf( 2 ' taken on this call before reaching TOUT' // char(0)) call rprintfdi( & ' with: R1 = %g, I1=%i' // char(0), TN, MXSTEP) ISTATE = -1 GO TO 580 C EWT(i) .le. 0.0 for some i (not at start of problem). ---------------- 510 EWTI = RWORK(LEWT+I-1) call rprintf( 1 'dvode -- At T (=R1), EWT(=I1) has become < 0 ' // char(0)) call rprintfdi( & ' with R1 = %g, I1 = %i' //char(0), TN, I) ISTATE = -6 GO TO 580 C Too much accuracy requested for machine precision. ------------------- 520 call rprintf( 1 'dvode -- At T (=R1), too much accuracy requested' // char(0)) call rprintf( 2 ' for precision of machine.. see TOLSF (=R2)' // char(0)) call rprintfd2( & ' with R1 = %g, R2 = %g' //char(0), TN , TOLSF ) RWORK(14) = TOLSF ISTATE = -2 GO TO 580 C KFLAG = -1. Error test failed repeatedly or with ABS(H) = HMIN. ----- 530 call rprintf( 1 'dvode -- At T (=R1), and step size H (=R2) the error'//char(0)) call rprintf( 2 ' test failed repeatedly or with abs(H) = HMIN' //char(0)) call rprintfd2( & ' with R1 = %g, R2 = %g' //char(0), TN, H ) ISTATE = -4 GO TO 560 C KFLAG = -2. Convergence failed repeatedly or with abs(H) = HMIN. ---- 540 call rprintf( 1 'dvode -- At T (=R1), and step size H (=R2) the' // char(0)) call rprintf( 2 ' corrector converged failed repeatedly' // char(0)) call rprintf( 3 ' or with abs(H) = HMIN ' // char(0)) call rprintfd2( & ' with: R1= %g, R2 = %g' // char(0), TN, H) ISTATE = -5 C Compute IMXER if relevant. ------------------------------------------- 560 BIG = ZERO IMXER = 1 DO 570 I = 1,N SIZE = ABS(RWORK(I+LACOR-1)*RWORK(I+LEWT-1)) IF (BIG .GE. SIZE) GO TO 570 BIG = SIZE IMXER = I 570 CONTINUE IWORK(16) = IMXER C Set Y vector, T, and optional output. -------------------------------- 580 CONTINUE CALL DCOPY (N, RWORK(LYH), 1, Y, 1) T = TN RWORK(11) = HU RWORK(12) = H RWORK(13) = TN IWORK(11) = NST IWORK(12) = NFE IWORK(13) = NJE IWORK(14) = NQU IWORK(15) = NQ IWORK(19) = NLU IWORK(20) = NNI IWORK(21) = NCFN IWORK(22) = NETF RETURN C----------------------------------------------------------------------- C Block I. C The following block handles all error returns due to illegal input C (ISTATE = -3), as detected before calling the core integrator. C First the error message routine is called. If the illegal input C is a negative ISTATE, the run is aborted (apparent infinite loop). C----------------------------------------------------------------------- 601 call rprintfi1( 1 'dvode -- ISTATE (=I1) illegal %i' // char(0), ISTATE) IF (ISTATE .LT. 0) GO TO 800 GO TO 700 602 call rprintfi1( 1 'dvode -- ITASK (=I1) illegal %i' // char(0), ITASK) GO TO 700 603 call rprintfi1( 1 'dvode -- ISTATE (=I1) >1 but dvode not initialised %i' & // char(0), ISTATE) GO TO 700 604 call rprintfi1( 1 'dvode -- NEQ (=I1) <1 %i' // char(0), NEQ) GO TO 700 605 call rprintfi2( 1 'dvode -- ISTATE =3 and NEQ increased (I1 to I2), %i, %i' & // char(0), N, NEQ) GO TO 700 606 call rprintfi1( 1 'dvode -- ITOL (=I1) illegal %i' // char(0), ITOL) GO TO 700 607 call rprintfi1( 1 'dvode -- IOPT (=I1) illegal %i' // char(0), IOPT) GO TO 700 608 call rprintfi1( 1 'dvode -- MF (=I1) illegal %i' // char(0), MF) GO TO 700 609 call rprintfi2( 1 'dvode -- ML (=I1) illegal: <0 or >=neq (+I2) %i, %i' & // char(0), ML,NEQ) GO TO 700 610 call rprintfi2( 1 'dvode -- MU (=I1) illegal: <= 0 or > neq (=I2) %i, %i' & // char(0), MU,NEQ) GO TO 700 611 call rprintfi1( 1 'dvode -- MAXORD (=I1) < 0 %i' // char(0), MAXORD) GO TO 700 612 call rprintfi1( 1 'dvode -- MXSTEP (=I1) < 0 %i' // char(0), MXSTEP) GO TO 700 613 call rprintfi1( 1 'dvode -- MXHNIL (=I1) < 0 %i' // char(0), MXHNIL) GO TO 700 614 call rprintfd2( 1 'dvode -- TOUT (=R1) behind T (=R2) %g, %g' & // char(0), TOUT, T ) GO TO 700 615 call rprintfd1( 1 'dvode -- HMAX (=R1) <= 0 %g' // char(0), HMAX) GO TO 700 616 call rprintfd1( 1 'dvode -- HMIN (=R1) <=0 %g' // char(0), HMIN) GO TO 700 617 CONTINUE call rprintfi2( 1 'dvode -- RWORK length needed, LENRW (=I1) exceeds LRW (=I2) & %i, %i' // char(0), LENRW, LRW) GO TO 700 618 CONTINUE call rprintfi2( 1 'dvode -- IWORK length needed, LENIW (=I1) exceeds LIW (=I2) & %i, %i' // char(0), LENIW, LIW) GO TO 700 619 call rprintfid( 1 'dvode -- RTOL(I1) is R1 < 0 %i, %g' // char(0), I, RTOLI) GO TO 700 620 call rprintfid( 1 'dvode -- ATOL (I1) is R1 < 0 %i, %g' // char(0), I, ATOLI ) GO TO 700 621 EWTI = RWORK(LEWT+I-1) call rprintfid( 1 'dvode -- EWT (I1) is R1 <= 0 %i, %g' // char(0), I, EWTI) GO TO 700 622 CONTINUE call rprintfd2( 1 'dvode -- TOUT (=R1) too close to T (=R2) to start integration' & // '%g, %g' // char(0), TOUT, T ) GO TO 700 623 CONTINUE call rprintfi1( 1 'dvode -- ITASK = I1 %i', ITASK) call rprintfd2( 2 'and TOUT (=R1) behind TCUR-HU (=R2) %g, %g' & // char(0), TOUT, TP) GO TO 700 624 CONTINUE call rprintfd2( 1 'dvode -- ITASK = 4 or 5 and TCRIT (=R1) behind TCUR (=R2)' & // ' &g, %g' // char(0), TCRIT, TN) GO TO 700 625 CONTINUE call rprintfd2( 1 'dvode -- ITASK = 4 or 5 and TCRIT (=R1) behind TOUT (=R2)' & // ' %g, %g' // char(0), TCRIT, TOUT) GO TO 700 626 call rprintf( 1 'dvode -- at start of problem, too much accuracy' // char(0)) call rprintfd1( 2 ' requested for precision of machine.. & see TOLSF (=R1) %g' // char(0), TOLSF) RWORK(14) = TOLSF GO TO 700 627 call rprintfid( 1 'dvode -- trouble from DVINDY. ITASK = I1, TOUT = R1 %i, %g' & // char(0), ITASK, TOUT) C 700 CONTINUE ISTATE = -3 RETURN C 800 call rprintf( 1 'dvode -- run aborted.. apparent infinite loop' // char(0)) RETURN C----------------------- End of Subroutine DVODE ----------------------- END C*********************************************************************** CDECK DVHIN SUBROUTINE DVHIN (N, T0, Y0, YDOT, F, RPAR, IPAR, TOUT, UROUND, & & EWT, ITOL, ATOL, Y, TEMP, H0, NITER, IER) EXTERNAL F DOUBLE PRECISION T0, Y0, YDOT, RPAR, TOUT, UROUND, EWT, ATOL, Y, & & TEMP, H0 INTEGER N, IPAR, ITOL, NITER, IER DIMENSION Y0(*), YDOT(*), EWT(*), ATOL(*), Y(*), & & TEMP(*), RPAR(*), IPAR(*) C----------------------------------------------------------------------- C Call sequence input -- N, T0, Y0, YDOT, F, RPAR, IPAR, TOUT, UROUND, C EWT, ITOL, ATOL, Y, TEMP C Call sequence output -- H0, NITER, IER C COMMON block variables accessed -- None C C Subroutines called by DVHIN.. F C Function routines called by DVHIN.. DVNORM C----------------------------------------------------------------------- C This routine computes the step size, H0, to be attempted on the C first step, when the user has not supplied a value for this. C C First we check that TOUT - T0 differs significantly from zero. Then C an iteration is done to approximate the initial second derivative C and this is used to define h from w.r.m.s.norm(h**2 * yddot / 2) = 1. C A bias factor of 1/2 is applied to the resulting h. C The sign of H0 is inferred from the initial values of TOUT and T0. C C Communication with DVHIN is done with the following variables.. C C N = Size of ODE system, input. C T0 = Initial value of independent variable, input. C Y0 = Vector of initial conditions, input. C YDOT = Vector of initial first derivatives, input. C F = Name of subroutine for right-hand side f(t,y), input. C RPAR, IPAR = Dummy names for user's real and integer work arrays. C TOUT = First output value of independent variable C UROUND = Machine unit roundoff C EWT, ITOL, ATOL = Error weights and tolerance parameters C as described in the driver routine, input. C Y, TEMP = Work arrays of length N. C H0 = Step size to be attempted, output. C NITER = Number of iterations (and of f evaluations) to compute H0, C output. C IER = The error flag, returned with the value C IER = 0 if no trouble occurred, or C IER = -1 if TOUT and T0 are considered too close to proceed. C----------------------------------------------------------------------- C C Type declarations for local variables -------------------------------- C DOUBLE PRECISION AFI, ATOLI, DELYI, HALF, HG, HLB, HNEW, HRAT, & & HUB, HUN, PT1, T1, TDIST, TROUND, TWO, YDDNRM,H INTEGER I, ITER C C Type declaration for function subroutines called --------------------- C DOUBLE PRECISION DVNORM C----------------------------------------------------------------------- C The following Fortran-77 declaration is to cause the values of the C listed (local) variables to be saved between calls to this integrator. C----------------------------------------------------------------------- SAVE HALF, HUN, PT1, TWO DATA HALF /0.5D0/, HUN /100.0D0/, PT1 /0.1D0/, TWO /2.0D0/ C NITER = 0 TDIST = ABS(TOUT - T0) TROUND = UROUND*MAX(ABS(T0),ABS(TOUT)) IF (TDIST .LT. TWO*TROUND) GO TO 100 C C Set a lower bound on h based on the roundoff level in T0 and TOUT. --- HLB = HUN*TROUND C Set an upper bound on h based on TOUT-T0 and the initial Y and YDOT. - HUB = PT1*TDIST ATOLI = ATOL(1) DO 10 I = 1, N IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) DELYI = PT1*ABS(Y0(I)) + ATOLI AFI = ABS(YDOT(I)) IF (AFI*HUB .GT. DELYI) HUB = DELYI/AFI 10 CONTINUE C C Set initial guess for h as geometric mean of upper and lower bounds. - ITER = 0 HG = SQRT(HLB*HUB) C If the bounds have crossed, exit with the mean value. ---------------- IF (HUB .LT. HLB) THEN H0 = HG GO TO 90 ENDIF C C Looping point for iteration. ----------------------------------------- 50 CONTINUE C Estimate the second derivative as a difference quotient in f. -------- H = SIGN (HG, TOUT - T0) C Revision 941222 included (KS) T1 = T0 + H DO 60 I = 1, N Y(I) = Y0(I) + H*YDOT(I) 60 CONTINUE CALL F (N, T1, Y, TEMP, RPAR, IPAR) DO 70 I = 1, N TEMP(I) = (TEMP(I) - YDOT(I))/H 70 CONTINUE YDDNRM = DVNORM (N, TEMP, EWT) C Get the corresponding new value of h. -------------------------------- IF (YDDNRM*HUB*HUB .GT. TWO) THEN HNEW = SQRT(TWO/YDDNRM) ELSE HNEW = SQRT(HG*HUB) ENDIF ITER = ITER + 1 C----------------------------------------------------------------------- C Test the stopping conditions. C Stop if the new and previous h values differ by a factor of .lt. 2. C Stop if four iterations have been done. Also, stop with previous h C if HNEW/HG .gt. 2 after first iteration, as this probably means that C the second derivative value is bad because of cancellation error. C----------------------------------------------------------------------- IF (ITER .GE. 4) GO TO 80 HRAT = HNEW/HG IF ( (HRAT .GT. HALF) .AND. (HRAT .LT. TWO) ) GO TO 80 IF ( (ITER .GE. 2) .AND. (HNEW .GT. TWO*HG) ) THEN HNEW = HG GO TO 80 ENDIF HG = HNEW GO TO 50 C C Iteration done. Apply bounds, bias factor, and sign. Then exit. ---- 80 H0 = HNEW*HALF IF (H0 .LT. HLB) H0 = HLB IF (H0 .GT. HUB) H0 = HUB 90 H0 = SIGN(H0, TOUT - T0) NITER = ITER IER = 0 RETURN C Error return for TOUT - T0 too small. -------------------------------- 100 IER = -1 RETURN C----------------------- End of Subroutine DVHIN ----------------------- END CDECK DVINDY C*********************************************************************** SUBROUTINE DVINDY (T, K, YH, LDYH, DKY, IFLAG) DOUBLE PRECISION T, YH, DKY INTEGER K, LDYH, IFLAG DIMENSION YH(LDYH,*), DKY(*) C----------------------------------------------------------------------- C Call sequence input -- T, K, YH, LDYH C Call sequence output -- DKY, IFLAG C COMMON block variables accessed.. C /DVOD01/ -- H, TN, UROUND, L, N, NQ C /DVOD02/ -- HU C C Subroutines called by DVINDY.. DSCAL, XERRWD C Function routines called by DVINDY.. None C----------------------------------------------------------------------- C DVINDY computes interpolated values of the K-th derivative of the C dependent variable vector y, and stores it in DKY. This routine C is called within the package with K = 0 and T = TOUT, but may C also be called by the user for any K up to the current order. C (See detailed instructions in the usage documentation.) C----------------------------------------------------------------------- C The computed values in DKY are gotten by interpolation using the C Nordsieck history array YH. This array corresponds uniquely to a C vector-valued polynomial of degree NQCUR or less, and DKY is set C to the K-th derivative of this polynomial at T. C The formula for DKY is.. C q C DKY(i) = sum c(j,K) * (T - TN)**(j-K) * H**(-j) * YH(i,j+1) C j=K C where c(j,K) = j*(j-1)*...*(j-K+1), q = NQCUR, TN = TCUR, H = HCUR. C The quantities NQ = NQCUR, L = NQ+1, N, TN, and H are C communicated by COMMON. The above sum is done in reverse order. C IFLAG is returned negative if either K or T is out of bounds. C C Discussion above and comments in driver explain all variables. C----------------------------------------------------------------------- C C Type declarations for labeled COMMON block DVOD01 -------------------- C DOUBLE PRECISION ACNRM, CCMXJ, CONP, CRATE, DRC, EL, & & ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, & & RC, RL1, TAU, TQ, TN, UROUND INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, & & L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, & & LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, & & N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, & & NSLP, NYH C C Type declarations for labeled COMMON block DVOD02 -------------------- C DOUBLE PRECISION HU INTEGER NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST C C Type declarations for local variables -------------------------------- C DOUBLE PRECISION C, HUN, R, S, TFUZZ, TN1, TP, ZERO INTEGER I, IC, J, JB, JB2, JJ, JJ1, JP1 C----------------------------------------------------------------------- C The following Fortran-77 declaration is to cause the values of the C listed (local) variables to be saved between calls to this integrator. C----------------------------------------------------------------------- SAVE HUN, ZERO C COMMON /DVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), & & ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, & & RC, RL1, TAU(13), TQ(5), TN, UROUND, & & ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, & & L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, & & LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, & & N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, & & NSLP, NYH COMMON /DVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST C DATA HUN /100.0D0/, ZERO /0.0D0/ C IFLAG = 0 IF (K .LT. 0 .OR. K .GT. NQ) GO TO 80 TFUZZ = HUN*UROUND*(TN + HU) TP = TN - HU - TFUZZ TN1 = TN + TFUZZ IF ((T-TP)*(T-TN1) .GT. ZERO) GO TO 90 C S = (T - TN)/H IC = 1 IF (K .EQ. 0) GO TO 15 JJ1 = L - K DO 10 JJ = JJ1, NQ IC = IC*JJ 10 CONTINUE 15 C = REAL(IC) DO 20 I = 1, N DKY(I) = C*YH(I,L) 20 CONTINUE IF (K .EQ. NQ) GO TO 55 JB2 = NQ - K DO 50 JB = 1, JB2 J = NQ - JB JP1 = J + 1 IC = 1 IF (K .EQ. 0) GO TO 35 JJ1 = JP1 - K DO 30 JJ = JJ1, J IC = IC*JJ 30 CONTINUE 35 C = REAL(IC) DO 40 I = 1, N DKY(I) = C*YH(I,JP1) + S*DKY(I) 40 CONTINUE 50 CONTINUE IF (K .EQ. 0) RETURN 55 R = H**(-K) CALL DSCAL (N, R, DKY, 1) RETURN C 80 call rprinti1( 1 'dvode -- DVINDY -- K (=I1) illegal ', K) IFLAG = -1 RETURN 90 call rprintd1( 1 'dvode -- DVINDY -- T (=R1) illegal ', T) call rprintd2( 1 'dvode -- T not in interval TCUR-HU (=R1) to TCUR (=R2) ', 2 TP,TN) IFLAG = -2 RETURN C----------------------- End of Subroutine DVINDY ---------------------- END C*********************************************************************** CDECK DVSTEP SUBROUTINE DVSTEP (Y, YH, LDYH, YH1, EWT, SAVF, VSAV, ACOR, & & WM, IWM, F, JAC, PSOL, VNLS, RPAR, IPAR) EXTERNAL F, JAC, PSOL, VNLS DOUBLE PRECISION Y, YH, YH1, EWT, SAVF, VSAV, ACOR, WM, RPAR INTEGER LDYH, IWM, IPAR DIMENSION Y(*), YH(LDYH,*), YH1(*), EWT(*), SAVF(*), VSAV(*), & & ACOR(*), WM(*), IWM(*), RPAR(*), IPAR(*) C----------------------------------------------------------------------- C Call sequence input -- Y, YH, LDYH, YH1, EWT, SAVF, VSAV, C ACOR, WM, IWM, F, JAC, PSOL, VNLS, RPAR, IPAR C Call sequence output -- YH, ACOR, WM, IWM C COMMON block variables accessed.. C /DVOD01/ ACNRM, EL(13), H, HMIN, HMXI, HNEW, HSCAL, RC, TAU(13), C TQ(5), TN, JCUR, JSTART, KFLAG, KUTH, C L, LMAX, MAXORD, MITER, N, NEWQ, NQ, NQWAIT C /DVOD02/ HU, NCFN, NETF, NFE, NQU, NST C C Subroutines called by DVSTEP.. F, DAXPY, DCOPY, DSCAL, C DVJUST, VNLS, DVSET C Function routines called by DVSTEP.. DVNORM C----------------------------------------------------------------------- C DVSTEP performs one step of the integration of an initial value C problem for a system of ordinary differential equations. C DVSTEP calls subroutine VNLS for the solution of the nonlinear system C arising in the time step. Thus it is independent of the problem C Jacobian structure and the type of nonlinear system solution method. C DVSTEP returns a completion flag KFLAG (in COMMON). C A return with KFLAG = -1 or -2 means either ABS(H) = HMIN or 10 C consecutive failures occurred. On a return with KFLAG negative, C the values of TN and the YH array are as of the beginning of the last C step, and H is the last step size attempted. C C Communication with DVSTEP is done with the following variables.. C C Y = An array of length N used for the dependent variable vector. C YH = An LDYH by LMAX array containing the dependent variables C and their approximate scaled derivatives, where C LMAX = MAXORD + 1. YH(i,j+1) contains the approximate C j-th derivative of y(i), scaled by H**j/factorial(j) C (j = 0,1,...,NQ). On entry for the first step, the first C two columns of YH must be set from the initial values. C LDYH = A constant integer .ge. N, the first dimension of YH. C N is the number of ODEs in the system. C YH1 = A one-dimensional array occupying the same space as YH. C EWT = An array of length N containing multiplicative weights C for local error measurements. Local errors in y(i) are C compared to 1.0/EWT(i) in various error tests. C SAVF = An array of working storage, of length N. C also used for input of YH(*,MAXORD+2) when JSTART = -1 C and MAXORD .lt. the current order NQ. C VSAV = A work array of length N passed to subroutine VNLS. C ACOR = A work array of length N, used for the accumulated C corrections. On a successful return, ACOR(i) contains C the estimated one-step local error in y(i). C WM,IWM = Real and integer work arrays associated with matrix C operations in VNLS. C F = Dummy name for the user supplied subroutine for f. C JAC = Dummy name for the user supplied Jacobian subroutine. C PSOL = Dummy name for the subroutine passed to VNLS, for C possible use there. C VNLS = Dummy name for the nonlinear system solving subroutine, C whose real name is dependent on the method used. C RPAR, IPAR = Dummy names for user's real and integer work arrays. C----------------------------------------------------------------------- C C Type declarations for labeled COMMON block DVOD01 -------------------- C DOUBLE PRECISION ACNRM, CCMXJ, CONP, CRATE, DRC, EL, & & ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, & & RC, RL1, TAU, TQ, TN, UROUND INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, & & L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, & & LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, & & N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, & & NSLP, NYH C C Type declarations for labeled COMMON block DVOD02 -------------------- C DOUBLE PRECISION HU INTEGER NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST C C Type declarations for local variables -------------------------------- C DOUBLE PRECISION ADDON, BIAS1,BIAS2,BIAS3, CNQUOT, DDN, DSM, DUP, & & ETACF, ETAMIN, ETAMX1, ETAMX2, ETAMX3, ETAMXF, & & ETAQ, ETAQM1, ETAQP1, FLOTL, ONE, ONEPSM, & & R, THRESH, TOLD, ZERO INTEGER I, I1, I2, IBACK, J, JB, KFC, KFH, MXNCF, NCF, NFLAG C C Type declaration for function subroutines called --------------------- C DOUBLE PRECISION DVNORM C----------------------------------------------------------------------- C The following Fortran-77 declaration is to cause the values of the C listed (local) variables to be saved between calls to this integrator. C----------------------------------------------------------------------- SAVE ADDON, BIAS1, BIAS2, BIAS3, & & ETACF, ETAMIN, ETAMX1, ETAMX2, ETAMX3, ETAMXF, & & KFC, KFH, MXNCF, ONEPSM, THRESH, ONE, ZERO C----------------------------------------------------------------------- COMMON /DVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), & & ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, & & RC, RL1, TAU(13), TQ(5), TN, UROUND, & & ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, & & L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, & & LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, & & N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, & & NSLP, NYH COMMON /DVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST C DATA KFC/-3/, KFH/-7/, MXNCF/10/ DATA ADDON /1.0D-6/, BIAS1 /6.0D0/, BIAS2 /6.0D0/, & & BIAS3 /10.0D0/, ETACF /0.25D0/, ETAMIN /0.1D0/, & & ETAMXF /0.2D0/, ETAMX1 /1.0D4/, ETAMX2 /10.0D0/, & & ETAMX3 /10.0D0/, ONEPSM /1.00001D0/, THRESH /1.5D0/ DATA ONE/1.0D0/, ZERO/0.0D0/ C KFLAG = 0 TOLD = TN NCF = 0 JCUR = 0 NFLAG = 0 IF (JSTART .GT. 0) GO TO 20 IF (JSTART .EQ. -1) GO TO 100 C----------------------------------------------------------------------- C On the first call, the order is set to 1, and other variables are C initialized. ETAMAX is the maximum ratio by which H can be increased C in a single step. It is normally 1.5, but is larger during the C first 10 steps to compensate for the small initial H. If a failure C occurs (in corrector convergence or error test), ETAMAX is set to 1 C for the next increase. C----------------------------------------------------------------------- LMAX = MAXORD + 1 NQ = 1 L = 2 NQNYH = NQ*LDYH TAU(1) = H PRL1 = ONE RC = ZERO ETAMAX = ETAMX1 NQWAIT = 2 HSCAL = H GO TO 200 C----------------------------------------------------------------------- C Take preliminary actions on a normal continuation step (JSTART.GT.0). C If the driver changed H, then ETA must be reset and NEWH set to 1. C If a change of order was dictated on the previous step, then C it is done here and appropriate adjustments in the history are made. C On an order decrease, the history array is adjusted by DVJUST. C On an order increase, the history array is augmented by a column. C On a change of step size H, the history array YH is rescaled. C----------------------------------------------------------------------- 20 CONTINUE IF (KUTH .EQ. 1) THEN ETA = MIN(ETA,H/HSCAL) NEWH = 1 ENDIF 50 IF (NEWH .EQ. 0) GO TO 200 IF (NEWQ .EQ. NQ) GO TO 150 IF (NEWQ .LT. NQ) THEN CALL DVJUST (YH, LDYH, -1) NQ = NEWQ L = NQ + 1 NQWAIT = L GO TO 150 ENDIF IF (NEWQ .GT. NQ) THEN CALL DVJUST (YH, LDYH, 1) NQ = NEWQ L = NQ + 1 NQWAIT = L GO TO 150 ENDIF C----------------------------------------------------------------------- C The following block handles preliminaries needed when JSTART = -1. C If N was reduced, zero out part of YH to avoid undefined references. C If MAXORD was reduced to a value less than the tentative order NEWQ, C then NQ is set to MAXORD, and a new H ratio ETA is chosen. C Otherwise, we take the same preliminary actions as for JSTART .gt. 0. C In any case, NQWAIT is reset to L = NQ + 1 to prevent further C changes in order for that many steps. C The new H ratio ETA is limited by the input H if KUTH = 1, C by HMIN if KUTH = 0, and by HMXI in any case. C Finally, the history array YH is rescaled. C----------------------------------------------------------------------- 100 CONTINUE LMAX = MAXORD + 1 IF (N .EQ. LDYH) GO TO 120 I1 = 1 + (NEWQ + 1)*LDYH I2 = (MAXORD + 1)*LDYH IF (I1 .GT. I2) GO TO 120 DO 110 I = I1, I2 YH1(I) = ZERO 110 CONTINUE 120 IF (NEWQ .LE. MAXORD) GO TO 140 FLOTL = REAL(LMAX) IF (MAXORD .LT. NQ-1) THEN DDN = DVNORM (N, SAVF, EWT)/TQ(1) ETA = ONE/((BIAS1*DDN)**(ONE/FLOTL) + ADDON) ENDIF CKS: value ETAQ used before its value defined IF (MAXORD .EQ. NQ .AND. NEWQ .EQ. NQ+1) ETA = ETAQ IF (MAXORD .EQ. NQ-1 .AND. NEWQ .EQ. NQ+1) THEN CKS: value ETAMQ1 used before its value defined ETA = ETAQM1 CALL DVJUST (YH, LDYH, -1) ENDIF IF (MAXORD .EQ. NQ-1 .AND. NEWQ .EQ. NQ) THEN DDN = DVNORM (N, SAVF, EWT)/TQ(1) ETA = ONE/((BIAS1*DDN)**(ONE/FLOTL) + ADDON) CALL DVJUST (YH, LDYH, -1) ENDIF ETA = MIN(ETA,ONE) NQ = MAXORD L = LMAX 140 IF (KUTH .EQ. 1) ETA = MIN(ETA,ABS(H/HSCAL)) IF (KUTH .EQ. 0) ETA = MAX(ETA,HMIN/ABS(HSCAL)) ETA = ETA/MAX(ONE,ABS(HSCAL)*HMXI*ETA) NEWH = 1 NQWAIT = L IF (NEWQ .LE. MAXORD) GO TO 50 C Rescale the history array for a change in H by a factor of ETA. ------ 150 R = ONE DO 180 J = 2, L R = R*ETA CALL DSCAL (N, R, YH(1,J), 1 ) 180 CONTINUE H = HSCAL*ETA HSCAL = H RC = RC*ETA NQNYH = NQ*LDYH C----------------------------------------------------------------------- C This section computes the predicted values by effectively C multiplying the YH array by the Pascal triangle matrix. C DVSET is called to calculate all integration coefficients. C RC is the ratio of new to old values of the coefficient H/EL(2)=h/l1. C----------------------------------------------------------------------- 200 TN = TN + H I1 = NQNYH + 1 DO 220 JB = 1, NQ I1 = I1 - LDYH DO 210 I = I1, NQNYH YH1(I) = YH1(I) + YH1(I+LDYH) 210 CONTINUE 220 CONTINUE CALL DVSET RL1 = ONE/EL(2) RC = RC*(RL1/PRL1) PRL1 = RL1 C C Call the nonlinear system solver. ------------------------------------ C CALL VNLS (Y, YH, LDYH, VSAV, SAVF, EWT, ACOR, IWM, WM, & & F, JAC, PSOL, NFLAG, RPAR, IPAR) C IF (NFLAG .EQ. 0) GO TO 450 C----------------------------------------------------------------------- C The VNLS routine failed to achieve convergence (NFLAG .NE. 0). C The YH array is retracted to its values before prediction. C The step size H is reduced and the step is retried, if possible. C Otherwise, an error exit is taken. C----------------------------------------------------------------------- NCF = NCF + 1 NCFN = NCFN + 1 ETAMAX = ONE TN = TOLD I1 = NQNYH + 1 DO 430 JB = 1, NQ I1 = I1 - LDYH DO 420 I = I1, NQNYH YH1(I) = YH1(I) - YH1(I+LDYH) 420 CONTINUE 430 CONTINUE IF (NFLAG .LT. -1) GO TO 680 IF (ABS(H) .LE. HMIN*ONEPSM) GO TO 670 IF (NCF .EQ. MXNCF) GO TO 670 ETA = ETACF ETA = MAX(ETA,HMIN/ABS(H)) NFLAG = -1 GO TO 150 C----------------------------------------------------------------------- C The corrector has converged (NFLAG = 0). The local error test is C made and control passes to statement 500 if it fails. C----------------------------------------------------------------------- 450 CONTINUE DSM = ACNRM/TQ(2) IF (DSM .GT. ONE) GO TO 500 C----------------------------------------------------------------------- C After a successful step, update the YH and TAU arrays and decrement C NQWAIT. If NQWAIT is then 1 and NQ .lt. MAXORD, then ACOR is saved C for use in a possible order increase on the next step. C If ETAMAX = 1 (a failure occurred this step), keep NQWAIT .ge. 2. C----------------------------------------------------------------------- KFLAG = 0 NST = NST + 1 HU = H NQU = NQ DO 470 IBACK = 1, NQ I = L - IBACK TAU(I+1) = TAU(I) 470 CONTINUE TAU(1) = H DO 480 J = 1, L CALL DAXPY (N, EL(J), ACOR, 1, YH(1,J), 1 ) 480 CONTINUE NQWAIT = NQWAIT - 1 IF ((L .EQ. LMAX) .OR. (NQWAIT .NE. 1)) GO TO 490 CALL DCOPY (N, ACOR, 1, YH(1,LMAX), 1 ) CONP = TQ(5) 490 IF (ETAMAX .NE. ONE) GO TO 560 IF (NQWAIT .LT. 2) NQWAIT = 2 NEWQ = NQ NEWH = 0 ETA = ONE HNEW = H GO TO 690 C----------------------------------------------------------------------- C The error test failed. KFLAG keeps track of multiple failures. C Restore TN and the YH array to their previous values, and prepare C to try the step again. Compute the optimum step size for the C same order. After repeated failures, H is forced to decrease C more rapidly. C----------------------------------------------------------------------- 500 KFLAG = KFLAG - 1 NETF = NETF + 1 NFLAG = -2 TN = TOLD I1 = NQNYH + 1 DO 520 JB = 1, NQ I1 = I1 - LDYH DO 510 I = I1, NQNYH YH1(I) = YH1(I) - YH1(I+LDYH) 510 CONTINUE 520 CONTINUE IF (ABS(H) .LE. HMIN*ONEPSM) GO TO 660 ETAMAX = ONE IF (KFLAG .LE. KFC) GO TO 530 C Compute ratio of new H to current H at the current order. ------------ FLOTL = REAL(L) ETA = ONE/((BIAS2*DSM)**(ONE/FLOTL) + ADDON) ETA = MAX(ETA,HMIN/ABS(H),ETAMIN) IF ((KFLAG .LE. -2) .AND. (ETA .GT. ETAMXF)) ETA = ETAMXF GO TO 150 C----------------------------------------------------------------------- C Control reaches this section if 3 or more consecutive failures C have occurred. It is assumed that the elements of the YH array C have accumulated errors of the wrong order. The order is reduced C by one, if possible. Then H is reduced by a factor of 0.1 and C the step is retried. After a total of 7 consecutive failures, C an exit is taken with KFLAG = -1. C----------------------------------------------------------------------- 530 IF (KFLAG .EQ. KFH) GO TO 660 IF (NQ .EQ. 1) GO TO 540 ETA = MAX(ETAMIN,HMIN/ABS(H)) CALL DVJUST (YH, LDYH, -1) L = NQ NQ = NQ - 1 NQWAIT = L GO TO 150 540 ETA = MAX(ETAMIN,HMIN/ABS(H)) H = H*ETA HSCAL = H TAU(1) = H CALL F (N, TN, Y, SAVF, RPAR, IPAR) NFE = NFE + 1 DO 550 I = 1, N YH(I,2) = H*SAVF(I) 550 CONTINUE NQWAIT = 10 GO TO 200 C----------------------------------------------------------------------- C If NQWAIT = 0, an increase or decrease in order by one is considered. C Factors ETAQ, ETAQM1, ETAQP1 are computed by which H could C be multiplied at order q, q-1, or q+1, respectively. C The largest of these is determined, and the new order and C step size set accordingly. C A change of H or NQ is made only if H increases by at least a C factor of THRESH. If an order change is considered and rejected, C then NQWAIT is set to 2 (reconsider it after 2 steps). C----------------------------------------------------------------------- C Compute ratio of new H to current H at the current order. ------------ 560 FLOTL = REAL(L) ETAQ = ONE/((BIAS2*DSM)**(ONE/FLOTL) + ADDON) IF (NQWAIT .NE. 0) GO TO 600 NQWAIT = 2 ETAQM1 = ZERO IF (NQ .EQ. 1) GO TO 570 C Compute ratio of new H to current H at the current order less one. --- DDN = DVNORM (N, YH(1,L), EWT)/TQ(1) ETAQM1 = ONE/((BIAS1*DDN)**(ONE/(FLOTL - ONE)) + ADDON) 570 ETAQP1 = ZERO IF (L .EQ. LMAX) GO TO 580 C Compute ratio of new H to current H at current order plus one. ------- CNQUOT = (TQ(5)/CONP)*(H/TAU(2))**L DO 575 I = 1, N SAVF(I) = ACOR(I) - CNQUOT*YH(I,LMAX) 575 CONTINUE DUP = DVNORM (N, SAVF, EWT)/TQ(3) ETAQP1 = ONE/((BIAS3*DUP)**(ONE/(FLOTL + ONE)) + ADDON) 580 IF (ETAQ .GE. ETAQP1) GO TO 590 IF (ETAQP1 .GT. ETAQM1) GO TO 620 GO TO 610 590 IF (ETAQ .LT. ETAQM1) GO TO 610 600 ETA = ETAQ NEWQ = NQ GO TO 630 610 ETA = ETAQM1 NEWQ = NQ - 1 GO TO 630 620 ETA = ETAQP1 NEWQ = NQ + 1 CALL DCOPY (N, ACOR, 1, YH(1,LMAX), 1) C Test tentative new H against THRESH, ETAMAX, and HMXI, then exit. ---- 630 IF (ETA .LT. THRESH .OR. ETAMAX .EQ. ONE) GO TO 640 ETA = MIN(ETA,ETAMAX) ETA = ETA/MAX(ONE,ABS(H)*HMXI*ETA) NEWH = 1 HNEW = H*ETA GO TO 690 640 NEWQ = NQ NEWH = 0 ETA = ONE HNEW = H GO TO 690 C----------------------------------------------------------------------- C All returns are made through this section. C On a successful return, ETAMAX is reset and ACOR is scaled. C----------------------------------------------------------------------- 660 KFLAG = -1 GO TO 720 670 KFLAG = -2 GO TO 720 680 IF (NFLAG .EQ. -2) KFLAG = -3 IF (NFLAG .EQ. -3) KFLAG = -4 GO TO 720 690 ETAMAX = ETAMX3 IF (NST .LE. 10) ETAMAX = ETAMX2 R = ONE/TQ(2) CALL DSCAL (N, R, ACOR, 1) 720 JSTART = 1 RETURN C----------------------- End of Subroutine DVSTEP ---------------------- END C*********************************************************************** CDECK DVSET SUBROUTINE DVSET C----------------------------------------------------------------------- C Call sequence communication.. None C COMMON block variables accessed.. C /DVOD01/ -- EL(13), H, TAU(13), TQ(5), L(= NQ + 1), C METH, NQ, NQWAIT C C Subroutines called by DVSET.. None C Function routines called by DVSET.. None C----------------------------------------------------------------------- C DVSET is called by DVSTEP and sets coefficients for use there. C C For each order NQ, the coefficients in EL are calculated by use of C the generating polynomial lambda(x), with coefficients EL(i). C lambda(x) = EL(1) + EL(2)*x + ... + EL(NQ+1)*(x**NQ). C For the backward differentiation formulas, C NQ-1 C lambda(x) = (1 + x/xi*(NQ)) * product (1 + x/xi(i) ) . C i = 1 C For the Adams formulas, C NQ-1 C (d/dx) lambda(x) = c * product (1 + x/xi(i) ) , C i = 1 C lambda(-1) = 0, lambda(0) = 1, C where c is a normalization constant. C In both cases, xi(i) is defined by C H*xi(i) = t sub n - t sub (n-i) C = H + TAU(1) + TAU(2) + ... TAU(i-1). C C C In addition to variables described previously, communication C with DVSET uses the following.. C TAU = A vector of length 13 containing the past NQ values C of H. C EL = A vector of length 13 in which vset stores the C coefficients for the corrector formula. C TQ = A vector of length 5 in which vset stores constants C used for the convergence test, the error test, and the C selection of H at a new order. C METH = The basic method indicator. C NQ = The current order. C L = NQ + 1, the length of the vector stored in EL, and C the number of columns of the YH array being used. C NQWAIT = A counter controlling the frequency of order changes. C An order change is about to be considered if NQWAIT = 1. C----------------------------------------------------------------------- C C Type declarations for labeled COMMON block DVOD01 -------------------- C DOUBLE PRECISION ACNRM, CCMXJ, CONP, CRATE, DRC, EL, & & ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, & & RC, RL1, TAU, TQ, TN, UROUND INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, & & L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, & & LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, & & N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, & & NSLP, NYH C C Type declarations for local variables -------------------------------- C DOUBLE PRECISION AHATN0, ALPH0, CNQM1, CORTES, CSUM, ELP, EM, & & EM0, FLOTI, FLOTL, FLOTNQ, HSUM, ONE, RXI, RXIS, S, SIX, & & T1, T2, T3, T4, T5, T6, TWO, XI, ZERO INTEGER I, IBACK, J, JP1, NQM1, NQM2 C DIMENSION EM(13) C----------------------------------------------------------------------- C The following Fortran-77 declaration is to cause the values of the C listed (local) variables to be saved between calls to this integrator. C----------------------------------------------------------------------- SAVE CORTES, ONE, SIX, TWO, ZERO C COMMON /DVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), & & ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, & & RC, RL1, TAU(13), TQ(5), TN, UROUND, & & ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, & & L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, & & LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, & & N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, & & NSLP, NYH C DATA CORTES /0.1D0/ DATA ONE /1.0D0/, SIX /6.0D0/, TWO /2.0D0/, ZERO /0.0D0/ C FLOTL = REAL(L) NQM1 = NQ - 1 NQM2 = NQ - 2 C GO TO (100, 200), METH SELECT CASE (METH) CASE(1) GOTO 100 CASE(2) GOTO 200 END SELECT C C Set coefficients for Adams methods. ---------------------------------- 100 IF (NQ .NE. 1) GO TO 110 EL(1) = ONE EL(2) = ONE TQ(1) = ONE TQ(2) = TWO TQ(3) = SIX*TQ(2) TQ(5) = ONE GO TO 300 110 HSUM = H EM(1) = ONE FLOTNQ = FLOTL - ONE DO 115 I = 2, L EM(I) = ZERO 115 CONTINUE DO 150 J = 1, NQM1 IF ((J .NE. NQM1) .OR. (NQWAIT .NE. 1)) GO TO 130 S = ONE CSUM = ZERO DO 120 I = 1, NQM1 CSUM = CSUM + S*EM(I)/REAL(I+1) S = -S 120 CONTINUE TQ(1) = EM(NQM1)/(FLOTNQ*CSUM) 130 RXI = H/HSUM DO 140 IBACK = 1, J I = (J + 2) - IBACK EM(I) = EM(I) + EM(I-1)*RXI 140 CONTINUE HSUM = HSUM + TAU(J) 150 CONTINUE C Compute integral from -1 to 0 of polynomial and of x times it. ------- S = ONE EM0 = ZERO CSUM = ZERO DO 160 I = 1, NQ FLOTI = REAL(I) EM0 = EM0 + S*EM(I)/FLOTI CSUM = CSUM + S*EM(I)/(FLOTI+ONE) S = -S 160 CONTINUE C In EL, form coefficients of normalized integrated polynomial. -------- S = ONE/EM0 EL(1) = ONE DO 170 I = 1, NQ EL(I+1) = S*EM(I)/REAL(I) 170 CONTINUE XI = HSUM/H TQ(2) = XI*EM0/CSUM TQ(5) = XI/EL(L) IF (NQWAIT .NE. 1) GO TO 300 C For higher order control constant, multiply polynomial by 1+x/xi(q). - RXI = ONE/XI DO 180 IBACK = 1, NQ I = (L + 1) - IBACK EM(I) = EM(I) + EM(I-1)*RXI 180 CONTINUE C Compute integral of polynomial. -------------------------------------- S = ONE CSUM = ZERO DO 190 I = 1, L CSUM = CSUM + S*EM(I)/REAL(I+1) S = -S 190 CONTINUE TQ(3) = FLOTL*EM0/CSUM GO TO 300 C C Set coefficients for BDF methods. ------------------------------------ 200 DO 210 I = 3, L EL(I) = ZERO 210 CONTINUE EL(1) = ONE EL(2) = ONE ALPH0 = -ONE AHATN0 = -ONE HSUM = H RXI = ONE RXIS = ONE IF (NQ .EQ. 1) GO TO 240 DO 230 J = 1, NQM2 C In EL, construct coefficients of (1+x/xi(1))*...*(1+x/xi(j+1)). ------ HSUM = HSUM + TAU(J) RXI = H/HSUM JP1 = J + 1 ALPH0 = ALPH0 - ONE/REAL(JP1) DO 220 IBACK = 1, JP1 I = (J + 3) - IBACK EL(I) = EL(I) + EL(I-1)*RXI 220 CONTINUE 230 CONTINUE ALPH0 = ALPH0 - ONE/REAL(NQ) RXIS = -EL(2) - ALPH0 HSUM = HSUM + TAU(NQM1) RXI = H/HSUM AHATN0 = -EL(2) - RXI DO 235 IBACK = 1, NQ I = (NQ + 2) - IBACK EL(I) = EL(I) + EL(I-1)*RXIS 235 CONTINUE 240 T1 = ONE - AHATN0 + ALPH0 T2 = ONE + REAL(NQ)*T1 TQ(2) = ABS(ALPH0*T2/T1) TQ(5) = ABS(T2/(EL(L)*RXI/RXIS)) IF (NQWAIT .NE. 1) GO TO 300 CNQM1 = RXIS/EL(L) T3 = ALPH0 + ONE/REAL(NQ) T4 = AHATN0 + RXI ELP = T3/(ONE - T4 + T3) TQ(1) = ABS(ELP/CNQM1) HSUM = HSUM + TAU(NQ) RXI = H/HSUM T5 = ALPH0 - ONE/REAL(NQ+1) T6 = AHATN0 - RXI ELP = T2/(ONE - T6 + T5) TQ(3) = ABS(ELP*RXI*(FLOTL + ONE)*T5) 300 TQ(4) = CORTES*TQ(2) RETURN C----------------------- End of Subroutine DVSET ----------------------- END C*********************************************************************** CDECK DVJUST SUBROUTINE DVJUST (YH, LDYH, IORD) DOUBLE PRECISION YH INTEGER LDYH, IORD DIMENSION YH(LDYH,*) C----------------------------------------------------------------------- C Call sequence input -- YH, LDYH, IORD C Call sequence output -- YH C COMMON block input -- NQ, METH, LMAX, HSCAL, TAU(13), N C COMMON block variables accessed.. C /DVOD01/ -- HSCAL, TAU(13), LMAX, METH, N, NQ, C C Subroutines called by DVJUST.. DAXPY C Function routines called by DVJUST.. None C----------------------------------------------------------------------- C This subroutine adjusts the YH array on reduction of order, C and also when the order is increased for the stiff option (METH = 2). C Communication with DVJUST uses the following.. C IORD = An integer flag used when METH = 2 to indicate an order C increase (IORD = +1) or an order decrease (IORD = -1). C HSCAL = Step size H used in scaling of Nordsieck array YH. C (If IORD = +1, DVJUST assumes that HSCAL = TAU(1).) C See References 1 and 2 for details. C----------------------------------------------------------------------- C C Type declarations for labeled COMMON block DVOD01 -------------------- C DOUBLE PRECISION ACNRM, CCMXJ, CONP, CRATE, DRC, EL, & & ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, & & RC, RL1, TAU, TQ, TN, UROUND INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, & & L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, & & LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, & & N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, & & NSLP, NYH C C Type declarations for local variables -------------------------------- C DOUBLE PRECISION ALPH0, ALPH1, HSUM, ONE, PROD, T1, XI,XIOLD, ZERO INTEGER I, IBACK, J, JP1, LP1, NQM1, NQM2, NQP1 C----------------------------------------------------------------------- C The following Fortran-77 declaration is to cause the values of the C listed (local) variables to be saved between calls to this integrator. C----------------------------------------------------------------------- SAVE ONE, ZERO C COMMON /DVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), & & ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, & & RC, RL1, TAU(13), TQ(5), TN, UROUND, & & ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, & & L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, & & LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, & & N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, & & NSLP, NYH C DATA ONE /1.0D0/, ZERO /0.0D0/ C IF ((NQ .EQ. 2) .AND. (IORD .NE. 1)) RETURN NQM1 = NQ - 1 NQM2 = NQ - 2 C GO TO (100, 200), METH SELECT CASE (METH) CASE(1) GOTO 100 CASE(2) GOTO 200 END SELECT C----------------------------------------------------------------------- C Nonstiff option... C Check to see if the order is being increased or decreased. C----------------------------------------------------------------------- 100 CONTINUE IF (IORD .EQ. 1) GO TO 180 C Order decrease. ------------------------------------------------------ DO 110 J = 1, LMAX EL(J) = ZERO 110 CONTINUE EL(2) = ONE HSUM = ZERO DO 130 J = 1, NQM2 C Construct coefficients of x*(x+xi(1))*...*(x+xi(j)). ----------------- HSUM = HSUM + TAU(J) XI = HSUM/HSCAL JP1 = J + 1 DO 120 IBACK = 1, JP1 I = (J + 3) - IBACK EL(I) = EL(I)*XI + EL(I-1) 120 CONTINUE 130 CONTINUE C Construct coefficients of integrated polynomial. --------------------- DO 140 J = 2, NQM1 EL(J+1) = REAL(NQ)*EL(J)/REAL(J) 140 CONTINUE C Subtract correction terms from YH array. ----------------------------- DO 170 J = 3, NQ DO 160 I = 1, N YH(I,J) = YH(I,J) - YH(I,L)*EL(J) 160 CONTINUE 170 CONTINUE RETURN C Order increase. ------------------------------------------------------ C Zero out next column in YH array. ------------------------------------ 180 CONTINUE LP1 = L + 1 DO 190 I = 1, N YH(I,LP1) = ZERO 190 CONTINUE RETURN C----------------------------------------------------------------------- C Stiff option... C Check to see if the order is being increased or decreased. C----------------------------------------------------------------------- 200 CONTINUE IF (IORD .EQ. 1) GO TO 300 C Order decrease. ------------------------------------------------------ DO 210 J = 1, LMAX EL(J) = ZERO 210 CONTINUE EL(3) = ONE HSUM = ZERO DO 230 J = 1,NQM2 C Construct coefficients of x*x*(x+xi(1))*...*(x+xi(j)). --------------- HSUM = HSUM + TAU(J) XI = HSUM/HSCAL JP1 = J + 1 DO 220 IBACK = 1, JP1 I = (J + 4) - IBACK EL(I) = EL(I)*XI + EL(I-1) 220 CONTINUE 230 CONTINUE C Subtract correction terms from YH array. ----------------------------- DO 250 J = 3,NQ DO 240 I = 1, N YH(I,J) = YH(I,J) - YH(I,L)*EL(J) 240 CONTINUE 250 CONTINUE RETURN C Order increase. ------------------------------------------------------ 300 DO 310 J = 1, LMAX EL(J) = ZERO 310 CONTINUE EL(3) = ONE ALPH0 = -ONE ALPH1 = ONE PROD = ONE XIOLD = ONE HSUM = HSCAL IF (NQ .EQ. 1) GO TO 340 DO 330 J = 1, NQM1 C Construct coefficients of x*x*(x+xi(1))*...*(x+xi(j)). --------------- JP1 = J + 1 HSUM = HSUM + TAU(JP1) XI = HSUM/HSCAL PROD = PROD*XI ALPH0 = ALPH0 - ONE/REAL(JP1) ALPH1 = ALPH1 + ONE/XI DO 320 IBACK = 1, JP1 I = (J + 4) - IBACK EL(I) = EL(I)*XIOLD + EL(I-1) 320 CONTINUE XIOLD = XI 330 CONTINUE 340 CONTINUE T1 = (-ALPH0 - ALPH1)/PROD C Load column L + 1 in YH array. --------------------------------------- LP1 = L + 1 DO 350 I = 1, N YH(I,LP1) = T1*YH(I,LMAX) 350 CONTINUE C Add correction terms to YH array. ------------------------------------ NQP1 = NQ + 1 DO 370 J = 3, NQP1 CALL DAXPY (N, EL(J), YH(1,LP1), 1, YH(1,J), 1 ) 370 CONTINUE RETURN C----------------------- End of Subroutine DVJUST ---------------------- END C*********************************************************************** CDECK DVNLSD SUBROUTINE DVNLSD (Y, YH, LDYH, VSAV, SAVF, EWT, ACOR, IWM, WM, & & F, JAC, PDUM, NFLAG, RPAR, IPAR) EXTERNAL F, JAC, PDUM DOUBLE PRECISION Y, YH, VSAV, SAVF, EWT, ACOR, WM, RPAR INTEGER LDYH, IWM, NFLAG, IPAR DIMENSION Y(*), YH(LDYH,*), VSAV(*), SAVF(*), EWT(*), ACOR(*), & & IWM(*), WM(*), RPAR(*), IPAR(*) C----------------------------------------------------------------------- C Call sequence input -- Y, YH, LDYH, SAVF, EWT, ACOR, IWM, WM, C F, JAC, NFLAG, RPAR, IPAR C Call sequence output -- YH, ACOR, WM, IWM, NFLAG C COMMON block variables accessed.. C /DVOD01/ ACNRM, CRATE, DRC, H, RC, RL1, TQ(5), TN, ICF, C JCUR, METH, MITER, N, NSLP C /DVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST C C Subroutines called by DVNLSD.. F, DAXPY, DCOPY, DSCAL, DVJAC, DVSOL C Function routines called by DVNLSD.. DVNORM C----------------------------------------------------------------------- C Subroutine DVNLSD is a nonlinear system solver, which uses functional C iteration or a chord (modified Newton) method. For the chord method C direct linear algebraic system solvers are used. Subroutine DVNLSD C then handles the corrector phase of this integration package. C C Communication with DVNLSD is done with the following variables. (For C more details, please see the comments in the driver subroutine.) C C Y = The dependent variable, a vector of length N, input. C YH = The Nordsieck (Taylor) array, LDYH by LMAX, input C and output. On input, it contains predicted values. C LDYH = A constant .ge. N, the first dimension of YH, input. C VSAV = Unused work array. C SAVF = A work array of length N. C EWT = An error weight vector of length N, input. C ACOR = A work array of length N, used for the accumulated C corrections to the predicted y vector. C WM,IWM = Real and integer work arrays associated with matrix C operations in chord iteration (MITER .ne. 0). C F = Dummy name for user supplied routine for f. C JAC = Dummy name for user supplied Jacobian routine. C PDUM = Unused dummy subroutine name. Included for uniformity C over collection of integrators. C NFLAG = Input/output flag, with values and meanings as follows.. C INPUT C 0 first call for this time step. C -1 convergence failure in previous call to DVNLSD. C -2 error test failure in DVSTEP. C OUTPUT C 0 successful completion of nonlinear solver. C -1 convergence failure or singular matrix. C -2 unrecoverable error in matrix preprocessing C (cannot occur here). C -3 unrecoverable error in solution (cannot occur C here). C RPAR, IPAR = Dummy names for user's real and integer work arrays. C C IPUP = Own variable flag with values and meanings as follows.. C 0, do not update the Newton matrix. C MITER .ne. 0, update Newton matrix, because it is the C initial step, order was changed, the error C test failed, or an update is indicated by C the scalar RC or step counter NST. C C For more details, see comments in driver subroutine. C----------------------------------------------------------------------- C Type declarations for labeled COMMON block DVOD01 -------------------- C DOUBLE PRECISION ACNRM, CCMXJ, CONP, CRATE, DRC, EL, & & ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, & & RC, RL1, TAU, TQ, TN, UROUND INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, & & L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, & & LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, & & N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, & & NSLP, NYH C C Type declarations for labeled COMMON block DVOD02 -------------------- C DOUBLE PRECISION HU INTEGER NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST C C Type declarations for local variables -------------------------------- C DOUBLE PRECISION CCMAX, CRDOWN, CSCALE, DCON, DEL, DELP, ONE, & & RDIV, TWO, ZERO INTEGER I, IERPJ, IERSL, M, MAXCOR, MSBP C C Type declaration for function subroutines called --------------------- C DOUBLE PRECISION DVNORM C----------------------------------------------------------------------- C The following Fortran-77 declaration is to cause the values of the C listed (local) variables to be saved between calls to this integrator. C----------------------------------------------------------------------- SAVE CCMAX, CRDOWN, MAXCOR, MSBP, RDIV, ONE, TWO, ZERO C COMMON /DVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), & & ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, & & RC, RL1, TAU(13), TQ(5), TN, UROUND, & & ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, & & L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, & & LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, & & N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, & & NSLP, NYH COMMON /DVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST C DATA CCMAX /0.3D0/, CRDOWN /0.3D0/, MAXCOR /3/, MSBP /20/, & & RDIV /2.0D0/ DATA ONE /1.0D0/, TWO /2.0D0/, ZERO /0.0D0/ C----------------------------------------------------------------------- C On the first step, on a change of method order, or after a C nonlinear convergence failure with NFLAG = -2, set IPUP = MITER C to force a Jacobian update when MITER .ne. 0. C----------------------------------------------------------------------- IF (JSTART .EQ. 0) NSLP = 0 IF (NFLAG .EQ. 0) ICF = 0 IF (NFLAG .EQ. -2) IPUP = MITER IF ( (JSTART .EQ. 0) .OR. (JSTART .EQ. -1) ) IPUP = MITER C If this is functional iteration, set CRATE .eq. 1 and drop to 220 IF (MITER .EQ. 0) THEN CRATE = ONE GO TO 220 ENDIF C----------------------------------------------------------------------- C RC is the ratio of new to old values of the coefficient H/EL(2)=h/l1. C When RC differs from 1 by more than CCMAX, IPUP is set to MITER C to force DVJAC to be called, if a Jacobian is involved. C In any case, DVJAC is called at least every MSBP steps. C----------------------------------------------------------------------- DRC = ABS(RC-ONE) IF (DRC .GT. CCMAX .OR. NST .GE. NSLP+MSBP) IPUP = MITER C----------------------------------------------------------------------- C Up to MAXCOR corrector iterations are taken. A convergence test is C made on the r.m.s. norm of each correction, weighted by the error C weight vector EWT. The sum of the corrections is accumulated in the C vector ACOR(i). The YH array is not altered in the corrector loop. C----------------------------------------------------------------------- 220 M = 0 DELP = ZERO CALL DCOPY (N, YH(1,1), 1, Y, 1 ) CALL F (N, TN, Y, SAVF, RPAR, IPAR) NFE = NFE + 1 IF (IPUP .LE. 0) GO TO 250 C----------------------------------------------------------------------- C If indicated, the matrix P = I - h*rl1*J is reevaluated and C preprocessed before starting the corrector iteration. IPUP is set C to 0 as an indicator that this has been done. C----------------------------------------------------------------------- CALL DVJAC (Y, YH, LDYH, EWT, ACOR, SAVF, WM, IWM, F, JAC, IERPJ, & & RPAR, IPAR) IPUP = 0 RC = ONE DRC = ZERO CRATE = ONE NSLP = NST C If matrix is singular, take error return to force cut in step size. -- IF (IERPJ .NE. 0) GO TO 430 250 DO 260 I = 1,N ACOR(I) = ZERO 260 CONTINUE C This is a looping point for the corrector iteration. ----------------- 270 IF (MITER .NE. 0) GO TO 350 C----------------------------------------------------------------------- C In the case of functional iteration, update Y directly from C the result of the last function evaluation. C----------------------------------------------------------------------- DO 280 I = 1,N SAVF(I) = RL1*(H*SAVF(I) - YH(I,2)) 280 CONTINUE DO 290 I = 1,N Y(I) = SAVF(I) - ACOR(I) 290 CONTINUE DEL = DVNORM (N, Y, EWT) DO 300 I = 1,N Y(I) = YH(I,1) + SAVF(I) 300 CONTINUE CALL DCOPY (N, SAVF, 1, ACOR, 1) GO TO 400 C----------------------------------------------------------------------- C In the case of the chord method, compute the corrector error, C and solve the linear system with that as right-hand side and C P as coefficient matrix. The correction is scaled by the factor C 2/(1+RC) to account for changes in h*rl1 since the last DVJAC call. C----------------------------------------------------------------------- 350 DO 360 I = 1,N Y(I) = (RL1*H)*SAVF(I) - (RL1*YH(I,2) + ACOR(I)) 360 CONTINUE CALL DVSOL (WM, IWM, Y, IERSL) NNI = NNI + 1 IF (IERSL .GT. 0) GO TO 410 IF (METH .EQ. 2 .AND. RC .NE. ONE) THEN CSCALE = TWO/(ONE + RC) CALL DSCAL (N, CSCALE, Y, 1) ENDIF DEL = DVNORM (N, Y, EWT) CALL DAXPY (N, ONE, Y, 1, ACOR, 1) DO 380 I = 1,N Y(I) = YH(I,1) + ACOR(I) 380 CONTINUE C----------------------------------------------------------------------- C Test for convergence. If M .gt. 0, an estimate of the convergence C rate constant is stored in CRATE, and this is used in the test. C----------------------------------------------------------------------- 400 IF (M .NE. 0) CRATE = MAX(CRDOWN*CRATE,DEL/DELP) DCON = DEL*MIN(ONE,CRATE)/TQ(4) IF (DCON .LE. ONE) GO TO 450 M = M + 1 IF (M .EQ. MAXCOR) GO TO 410 IF (M .GE. 2 .AND. DEL .GT. RDIV*DELP) GO TO 410 DELP = DEL CALL F (N, TN, Y, SAVF, RPAR, IPAR) NFE = NFE + 1 GO TO 270 C 410 IF (MITER .EQ. 0 .OR. JCUR .EQ. 1) GO TO 430 ICF = 1 IPUP = MITER GO TO 220 C 430 CONTINUE NFLAG = -1 ICF = 2 IPUP = MITER RETURN C C Return for successful step. ------------------------------------------ 450 NFLAG = 0 JCUR = 0 ICF = 0 IF (M .EQ. 0) ACNRM = DEL IF (M .GT. 0) ACNRM = DVNORM (N, ACOR, EWT) RETURN C----------------------- End of Subroutine DVNLSD ---------------------- END C*********************************************************************** CDECK DVJAC SUBROUTINE DVJAC (Y, YH, LDYH, EWT, FTEM, SAVF, WM, IWM, F, JAC, & & IERPJ, RPAR, IPAR) EXTERNAL F, JAC DOUBLE PRECISION Y, YH, EWT, FTEM, SAVF, WM, RPAR INTEGER LDYH, IWM, IERPJ, IPAR DIMENSION Y(*), YH(LDYH,*), EWT(*), FTEM(*), SAVF(*), & & WM(*), IWM(*), RPAR(*), IPAR(*) C----------------------------------------------------------------------- C Call sequence input -- Y, YH, LDYH, EWT, FTEM, SAVF, WM, IWM, C F, JAC, RPAR, IPAR C Call sequence output -- WM, IWM, IERPJ C COMMON block variables accessed.. C /DVOD01/ CCMXJ, DRC, H, RL1, TN, UROUND, ICF, JCUR, LOCJS, C MSBJ, NSLJ C /DVOD02/ NFE, NST, NJE, NLU C C Subroutines called by DVJAC.. F, JAC, DACOPY, DCOPY, DGBFA, DGEFA, C DSCAL C Function routines called by DVJAC.. DVNORM C----------------------------------------------------------------------- C DVJAC is called by DVSTEP to compute and process the matrix C P = I - h*rl1*J , where J is an approximation to the Jacobian. C Here J is computed by the user-supplied routine JAC if C MITER = 1 or 4, or by finite differencing if MITER = 2, 3, or 5. C If MITER = 3, a diagonal approximation to J is used. C If JSV = -1, J is computed from scratch in all cases. C If JSV = 1 and MITER = 1, 2, 4, or 5, and if the saved value of J is C considered acceptable, then P is constructed from the saved J. C J is stored in wm and replaced by P. If MITER .ne. 3, P is then C subjected to LU decomposition in preparation for later solution C of linear systems with P as coefficient matrix. This is done C by DGEFA if MITER = 1 or 2, and by DGBFA if MITER = 4 or 5. C C Communication with DVJAC is done with the following variables. (For C more details, please see the comments in the driver subroutine.) C Y = Vector containing predicted values on entry. C YH = The Nordsieck array, an LDYH by LMAX array, input. C LDYH = A constant .ge. N, the first dimension of YH, input. C EWT = An error weight vector of length N. C SAVF = Array containing f evaluated at predicted y, input. C WM = Real work space for matrices. In the output, it containS C the inverse diagonal matrix if MITER = 3 and the LU C decomposition of P if MITER is 1, 2 , 4, or 5. C Storage of matrix elements starts at WM(3). C Storage of the saved Jacobian starts at WM(LOCJS). C WM also contains the following matrix-related data.. C WM(1) = SQRT(UROUND), used in numerical Jacobian step. C WM(2) = H*RL1, saved for later use if MITER = 3. C IWM = Integer work space containing pivot information, C starting at IWM(31), if MITER is 1, 2, 4, or 5. C IWM also contains band parameters ML = IWM(1) and C MU = IWM(2) if MITER is 4 or 5. C F = Dummy name for the user supplied subroutine for f. C JAC = Dummy name for the user supplied Jacobian subroutine. C RPAR, IPAR = Dummy names for user's real and integer work arrays. C RL1 = 1/EL(2) (input). C IERPJ = Output error flag, = 0 if no trouble, 1 if the P C matrix is found to be singular. C JCUR = Output flag to indicate whether the Jacobian matrix C (or approximation) is now current. C JCUR = 0 means J is not current. C JCUR = 1 means J is current. C----------------------------------------------------------------------- C C Type declarations for labeled COMMON block DVOD01 -------------------- C DOUBLE PRECISION ACNRM, CCMXJ, CONP, CRATE, DRC, EL, & & ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, & & RC, RL1, TAU, TQ, TN, UROUND INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, & & L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, & & LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, & & N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, & & NSLP, NYH C C Type declarations for labeled COMMON block DVOD02 -------------------- C DOUBLE PRECISION HU INTEGER NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST C C Type declarations for local variables -------------------------------- C DOUBLE PRECISION CON, DI, FAC, HRL1, ONE, PT1, R, R0, SRUR, THOU, & & YI, YJ, YJJ, ZERO INTEGER I, I1, I2, IER, II, J, J1, JJ, JOK, LENP, MBA, MBAND, & & MEB1, MEBAND, ML, ML3, MU, NP1 C C Type declaration for function subroutines called --------------------- C DOUBLE PRECISION DVNORM C----------------------------------------------------------------------- C The following Fortran-77 declaration is to cause the values of the C listed (local) variables to be saved between calls to this subroutine. C----------------------------------------------------------------------- SAVE ONE, PT1, THOU, ZERO C----------------------------------------------------------------------- COMMON /DVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), & & ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, & & RC, RL1, TAU(13), TQ(5), TN, UROUND, & & ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, & & L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, & & LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, & & N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, & & NSLP, NYH COMMON /DVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST C DATA ONE /1.0D0/, THOU /1000.0D0/, ZERO /0.0D0/, PT1 /0.1D0/ C IERPJ = 0 HRL1 = H*RL1 C See whether J should be evaluated (JOK = -1) or not (JOK = 1). ------- JOK = JSV IF (JSV .EQ. 1) THEN IF (NST .EQ. 0 .OR. NST .GT. NSLJ+MSBJ) JOK = -1 IF (ICF .EQ. 1 .AND. DRC .LT. CCMXJ) JOK = -1 IF (ICF .EQ. 2) JOK = -1 ENDIF C End of setting JOK. -------------------------------------------------- C IF (JOK .EQ. -1 .AND. MITER .EQ. 1) THEN C If JOK = -1 and MITER = 1, call JAC to evaluate Jacobian. ------------ NJE = NJE + 1 NSLJ = NST JCUR = 1 LENP = N*N DO 110 I = 1,LENP WM(I+2) = ZERO 110 CONTINUE CALL JAC (N, TN, Y, 0, 0, WM(3), N, RPAR, IPAR) IF (JSV .EQ. 1) CALL DCOPY (LENP, WM(3), 1, WM(LOCJS), 1) ENDIF C IF (JOK .EQ. -1 .AND. MITER .EQ. 2) THEN C If MITER = 2, make N calls to F to approximate the Jacobian. --------- NJE = NJE + 1 NSLJ = NST JCUR = 1 FAC = DVNORM (N, SAVF, EWT) R0 = THOU*ABS(H)*UROUND*REAL(N)*FAC IF (R0 .EQ. ZERO) R0 = ONE SRUR = WM(1) J1 = 2 DO 230 J = 1,N YJ = Y(J) R = MAX(SRUR*ABS(YJ),R0/EWT(J)) Y(J) = Y(J) + R FAC = ONE/R CALL F (N, TN, Y, FTEM, RPAR, IPAR) DO 220 I = 1,N WM(I+J1) = (FTEM(I) - SAVF(I))*FAC 220 CONTINUE Y(J) = YJ J1 = J1 + N 230 CONTINUE NFE = NFE + N LENP = N*N IF (JSV .EQ. 1) CALL DCOPY (LENP, WM(3), 1, WM(LOCJS), 1) ENDIF C IF (JOK .EQ. 1 .AND. (MITER .EQ. 1 .OR. MITER .EQ. 2)) THEN JCUR = 0 LENP = N*N CALL DCOPY (LENP, WM(LOCJS), 1, WM(3), 1) ENDIF C IF (MITER .EQ. 1 .OR. MITER .EQ. 2) THEN C Multiply Jacobian by scalar, add identity, and do LU decomposition. -- CON = -HRL1 CALL DSCAL (LENP, CON, WM(3), 1) J = 3 NP1 = N + 1 DO 250 I = 1,N WM(J) = WM(J) + ONE J = J + NP1 250 CONTINUE NLU = NLU + 1 CALL DGEFA (WM(3), N, N, IWM(31), IER) IF (IER .NE. 0) IERPJ = 1 RETURN ENDIF C End of code block for MITER = 1 or 2. -------------------------------- C IF (MITER .EQ. 3) THEN C If MITER = 3, construct a diagonal approximation to J and P. --------- NJE = NJE + 1 JCUR = 1 WM(2) = HRL1 R = RL1*PT1 DO 310 I = 1,N Y(I) = Y(I) + R*(H*SAVF(I) - YH(I,2)) 310 CONTINUE CALL F (N, TN, Y, WM(3), RPAR, IPAR) NFE = NFE + 1 DO 320 I = 1,N R0 = H*SAVF(I) - YH(I,2) DI = PT1*R0 - H*(WM(I+2) - SAVF(I)) WM(I+2) = ONE IF (ABS(R0) .LT. UROUND/EWT(I)) GO TO 320 IF (ABS(DI) .EQ. ZERO) GO TO 330 WM(I+2) = PT1*R0/DI 320 CONTINUE RETURN 330 IERPJ = 1 RETURN ENDIF C End of code block for MITER = 3. ------------------------------------- C C Set constants for MITER = 4 or 5. ------------------------------------ ML = IWM(1) MU = IWM(2) ML3 = ML + 3 MBAND = ML + MU + 1 MEBAND = MBAND + ML LENP = MEBAND*N C IF (JOK .EQ. -1 .AND. MITER .EQ. 4) THEN C If JOK = -1 and MITER = 4, call JAC to evaluate Jacobian. ------------ NJE = NJE + 1 NSLJ = NST JCUR = 1 DO 410 I = 1,LENP WM(I+2) = ZERO 410 CONTINUE CALL JAC (N, TN, Y, ML, MU, WM(ML3), MEBAND, RPAR, IPAR) IF (JSV .EQ. 1) & & CALL DACOPY (MBAND, N, WM(ML3), MEBAND, WM(LOCJS), MBAND) ENDIF C IF (JOK .EQ. -1 .AND. MITER .EQ. 5) THEN C If MITER = 5, make N calls to F to approximate the Jacobian. --------- NJE = NJE + 1 NSLJ = NST JCUR = 1 MBA = MIN(MBAND,N) MEB1 = MEBAND - 1 SRUR = WM(1) FAC = DVNORM (N, SAVF, EWT) R0 = THOU*ABS(H)*UROUND*REAL(N)*FAC IF (R0 .EQ. ZERO) R0 = ONE DO 560 J = 1,MBA DO 530 I = J,N,MBAND YI = Y(I) R = MAX(SRUR*ABS(YI),R0/EWT(I)) Y(I) = Y(I) + R 530 CONTINUE CALL F (N, TN, Y, FTEM, RPAR, IPAR) DO 550 JJ = J,N,MBAND Y(JJ) = YH(JJ,1) YJJ = Y(JJ) R = MAX(SRUR*ABS(YJJ),R0/EWT(JJ)) FAC = ONE/R I1 = MAX(JJ-MU,1) I2 = MIN(JJ+ML,N) II = JJ*MEB1 - ML + 2 DO 540 I = I1,I2 WM(II+I) = (FTEM(I) - SAVF(I))*FAC 540 CONTINUE 550 CONTINUE 560 CONTINUE NFE = NFE + MBA IF (JSV .EQ. 1) & & CALL DACOPY (MBAND, N, WM(ML3), MEBAND, WM(LOCJS), MBAND) ENDIF C IF (JOK .EQ. 1) THEN JCUR = 0 CALL DACOPY (MBAND, N, WM(LOCJS), MBAND, WM(ML3), MEBAND) ENDIF C C Multiply Jacobian by scalar, add identity, and do LU decomposition. CON = -HRL1 CALL DSCAL (LENP, CON, WM(3), 1 ) II = MBAND + 2 DO 580 I = 1,N WM(II) = WM(II) + ONE II = II + MEBAND 580 CONTINUE NLU = NLU + 1 CALL DGBFA (WM(3), MEBAND, N, ML, MU, IWM(31), IER) IF (IER .NE. 0) IERPJ = 1 RETURN C End of code block for MITER = 4 or 5. -------------------------------- C C----------------------- End of Subroutine DVJAC ----------------------- END C*********************************************************************** CDECK DACOPY SUBROUTINE DACOPY (NROW, NCOL, A, NROWA, B, NROWB) DOUBLE PRECISION A, B INTEGER NROW, NCOL, NROWA, NROWB DIMENSION A(NROWA,NCOL), B(NROWB,NCOL) C----------------------------------------------------------------------- C Call sequence input -- NROW, NCOL, A, NROWA, NROWB C Call sequence output -- B C COMMON block variables accessed -- None C C Subroutines called by DACOPY.. DCOPY C Function routines called by DACOPY.. None C----------------------------------------------------------------------- C This routine copies one rectangular array, A, to another, B, C where A and B may have different row dimensions, NROWA and NROWB. C The data copied consists of NROW rows and NCOL columns. C----------------------------------------------------------------------- INTEGER IC C DO 20 IC = 1,NCOL CALL DCOPY (NROW, A(1,IC), 1, B(1,IC), 1) 20 CONTINUE C RETURN C----------------------- End of Subroutine DACOPY ---------------------- END C*********************************************************************** CDECK DVSOL SUBROUTINE DVSOL (WM, IWM, X, IERSL) DOUBLE PRECISION WM, X INTEGER IWM, IERSL DIMENSION WM(*), IWM(*), X(*) C----------------------------------------------------------------------- C Call sequence input -- WM, IWM, X C Call sequence output -- X, IERSL C COMMON block variables accessed.. C /DVOD01/ -- H, RL1, MITER, N C C Subroutines called by DVSOL.. DGESL, DGBSL C Function routines called by DVSOL.. None C----------------------------------------------------------------------- C This routine manages the solution of the linear system arising from C a chord iteration. It is called if MITER .ne. 0. C If MITER is 1 or 2, it calls DGESL to accomplish this. C If MITER = 3 it updates the coefficient H*RL1 in the diagonal C matrix, and then computes the solution. C If MITER is 4 or 5, it calls DGBSL. C Communication with DVSOL uses the following variables.. C WM = Real work space containing the inverse diagonal matrix if C MITER = 3 and the LU decomposition of the matrix otherwise. C Storage of matrix elements starts at WM(3). C WM also contains the following matrix-related data.. C WM(1) = SQRT(UROUND) (not used here), C WM(2) = HRL1, the previous value of H*RL1, used if MITER = 3. C IWM = Integer work space containing pivot information, starting at C IWM(31), if MITER is 1, 2, 4, or 5. IWM also contains band C parameters ML = IWM(1) and MU = IWM(2) if MITER is 4 or 5. C X = The right-hand side vector on input, and the solution vector C on output, of length N. C IERSL = Output flag. IERSL = 0 if no trouble occurred. C IERSL = 1 if a singular matrix arose with MITER = 3. C----------------------------------------------------------------------- C C Type declarations for labeled COMMON block DVOD01 -------------------- C DOUBLE PRECISION ACNRM, CCMXJ, CONP, CRATE, DRC, EL, & & ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, & & RC, RL1, TAU, TQ, TN, UROUND INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, & & L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, & & LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, & & N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, & & NSLP, NYH C C Type declarations for local variables -------------------------------- C INTEGER I, MEBAND, ML, MU DOUBLE PRECISION DI, HRL1, ONE, PHRL1, R, ZERO C----------------------------------------------------------------------- C The following Fortran-77 declaration is to cause the values of the C listed (local) variables to be saved between calls to this integrator. C----------------------------------------------------------------------- SAVE ONE, ZERO C COMMON /DVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), & & ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, & & RC, RL1, TAU(13), TQ(5), TN, UROUND, & & ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, & & L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, & & LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, & & N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, & & NSLP, NYH C DATA ONE /1.0D0/, ZERO /0.0D0/ C IERSL = 0 C GO TO (100, 100, 300, 400, 400), MITER SELECT CASE (MITER) CASE(1) GOTO 100 CASE(2) GOTO 100 CASE(3) GOTO 300 CASE(4) GOTO 400 CASE(5) GOTO 400 END SELECT 100 CALL DGESL (WM(3), N, N, IWM(31), X, 0) RETURN C 300 PHRL1 = WM(2) HRL1 = H*RL1 WM(2) = HRL1 IF (HRL1 .EQ. PHRL1) GO TO 330 R = HRL1/PHRL1 DO 320 I = 1,N DI = ONE - R*(ONE - ONE/WM(I+2)) IF (ABS(DI) .EQ. ZERO) GO TO 390 WM(I+2) = ONE/DI 320 CONTINUE C 330 DO 340 I = 1,N X(I) = WM(I+2)*X(I) 340 CONTINUE RETURN 390 IERSL = 1 RETURN C 400 ML = IWM(1) MU = IWM(2) MEBAND = 2*ML + MU + 1 CALL DGBSL (WM(3), MEBAND, N, ML, MU, IWM(31), X, 0) RETURN C----------------------- End of Subroutine DVSOL ----------------------- END C******************************************************************** C of xidamax C******************************************************************** C of xDscal C******************************************************************** C of xdaxpy C******************************************************************** C of xDDOT C*********************************************************************** deSolve/src/call_euler.c0000754000175100001440000001440213131751003014730 0ustar hornikusers/*==========================================================================*/ /* Runge-Kutta Solvers, (C) Th. Petzoldt, License: GPL >=2 */ /* Euler Fixed Step Integrator */ /* (special version with less overhead than the general solution) */ /*==========================================================================*/ #include "rk_util.h" SEXP call_euler(SEXP Xstart, SEXP Times, SEXP Func, SEXP Initfunc, SEXP Parms, SEXP Nout, SEXP Rho, SEXP Verbose, SEXP Rpar, SEXP Ipar, SEXP Flist) { /* Initialization */ long int old_N_Protect = save_N_Protected(); double *tt = NULL, *xs = NULL; double *tmp, *FF, *out; SEXP R_f, R_y0, R_yout; double *f, *y0, *yout; double t, dt; int i = 0, j=0, it=0, nt = 0, neq=0; int isForcing; /*------------------------------------------------------------------------*/ /* Processing of Arguments */ /*------------------------------------------------------------------------*/ PROTECT(Times = AS_NUMERIC(Times)); incr_N_Protect(); tt = NUMERIC_POINTER(Times); nt = length(Times); PROTECT(Xstart = AS_NUMERIC(Xstart)); incr_N_Protect(); xs = NUMERIC_POINTER(Xstart); neq = length(Xstart); tmp = (double *) R_alloc(neq, sizeof(double)); FF = (double *) R_alloc(neq, sizeof(double)); int nout = INTEGER(Nout)[0]; /* n of global outputs if func is in a DLL */ int verbose = INTEGER(Verbose)[0]; /*------------------------------------------------------------------------*/ /* timesteps (for advection computation in ReacTran) */ /*------------------------------------------------------------------------*/ for (i = 0; i < 2; i++) timesteps[i] = tt[1] - tt[0]; /*------------------------------------------------------------------------*/ /* DLL, ipar, rpar (for compatibility with lsoda) */ /*------------------------------------------------------------------------*/ int isDll = FALSE; //int ntot = 0; int lrpar= 0, lipar = 0; int *ipar = NULL; if (inherits(Func, "NativeSymbol")) { /* function is a dll */ isDll = TRUE; if (nout > 0) isOut = TRUE; //ntot = neq + nout; /* length of yout */ lrpar = nout + LENGTH(Rpar); /* length of rpar; LENGTH(Rpar) is always >0 */ lipar = 3 + LENGTH(Ipar); /* length of ipar */ } else { /* function is not a dll */ isDll = FALSE; isOut = FALSE; //ntot = neq; lipar = 3; /* in lsoda = 1; */ lrpar = nout; /* in lsoda = 1; */ } out = (double *) R_alloc(lrpar, sizeof(double)); ipar = (int *) R_alloc(lipar, sizeof(int)); ipar[0] = nout; /* first 3 elements of ipar are special */ ipar[1] = lrpar; ipar[2] = lipar; if (isDll == 1) { /* other elements of ipar are set in R-function lsodx via argument *ipar* */ for (j = 0; j < LENGTH(Ipar); j++) ipar[j+3] = INTEGER(Ipar)[j]; /* out: first nout elements of out are reserved for output variables other elements are set via argument *rpar* */ for (j = 0; j < nout; j++) out[j] = 0.0; for (j = 0; j < LENGTH(Rpar); j++) out[nout+j] = REAL(Rpar)[j]; } /*------------------------------------------------------------------------*/ /* Allocation of Workspace */ /*------------------------------------------------------------------------*/ PROTECT(R_y0 = allocVector(REALSXP, neq)); incr_N_Protect(); PROTECT(R_f = allocVector(REALSXP, neq)); incr_N_Protect(); y0 = REAL(R_y0); f = REAL(R_f); /* matrix for holding the outputs */ PROTECT(R_yout = allocMatrix(REALSXP, nt, neq + nout + 1)); incr_N_Protect(); yout = REAL(R_yout); /* attribute that stores state information, similar to lsoda */ SEXP R_istate; int *istate; PROTECT(R_istate = allocVector(INTSXP, 22)); incr_N_Protect(); istate = INTEGER(R_istate); istate[0] = 0; /* assume succesful return */ for (i = 0; i < 22; i++) istate[i] = 0; /*------------------------------------------------------------------------*/ /* Initialization of Parameters (for DLL functions) */ /*------------------------------------------------------------------------*/ initParms(Initfunc, Parms); isForcing = initForcings(Flist); /*------------------------------------------------------------------------*/ /* Initialization of Integration Loop */ /*------------------------------------------------------------------------*/ yout[0] = tt[0]; /* initial time */ for (i = 0; i < neq; i++) { y0[i] = xs[i]; yout[(i + 1) * nt] = y0[i]; } /*------------------------------------------------------------------------*/ /* Main Loop */ /*------------------------------------------------------------------------*/ for (it = 0; it < nt - 1; it++) { t = tt[it]; dt = tt[it + 1] - t; timesteps[0] = timesteps[1]; timesteps[1] = dt; if (verbose) Rprintf("Time steps = %d / %d time = %e\n", it + 1, nt, t); derivs(Func, t, y0, Parms, Rho, f, out, 0, neq, ipar, isDll, isForcing); for (i = 0; i < neq; i++) { y0[i] = y0[i] + dt * f[i]; } /* store outputs */ if (it < nt) { yout[it + 1] = t + dt; for (i = 0; i < neq; i++) yout[it + 1 + nt * (1 + i)] = y0[i]; } } /* end of main loop */ /*------------------------------------------------------------------------*/ /* call derivs again to get global outputs */ /*------------------------------------------------------------------------*/ if(nout > 0) { for (int j = 0; j < nt; j++) { t = yout[j]; for (i = 0; i < neq; i++) tmp[i] = yout[j + nt * (1 + i)]; derivs(Func, t, tmp, Parms, Rho, FF, out, -1, neq, ipar, isDll, isForcing); for (i = 0; i < nout; i++) { yout[j + nt * (1 + neq + i)] = out[i]; } } } /* attach diagnostic information (codes are compatible to lsoda) */ setIstate(R_yout, R_istate, istate, it, 1, 0, 1, 0); timesteps[0] = 0; timesteps[1] = 0; restore_N_Protected(old_N_Protect); return(R_yout); } deSolve/src/rk_auto.c0000754000175100001440000002177413131751003014277 0ustar hornikusers/*==========================================================================*/ /* Runge-Kutta Solvers, (C) Th. Petzoldt, License: GPL >= 2 */ /* General RK Solver for methods with adaptive step size */ /* -- main loop == core function -- */ /* Parts inspired by Press et al., 2002, 2007; */ /* see vignette for full references */ /*==========================================================================*/ #include "rk_util.h" void rk_auto( /* integers */ int fsal, int neq, int stage, int isDll, int isForcing, int verbose, int nknots, int interpolate, int densetype, int maxsteps, int nt, /* int pointers */ int* _iknots, int* _it, int* _it_ext, int* _it_tot, int* _it_rej, int* istate, int* ipar, /* double */ double t, double tmax, double hmin, double hmax, double alpha, double beta, /* double pointers */ double* _dt, double* _errold, /* arrays */ double* tt, double* y0, double* y1, double* y2, double* dy1, double* dy2, double* f, double* y, double* Fj, double* tmp, double* FF, double* rr, double* A, double* out, double* bb1, double* bb2, double* cc, double* dd, double* atol, double* rtol, double* yknots, double* yout, /* SEXPs */ SEXP Func, SEXP Parms, SEXP Rho ) { int i = 0, j = 0, j1 = 0, k = 0, accept = FALSE, nreject = *_it_rej, one = 1; int iknots = *_iknots, it = *_it, it_ext = *_it_ext, it_tot = *_it_tot; double err, dtnew, t_ext; double dt = *_dt, errold = *_errold; /* todo: make this user adjustable */ static const double minscale = 0.2, maxscale = 10.0, safe = 0.9; /*------------------------------------------------------------------------*/ /* Main Loop */ /*------------------------------------------------------------------------*/ do { if (accept) timesteps[0] = timesteps[1]; timesteps[1] = dt; /* save former results of last step if the method allows this (first same as last) */ /* Karline: improve by saving "accepted" FF, use this when rejected */ if (fsal && accept){ j1 = 1; for (i = 0; i < neq; i++) FF[i] = FF[i + neq * (stage - 1)]; } else { j1 = 0; } /****** Prepare Coefficients from Butcher table ******/ for (j = j1; j < stage; j++) { for(i = 0; i < neq; i++) Fj[i] = 0; k = 0; while(k < j) { for(i = 0; i < neq; i++) Fj[i] = Fj[i] + A[j + stage * k] * FF[i + neq * k] * dt; k++; } for (int i = 0; i < neq; i++) { tmp[i] = Fj[i] + y0[i]; } /****** Compute Derivatives ******/ /* pass option to avoid unnecessary copying in derivs */ derivs(Func, t + dt * cc[j], tmp, Parms, Rho, FF, out, j, neq, ipar, isDll, isForcing); } /*====================================================================*/ /* Estimation of new values */ /*====================================================================*/ /* use BLAS wrapper with reduced error checking */ blas_matprod1(FF, neq, stage, bb1, stage, one, dy1); blas_matprod1(FF, neq, stage, bb2, stage, one, dy2); it_tot++; /* count total number of time steps */ for (i = 0; i < neq; i++) { y1[i] = y0[i] + dt * dy1[i]; y2[i] = y0[i] + dt * dy2[i]; } /*====================================================================*/ /* stepsize adjustment */ /*====================================================================*/ err = maxerr(y0, y1, y2, atol, rtol, neq); dtnew = dt; if (err == 0) { /* use max scale if all tolerances are zero */ dtnew = fmin(dt * 10, hmax); errold = fmax(err, 1e-4); /* 1e-4 taken from Press et al. */ accept = TRUE; } else if (err < 1.0) { /* increase step size only if last one was accepted */ if (accept) dtnew = fmin(hmax, dt * fmin(safe * pow(err, -alpha) * pow(errold, beta), maxscale)); errold = fmax(err, 1e-4); /* 1e-4 taken from Press et al. */ accept = TRUE; } else if (err > 1.0) { nreject++; /* count total number of rejected steps */ accept = FALSE; dtnew = dt * fmax(safe * pow(err, -alpha), minscale); } if (dtnew < hmin) { accept = TRUE; if (verbose) Rprintf("warning, h < Hmin\n"); istate[0] = -2; dtnew = hmin; } /*====================================================================*/ /* Interpolation and Data Storage */ /*====================================================================*/ if (accept) { if (interpolate) { /*--------------------------------------------------------------------*/ /* case A1) "dense output type 1": built-in polynomial interpolation */ /* available for certain rk formulae, e.g. for rk45dp7 */ /*--------------------------------------------------------------------*/ if (densetype == 1) { denspar(FF, y0, y2, dt, dd, neq, stage, rr); t_ext = tt[it_ext]; while (t_ext <= t + dt) { densout(rr, t, t_ext, dt, tmp, neq); /* store outputs */ if (it_ext < nt) { yout[it_ext] = t_ext; for (i = 0; i < neq; i++) yout[it_ext + nt * (1 + i)] = tmp[i]; } if(it_ext < nt-1) t_ext = tt[++it_ext]; else break; } /*--------------------------------------------------------------------*/ /* case A2) dense output type 2: the Cash-Karp method */ /*--------------------------------------------------------------------*/ } else if (densetype == 2) { /* dense output method 2 = Cash-Karp */ derivs(Func, t + dt, y2, Parms, Rho, dy2, out, 0, neq, ipar, isDll, isForcing); t_ext = tt[it_ext]; while (t_ext <= t + dt) { densoutck(t, t_ext, dt, y0, FF, dy2, tmp, neq); /* store outputs */ if (it_ext < nt) { yout[it_ext] = t_ext; for (i = 0; i < neq; i++) yout[it_ext + nt * (1 + i)] = tmp[i]; } if(it_ext < nt-1) t_ext = tt[++it_ext]; else break; } /* FSAL (first same as last) for Cash-Karp */ for (i = 0; i < neq; i++) FF[i + neq * (stage - 1)] = dy2[i] ; /*--------------------------------------------------------------------*/ /* case B) "Neville-Aitken-Interpolation" for integrators */ /* without dense output */ /*--------------------------------------------------------------------*/ } else { /* (1) collect number "nknots" of knots in advance */ yknots[iknots] = t + dt; /* time is first column */ for (i = 0; i < neq; i++) yknots[iknots + nknots * (1 + i)] = y2[i]; if (iknots < (nknots - 1)) { iknots++; } else { /* (2) do polynomial interpolation */ t_ext = tt[it_ext]; while (t_ext <= t + dt) { neville(yknots, &yknots[nknots], t_ext, tmp, nknots, neq); /* (3) store outputs */ if (it_ext < nt) { yout[it_ext] = t_ext; for (i = 0; i < neq; i++) yout[it_ext + nt * (1 + i)] = tmp[i]; } if(it_ext < nt-1) t_ext = tt[++it_ext]; else break; } shiftBuffer(yknots, nknots, neq + 1); } } } else { /*--------------------------------------------------------------------*/ /* Case C) no interpolation at all (for step to step integration); */ /* results are stored after the call */ /*--------------------------------------------------------------------*/ } /*--------------------------------------------------------------------*/ /* next time step */ /*--------------------------------------------------------------------*/ t = t + dt; it++; for (i=0; i < neq; i++) y0[i] = y2[i]; } /* else rejected time step */ dt = fmin(dtnew, tmax - t); if (it_ext > nt) { Rprintf("error in RK solver rk_auto.c: output buffer overflow\n"); break; } if (it_tot > maxsteps) { istate[0] = -1; warning("Number of time steps %i exceeded maxsteps at t = %g\n", it, t); break; } /* tolerance to avoid rounding errors */ } while (t < (tmax - 100.0 * DBL_EPSILON * dt)); /* end of rk main loop */ /* return reference values */ *_iknots = iknots; *_it = it; *_it_ext = it_ext; *_it_rej = nreject; *_it_tot = it_tot; *_dt = dtnew; *_errold = errold; } deSolve/src/deSolve_utils.c0000754000175100001440000003271613131751003015452 0ustar hornikusers/* Define some global variables and functions that operate on some of them */ #include #include #ifndef R_INTERNALS_H_ #include #endif #include #include #include "deSolve.h" #include "externalptr.h" /*================================================== some functions for keeping track of how many SEXPs are PROTECTed, and UNPROTECTing them in the case of a FORTRAN stop. ==================================================*/ long int N_Protected = 0; /* initialize this with zero at the first time */ int solver_locked = 0; /* prevent nested calls of odepack solvers */ void init_N_Protect(void) { N_Protected = 0; } void incr_N_Protect(void) { N_Protected++; } void unprotect_all(void) { UNPROTECT((int) N_Protected); } long int save_N_Protected(void) { int saved_N = N_Protected; init_N_Protect(); return saved_N; } void restore_N_Protected(long int n) { unprotect_all(); N_Protected = n; } void my_unprotect(int n) { UNPROTECT(n); N_Protected -= n; } void lock_solver(void) { if (solver_locked) { /* important: unlock for the next call *after* error */ solver_locked = 0; error("The used combination of solvers cannot be nested.\n"); } solver_locked = 1; } void unlock_solver(void) { solver_locked = 0; timesteps[0] = 0; timesteps[1] = 0; } /* Globals :*/ SEXP R_deriv_func; SEXP R_jac_func; SEXP R_jac_vec; SEXP R_root_func; SEXP R_event_func; SEXP R_envir; SEXP odesolve_gparms; SEXP R_res_func; SEXP R_daejac_func; SEXP R_psol_func; SEXP R_mas_func; SEXP de_gparms; /*====================================================== SEXP initialisation functions =======================================================*/ void initglobals(int nt, int ntot) { /* PROTECT(Time = NEW_NUMERIC(1)); incr_N_Protect(); */ PROTECT(Y = allocVector(REALSXP,(n_eq))); incr_N_Protect(); PROTECT(YOUT = allocMatrix(REALSXP,ntot+1,nt)); incr_N_Protect(); } void initdaeglobals(int nt, int ntot) { /* PROTECT(Time = NEW_NUMERIC(1)); incr_N_Protect(); */ PROTECT(Rin = NEW_NUMERIC(2)); incr_N_Protect(); PROTECT(Y = allocVector(REALSXP,n_eq)); incr_N_Protect(); PROTECT(YPRIME = allocVector(REALSXP,n_eq)); incr_N_Protect(); PROTECT(YOUT = allocMatrix(REALSXP,ntot+1,nt)); incr_N_Protect(); } /*====================================================== Parameter initialisation functions note: forcing initialisation function is in forcings.c =======================================================*/ void initParms(SEXP Initfunc, SEXP Parms) { if (Initfunc == NA_STRING) return; if (inherits(Initfunc, "NativeSymbol")) { init_func_type *initializer; PROTECT(de_gparms = Parms); incr_N_Protect(); initializer = (init_func_type *) R_ExternalPtrAddrFn_(Initfunc); initializer(Initdeparms); } } void Initdeparms(int *N, double *parms) { int i, Nparms; Nparms = LENGTH(de_gparms); if ((*N) != Nparms) { warning("Number of parameters passed to solver, %i; number in DLL, %i\n", Nparms, *N); PROBLEM "Confusion over the length of parms" ERROR; } else { for (i = 0; i < *N; i++) parms[i] = REAL(de_gparms)[i]; } } SEXP get_deSolve_gparms(void) { return de_gparms; } /*=========================================================================== C-equivalent of R-function timestep: gets the past and new time step =========================================================================== */ SEXP getTimestep() { SEXP value; PROTECT(value = NEW_NUMERIC(2)); if (timesteps == NULL) { /* integration not yet started... */ for (int i = 0; i < 2; i++) NUMERIC_POINTER(value)[i] = 0.0; } else for (int i = 0; i < 2; i++) NUMERIC_POINTER(value)[i] = timesteps[i]; UNPROTECT(1); return(value); } /*============================ ====================== Termination ===================================================*/ /* an error occurred - save output in YOUT2 */ void returnearly (int Print, int it, int ntot) { int j, k; if (Print) warning("Returning early. Results are accurate, as far as they go\n"); PROTECT(YOUT2 = allocMatrix(REALSXP,ntot+1,(it+2))); incr_N_Protect(); for (k = 0; k < it+2; k++) for (j = 0; j < ntot+1; j++) REAL(YOUT2)[k*(ntot+1) + j] = REAL(YOUT)[k*(ntot+1) + j]; } /* add ISTATE and RSTATE */ void terminate(int istate, int * iwork, int ilen, int ioffset, double * rwork, int rlen, int roffset) { int k; PROTECT(ISTATE = allocVector(INTSXP, ilen)); incr_N_Protect(); for (k = 0; k < ilen-1; k++) INTEGER(ISTATE)[k+1] = iwork[k +ioffset]; INTEGER(ISTATE)[0] = istate; PROTECT(RWORK = allocVector(REALSXP, rlen)); incr_N_Protect(); for (k = 0; k < rlen; k++) REAL(RWORK)[k] = rwork[k+roffset]; if (istate > 0) { setAttrib(YOUT, install("istate"), ISTATE); setAttrib(YOUT, install("rstate"), RWORK); } else { setAttrib(YOUT2, install("istate"), ISTATE); setAttrib(YOUT2, install("rstate"), RWORK); } /* timestep = 0 - for use in getTimestep */ timesteps[0] = 0; timesteps[1] = 0; } /*================================================== extracting elements from a list ===================================================*/ SEXP getListElement(SEXP list, const char *str) { SEXP elmt = R_NilValue, names = getAttrib(list, R_NamesSymbol); int i; for (i = 0; i < length(list); i++) if (strcmp(CHAR(STRING_ELT(names, i)), str) == 0) { elmt = VECTOR_ELT(list, i); break; } return elmt; } /*================================================== output initialisation function out and ipar are used to pass output variables (number set by nout) followed by other input by R-arguments rpar, ipar ipar[0]: number of output variables, ipar[1]: length of rpar, ipar[2]: length of ipar ===================================================*/ /* Initialise output - output variables calculated in R-code ... */ void initOutR(int isDll, int *nout, int *ntot, int neq, SEXP nOut, SEXP Rpar, SEXP Ipar) { int j, lrpar, lipar; *nout = INTEGER(nOut)[0]; /* number of output variables */ if (isDll) { /* function is a dll */ if (*nout > 0) isOut = 1; *ntot = neq + *nout; /* length of yout */ lrpar = *nout + LENGTH(Rpar); /* length of rpar; LENGTH(Rpar) is always >0 */ lipar = 3 + LENGTH(Ipar); /* length of ipar */ } else { /* function is not a dll */ isOut = 0; *ntot = neq; lipar = 1; lrpar = 1; } out = (double*) R_alloc(lrpar, sizeof(double)); ipar = (int*) R_alloc(lipar, sizeof(int)); if (isDll ==1) { ipar[0] = *nout; /* first 3 elements of ipar are special */ ipar[1] = lrpar; ipar[2] = lipar; /* other elements of ipar are set in R-function lsodx via argument *ipar* */ for (j = 0; j < LENGTH(Ipar); j++) ipar[j+3] = INTEGER(Ipar)[j]; /* first nout elements of rpar reserved for output variables other elements are set in R-function lsodx via argument *rpar* */ for (j = 0; j < *nout; j++) out[j] = 0.; for (j = 0; j < LENGTH(Rpar); j++) out[*nout+j] = REAL(Rpar)[j]; } } /* Initialise output - output variables calculated in C-code ... */ void initOutC(int isDll, int *nout, int *ntot, int neq, SEXP nOut, SEXP Rpar, SEXP Ipar) { int j, lrpar, lipar; /* initialise output when a dae ... */ /* output always done here in C-code (<-> lsode, vode)... */ *nout = INTEGER(nOut)[0]; *ntot = n_eq+*nout; if (isDll == 1) { /* function is a dll */ lrpar = *nout + LENGTH(Rpar); /* length of rpar */ lipar = 3 + LENGTH(Ipar); /* length of ipar */ } else { /* function is not a dll */ lipar = 3; lrpar = *nout; } out = (double*) R_alloc(lrpar, sizeof(double)); ipar = (int*) R_alloc(lipar, sizeof(int)); if (isDll == 1) { ipar[0] = *nout; /* first 3 elements of ipar are special */ ipar[1] = lrpar; ipar[2] = lipar; /* other elements of ipar are set in R-function lsodx via argument *ipar* */ for (j = 0; j < LENGTH(Ipar); j++) ipar[j+3] = INTEGER(Ipar)[j]; /* first nout elements of rpar reserved for output variables other elements are set in R-function lsodx via argument *rpar* */ for (j = 0; j < *nout; j++) out[j] = 0.; for (j = 0; j < LENGTH(Rpar); j++) out[*nout+j] = REAL(Rpar)[j]; } } /*================================================== 1-D, 2-D and 3-D sparsity structure ================================================== */ void sparsity1D (SEXP Type, int* iwork, int neq, int liw) { int nspec, nx, ij, i, j, k, l; nspec = INTEGER(Type)[1]; /* number of components*/ nx = INTEGER(Type)[2]; /* dimension x*/ ij = 31 + neq; iwork[30] = 1; k = 1; for( i = 0; i < nspec; i++) { for( j = 0; j < nx; j++) { if (ij > liw-3-nspec) error ("not enough memory allocated in iwork - increase liw %i ",liw); iwork[ij++] = k; if (j < nx-1) iwork[ij++] = k+1 ; if (j > 0) iwork[ij++] = k-1 ; for(l = 0; l < nspec; l++) if (l != i) iwork[ij++] = l*nx+j+1; iwork[30+k] = ij-30-neq; k = k+1; } } iwork[ij] = 0; } /*==================================================*/ void sparsity2D (SEXP Type, int* iwork, int neq, int liw) { int nspec, nx, ny, bndx, bndy, Nt, ij, isp, i, j, k, l, m; nspec = INTEGER(Type)[1]; /* number components*/ nx = INTEGER(Type)[2]; /* dimension x*/ ny = INTEGER(Type)[3]; /* dimension y*/ bndx = INTEGER(Type)[4]; /* cyclic boundary x*/ bndy = INTEGER(Type)[5]; /* cyclic boundary y*/ Nt = nx*ny; ij = 31 + neq; iwork[30] = 1; m = 1; for( i = 0; i < nspec; i++) { isp = i*Nt; for( j = 0; j < nx; j++) { for( k = 0; k < ny; k++) { if (ij > liw-8-nspec) error("not enough memory allocated in iwork - increase liw %i ",liw); iwork[ij++] = m; if (k < ny-1) iwork[ij++] = m+1; if (j < nx-1) iwork[ij++] = m+ny; if (j > 0) iwork[ij++] = m-ny; if (k > 0) iwork[ij++] = m-1; if (bndx == 1) { if (j == 0) iwork[ij++] = isp+(nx-1)*ny+k+1; if (j == nx-1) iwork[ij++] = isp+k+1; } if (bndy == 1) { if (k == 0) iwork[ij++] = isp+(j+1)*ny; if (k == ny-1) iwork[ij++] = isp + j*ny +1; } for(l = 0; l < nspec; l++) if (l != i) iwork[ij++] = l*Nt+j*ny+k+1; iwork[30+m] = ij-30-neq; m = m+1; } } } } void interact (int *ij, int nnz, int *iwork, int is, int ival) { int i, isave; isave = 1; /* check if not yet present for current state */ for (i = is; i < *ij; i++) if (iwork[i] == ival) { isave = 0; break; } /* save */ if (isave == 1) { if (*ij > nnz) error ("not enough memory allocated in iwork - increase liw %i ", nnz); iwork[(*ij)++] = ival; } } /*==================================================*/ /* an element in C-array A(I,J,K), i=0,dim(1)-1 etc... is positioned at j*dim(2)*dim(3) + k*dim(3) + l + 1 in FORTRAN VECTOR! includes check on validity dimens and boundary are reversed ... */ void sparsity3D (SEXP Type, int* iwork, int neq, int liw) { int nspec, nx, ny, nz, bndx, bndy, bndz, Nt, ij, is, isp, i, j, k, l, m, ll; nspec = INTEGER(Type)[1]; nx = INTEGER(Type)[2]; ny = INTEGER(Type)[3]; nz = INTEGER(Type)[4]; bndx = INTEGER(Type)[5]; bndy = INTEGER(Type)[6]; bndz = INTEGER(Type)[7]; Nt = nx*ny*nz; ij = 31+neq; iwork[30] = 1; m = 1; for( i = 0; i < nspec; i++) { isp = i*Nt; for( j = 0; j < nx; j++) { for( k = 0; k < ny; k++) { for( ll = 0; ll < nz; ll++) { is = ij; if (ij > liw-6-nspec) error ("not enough memory allocated in iwork - increase liw %i ", liw); interact (&ij, liw, iwork, is, m); if (ll < nz-1) interact (&ij, liw, iwork, is, m+1); else if (bndz == 1) interact (&ij, liw, iwork, is, isp + j*ny*nz + k*nz + 1); if (k < ny-1) interact (&ij, liw, iwork, is, m+nz); else if (bndy == 1) interact (&ij, liw, iwork, is, isp + j*ny*nz + ll + 1); if (j < nx-1) interact (&ij, liw, iwork, is, m+ny*nz); else if (bndx == 1) interact (&ij, liw, iwork, is, isp + k*nz + ll + 1); if (j > 0) interact (&ij, liw, iwork, is, m-ny*nz); else if (bndx == 1) interact (&ij, liw, iwork, is, isp+(nx-1)*ny*nz+k*nz+ll+1); if (k > 0) interact (&ij, liw, iwork, is, m-nz); else if (bndy == 1) interact (&ij, liw, iwork, is, isp + j*ny*nz+(ny-1)*nz+ll+1); if (ll > 0) interact (&ij, liw, iwork, is, m-1); else if (bndz == 1) interact (&ij, liw, iwork, is, isp + j*ny*nz+k*nz+nz); for(l = 0; l < nspec; l++) if (l != i) interact (&ij, liw, iwork, is, l*Nt+j*ny*nz+k*nz+ll+1); iwork[30+m] = ij-30-neq; m = m+1; } } } } } deSolve/src/brent.c0000754000175100001440000000643513131751003013742 0ustar hornikusers/* brent's rootfinding method, based on R_Zeroin_2, itself based on NETLIB c/brent.shar */ /************************************************************************* * C math library * function ZEROIN - obtain a function zero within the given range * * Input * double zeroin(ax,bx,f,info,Tol,Maxit) * double ax; Root will be seeked for within * double bx; a range [ax,bx] * double (f)(double x, void *info); Name of the function whose zero * will be seeked for * double *rw; int *iw; Additional real and integer vector * double tol; Acceptable tolerance for the root * int maxit; Max. iterations * * * Output * Zeroin returns an estimate for the root with accuracy * 4*EPSILON*abs(x) + tol * * Algorithm * G.Forsythe, M.Malcolm, C.Moler, Computer methods for mathematical * computations. M., Mir, 1980, p.180 of the Russian edition ************************************************************************ */ #include #include #include #define EPSILON DBL_EPSILON double brent( /* An estimate of the root */ double ax, /* Left border | of the range */ double bx, /* Right border| the root is seeked*/ double fa, double fb, /* f(a), f(b) */ double f (double x, double *rw, int *iw), /* Function under investigation */ double *rw, int *iw, double tol, /* Acceptable tolerance */ int maxit) /* Max # of iterations */ { double a,b,c, fc; a = ax; b = bx; c = a; fc = fa; maxit = maxit + 1; /* First test if we have a root at an endpoint */ if(fa == 0.0) return a; if(fb == 0.0) return b; /* Main iteration loop */ while(maxit--) { double prev_step = b-a; double tol_act; /* Actual tolerance */ double p; /* Interpolation step in the form p/q; */ double q; double new_step; /* Step at this iteration */ if( fabs(fc) < fabs(fb) ){ /* Swap data for b to be the */ a = b; b = c; c = a; /* best approximation */ fa=fb; fb=fc; fc=fa; } tol_act = 2*EPSILON*fabs(b) + tol/2; new_step = (c-b)/2; if( fabs(new_step) <= tol_act || fb == (double)0 ) return b; /* Decide if the interpolation can be tried */ if( fabs(prev_step) >= tol_act && fabs(fa) > fabs(fb) ) { register double t1,cb,t2; cb = c-b; if( a == c ) { /* linear interpolation*/ t1 = fb/fa; p = cb*t1; q = 1.0 - t1; } else { /* Quadric inverse interpolation*/ q = fa/fc; t1 = fb/fc; t2 = fb/fa; p = t2 * ( cb*q*(q-t1) - (b-a)*(t1-1.0) ); q = (q-1.0) * (t1-1.0) * (t2-1.0); } if( p > (double)0 ) q = -q; else p = -p; if( p < (0.75*cb*q-fabs(tol_act*q)/2) && p < fabs(prev_step*q/2) ) new_step = p/q; } if( fabs(new_step) < tol_act) { /* Adjust step to be not less than tol*/ if( new_step > (double)0 ) new_step = tol_act; else new_step = -tol_act; } a = b; fa = fb; /* Save the previous approx. */ b += new_step; fb = f (b, rw, iw); if( (fb > 0 && fc > 0) || (fb < 0 && fc < 0) ) { c = a; fc = fa; /* Adjust c to have a sign opposite to that of b */ } } /* failed! */ return b; } deSolve/src/call_rkFixed.c0000754000175100001440000002340213131751003015210 0ustar hornikusers/*==========================================================================*/ /* Runge-Kutta Solvers, (C) Th. Petzoldt, License: GPL >=2 */ /* General RK Solver for methods with fixed step size */ /*==========================================================================*/ #include "rk_util.h" SEXP call_rkFixed(SEXP Xstart, SEXP Times, SEXP Func, SEXP Initfunc, SEXP Parms, SEXP eventfunc, SEXP elist, SEXP Nout, SEXP Rho, SEXP Tcrit, SEXP Verbose, SEXP Hini, SEXP Rpar, SEXP Ipar, SEXP Method, SEXP Maxsteps, SEXP Flist) { /** Initialization **/ long int old_N_Protect = save_N_Protected(); double *tt = NULL, *xs = NULL; double *y, *f, *Fj, *tmp, *FF, *rr; SEXP R_yout; double *y0, *y1, *dy1, *out, *yout; double t, dt, tmax; int fsal = FALSE; /* fixed step methods have no FSAL */ int interpolate = TRUE; /* polynomial interpolation is done by default */ int i = 0, j=0, it=0, it_tot=0, it_ext=0, nt = 0, neq=0; int isForcing, isEvent; /**************************************************************************/ /****** Processing of Arguments ******/ /**************************************************************************/ double tcrit = REAL(Tcrit)[0]; double hini = REAL(Hini)[0]; int maxsteps = INTEGER(Maxsteps)[0]; int nout = INTEGER(Nout)[0]; /* number of global outputs if func is in a DLL */ int verbose = INTEGER(Verbose)[0]; int stage = (int)REAL(getListElement(Method, "stage"))[0]; SEXP R_A, R_B1, R_C; double *A, *bb1, *cc=NULL; PROTECT(R_A = getListElement(Method, "A")); incr_N_Protect(); A = REAL(R_A); PROTECT(R_B1 = getListElement(Method, "b1")); incr_N_Protect(); bb1 = REAL(R_B1); PROTECT(R_C = getListElement(Method, "c")); incr_N_Protect(); if (length(R_C)) cc = REAL(R_C); double qerr = REAL(getListElement(Method, "Qerr"))[0]; PROTECT(Times = AS_NUMERIC(Times)); incr_N_Protect(); tt = NUMERIC_POINTER(Times); nt = length(Times); PROTECT(Xstart = AS_NUMERIC(Xstart)); incr_N_Protect(); xs = NUMERIC_POINTER(Xstart); neq = length(Xstart); /*------------------------------------------------------------------------*/ /* timesteps (for advection computation in ReacTran) */ /*------------------------------------------------------------------------*/ if (hini > 0) for (i = 0; i < 2; i++) timesteps[i] = fmin(hini, tt[1] - tt[0]); else for (i = 0; i < 2; i++) timesteps[i] = tt[1] - tt[0]; /**************************************************************************/ /****** DLL, ipar, rpar (to be compatible with lsoda) ******/ /**************************************************************************/ int isDll = FALSE; //int ntot = 0; int lrpar= 0, lipar = 0; int *ipar = NULL; if (inherits(Func, "NativeSymbol")) { /* function is a dll */ isDll = TRUE; if (nout > 0) isOut = TRUE; //ntot = neq + nout; /* length of yout */ lrpar = nout + LENGTH(Rpar); /* length of rpar; LENGTH(Rpar) is always >0 */ lipar = 3 + LENGTH(Ipar); /* length of ipar */ } else { /* function is not a dll */ isDll = FALSE; isOut = FALSE; //ntot = neq; lipar = 3; /* in lsoda = 1 */ lrpar = nout; /* in lsoda = 1 */ } out = (double *) R_alloc(lrpar, sizeof(double)); ipar = (int *) R_alloc(lipar, sizeof(int)); ipar[0] = nout; /* first 3 elements of ipar are special */ ipar[1] = lrpar; ipar[2] = lipar; if (isDll == 1) { /* other elements of ipar are set in R-function lsodx via argument *ipar* */ for (j = 0; j < LENGTH(Ipar); j++) ipar[j+3] = INTEGER(Ipar)[j]; /* out: first nout elements of out are reserved for output variables other elements are set via argument *rpar* */ for (j = 0; j < nout; j++) out[j] = 0.0; for (j = 0; j < LENGTH(Rpar); j++) out[nout+j] = REAL(Rpar)[j]; } /*------------------------------------------------------------------------*/ /* Allocation of Workspace */ /*------------------------------------------------------------------------*/ y0 = (double *) R_alloc(neq, sizeof(double)); y1 = (double *) R_alloc(neq, sizeof(double)); dy1 = (double *) R_alloc(neq, sizeof(double)); f = (double *) R_alloc(neq, sizeof(double)); y = (double *) R_alloc(neq, sizeof(double)); Fj = (double *) R_alloc(neq, sizeof(double)); tmp = (double *) R_alloc(neq, sizeof(double)); FF = (double *) R_alloc(neq * stage, sizeof(double)); rr = (double *) R_alloc(neq * 5, sizeof(double)); /* matrix for polynomial interpolation */ SEXP R_nknots; int nknots = 6; /* 6 = 5th order polynomials by default*/ int iknots = 0; /* counter for knots buffer */ double *yknots; PROTECT(R_nknots = getListElement(Method, "nknots")); incr_N_Protect(); if (length(R_nknots)) nknots = INTEGER(R_nknots)[0] + 1; if (nknots < 2) {nknots=1; interpolate = FALSE;} yknots = (double *) R_alloc((neq + 1) * (nknots + 1), sizeof(double)); /* matrix for holding states and global outputs */ PROTECT(R_yout = allocMatrix(REALSXP, nt, neq + nout + 1)); incr_N_Protect(); yout = REAL(R_yout); /* initialize outputs with NA first */ for (i = 0; i < nt * (neq + nout + 1); i++) yout[i] = NA_REAL; /* attribute that stores state information, similar to lsoda */ SEXP R_istate; int *istate; PROTECT(R_istate = allocVector(INTSXP, 22)); incr_N_Protect(); istate = INTEGER(R_istate); istate[0] = 0; /* assume succesful return */ for (i = 0; i < 22; i++) istate[i] = 0; /*------------------------------------------------------------------------*/ /* Initialization of Parameters (for DLL functions) */ /*------------------------------------------------------------------------*/ PROTECT(Y = allocVector(REALSXP,(neq))); incr_N_Protect(); initParms(Initfunc, Parms); isForcing = initForcings(Flist); isEvent = initEvents(elist, eventfunc, 0); if (isEvent) interpolate = FALSE; /*------------------------------------------------------------------------*/ /* Initialization of Integration Loop */ /*------------------------------------------------------------------------*/ yout[0] = tt[0]; /* initial time */ yknots[0] = tt[0]; /* for polynomial interpolation */ for (i = 0; i < neq; i++) { y0[i] = xs[i]; /* initial values */ yout[(i + 1) * nt] = y0[i]; /* output array */ yknots[iknots + nknots * (i + 1)] = xs[i]; /* for polynomials */ } iknots++; t = tt[0]; tmax = fmax(tt[nt - 1], tcrit); /* Initialization of work arrays (to be on the safe side, remove this later) */ for (i = 0; i < neq; i++) { y1[i] = 0; Fj[i] = 0; for (j= 0; j < stage; j++) { FF[i + j * neq] = 0; } } /*------------------------------------------------------------------------*/ /* Main Loop */ /*------------------------------------------------------------------------*/ it = 1; /* step counter; zero element is initial state */ it_ext = 0; /* counter for external time step (dense output) */ it_tot = 0; /* total number of time steps */ if (interpolate) { /* integrate over the whole time step and interpolate internally */ rk_fixed( fsal, neq, stage, isDll, isForcing, verbose, nknots, interpolate, maxsteps, nt, &iknots, &it, &it_ext, &it_tot, istate, ipar, t, tmax, hini, &dt, tt, y0, y1, dy1, f, y, Fj, tmp, FF, rr, A, out, bb1, cc, yknots, yout, Func, Parms, Rho ); } else { /* integrate until next time step and return */ for (int j = 0; j < nt - 1; j++) { t = tt[j]; tmax = fmin(tt[j + 1], tcrit); dt = tmax - t; if (isEvent) { updateevent(&t, y0, istate); } rk_fixed( fsal, neq, stage, isDll, isForcing, verbose, nknots, interpolate, maxsteps, nt, &iknots, &it, &it_ext, &it_tot, istate, ipar, t, tmax, fmin(hini, fabs(dt)) * sign(dt), // <----- hini for backward steps (still experimental) &dt, tt, y0, y1, dy1, f, y, Fj, tmp, FF, rr, A, out, bb1, cc, yknots, yout, Func, Parms, Rho ); /* in this mode, internal interpolation is skipped, so we can simply store the results at the end of each call */ yout[j + 1] = tmax; for (i = 0; i < neq; i++) yout[j + 1 + nt * (1 + i)] = y1[i]; } } /*====================================================================*/ /* call derivs again to get global outputs */ /* j = -1 suppresses unnecessary internal copying */ /*====================================================================*/ if(nout > 0) { for (int j = 0; j < nt; j++) { t = yout[j]; for (i = 0; i < neq; i++) tmp[i] = yout[j + nt * (1 + i)]; derivs(Func, t, tmp, Parms, Rho, FF, out, -1, neq, ipar, isDll, isForcing); for (i = 0; i < nout; i++) { yout[j + nt * (1 + neq + i)] = out[i]; } } } /* attach diagnostic information (codes are compatible to lsoda) */ setIstate(R_yout, R_istate, istate, it_tot, stage, fsal, qerr, 0); /* verbose printing in debugging mode*/ if (verbose) { Rprintf("Number of time steps it = %d, it_ext = %d, it_tot = %d\n", it, it_ext, it_tot); Rprintf("Maxsteps %d\n", maxsteps); } /* release R resources */ timesteps[0] = 0; timesteps[1] = 0; restore_N_Protected(old_N_Protect); return(R_yout); } deSolve/src/radau5a.f0000754000175100001440000030077013131751003014154 0ustar hornikusersc----------------------------------------------------------------------- c additional linear algebra routines required by RADAU5 c----------------------------------------------------------------------- c KS: changed sol -> solradau , ... C KS: write statements rewritten C ****************************************** C VERSION OF SEPTEMBER 18, 1995 C ****************************************** C SUBROUTINE DECOMR(N,FJAC,LDJAC,FMAS,LDMAS,MLMAS,MUMAS, & M1,M2,NM1,FAC1,E1,LDE1,IP1,IER,IJOB,CALHES,IPHES) IMPLICIT REAL(KIND=8) (A-H,O-Z) DIMENSION FJAC(LDJAC,N),FMAS(LDMAS,NM1),E1(LDE1,NM1), & IP1(NM1),IPHES(N) LOGICAL CALHES COMMON/LINAL/MLE,MUE,MBJAC,MBB,MDIAG,MDIFF,MBDIAG C IF (IJOB .EQ. 1) THEN GOTO 1 ELSE IF (IJOB .EQ. 2) THEN GOTO 2 ELSE IF (IJOB .EQ. 3) THEN GOTO 3 ELSE IF (IJOB .EQ. 4) THEN GOTO 4 ELSE IF (IJOB .EQ. 5) THEN GOTO 5 ELSE IF (IJOB .EQ. 6) THEN GOTO 6 ELSE IF (IJOB .EQ. 7) THEN GOTO 7 ELSE IF (IJOB .LE. 10) THEN GOTO 55 ELSE IF (IJOB .EQ. 11) THEN GOTO 11 ELSE IF (IJOB .EQ. 12) THEN GOTO 12 ELSE IF (IJOB .EQ. 13) THEN GOTO 13 ELSE IF (IJOB .EQ. 14) THEN GOTO 14 ELSE IF (IJOB .EQ. 15) THEN GOTO 15 ENDIF C karline: changed from C GOTO (1,2,3,4,5,6,7,55,55,55,11,12,13,14,15), IJOB C C ----------------------------------------------------------- C 1 CONTINUE C --- B=IDENTITY, JACOBIAN A FULL MATRIX DO J=1,N DO I=1,N E1(I,J)=-FJAC(I,J) END DO E1(J,J)=E1(J,J)+FAC1 END DO CALL DECradau(N,LDE1,E1,IP1,IER) RETURN C C ----------------------------------------------------------- C 11 CONTINUE C --- B=IDENTITY, JACOBIAN A FULL MATRIX, SECOND ORDER DO J=1,NM1 JM1=J+M1 DO I=1,NM1 E1(I,J)=-FJAC(I,JM1) END DO E1(J,J)=E1(J,J)+FAC1 END DO 45 MM=M1/M2 DO J=1,M2 DO I=1,NM1 SUM=0.D0 DO K=0,MM-1 SUM=(SUM+FJAC(I,J+K*M2))/FAC1 END DO E1(I,J)=E1(I,J)-SUM END DO END DO CALL DECradau (NM1,LDE1,E1,IP1,IER) RETURN C C ----------------------------------------------------------- C 2 CONTINUE C --- B=IDENTITY, JACOBIAN A BANDED MATRIX DO J=1,N DO I=1,MBJAC E1(I+MLE,J)=-FJAC(I,J) END DO E1(MDIAG,J)=E1(MDIAG,J)+FAC1 END DO CALL DECradB (N,LDE1,E1,MLE,MUE,IP1,IER) RETURN C C ----------------------------------------------------------- C 12 CONTINUE C --- B=IDENTITY, JACOBIAN A BANDED MATRIX, SECOND ORDER DO J=1,NM1 JM1=J+M1 DO I=1,MBJAC E1(I+MLE,J)=-FJAC(I,JM1) END DO E1(MDIAG,J)=E1(MDIAG,J)+FAC1 END DO 46 MM=M1/M2 DO J=1,M2 DO I=1,MBJAC SUM=0.D0 DO K=0,MM-1 SUM=(SUM+FJAC(I,J+K*M2))/FAC1 END DO E1(I+MLE,J)=E1(I+MLE,J)-SUM END DO END DO CALL DECradB (NM1,LDE1,E1,MLE,MUE,IP1,IER) RETURN C C ----------------------------------------------------------- C 3 CONTINUE C --- B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX DO J=1,N DO I=1,N E1(I,J)=-FJAC(I,J) END DO DO I=MAX(1,J-MUMAS),MIN(N,J+MLMAS) E1(I,J)=E1(I,J)+FAC1*FMAS(I-J+MBDIAG,J) END DO END DO CALL DECradau (N,LDE1,E1,IP1,IER) RETURN C C ----------------------------------------------------------- C 13 CONTINUE C --- B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX, SECOND ORDER DO J=1,NM1 JM1=J+M1 DO I=1,NM1 E1(I,J)=-FJAC(I,JM1) END DO DO I=MAX(1,J-MUMAS),MIN(NM1,J+MLMAS) E1(I,J)=E1(I,J)+FAC1*FMAS(I-J+MBDIAG,J) END DO END DO GOTO 45 C C ----------------------------------------------------------- C 4 CONTINUE C --- B IS A BANDED MATRIX, JACOBIAN A BANDED MATRIX DO J=1,N DO I=1,MBJAC E1(I+MLE,J)=-FJAC(I,J) END DO DO I=1,MBB IB=I+MDIFF E1(IB,J)=E1(IB,J)+FAC1*FMAS(I,J) END DO END DO CALL DECradB (N,LDE1,E1,MLE,MUE,IP1,IER) RETURN C C ----------------------------------------------------------- C 14 CONTINUE C --- B IS A BANDED MATRIX, JACOBIAN A BANDED MATRIX, SECOND ORDER DO J=1,NM1 JM1=J+M1 DO I=1,MBJAC E1(I+MLE,J)=-FJAC(I,JM1) END DO DO I=1,MBB IB=I+MDIFF E1(IB,J)=E1(IB,J)+FAC1*FMAS(I,J) END DO END DO GOTO 46 C C ----------------------------------------------------------- C 5 CONTINUE C --- B IS A FULL MATRIX, JACOBIAN A FULL MATRIX DO J=1,N DO I=1,N E1(I,J)=FMAS(I,J)*FAC1-FJAC(I,J) END DO END DO CALL DECradau (N,LDE1,E1,IP1,IER) RETURN C C ----------------------------------------------------------- C 15 CONTINUE C --- B IS A FULL MATRIX, JACOBIAN A FULL MATRIX, SECOND ORDER DO J=1,NM1 JM1=J+M1 DO I=1,NM1 E1(I,J)=FMAS(I,J)*FAC1-FJAC(I,JM1) END DO END DO GOTO 45 C C ----------------------------------------------------------- C 6 CONTINUE C --- B IS A FULL MATRIX, JACOBIAN A BANDED MATRIX C --- THIS OPTION IS NOT PROVIDED RETURN C C ----------------------------------------------------------- C 7 CONTINUE C --- B=IDENTITY, JACOBIAN A FULL MATRIX, HESSENBERG-OPTION IF (CALHES) CALL ELMHES (LDJAC,N,1,N,FJAC,IPHES) CALHES=.FALSE. DO J=1,N-1 J1=J+1 E1(J1,J)=-FJAC(J1,J) END DO DO J=1,N DO I=1,J E1(I,J)=-FJAC(I,J) END DO E1(J,J)=E1(J,J)+FAC1 END DO CALL DECH(N,LDE1,E1,1,IP1,IER) RETURN C C ----------------------------------------------------------- C 55 CONTINUE RETURN END C C END OF SUBROUTINE DECOMR C C *********************************************************** C SUBROUTINE DECOMC(N,FJAC,LDJAC,FMAS,LDMAS,MLMAS,MUMAS, & M1,M2,NM1,ALPHN,BETAN,E2R,E2I,LDE1,IP2,IER,IJOB) IMPLICIT REAL(KIND=8) (A-H,O-Z) DIMENSION FJAC(LDJAC,N),FMAS(LDMAS,NM1), & E2R(LDE1,NM1),E2I(LDE1,NM1),IP2(NM1) COMMON/LINAL/MLE,MUE,MBJAC,MBB,MDIAG,MDIFF,MBDIAG C IF (IJOB .EQ. 1) THEN GOTO 1 ELSE IF (IJOB .EQ. 2) THEN GOTO 2 ELSE IF (IJOB .EQ. 3) THEN GOTO 3 ELSE IF (IJOB .EQ. 4) THEN GOTO 4 ELSE IF (IJOB .EQ. 5) THEN GOTO 5 ELSE IF (IJOB .EQ. 6) THEN GOTO 6 ELSE IF (IJOB .EQ. 7) THEN GOTO 7 ELSE IF (IJOB .LE. 10) THEN GOTO 55 ELSE IF (IJOB .EQ. 11) THEN GOTO 11 ELSE IF (IJOB .EQ. 12) THEN GOTO 12 ELSE IF (IJOB .EQ. 13) THEN GOTO 13 ELSE IF (IJOB .EQ. 14) THEN GOTO 14 ELSE IF (IJOB .EQ. 15) THEN GOTO 15 ENDIF C karline: changed from C GOTO (1,2,3,4,5,6,7,55,55,55,11,12,13,14,15), IJOB C C ----------------------------------------------------------- C 1 CONTINUE C --- B=IDENTITY, JACOBIAN A FULL MATRIX DO J=1,N DO I=1,N E2R(I,J)=-FJAC(I,J) E2I(I,J)=0.D0 END DO E2R(J,J)=E2R(J,J)+ALPHN E2I(J,J)=BETAN END DO CALL DECC (N,LDE1,E2R,E2I,IP2,IER) RETURN C C ----------------------------------------------------------- C 11 CONTINUE C --- B=IDENTITY, JACOBIAN A FULL MATRIX, SECOND ORDER DO J=1,NM1 JM1=J+M1 DO I=1,NM1 E2R(I,J)=-FJAC(I,JM1) E2I(I,J)=0.D0 END DO E2R(J,J)=E2R(J,J)+ALPHN E2I(J,J)=BETAN END DO 45 MM=M1/M2 ABNO=ALPHN**2+BETAN**2 ALP=ALPHN/ABNO BET=BETAN/ABNO DO J=1,M2 DO I=1,NM1 SUMR=0.D0 SUMI=0.D0 DO K=0,MM-1 SUMS=SUMR+FJAC(I,J+K*M2) SUMR=SUMS*ALP+SUMI*BET SUMI=SUMI*ALP-SUMS*BET END DO E2R(I,J)=E2R(I,J)-SUMR E2I(I,J)=E2I(I,J)-SUMI END DO END DO CALL DECC (NM1,LDE1,E2R,E2I,IP2,IER) RETURN C C ----------------------------------------------------------- C 2 CONTINUE C --- B=IDENTITY, JACOBIAN A BANDED MATRIX DO J=1,N DO I=1,MBJAC IMLE=I+MLE E2R(IMLE,J)=-FJAC(I,J) E2I(IMLE,J)=0.D0 END DO E2R(MDIAG,J)=E2R(MDIAG,J)+ALPHN E2I(MDIAG,J)=BETAN END DO CALL DECBC (N,LDE1,E2R,E2I,MLE,MUE,IP2,IER) RETURN C C ----------------------------------------------------------- C 12 CONTINUE C --- B=IDENTITY, JACOBIAN A BANDED MATRIX, SECOND ORDER DO J=1,NM1 JM1=J+M1 DO I=1,MBJAC E2R(I+MLE,J)=-FJAC(I,JM1) E2I(I+MLE,J)=0.D0 END DO E2R(MDIAG,J)=E2R(MDIAG,J)+ALPHN E2I(MDIAG,J)=E2I(MDIAG,J)+BETAN END DO 46 MM=M1/M2 ABNO=ALPHN**2+BETAN**2 ALP=ALPHN/ABNO BET=BETAN/ABNO DO J=1,M2 DO I=1,MBJAC SUMR=0.D0 SUMI=0.D0 DO K=0,MM-1 SUMS=SUMR+FJAC(I,J+K*M2) SUMR=SUMS*ALP+SUMI*BET SUMI=SUMI*ALP-SUMS*BET END DO IMLE=I+MLE E2R(IMLE,J)=E2R(IMLE,J)-SUMR E2I(IMLE,J)=E2I(IMLE,J)-SUMI END DO END DO CALL DECBC (NM1,LDE1,E2R,E2I,MLE,MUE,IP2,IER) RETURN C C ----------------------------------------------------------- C 3 CONTINUE C --- B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX DO J=1,N DO I=1,N E2R(I,J)=-FJAC(I,J) E2I(I,J)=0.D0 END DO END DO DO J=1,N DO I=MAX(1,J-MUMAS),MIN(N,J+MLMAS) BB=FMAS(I-J+MBDIAG,J) E2R(I,J)=E2R(I,J)+ALPHN*BB E2I(I,J)=BETAN*BB END DO END DO CALL DECC(N,LDE1,E2R,E2I,IP2,IER) RETURN C C ----------------------------------------------------------- C 13 CONTINUE C --- B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX, SECOND ORDER DO J=1,NM1 JM1=J+M1 DO I=1,NM1 E2R(I,J)=-FJAC(I,JM1) E2I(I,J)=0.D0 END DO DO I=MAX(1,J-MUMAS),MIN(NM1,J+MLMAS) FFMA=FMAS(I-J+MBDIAG,J) E2R(I,J)=E2R(I,J)+ALPHN*FFMA E2I(I,J)=E2I(I,J)+BETAN*FFMA END DO END DO GOTO 45 C C ----------------------------------------------------------- C 4 CONTINUE C --- B IS A BANDED MATRIX, JACOBIAN A BANDED MATRIX DO J=1,N DO I=1,MBJAC IMLE=I+MLE E2R(IMLE,J)=-FJAC(I,J) E2I(IMLE,J)=0.D0 END DO DO I=MAX(1,MUMAS+2-J),MIN(MBB,MUMAS+1-J+N) IB=I+MDIFF BB=FMAS(I,J) E2R(IB,J)=E2R(IB,J)+ALPHN*BB E2I(IB,J)=BETAN*BB END DO END DO CALL DECBC (N,LDE1,E2R,E2I,MLE,MUE,IP2,IER) RETURN C C ----------------------------------------------------------- C 14 CONTINUE C --- B IS A BANDED MATRIX, JACOBIAN A BANDED MATRIX, SECOND ORDER DO J=1,NM1 JM1=J+M1 DO I=1,MBJAC E2R(I+MLE,J)=-FJAC(I,JM1) E2I(I+MLE,J)=0.D0 END DO DO I=1,MBB IB=I+MDIFF FFMA=FMAS(I,J) E2R(IB,J)=E2R(IB,J)+ALPHN*FFMA E2I(IB,J)=E2I(IB,J)+BETAN*FFMA END DO END DO GOTO 46 C C ----------------------------------------------------------- C 5 CONTINUE C --- B IS A FULL MATRIX, JACOBIAN A FULL MATRIX DO J=1,N DO I=1,N BB=FMAS(I,J) E2R(I,J)=BB*ALPHN-FJAC(I,J) E2I(I,J)=BB*BETAN END DO END DO CALL DECC(N,LDE1,E2R,E2I,IP2,IER) RETURN C C ----------------------------------------------------------- C 15 CONTINUE C --- B IS A FULL MATRIX, JACOBIAN A FULL MATRIX, SECOND ORDER DO J=1,NM1 JM1=J+M1 DO I=1,NM1 E2R(I,J)=ALPHN*FMAS(I,J)-FJAC(I,JM1) E2I(I,J)=BETAN*FMAS(I,J) END DO END DO GOTO 45 C C ----------------------------------------------------------- C 6 CONTINUE C --- B IS A FULL MATRIX, JACOBIAN A BANDED MATRIX C --- THIS OPTION IS NOT PROVIDED RETURN C C ----------------------------------------------------------- C 7 CONTINUE C --- B=IDENTITY, JACOBIAN A FULL MATRIX, HESSENBERG-OPTION DO J=1,N-1 J1=J+1 E2R(J1,J)=-FJAC(J1,J) E2I(J1,J)=0.D0 END DO DO J=1,N DO I=1,J E2I(I,J)=0.D0 E2R(I,J)=-FJAC(I,J) END DO E2R(J,J)=E2R(J,J)+ALPHN E2I(J,J)=BETAN END DO CALL DECHC(N,LDE1,E2R,E2I,1,IP2,IER) RETURN C C ----------------------------------------------------------- C 55 CONTINUE RETURN END C C END OF SUBROUTINE DECOMC C C *********************************************************** C SUBROUTINE SLVRAR(N,FJAC,LDJAC,MLJAC,MUJAC,FMAS,LDMAS,MLMAS,MUMAS, & M1,M2,NM1,FAC1,E1,LDE1,Z1,F1,IP1,IPHES,IER,IJOB) IMPLICIT REAL(KIND=8) (A-H,O-Z) DIMENSION FJAC(LDJAC,N),FMAS(LDMAS,NM1),E1(LDE1,NM1), & IP1(NM1),IPHES(N),Z1(N),F1(N) COMMON/LINAL/MLE,MUE,MBJAC,MBB,MDIAG,MDIFF,MBDIAG C IF (IJOB .EQ. 1) THEN GOTO 1 ELSE IF (IJOB .EQ. 2) THEN GOTO 2 ELSE IF (IJOB .EQ. 3) THEN GOTO 3 ELSE IF (IJOB .EQ. 4) THEN GOTO 4 ELSE IF (IJOB .EQ. 5) THEN GOTO 5 ELSE IF (IJOB .EQ. 6) THEN GOTO 6 ELSE IF (IJOB .EQ. 7) THEN GOTO 7 ELSE IF (IJOB .LE. 10) THEN GOTO 55 ELSE IF (IJOB .EQ. 11) THEN GOTO 11 ELSE IF (IJOB .EQ. 12) THEN GOTO 12 ELSE IF (IJOB .EQ. 13 .OR. IJOB .EQ. 14) THEN GOTO 13 ELSE IF (IJOB .EQ. 15) THEN GOTO 15 ENDIF C karline: changed from C GOTO (1,2,3,4,5,6,7,55,55,55,11,12,13,13,15), IJOB C C ----------------------------------------------------------- C 1 CONTINUE C --- B=IDENTITY, JACOBIAN A FULL MATRIX DO I=1,N Z1(I)=Z1(I)-F1(I)*FAC1 END DO CALL solradau (N,LDE1,E1,Z1,IP1) RETURN C C ----------------------------------------------------------- C 11 CONTINUE C --- B=IDENTITY, JACOBIAN A FULL MATRIX, SECOND ORDER DO I=1,N Z1(I)=Z1(I)-F1(I)*FAC1 END DO 48 CONTINUE MM=M1/M2 DO J=1,M2 SUM1=0.D0 DO K=MM-1,0,-1 JKM=J+K*M2 SUM1=(Z1(JKM)+SUM1)/FAC1 DO I=1,NM1 IM1=I+M1 Z1(IM1)=Z1(IM1)+FJAC(I,JKM)*SUM1 END DO END DO END DO CALL solradau (NM1,LDE1,E1,Z1(M1+1),IP1) 49 CONTINUE DO I=M1,1,-1 Z1(I)=(Z1(I)+Z1(M2+I))/FAC1 END DO RETURN C C ----------------------------------------------------------- C 2 CONTINUE C --- B=IDENTITY, JACOBIAN A BANDED MATRIX DO I=1,N Z1(I)=Z1(I)-F1(I)*FAC1 END DO CALL SOLradB (N,LDE1,E1,MLE,MUE,Z1,IP1) RETURN C C ----------------------------------------------------------- C 12 CONTINUE C --- B=IDENTITY, JACOBIAN A BANDED MATRIX, SECOND ORDER DO I=1,N Z1(I)=Z1(I)-F1(I)*FAC1 END DO 45 CONTINUE MM=M1/M2 DO J=1,M2 SUM1=0.D0 DO K=MM-1,0,-1 JKM=J+K*M2 SUM1=(Z1(JKM)+SUM1)/FAC1 DO I=MAX(1,J-MUJAC),MIN(NM1,J+MLJAC) IM1=I+M1 Z1(IM1)=Z1(IM1)+FJAC(I+MUJAC+1-J,JKM)*SUM1 END DO END DO END DO CALL SOLradB (NM1,LDE1,E1,MLE,MUE,Z1(M1+1),IP1) GOTO 49 C C ----------------------------------------------------------- C 3 CONTINUE C --- B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX DO I=1,N S1=0.0D0 DO J=MAX(1,I-MLMAS),MIN(N,I+MUMAS) S1=S1-FMAS(I-J+MBDIAG,J)*F1(J) END DO Z1(I)=Z1(I)+S1*FAC1 END DO CALL solradau (N,LDE1,E1,Z1,IP1) RETURN C C ----------------------------------------------------------- C 13 CONTINUE C --- B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX, SECOND ORDER DO I=1,M1 Z1(I)=Z1(I)-F1(I)*FAC1 END DO DO I=1,NM1 IM1=I+M1 S1=0.0D0 DO J=MAX(1,I-MLMAS),MIN(NM1,I+MUMAS) S1=S1-FMAS(I-J+MBDIAG,J)*F1(J+M1) END DO Z1(IM1)=Z1(IM1)+S1*FAC1 END DO IF (IJOB.EQ.14) GOTO 45 GOTO 48 C C ----------------------------------------------------------- C 4 CONTINUE C --- B IS A BANDED MATRIX, JACOBIAN A BANDED MATRIX DO I=1,N S1=0.0D0 DO J=MAX(1,I-MLMAS),MIN(N,I+MUMAS) S1=S1-FMAS(I-J+MBDIAG,J)*F1(J) END DO Z1(I)=Z1(I)+S1*FAC1 END DO CALL SOLradB (N,LDE1,E1,MLE,MUE,Z1,IP1) RETURN C C ----------------------------------------------------------- C 5 CONTINUE C --- B IS A FULL MATRIX, JACOBIAN A FULL MATRIX DO I=1,N S1=0.0D0 DO J=1,N S1=S1-FMAS(I,J)*F1(J) END DO Z1(I)=Z1(I)+S1*FAC1 END DO CALL solradau (N,LDE1,E1,Z1,IP1) RETURN C C ----------------------------------------------------------- C 15 CONTINUE C --- B IS A FULL MATRIX, JACOBIAN A FULL MATRIX, SECOND ORDER DO I=1,M1 Z1(I)=Z1(I)-F1(I)*FAC1 END DO DO I=1,NM1 IM1=I+M1 S1=0.0D0 DO J=1,NM1 S1=S1-FMAS(I,J)*F1(J+M1) END DO Z1(IM1)=Z1(IM1)+S1*FAC1 END DO GOTO 48 C C ----------------------------------------------------------- C 6 CONTINUE C --- B IS A FULL MATRIX, JACOBIAN A BANDED MATRIX C --- THIS OPTION IS NOT PROVIDED RETURN C C ----------------------------------------------------------- C 7 CONTINUE C --- B=IDENTITY, JACOBIAN A FULL MATRIX, HESSENBERG-OPTION DO I=1,N Z1(I)=Z1(I)-F1(I)*FAC1 END DO DO MM=N-2,1,-1 MP=N-MM MP1=MP-1 I=IPHES(MP) IF (I.EQ.MP) GOTO 746 ZSAFE=Z1(MP) Z1(MP)=Z1(I) Z1(I)=ZSAFE 746 CONTINUE DO I=MP+1,N Z1(I)=Z1(I)-FJAC(I,MP1)*Z1(MP) END DO END DO CALL SOLH(N,LDE1,E1,1,Z1,IP1) DO MM=1,N-2 MP=N-MM MP1=MP-1 DO I=MP+1,N Z1(I)=Z1(I)+FJAC(I,MP1)*Z1(MP) END DO I=IPHES(MP) IF (I.EQ.MP) GOTO 750 ZSAFE=Z1(MP) Z1(MP)=Z1(I) Z1(I)=ZSAFE 750 CONTINUE END DO RETURN C C ----------------------------------------------------------- C 55 CONTINUE RETURN END C C END OF SUBROUTINE SLVRAR C C *********************************************************** C SUBROUTINE SLVRAI(N,FJAC,LDJAC,MLJAC,MUJAC,FMAS,LDMAS,MLMAS,MUMAS, & M1,M2,NM1,ALPHN,BETAN,E2R,E2I,LDE1,Z2,Z3, & F2,F3,CONT,IP2,IPHES,IER,IJOB) IMPLICIT REAL(KIND=8) (A-H,O-Z) DIMENSION FJAC(LDJAC,N),FMAS(LDMAS,NM1), & IP2(NM1),IPHES(N),Z2(N),Z3(N),F2(N),F3(N) DIMENSION E2R(LDE1,NM1),E2I(LDE1,NM1) COMMON/LINAL/MLE,MUE,MBJAC,MBB,MDIAG,MDIFF,MBDIAG IF (IJOB .EQ. 1) THEN GOTO 1 ELSE IF (IJOB .EQ. 2) THEN GOTO 2 ELSE IF (IJOB .EQ. 3) THEN GOTO 3 ELSE IF (IJOB .EQ. 4) THEN GOTO 4 ELSE IF (IJOB .EQ. 5) THEN GOTO 5 ELSE IF (IJOB .EQ. 6) THEN GOTO 6 ELSE IF (IJOB .EQ. 7) THEN GOTO 7 ELSE IF (IJOB .LE. 10) THEN GOTO 55 ELSE IF (IJOB .EQ. 11) THEN GOTO 11 ELSE IF (IJOB .EQ. 12) THEN GOTO 12 ELSE IF (IJOB .EQ. 13) THEN GOTO 13 ELSE IF (IJOB .EQ. 14) THEN GOTO 13 ELSE IF (IJOB .EQ. 15) THEN GOTO 15 ENDIF C karline: changed from C GOTO (1,2,3,4,5,6,7,55,55,55,11,12,13,13,15), IJOB C C ----------------------------------------------------------- C 1 CONTINUE C --- B=IDENTITY, JACOBIAN A FULL MATRIX DO I=1,N S2=-F2(I) S3=-F3(I) Z2(I)=Z2(I)+S2*ALPHN-S3*BETAN Z3(I)=Z3(I)+S3*ALPHN+S2*BETAN END DO CALL SOLC (N,LDE1,E2R,E2I,Z2,Z3,IP2) RETURN C C ----------------------------------------------------------- C 11 CONTINUE C --- B=IDENTITY, JACOBIAN A FULL MATRIX, SECOND ORDER DO I=1,N S2=-F2(I) S3=-F3(I) Z2(I)=Z2(I)+S2*ALPHN-S3*BETAN Z3(I)=Z3(I)+S3*ALPHN+S2*BETAN END DO 48 ABNO=ALPHN**2+BETAN**2 MM=M1/M2 DO J=1,M2 SUM2=0.D0 SUM3=0.D0 DO K=MM-1,0,-1 JKM=J+K*M2 SUMH=(Z2(JKM)+SUM2)/ABNO SUM3=(Z3(JKM)+SUM3)/ABNO SUM2=SUMH*ALPHN+SUM3*BETAN SUM3=SUM3*ALPHN-SUMH*BETAN DO I=1,NM1 IM1=I+M1 Z2(IM1)=Z2(IM1)+FJAC(I,JKM)*SUM2 Z3(IM1)=Z3(IM1)+FJAC(I,JKM)*SUM3 END DO END DO END DO CALL SOLC (NM1,LDE1,E2R,E2I,Z2(M1+1),Z3(M1+1),IP2) 49 CONTINUE DO I=M1,1,-1 MPI=M2+I Z2I=Z2(I)+Z2(MPI) Z3I=Z3(I)+Z3(MPI) Z3(I)=(Z3I*ALPHN-Z2I*BETAN)/ABNO Z2(I)=(Z2I*ALPHN+Z3I*BETAN)/ABNO END DO RETURN C C ----------------------------------------------------------- C 2 CONTINUE C --- B=IDENTITY, JACOBIAN A BANDED MATRIX DO I=1,N S2=-F2(I) S3=-F3(I) Z2(I)=Z2(I)+S2*ALPHN-S3*BETAN Z3(I)=Z3(I)+S3*ALPHN+S2*BETAN END DO CALL SOLBC (N,LDE1,E2R,E2I,MLE,MUE,Z2,Z3,IP2) RETURN C C ----------------------------------------------------------- C 12 CONTINUE C --- B=IDENTITY, JACOBIAN A BANDED MATRIX, SECOND ORDER DO I=1,N S2=-F2(I) S3=-F3(I) Z2(I)=Z2(I)+S2*ALPHN-S3*BETAN Z3(I)=Z3(I)+S3*ALPHN+S2*BETAN END DO 45 ABNO=ALPHN**2+BETAN**2 MM=M1/M2 DO J=1,M2 SUM2=0.D0 SUM3=0.D0 DO K=MM-1,0,-1 JKM=J+K*M2 SUMH=(Z2(JKM)+SUM2)/ABNO SUM3=(Z3(JKM)+SUM3)/ABNO SUM2=SUMH*ALPHN+SUM3*BETAN SUM3=SUM3*ALPHN-SUMH*BETAN DO I=MAX(1,J-MUJAC),MIN(NM1,J+MLJAC) IM1=I+M1 IIMU=I+MUJAC+1-J Z2(IM1)=Z2(IM1)+FJAC(IIMU,JKM)*SUM2 Z3(IM1)=Z3(IM1)+FJAC(IIMU,JKM)*SUM3 END DO END DO END DO CALL SOLBC (NM1,LDE1,E2R,E2I,MLE,MUE,Z2(M1+1),Z3(M1+1),IP2) GOTO 49 C C ----------------------------------------------------------- C 3 CONTINUE C --- B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX DO I=1,N S2=0.0D0 S3=0.0D0 DO J=MAX(1,I-MLMAS),MIN(N,I+MUMAS) BB=FMAS(I-J+MBDIAG,J) S2=S2-BB*F2(J) S3=S3-BB*F3(J) END DO Z2(I)=Z2(I)+S2*ALPHN-S3*BETAN Z3(I)=Z3(I)+S3*ALPHN+S2*BETAN END DO CALL SOLC(N,LDE1,E2R,E2I,Z2,Z3,IP2) RETURN C C ----------------------------------------------------------- C 13 CONTINUE C --- B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX, SECOND ORDER DO I=1,M1 S2=-F2(I) S3=-F3(I) Z2(I)=Z2(I)+S2*ALPHN-S3*BETAN Z3(I)=Z3(I)+S3*ALPHN+S2*BETAN END DO DO I=1,NM1 IM1=I+M1 S2=0.0D0 S3=0.0D0 DO J=MAX(1,I-MLMAS),MIN(NM1,I+MUMAS) JM1=J+M1 BB=FMAS(I-J+MBDIAG,J) S2=S2-BB*F2(JM1) S3=S3-BB*F3(JM1) END DO Z2(IM1)=Z2(IM1)+S2*ALPHN-S3*BETAN Z3(IM1)=Z3(IM1)+S3*ALPHN+S2*BETAN END DO IF (IJOB.EQ.14) GOTO 45 GOTO 48 C C ----------------------------------------------------------- C 4 CONTINUE C --- B IS A BANDED MATRIX, JACOBIAN A BANDED MATRIX DO I=1,N S2=0.0D0 S3=0.0D0 DO J=MAX(1,I-MLMAS),MIN(N,I+MUMAS) BB=FMAS(I-J+MBDIAG,J) S2=S2-BB*F2(J) S3=S3-BB*F3(J) END DO Z2(I)=Z2(I)+S2*ALPHN-S3*BETAN Z3(I)=Z3(I)+S3*ALPHN+S2*BETAN END DO CALL SOLBC(N,LDE1,E2R,E2I,MLE,MUE,Z2,Z3,IP2) RETURN C C ----------------------------------------------------------- C 5 CONTINUE C --- B IS A FULL MATRIX, JACOBIAN A FULL MATRIX DO I=1,N S2=0.0D0 S3=0.0D0 DO J=1,N BB=FMAS(I,J) S2=S2-BB*F2(J) S3=S3-BB*F3(J) END DO Z2(I)=Z2(I)+S2*ALPHN-S3*BETAN Z3(I)=Z3(I)+S3*ALPHN+S2*BETAN END DO CALL SOLC(N,LDE1,E2R,E2I,Z2,Z3,IP2) RETURN C C ----------------------------------------------------------- C 15 CONTINUE C --- B IS A FULL MATRIX, JACOBIAN A FULL MATRIX, SECOND ORDER DO I=1,M1 S2=-F2(I) S3=-F3(I) Z2(I)=Z2(I)+S2*ALPHN-S3*BETAN Z3(I)=Z3(I)+S3*ALPHN+S2*BETAN END DO DO I=1,NM1 IM1=I+M1 S2=0.0D0 S3=0.0D0 DO J=1,NM1 JM1=J+M1 BB=FMAS(I,J) S2=S2-BB*F2(JM1) S3=S3-BB*F3(JM1) END DO Z2(IM1)=Z2(IM1)+S2*ALPHN-S3*BETAN Z3(IM1)=Z3(IM1)+S3*ALPHN+S2*BETAN END DO GOTO 48 C C ----------------------------------------------------------- C 6 CONTINUE C --- B IS A FULL MATRIX, JACOBIAN A BANDED MATRIX C --- THIS OPTION IS NOT PROVIDED RETURN C C ----------------------------------------------------------- C 7 CONTINUE C --- B=IDENTITY, JACOBIAN A FULL MATRIX, HESSENBERG-OPTION DO I=1,N S2=-F2(I) S3=-F3(I) Z2(I)=Z2(I)+S2*ALPHN-S3*BETAN Z3(I)=Z3(I)+S3*ALPHN+S2*BETAN END DO DO MM=N-2,1,-1 MP=N-MM MP1=MP-1 I=IPHES(MP) IF (I.EQ.MP) GOTO 746 ZSAFE=Z2(MP) Z2(MP)=Z2(I) Z2(I)=ZSAFE ZSAFE=Z3(MP) Z3(MP)=Z3(I) Z3(I)=ZSAFE 746 CONTINUE DO I=MP+1,N E1IMP=FJAC(I,MP1) Z2(I)=Z2(I)-E1IMP*Z2(MP) Z3(I)=Z3(I)-E1IMP*Z3(MP) END DO END DO CALL SOLHC(N,LDE1,E2R,E2I,1,Z2,Z3,IP2) DO MM=1,N-2 MP=N-MM MP1=MP-1 DO I=MP+1,N E1IMP=FJAC(I,MP1) Z2(I)=Z2(I)+E1IMP*Z2(MP) Z3(I)=Z3(I)+E1IMP*Z3(MP) END DO I=IPHES(MP) IF (I.EQ.MP) GOTO 750 ZSAFE=Z2(MP) Z2(MP)=Z2(I) Z2(I)=ZSAFE ZSAFE=Z3(MP) Z3(MP)=Z3(I) Z3(I)=ZSAFE 750 CONTINUE END DO RETURN C C ----------------------------------------------------------- C 55 CONTINUE RETURN END C C END OF SUBROUTINE SLVRAI C C *********************************************************** C SUBROUTINE SLVRAD(N,FJAC,LDJAC,MLJAC,MUJAC,FMAS,LDMAS,MLMAS,MUMAS, & M1,M2,NM1,FAC1,ALPHN,BETAN,E1,E2R,E2I,LDE1,Z1,Z2,Z3, & F1,F2,F3,CONT,IP1,IP2,IPHES,IER,IJOB) IMPLICIT REAL(KIND=8) (A-H,O-Z) DIMENSION FJAC(LDJAC,N),FMAS(LDMAS,NM1),E1(LDE1,NM1), & E2R(LDE1,NM1),E2I(LDE1,NM1),IP1(NM1),IP2(NM1), & IPHES(N),Z1(N),Z2(N),Z3(N),F1(N),F2(N),F3(N) COMMON/LINAL/MLE,MUE,MBJAC,MBB,MDIAG,MDIFF,MBDIAG C IF (IJOB .EQ. 1) THEN GOTO 1 ELSE IF (IJOB .EQ. 2) THEN GOTO 2 ELSE IF (IJOB .EQ. 3) THEN GOTO 3 ELSE IF (IJOB .EQ. 4) THEN GOTO 4 ELSE IF (IJOB .EQ. 5) THEN GOTO 5 ELSE IF (IJOB .EQ. 6) THEN GOTO 6 ELSE IF (IJOB .EQ. 7) THEN GOTO 7 ELSE IF (IJOB .LE. 10) THEN GOTO 55 ELSE IF (IJOB .EQ. 11) THEN GOTO 11 ELSE IF (IJOB .EQ. 12) THEN GOTO 12 ELSE IF (IJOB .EQ. 13) THEN GOTO 13 ELSE IF (IJOB .EQ. 14) THEN GOTO 13 ELSE IF (IJOB .EQ. 15) THEN GOTO 15 ENDIF C karline: changed from C GOTO (1,2,3,4,5,6,7,55,55,55,11,12,13,13,15), IJOB C C ----------------------------------------------------------- C 1 CONTINUE C --- B=IDENTITY, JACOBIAN A FULL MATRIX DO I=1,N S2=-F2(I) S3=-F3(I) Z1(I)=Z1(I)-F1(I)*FAC1 Z2(I)=Z2(I)+S2*ALPHN-S3*BETAN Z3(I)=Z3(I)+S3*ALPHN+S2*BETAN END DO CALL solradau (N,LDE1,E1,Z1,IP1) CALL SOLC (N,LDE1,E2R,E2I,Z2,Z3,IP2) RETURN C C ----------------------------------------------------------- C 11 CONTINUE C --- B=IDENTITY, JACOBIAN A FULL MATRIX, SECOND ORDER DO I=1,N S2=-F2(I) S3=-F3(I) Z1(I)=Z1(I)-F1(I)*FAC1 Z2(I)=Z2(I)+S2*ALPHN-S3*BETAN Z3(I)=Z3(I)+S3*ALPHN+S2*BETAN END DO 48 ABNO=ALPHN**2+BETAN**2 MM=M1/M2 DO J=1,M2 SUM1=0.D0 SUM2=0.D0 SUM3=0.D0 DO K=MM-1,0,-1 JKM=J+K*M2 SUM1=(Z1(JKM)+SUM1)/FAC1 SUMH=(Z2(JKM)+SUM2)/ABNO SUM3=(Z3(JKM)+SUM3)/ABNO SUM2=SUMH*ALPHN+SUM3*BETAN SUM3=SUM3*ALPHN-SUMH*BETAN DO I=1,NM1 IM1=I+M1 Z1(IM1)=Z1(IM1)+FJAC(I,JKM)*SUM1 Z2(IM1)=Z2(IM1)+FJAC(I,JKM)*SUM2 Z3(IM1)=Z3(IM1)+FJAC(I,JKM)*SUM3 END DO END DO END DO CALL solradau (NM1,LDE1,E1,Z1(M1+1),IP1) CALL SOLC (NM1,LDE1,E2R,E2I,Z2(M1+1),Z3(M1+1),IP2) 49 CONTINUE DO I=M1,1,-1 MPI=M2+I Z1(I)=(Z1(I)+Z1(MPI))/FAC1 Z2I=Z2(I)+Z2(MPI) Z3I=Z3(I)+Z3(MPI) Z3(I)=(Z3I*ALPHN-Z2I*BETAN)/ABNO Z2(I)=(Z2I*ALPHN+Z3I*BETAN)/ABNO END DO RETURN C C ----------------------------------------------------------- C 2 CONTINUE C --- B=IDENTITY, JACOBIAN A BANDED MATRIX DO I=1,N S2=-F2(I) S3=-F3(I) Z1(I)=Z1(I)-F1(I)*FAC1 Z2(I)=Z2(I)+S2*ALPHN-S3*BETAN Z3(I)=Z3(I)+S3*ALPHN+S2*BETAN END DO CALL SOLradB (N,LDE1,E1,MLE,MUE,Z1,IP1) CALL SOLBC (N,LDE1,E2R,E2I,MLE,MUE,Z2,Z3,IP2) RETURN C C ----------------------------------------------------------- C 12 CONTINUE C --- B=IDENTITY, JACOBIAN A BANDED MATRIX, SECOND ORDER DO I=1,N S2=-F2(I) S3=-F3(I) Z1(I)=Z1(I)-F1(I)*FAC1 Z2(I)=Z2(I)+S2*ALPHN-S3*BETAN Z3(I)=Z3(I)+S3*ALPHN+S2*BETAN END DO 45 ABNO=ALPHN**2+BETAN**2 MM=M1/M2 DO J=1,M2 SUM1=0.D0 SUM2=0.D0 SUM3=0.D0 DO K=MM-1,0,-1 JKM=J+K*M2 SUM1=(Z1(JKM)+SUM1)/FAC1 SUMH=(Z2(JKM)+SUM2)/ABNO SUM3=(Z3(JKM)+SUM3)/ABNO SUM2=SUMH*ALPHN+SUM3*BETAN SUM3=SUM3*ALPHN-SUMH*BETAN DO I=MAX(1,J-MUJAC),MIN(NM1,J+MLJAC) IM1=I+M1 FFJA=FJAC(I+MUJAC+1-J,JKM) Z1(IM1)=Z1(IM1)+FFJA*SUM1 Z2(IM1)=Z2(IM1)+FFJA*SUM2 Z3(IM1)=Z3(IM1)+FFJA*SUM3 END DO END DO END DO CALL SOLradB (NM1,LDE1,E1,MLE,MUE,Z1(M1+1),IP1) CALL SOLBC (NM1,LDE1,E2R,E2I,MLE,MUE,Z2(M1+1),Z3(M1+1),IP2) GOTO 49 C C ----------------------------------------------------------- C 3 CONTINUE C --- B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX DO I=1,N S1=0.0D0 S2=0.0D0 S3=0.0D0 DO J=MAX(1,I-MLMAS),MIN(N,I+MUMAS) BB=FMAS(I-J+MBDIAG,J) S1=S1-BB*F1(J) S2=S2-BB*F2(J) S3=S3-BB*F3(J) END DO Z1(I)=Z1(I)+S1*FAC1 Z2(I)=Z2(I)+S2*ALPHN-S3*BETAN Z3(I)=Z3(I)+S3*ALPHN+S2*BETAN END DO CALL solradau (N,LDE1,E1,Z1,IP1) CALL SOLC(N,LDE1,E2R,E2I,Z2,Z3,IP2) RETURN C C ----------------------------------------------------------- C 13 CONTINUE C --- B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX, SECOND ORDER DO I=1,M1 S2=-F2(I) S3=-F3(I) Z1(I)=Z1(I)-F1(I)*FAC1 Z2(I)=Z2(I)+S2*ALPHN-S3*BETAN Z3(I)=Z3(I)+S3*ALPHN+S2*BETAN END DO DO I=1,NM1 IM1=I+M1 S1=0.0D0 S2=0.0D0 S3=0.0D0 J1B=MAX(1,I-MLMAS) J2B=MIN(NM1,I+MUMAS) DO J=J1B,J2B JM1=J+M1 BB=FMAS(I-J+MBDIAG,J) S1=S1-BB*F1(JM1) S2=S2-BB*F2(JM1) S3=S3-BB*F3(JM1) END DO Z1(IM1)=Z1(IM1)+S1*FAC1 Z2(IM1)=Z2(IM1)+S2*ALPHN-S3*BETAN Z3(IM1)=Z3(IM1)+S3*ALPHN+S2*BETAN END DO IF (IJOB.EQ.14) GOTO 45 GOTO 48 C C ----------------------------------------------------------- C 4 CONTINUE C --- B IS A BANDED MATRIX, JACOBIAN A BANDED MATRIX DO I=1,N S1=0.0D0 S2=0.0D0 S3=0.0D0 DO J=MAX(1,I-MLMAS),MIN(N,I+MUMAS) BB=FMAS(I-J+MBDIAG,J) S1=S1-BB*F1(J) S2=S2-BB*F2(J) S3=S3-BB*F3(J) END DO Z1(I)=Z1(I)+S1*FAC1 Z2(I)=Z2(I)+S2*ALPHN-S3*BETAN Z3(I)=Z3(I)+S3*ALPHN+S2*BETAN END DO CALL SOLradB (N,LDE1,E1,MLE,MUE,Z1,IP1) CALL SOLBC(N,LDE1,E2R,E2I,MLE,MUE,Z2,Z3,IP2) RETURN C C ----------------------------------------------------------- C 5 CONTINUE C --- B IS A FULL MATRIX, JACOBIAN A FULL MATRIX DO I=1,N S1=0.0D0 S2=0.0D0 S3=0.0D0 DO J=1,N BB=FMAS(I,J) S1=S1-BB*F1(J) S2=S2-BB*F2(J) S3=S3-BB*F3(J) END DO Z1(I)=Z1(I)+S1*FAC1 Z2(I)=Z2(I)+S2*ALPHN-S3*BETAN Z3(I)=Z3(I)+S3*ALPHN+S2*BETAN END DO CALL solradau (N,LDE1,E1,Z1,IP1) CALL SOLC(N,LDE1,E2R,E2I,Z2,Z3,IP2) RETURN C C ----------------------------------------------------------- C 15 CONTINUE C --- B IS A FULL MATRIX, JACOBIAN A FULL MATRIX, SECOND ORDER DO I=1,M1 S2=-F2(I) S3=-F3(I) Z1(I)=Z1(I)-F1(I)*FAC1 Z2(I)=Z2(I)+S2*ALPHN-S3*BETAN Z3(I)=Z3(I)+S3*ALPHN+S2*BETAN END DO DO I=1,NM1 IM1=I+M1 S1=0.0D0 S2=0.0D0 S3=0.0D0 DO J=1,NM1 JM1=J+M1 BB=FMAS(I,J) S1=S1-BB*F1(JM1) S2=S2-BB*F2(JM1) S3=S3-BB*F3(JM1) END DO Z1(IM1)=Z1(IM1)+S1*FAC1 Z2(IM1)=Z2(IM1)+S2*ALPHN-S3*BETAN Z3(IM1)=Z3(IM1)+S3*ALPHN+S2*BETAN END DO GOTO 48 C C ----------------------------------------------------------- C 6 CONTINUE C --- B IS A FULL MATRIX, JACOBIAN A BANDED MATRIX C --- THIS OPTION IS NOT PROVIDED RETURN C C ----------------------------------------------------------- C 7 CONTINUE C --- B=IDENTITY, JACOBIAN A FULL MATRIX, HESSENBERG-OPTION DO I=1,N S2=-F2(I) S3=-F3(I) Z1(I)=Z1(I)-F1(I)*FAC1 Z2(I)=Z2(I)+S2*ALPHN-S3*BETAN Z3(I)=Z3(I)+S3*ALPHN+S2*BETAN END DO DO MM=N-2,1,-1 MP=N-MM MP1=MP-1 I=IPHES(MP) IF (I.EQ.MP) GOTO 746 ZSAFE=Z1(MP) Z1(MP)=Z1(I) Z1(I)=ZSAFE ZSAFE=Z2(MP) Z2(MP)=Z2(I) Z2(I)=ZSAFE ZSAFE=Z3(MP) Z3(MP)=Z3(I) Z3(I)=ZSAFE 746 CONTINUE DO I=MP+1,N E1IMP=FJAC(I,MP1) Z1(I)=Z1(I)-E1IMP*Z1(MP) Z2(I)=Z2(I)-E1IMP*Z2(MP) Z3(I)=Z3(I)-E1IMP*Z3(MP) END DO END DO CALL SOLH(N,LDE1,E1,1,Z1,IP1) CALL SOLHC(N,LDE1,E2R,E2I,1,Z2,Z3,IP2) DO MM=1,N-2 MP=N-MM MP1=MP-1 DO I=MP+1,N E1IMP=FJAC(I,MP1) Z1(I)=Z1(I)+E1IMP*Z1(MP) Z2(I)=Z2(I)+E1IMP*Z2(MP) Z3(I)=Z3(I)+E1IMP*Z3(MP) END DO I=IPHES(MP) IF (I.EQ.MP) GOTO 750 ZSAFE=Z1(MP) Z1(MP)=Z1(I) Z1(I)=ZSAFE ZSAFE=Z2(MP) Z2(MP)=Z2(I) Z2(I)=ZSAFE ZSAFE=Z3(MP) Z3(MP)=Z3(I) Z3(I)=ZSAFE 750 CONTINUE END DO RETURN C C ----------------------------------------------------------- C 55 CONTINUE RETURN END C C END OF SUBROUTINE SLVRAD C C *********************************************************** C SUBROUTINE ESTRAD(N,FJAC,LDJAC,MLJAC,MUJAC,FMAS,LDMAS,MLMAS,MUMAS, & H,DD1,DD2,DD3,FCN,NFCN,Y0,Y,IJOB,X,M1,M2,NM1, & E1,LDE1,Z1,Z2,Z3,CONT,F1,F2,IP1,IPHES,SCAL,ERR, & FIRST,REJECT,FAC1,RPAR,IPAR) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION FJAC(LDJAC,N),FMAS(LDMAS,NM1),E1(LDE1,NM1),IP1(NM1), & SCAL(N),IPHES(N),Z1(N),Z2(N),Z3(N),F1(N),F2(N),Y0(N),Y(N) DIMENSION CONT(N),RPAR(1),IPAR(1) LOGICAL FIRST,REJECT COMMON/LINAL/MLE,MUE,MBJAC,MBB,MDIAG,MDIFF,MBDIAG HEE1=DD1/H HEE2=DD2/H HEE3=DD3/H IF (IJOB .EQ. 1) THEN GOTO 1 ELSE IF (IJOB .EQ. 2) THEN GOTO 2 ELSE IF (IJOB .EQ. 3) THEN GOTO 3 ELSE IF (IJOB .EQ. 4) THEN GOTO 4 ELSE IF (IJOB .EQ. 5) THEN GOTO 5 ELSE IF (IJOB .EQ. 6) THEN GOTO 6 ELSE IF (IJOB .EQ. 7) THEN GOTO 7 ELSE IF (IJOB .LE. 10) THEN GOTO 55 ELSE IF (IJOB .EQ. 11) THEN GOTO 11 ELSE IF (IJOB .EQ. 12) THEN GOTO 12 ELSE IF (IJOB .EQ. 13) THEN GOTO 13 ELSE IF (IJOB .EQ. 14) THEN GOTO 14 ELSE IF (IJOB .EQ. 15) THEN GOTO 15 ENDIF C karline changed from: C GOTO (1,2,3,4,5,6,7,55,55,55,11,12,13,14,15), IJOB C 1 CONTINUE C ------ B=IDENTITY, JACOBIAN A FULL MATRIX DO I=1,N F2(I)=HEE1*Z1(I)+HEE2*Z2(I)+HEE3*Z3(I) CONT(I)=F2(I)+Y0(I) END DO CALL solradau (N,LDE1,E1,CONT,IP1) GOTO 77 C 11 CONTINUE C ------ B=IDENTITY, JACOBIAN A FULL MATRIX, SECOND ORDER DO I=1,N F2(I)=HEE1*Z1(I)+HEE2*Z2(I)+HEE3*Z3(I) CONT(I)=F2(I)+Y0(I) END DO 48 MM=M1/M2 DO J=1,M2 SUM1=0.D0 DO K=MM-1,0,-1 SUM1=(CONT(J+K*M2)+SUM1)/FAC1 DO I=1,NM1 IM1=I+M1 CONT(IM1)=CONT(IM1)+FJAC(I,J+K*M2)*SUM1 END DO END DO END DO CALL solradau (NM1,LDE1,E1,CONT(M1+1),IP1) DO I=M1,1,-1 CONT(I)=(CONT(I)+CONT(M2+I))/FAC1 END DO GOTO 77 C 2 CONTINUE C ------ B=IDENTITY, JACOBIAN A BANDED MATRIX DO I=1,N F2(I)=HEE1*Z1(I)+HEE2*Z2(I)+HEE3*Z3(I) CONT(I)=F2(I)+Y0(I) END DO CALL SOLradB (N,LDE1,E1,MLE,MUE,CONT,IP1) GOTO 77 C 12 CONTINUE C ------ B=IDENTITY, JACOBIAN A BANDED MATRIX, SECOND ORDER DO I=1,N F2(I)=HEE1*Z1(I)+HEE2*Z2(I)+HEE3*Z3(I) CONT(I)=F2(I)+Y0(I) END DO 45 MM=M1/M2 DO J=1,M2 SUM1=0.D0 DO K=MM-1,0,-1 SUM1=(CONT(J+K*M2)+SUM1)/FAC1 DO I=MAX(1,J-MUJAC),MIN(NM1,J+MLJAC) IM1=I+M1 CONT(IM1)=CONT(IM1)+FJAC(I+MUJAC+1-J,J+K*M2)*SUM1 END DO END DO END DO CALL SOLradB (NM1,LDE1,E1,MLE,MUE,CONT(M1+1),IP1) DO I=M1,1,-1 CONT(I)=(CONT(I)+CONT(M2+I))/FAC1 END DO GOTO 77 C 3 CONTINUE C ------ B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX DO I=1,N F1(I)=HEE1*Z1(I)+HEE2*Z2(I)+HEE3*Z3(I) END DO DO I=1,N SUM=0.D0 DO J=MAX(1,I-MLMAS),MIN(N,I+MUMAS) SUM=SUM+FMAS(I-J+MBDIAG,J)*F1(J) END DO F2(I)=SUM CONT(I)=SUM+Y0(I) END DO CALL solradau (N,LDE1,E1,CONT,IP1) GOTO 77 C 13 CONTINUE C ------ B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX, SECOND ORDER DO I=1,M1 F2(I)=HEE1*Z1(I)+HEE2*Z2(I)+HEE3*Z3(I) CONT(I)=F2(I)+Y0(I) END DO DO I=M1+1,N F1(I)=HEE1*Z1(I)+HEE2*Z2(I)+HEE3*Z3(I) END DO DO I=1,NM1 SUM=0.D0 DO J=MAX(1,I-MLMAS),MIN(NM1,I+MUMAS) SUM=SUM+FMAS(I-J+MBDIAG,J)*F1(J+M1) END DO IM1=I+M1 F2(IM1)=SUM CONT(IM1)=SUM+Y0(IM1) END DO GOTO 48 C 4 CONTINUE C ------ B IS A BANDED MATRIX, JACOBIAN A BANDED MATRIX DO I=1,N F1(I)=HEE1*Z1(I)+HEE2*Z2(I)+HEE3*Z3(I) END DO DO I=1,N SUM=0.D0 DO J=MAX(1,I-MLMAS),MIN(N,I+MUMAS) SUM=SUM+FMAS(I-J+MBDIAG,J)*F1(J) END DO F2(I)=SUM CONT(I)=SUM+Y0(I) END DO CALL SOLradB (N,LDE1,E1,MLE,MUE,CONT,IP1) GOTO 77 C 14 CONTINUE C ------ B IS A BANDED MATRIX, JACOBIAN A BANDED MATRIX, SECOND ORDER DO I=1,M1 F2(I)=HEE1*Z1(I)+HEE2*Z2(I)+HEE3*Z3(I) CONT(I)=F2(I)+Y0(I) END DO DO I=M1+1,N F1(I)=HEE1*Z1(I)+HEE2*Z2(I)+HEE3*Z3(I) END DO DO I=1,NM1 SUM=0.D0 DO J=MAX(1,I-MLMAS),MIN(NM1,I+MUMAS) SUM=SUM+FMAS(I-J+MBDIAG,J)*F1(J+M1) END DO IM1=I+M1 F2(IM1)=SUM CONT(IM1)=SUM+Y0(IM1) END DO GOTO 45 C 5 CONTINUE C ------ B IS A FULL MATRIX, JACOBIAN A FULL MATRIX DO I=1,N F1(I)=HEE1*Z1(I)+HEE2*Z2(I)+HEE3*Z3(I) END DO DO I=1,N SUM=0.D0 DO J=1,N SUM=SUM+FMAS(I,J)*F1(J) END DO F2(I)=SUM CONT(I)=SUM+Y0(I) END DO CALL solradau (N,LDE1,E1,CONT,IP1) GOTO 77 C 15 CONTINUE C ------ B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX, SECOND ORDER DO I=1,M1 F2(I)=HEE1*Z1(I)+HEE2*Z2(I)+HEE3*Z3(I) CONT(I)=F2(I)+Y0(I) END DO DO I=M1+1,N F1(I)=HEE1*Z1(I)+HEE2*Z2(I)+HEE3*Z3(I) END DO DO I=1,NM1 SUM=0.D0 DO J=1,NM1 SUM=SUM+FMAS(I,J)*F1(J+M1) END DO IM1=I+M1 F2(IM1)=SUM CONT(IM1)=SUM+Y0(IM1) END DO GOTO 48 C 6 CONTINUE C ------ B IS A FULL MATRIX, JACOBIAN A BANDED MATRIX C ------ THIS OPTION IS NOT PROVIDED RETURN C 7 CONTINUE C ------ B=IDENTITY, JACOBIAN A FULL MATRIX, HESSENBERG-OPTION DO I=1,N F2(I)=HEE1*Z1(I)+HEE2*Z2(I)+HEE3*Z3(I) CONT(I)=F2(I)+Y0(I) END DO DO MM=N-2,1,-1 MP=N-MM I=IPHES(MP) IF (I.EQ.MP) GOTO 310 ZSAFE=CONT(MP) CONT(MP)=CONT(I) CONT(I)=ZSAFE 310 CONTINUE DO I=MP+1,N CONT(I)=CONT(I)-FJAC(I,MP-1)*CONT(MP) END DO END DO CALL SOLH(N,LDE1,E1,1,CONT,IP1) DO MM=1,N-2 MP=N-MM DO I=MP+1,N CONT(I)=CONT(I)+FJAC(I,MP-1)*CONT(MP) END DO I=IPHES(MP) IF (I.EQ.MP) GOTO 440 ZSAFE=CONT(MP) CONT(MP)=CONT(I) CONT(I)=ZSAFE 440 CONTINUE END DO C C -------------------------------------- C 77 CONTINUE ERR=0.D0 DO I=1,N ERR=ERR+(CONT(I)/SCAL(I))**2 END DO ERR=MAX(SQRT(ERR/N),1.D-10) C IF (ERR.LT.1.D0) RETURN IF (FIRST.OR.REJECT) THEN DO I=1,N CONT(I)=Y(I)+CONT(I) END DO CALL FCN(N,X,CONT,F1,RPAR,IPAR) NFCN=NFCN+1 DO I=1,N CONT(I)=F1(I)+F2(I) END DO IF (IJOB .EQ. 1 .OR. IJOB .EQ. 3 .OR. IJOB .EQ. 5) THEN GOTO 31 ELSE IF (IJOB .EQ. 2 .OR. IJOB .EQ. 4 .OR. IJOB .EQ. 6) THEN GOTO 32 ELSE IF (IJOB .EQ. 7) THEN GOTO 33 ELSE IF (IJOB .LE. 10) THEN GOTO 55 ELSE IF (IJOB .EQ.11 .OR. IJOB .EQ.13 .OR. IJOB .EQ.15) THEN GOTO 41 ELSE IF (IJOB .EQ. 12 .OR. IJOB .EQ. 14) THEN GOTO 42 END IF C karline: changed from C GOTO (31,32,31,32,31,32,33,55,55,55,41,42,41,42,41), IJOB C ------ FULL MATRIX OPTION 31 CONTINUE CALL solradau(N,LDE1,E1,CONT,IP1) GOTO 88 C ------ FULL MATRIX OPTION, SECOND ORDER 41 CONTINUE DO J=1,M2 SUM1=0.D0 DO K=MM-1,0,-1 SUM1=(CONT(J+K*M2)+SUM1)/FAC1 DO I=1,NM1 IM1=I+M1 CONT(IM1)=CONT(IM1)+FJAC(I,J+K*M2)*SUM1 END DO END DO END DO CALL solradau(NM1,LDE1,E1,CONT(M1+1),IP1) DO I=M1,1,-1 CONT(I)=(CONT(I)+CONT(M2+I))/FAC1 END DO GOTO 88 C ------ BANDED MATRIX OPTION 32 CONTINUE CALL SOLradB (N,LDE1,E1,MLE,MUE,CONT,IP1) GOTO 88 C ------ BANDED MATRIX OPTION, SECOND ORDER 42 CONTINUE DO J=1,M2 SUM1=0.D0 DO K=MM-1,0,-1 SUM1=(CONT(J+K*M2)+SUM1)/FAC1 DO I=MAX(1,J-MUJAC),MIN(NM1,J+MLJAC) IM1=I+M1 CONT(IM1)=CONT(IM1)+FJAC(I+MUJAC+1-J,J+K*M2)*SUM1 END DO END DO END DO CALL SOLradB (NM1,LDE1,E1,MLE,MUE,CONT(M1+1),IP1) DO I=M1,1,-1 CONT(I)=(CONT(I)+CONT(M2+I))/FAC1 END DO GOTO 88 C ------ HESSENBERG MATRIX OPTION 33 CONTINUE DO MM=N-2,1,-1 MP=N-MM I=IPHES(MP) IF (I.EQ.MP) GOTO 510 ZSAFE=CONT(MP) CONT(MP)=CONT(I) CONT(I)=ZSAFE 510 CONTINUE DO I=MP+1,N CONT(I)=CONT(I)-FJAC(I,MP-1)*CONT(MP) END DO END DO CALL SOLH(N,LDE1,E1,1,CONT,IP1) DO MM=1,N-2 MP=N-MM DO I=MP+1,N CONT(I)=CONT(I)+FJAC(I,MP-1)*CONT(MP) END DO I=IPHES(MP) IF (I.EQ.MP) GOTO 640 ZSAFE=CONT(MP) CONT(MP)=CONT(I) CONT(I)=ZSAFE 640 CONTINUE END DO C ----------------------------------- 88 CONTINUE ERR=0.D0 DO I=1,N ERR=ERR+(CONT(I)/SCAL(I))**2 END DO ERR=MAX(SQRT(ERR/N),1.D-10) END IF RETURN C ----------------------------------------------------------- 55 CONTINUE RETURN END C C END OF SUBROUTINE ESTRAD C C *********************************************************** C SUBROUTINE ESTRAV(N,FJAC,LDJAC,MLJAC,MUJAC,FMAS,LDMAS,MLMAS,MUMAS, & H,DD,FCN,NFCN,Y0,Y,IJOB,X,M1,M2,NM1,NS,NNS, & E1,LDE1,ZZ,CONT,FF,IP1,IPHES,SCAL,ERR, & FIRST,REJECT,FAC1,RPAR,IPAR) IMPLICIT REAL(KIND=8) (A-H,O-Z) DIMENSION FJAC(LDJAC,N),FMAS(LDMAS,NM1),E1(LDE1,NM1),IP1(NM1), & SCAL(N),IPHES(N),ZZ(NNS),FF(NNS),Y0(N),Y(N) DIMENSION DD(NS),CONT(N),RPAR(1),IPAR(1) LOGICAL FIRST,REJECT COMMON/LINAL/MLE,MUE,MBJAC,MBB,MDIAG,MDIFF,MBDIAG IF (IJOB .EQ. 1) THEN GOTO 1 ELSE IF (IJOB .EQ. 2) THEN GOTO 2 ELSE IF (IJOB .EQ. 3) THEN GOTO 3 ELSE IF (IJOB .EQ. 4) THEN GOTO 4 ELSE IF (IJOB .EQ. 5) THEN GOTO 5 ELSE IF (IJOB .EQ. 6) THEN GOTO 6 ELSE IF (IJOB .EQ. 7) THEN GOTO 7 ELSE IF (IJOB .LE. 10) THEN GOTO 55 ELSE IF (IJOB .EQ. 11) THEN GOTO 11 ELSE IF (IJOB .EQ. 12) THEN GOTO 12 ELSE IF (IJOB .EQ. 13) THEN GOTO 13 ELSE IF (IJOB .EQ. 14) THEN GOTO 14 ELSE IF (IJOB .EQ. 15) THEN GOTO 15 ENDIF C karline: changed from C GOTO (1,2,3,4,5,6,7,55,55,55,11,12,13,14,15), IJOB C 1 CONTINUE C ------ B=IDENTITY, JACOBIAN A FULL MATRIX DO I=1,N SUM=0.D0 DO K=1,NS SUM=SUM+DD(K)*ZZ(I+(K-1)*N) END DO FF(I+N)=SUM/H CONT(I)=FF(I+N)+Y0(I) END DO CALL solradau (N,LDE1,E1,CONT,IP1) GOTO 77 C 11 CONTINUE C ------ B=IDENTITY, JACOBIAN A FULL MATRIX, SECOND ORDER DO I=1,N SUM=0.D0 DO K=1,NS SUM=SUM+DD(K)*ZZ(I+(K-1)*N) END DO FF(I+N)=SUM/H CONT(I)=FF(I+N)+Y0(I) END DO 48 MM=M1/M2 DO J=1,M2 SUM1=0.D0 DO K=MM-1,0,-1 SUM1=(CONT(J+K*M2)+SUM1)/FAC1 DO I=1,NM1 IM1=I+M1 CONT(IM1)=CONT(IM1)+FJAC(I,J+K*M2)*SUM1 END DO END DO END DO CALL solradau (NM1,LDE1,E1,CONT(M1+1),IP1) DO I=M1,1,-1 CONT(I)=(CONT(I)+CONT(M2+I))/FAC1 END DO GOTO 77 C 2 CONTINUE C ------ B=IDENTITY, JACOBIAN A BANDED MATRIX DO I=1,N SUM=0.D0 DO K=1,NS SUM=SUM+DD(K)*ZZ(I+(K-1)*N) END DO FF(I+N)=SUM/H CONT(I)=FF(I+N)+Y0(I) END DO CALL SOLradB (N,LDE1,E1,MLE,MUE,CONT,IP1) GOTO 77 C 12 CONTINUE C ------ B=IDENTITY, JACOBIAN A BANDED MATRIX, SECOND ORDER DO I=1,N SUM=0.D0 DO K=1,NS SUM=SUM+DD(K)*ZZ(I+(K-1)*N) END DO FF(I+N)=SUM/H CONT(I)=FF(I+N)+Y0(I) END DO 45 MM=M1/M2 DO J=1,M2 SUM1=0.D0 DO K=MM-1,0,-1 SUM1=(CONT(J+K*M2)+SUM1)/FAC1 DO I=MAX(1,J-MUJAC),MIN(NM1,J+MLJAC) IM1=I+M1 CONT(IM1)=CONT(IM1)+FJAC(I+MUJAC+1-J,J+K*M2)*SUM1 END DO END DO END DO CALL SOLradB (NM1,LDE1,E1,MLE,MUE,CONT(M1+1),IP1) DO I=M1,1,-1 CONT(I)=(CONT(I)+CONT(M2+I))/FAC1 END DO GOTO 77 C 3 CONTINUE C ------ B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX DO I=1,N SUM=0.D0 DO K=1,NS SUM=SUM+DD(K)*ZZ(I+(K-1)*N) END DO FF(I)=SUM/H END DO DO I=1,N SUM=0.D0 DO J=MAX(1,I-MLMAS),MIN(N,I+MUMAS) SUM=SUM+FMAS(I-J+MBDIAG,J)*FF(J) END DO FF(I+N)=SUM CONT(I)=SUM+Y0(I) END DO CALL solradau (N,LDE1,E1,CONT,IP1) GOTO 77 C 13 CONTINUE C ------ B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX, SECOND ORDER DO I=1,M1 SUM=0.D0 DO K=1,NS SUM=SUM+DD(K)*ZZ(I+(K-1)*N) END DO FF(I+N)=SUM/H CONT(I)=FF(I+N)+Y0(I) END DO DO I=M1+1,N SUM=0.D0 DO K=1,NS SUM=SUM+DD(K)*ZZ(I+(K-1)*N) END DO FF(I)=SUM/H END DO DO I=1,NM1 SUM=0.D0 DO J=MAX(1,I-MLMAS),MIN(NM1,I+MUMAS) SUM=SUM+FMAS(I-J+MBDIAG,J)*FF(J+M1) END DO IM1=I+M1 FF(IM1+N)=SUM CONT(IM1)=SUM+Y0(IM1) END DO GOTO 48 C 4 CONTINUE C ------ B IS A BANDED MATRIX, JACOBIAN A BANDED MATRIX DO I=1,N SUM=0.D0 DO K=1,NS SUM=SUM+DD(K)*ZZ(I+(K-1)*N) END DO FF(I)=SUM/H END DO DO I=1,N SUM=0.D0 DO J=MAX(1,I-MLMAS),MIN(N,I+MUMAS) SUM=SUM+FMAS(I-J+MBDIAG,J)*FF(J) END DO FF(I+N)=SUM CONT(I)=SUM+Y0(I) END DO CALL SOLradB (N,LDE1,E1,MLE,MUE,CONT,IP1) GOTO 77 C 14 CONTINUE C ------ B IS A BANDED MATRIX, JACOBIAN A BANDED MATRIX, SECOND ORDER DO I=1,M1 SUM=0.D0 DO K=1,NS SUM=SUM+DD(K)*ZZ(I+(K-1)*N) END DO FF(I+N)=SUM/H CONT(I)=FF(I+N)+Y0(I) END DO DO I=M1+1,N SUM=0.D0 DO K=1,NS SUM=SUM+DD(K)*ZZ(I+(K-1)*N) END DO FF(I)=SUM/H END DO DO I=1,NM1 SUM=0.D0 DO J=MAX(1,I-MLMAS),MIN(NM1,I+MUMAS) SUM=SUM+FMAS(I-J+MBDIAG,J)*FF(J+M1) END DO IM1=I+M1 FF(IM1+N)=SUM CONT(IM1)=SUM+Y0(IM1) END DO GOTO 45 C 5 CONTINUE C ------ B IS A FULL MATRIX, JACOBIAN A FULL MATRIX DO I=1,N SUM=0.D0 DO K=1,NS SUM=SUM+DD(K)*ZZ(I+(K-1)*N) END DO FF(I)=SUM/H END DO DO I=1,N SUM=0.D0 DO J=1,N SUM=SUM+FMAS(I,J)*FF(J) END DO FF(I+N)=SUM CONT(I)=SUM+Y0(I) END DO CALL solradau (N,LDE1,E1,CONT,IP1) GOTO 77 C 15 CONTINUE C ------ B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX, SECOND ORDER DO I=1,M1 SUM=0.D0 DO K=1,NS SUM=SUM+DD(K)*ZZ(I+(K-1)*N) END DO FF(I+N)=SUM/H CONT(I)=FF(I+N)+Y0(I) END DO DO I=M1+1,N SUM=0.D0 DO K=1,NS SUM=SUM+DD(K)*ZZ(I+(K-1)*N) END DO FF(I)=SUM/H END DO DO I=1,NM1 SUM=0.D0 DO J=1,NM1 SUM=SUM+FMAS(I,J)*FF(J+M1) END DO IM1=I+M1 FF(IM1+N)=SUM CONT(IM1)=SUM+Y0(IM1) END DO GOTO 48 C 6 CONTINUE C ------ B IS A FULL MATRIX, JACOBIAN A BANDED MATRIX C ------ THIS OPTION IS NOT PROVIDED RETURN C 7 CONTINUE C ------ B=IDENTITY, JACOBIAN A FULL MATRIX, HESSENBERG-OPTION DO I=1,N SUM=0.D0 DO K=1,NS SUM=SUM+DD(K)*ZZ(I+(K-1)*N) END DO FF(I+N)=SUM/H CONT(I)=FF(I+N)+Y0(I) END DO DO MM=N-2,1,-1 MP=N-MM I=IPHES(MP) IF (I.EQ.MP) GOTO 310 ZSAFE=CONT(MP) CONT(MP)=CONT(I) CONT(I)=ZSAFE 310 CONTINUE DO I=MP+1,N CONT(I)=CONT(I)-FJAC(I,MP-1)*CONT(MP) END DO END DO CALL SOLH(N,LDE1,E1,1,CONT,IP1) DO MM=1,N-2 MP=N-MM DO I=MP+1,N CONT(I)=CONT(I)+FJAC(I,MP-1)*CONT(MP) END DO I=IPHES(MP) IF (I.EQ.MP) GOTO 440 ZSAFE=CONT(MP) CONT(MP)=CONT(I) CONT(I)=ZSAFE 440 CONTINUE END DO C C -------------------------------------- C 77 CONTINUE ERR=0.D0 DO I=1,N ERR=ERR+(CONT(I)/SCAL(I))**2 END DO ERR=MAX(SQRT(ERR/N),1.D-10) C IF (ERR.LT.1.D0) RETURN IF (FIRST.OR.REJECT) THEN DO I=1,N CONT(I)=Y(I)+CONT(I) END DO CALL FCN(N,X,CONT,FF,RPAR,IPAR) NFCN=NFCN+1 DO I=1,N CONT(I)=FF(I)+FF(I+N) END DO IF (IJOB.EQ.1 .OR. IJOB .EQ. 3 .OR. IJOB .EQ. 5) THEN GOTO 31 ELSE IF (IJOB .EQ.2 .OR. IJOB .EQ. 4 .OR. IJOB .EQ. 6) THEN GOTO 32 ELSE IF (IJOB .EQ.7) THEN GOTO 33 ELSE IF (IJOB .LE.10) THEN GOTO 55 ELSE IF (IJOB .EQ.11 .OR. IJOB .EQ. 13 .OR. IJOB.EQ.15) THEN GOTO 41 ELSE IF (IJOB .EQ.12 .OR. IJOB .EQ. 14) THEN GOTO 42 ENDIF C karline: changed from C GOTO (31,32,31,32,31,32,33,55,55,55,41,42,41,42,41), IJOB C ------ FULL MATRIX OPTION 31 CONTINUE CALL solradau (N,LDE1,E1,CONT,IP1) GOTO 88 C ------ FULL MATRIX OPTION, SECOND ORDER 41 CONTINUE DO J=1,M2 SUM1=0.D0 DO K=MM-1,0,-1 SUM1=(CONT(J+K*M2)+SUM1)/FAC1 DO I=1,NM1 IM1=I+M1 CONT(IM1)=CONT(IM1)+FJAC(I,J+K*M2)*SUM1 END DO END DO END DO CALL solradau (NM1,LDE1,E1,CONT(M1+1),IP1) DO I=M1,1,-1 CONT(I)=(CONT(I)+CONT(M2+I))/FAC1 END DO GOTO 88 C ------ BANDED MATRIX OPTION 32 CONTINUE CALL SOLradB (N,LDE1,E1,MLE,MUE,CONT,IP1) GOTO 88 C ------ BANDED MATRIX OPTION, SECOND ORDER 42 CONTINUE DO J=1,M2 SUM1=0.D0 DO K=MM-1,0,-1 SUM1=(CONT(J+K*M2)+SUM1)/FAC1 DO I=MAX(1,J-MUJAC),MIN(NM1,J+MLJAC) IM1=I+M1 CONT(IM1)=CONT(IM1)+FJAC(I+MUJAC+1-J,J+K*M2)*SUM1 END DO END DO END DO CALL SOLradB (NM1,LDE1,E1,MLE,MUE,CONT(M1+1),IP1) DO I=M1,1,-1 CONT(I)=(CONT(I)+CONT(M2+I))/FAC1 END DO GOTO 88 C ------ HESSENBERG MATRIX OPTION 33 CONTINUE DO MM=N-2,1,-1 MP=N-MM I=IPHES(MP) IF (I.EQ.MP) GOTO 510 ZSAFE=CONT(MP) CONT(MP)=CONT(I) CONT(I)=ZSAFE 510 CONTINUE DO I=MP+1,N CONT(I)=CONT(I)-FJAC(I,MP-1)*CONT(MP) END DO END DO CALL SOLH(N,LDE1,E1,1,CONT,IP1) DO MM=1,N-2 MP=N-MM DO I=MP+1,N CONT(I)=CONT(I)+FJAC(I,MP-1)*CONT(MP) END DO I=IPHES(MP) IF (I.EQ.MP) GOTO 640 ZSAFE=CONT(MP) CONT(MP)=CONT(I) CONT(I)=ZSAFE 640 CONTINUE END DO C ----------------------------------- 88 CONTINUE ERR=0.D0 DO I=1,N ERR=ERR+(CONT(I)/SCAL(I))**2 END DO ERR=MAX(SQRT(ERR/N),1.D-10) END IF RETURN C C ----------------------------------------------------------- C 55 CONTINUE RETURN END C C END OF SUBROUTINE ESTRAV C C *********************************************************** C SUBROUTINE SLVROD(N,FJAC,LDJAC,MLJAC,MUJAC,FMAS,LDMAS,MLMAS,MUMAS, & M1,M2,NM1,FAC1,E,LDE,IP,DY,AK,FX,YNEW,HD,IJOB,STAGE1) IMPLICIT REAL(KIND=8) (A-H,O-Z) DIMENSION FJAC(LDJAC,N),FMAS(LDMAS,NM1),E(LDE,NM1), & IP(NM1),DY(N),AK(N),FX(N),YNEW(N) LOGICAL STAGE1 COMMON/LINAL/MLE,MUE,MBJAC,MBB,MDIAG,MDIFF,MBDIAG C IF (HD.EQ.0.D0) THEN DO I=1,N AK(I)=DY(I) END DO ELSE DO I=1,N AK(I)=DY(I)+HD*FX(I) END DO END IF C C GOTO (1,2,3,4,5,6,55,55,55,55,11,12,13,13,15), IJOB IF (IJOB .EQ. 1) THEN GOTO 1 ELSE IF (IJOB .EQ. 2) THEN GOTO 2 ELSE IF (IJOB .EQ. 3) THEN GOTO 3 ELSE IF (IJOB .EQ. 4) THEN GOTO 4 ELSE IF (IJOB .EQ. 5) THEN GOTO 5 ELSE IF (IJOB .EQ. 6) THEN GOTO 6 ELSE IF (IJOB .LE. 10) THEN GOTO 55 ELSE IF (IJOB .EQ. 11) THEN GOTO 11 ELSE IF (IJOB .EQ. 12) THEN GOTO 12 ELSE IF (IJOB .LE. 14) THEN GOTO 13 ELSE IF (IJOB .EQ. 15) THEN GOTO 15 ENDIF C karline: was C GOTO (1,2,3,4,5,6,55,55,55,55,11,12,13,13,15), IJOB C C ----------------------------------------------------------- C 1 CONTINUE C --- B=IDENTITY, JACOBIAN A FULL MATRIX IF (STAGE1) THEN DO I=1,N AK(I)=AK(I)+YNEW(I) END DO END IF CALL solradau (N,LDE,E,AK,IP) RETURN C C ----------------------------------------------------------- C 11 CONTINUE C --- B=IDENTITY, JACOBIAN A FULL MATRIX, SECOND ORDER IF (STAGE1) THEN DO I=1,N AK(I)=AK(I)+YNEW(I) END DO END IF 48 MM=M1/M2 DO J=1,M2 SUM=0.D0 DO K=MM-1,0,-1 JKM=J+K*M2 SUM=(AK(JKM)+SUM)/FAC1 DO I=1,NM1 IM1=I+M1 AK(IM1)=AK(IM1)+FJAC(I,JKM)*SUM END DO END DO END DO CALL solradau (NM1,LDE,E,AK(M1+1),IP) DO I=M1,1,-1 AK(I)=(AK(I)+AK(M2+I))/FAC1 END DO RETURN C C ----------------------------------------------------------- C 2 CONTINUE C --- B=IDENTITY, JACOBIAN A BANDED MATRIX IF (STAGE1) THEN DO I=1,N AK(I)=AK(I)+YNEW(I) END DO END IF CALL SOLradB (N,LDE,E,MLE,MUE,AK,IP) RETURN C C ----------------------------------------------------------- C 12 CONTINUE C --- B=IDENTITY, JACOBIAN A BANDED MATRIX, SECOND ORDER IF (STAGE1) THEN DO I=1,N AK(I)=AK(I)+YNEW(I) END DO END IF 45 MM=M1/M2 DO J=1,M2 SUM=0.D0 DO K=MM-1,0,-1 JKM=J+K*M2 SUM=(AK(JKM)+SUM)/FAC1 DO I=MAX(1,J-MUJAC),MIN(NM1,J+MLJAC) IM1=I+M1 AK(IM1)=AK(IM1)+FJAC(I+MUJAC+1-J,JKM)*SUM END DO END DO END DO CALL SOLradB (NM1,LDE,E,MLE,MUE,AK(M1+1),IP) DO I=M1,1,-1 AK(I)=(AK(I)+AK(M2+I))/FAC1 END DO RETURN C C ----------------------------------------------------------- C 3 CONTINUE C --- B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX IF (STAGE1) THEN DO I=1,N SUM=0.D0 DO J=MAX(1,I-MLMAS),MIN(N,I+MUMAS) SUM=SUM+FMAS(I-J+MBDIAG,J)*YNEW(J) END DO AK(I)=AK(I)+SUM END DO END IF CALL solradau (N,LDE,E,AK,IP) RETURN C C ----------------------------------------------------------- C 13 CONTINUE C --- B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX, SECOND ORDER IF (STAGE1) THEN DO I=1,M1 AK(I)=AK(I)+YNEW(I) END DO DO I=1,NM1 SUM=0.D0 DO J=MAX(1,I-MLMAS),MIN(NM1,I+MUMAS) SUM=SUM+FMAS(I-J+MBDIAG,J)*YNEW(J+M1) END DO IM1=I+M1 AK(IM1)=AK(IM1)+SUM END DO END IF IF (IJOB.EQ.14) GOTO 45 GOTO 48 C C ----------------------------------------------------------- C 4 CONTINUE C --- B IS A BANDED MATRIX, JACOBIAN A BANDED MATRIX IF (STAGE1) THEN DO I=1,N SUM=0.D0 DO J=MAX(1,I-MLMAS),MIN(N,I+MUMAS) SUM=SUM+FMAS(I-J+MBDIAG,J)*YNEW(J) END DO AK(I)=AK(I)+SUM END DO END IF CALL SOLradB (N,LDE,E,MLE,MUE,AK,IP) RETURN C C ----------------------------------------------------------- C 5 CONTINUE C --- B IS A FULL MATRIX, JACOBIAN A FULL MATRIX IF (STAGE1) THEN DO I=1,N SUM=0.D0 DO J=1,N SUM=SUM+FMAS(I,J)*YNEW(J) END DO AK(I)=AK(I)+SUM END DO END IF CALL solradau (N,LDE,E,AK,IP) RETURN C C ----------------------------------------------------------- C 15 CONTINUE C --- B IS A FULL MATRIX, JACOBIAN A FULL MATRIX, SECOND ORDER IF (STAGE1) THEN DO I=1,M1 AK(I)=AK(I)+YNEW(I) END DO DO I=1,NM1 SUM=0.D0 DO J=1,NM1 SUM=SUM+FMAS(I,J)*YNEW(J+M1) END DO IM1=I+M1 AK(IM1)=AK(IM1)+SUM END DO END IF GOTO 48 C C ----------------------------------------------------------- C 6 CONTINUE C --- B IS A FULL MATRIX, JACOBIAN A BANDED MATRIX C --- THIS OPTION IS NOT PROVIDED IF (STAGE1) THEN DO 624 I=1,N SUM=0.D0 DO 623 J=1,N SUM=SUM+FMAS(I,J)*YNEW(J) 623 CONTINUE AK(I)=AK(I)+SUM 624 CONTINUE CALL SOLradB (N,LDE,E,MLE,MUE,AK,IP) END IF RETURN C C ----------------------------------------------------------- C 55 CONTINUE RETURN END C C END OF SUBROUTINE SLVROD C C C *********************************************************** C SUBROUTINE SLVSEU(N,FJAC,LDJAC,MLJAC,MUJAC,FMAS,LDMAS,MLMAS,MUMAS, & M1,M2,NM1,FAC1,E,LDE,IP,IPHES,DEL,IJOB) IMPLICIT REAL(KIND=8) (A-H,O-Z) DIMENSION FJAC(LDJAC,N),FMAS(LDMAS,NM1),E(LDE,NM1),DEL(N) DIMENSION IP(NM1),IPHES(N) COMMON/LINAL/MLE,MUE,MBJAC,MBB,MDIAG,MDIFF,MBDIAG C IF (IJOB .EQ. 1 .OR. IJOB .EQ. 3 .OR. IJOB .EQ. 5) THEN GOTO 1 ELSE IF (IJOB .EQ. 2 .OR. IJOB .EQ. 4) THEN GOTO 2 ELSE IF (IJOB.EQ.6.OR.IJOB.EQ.8.OR.IJOB.EQ.9.OR.IJOB.EQ.10) THEN GOTO 55 ELSE IF (IJOB .EQ. 7) THEN GOTO 7 ELSE IF (IJOB .EQ. 11 .OR. IJOB .EQ.13 .OR. IJOB .EQ. 15) THEN GOTO 11 ELSE IF (IJOB .EQ. 12 .OR. IJOB .EQ. 14) THEN GOTO 12 ENDIF C karline: the above was changed from this computed goto C GOTO (1,2,1,2,1,55,7,55,55,55,11,12,11,12,11), IJOB C C ----------------------------------------------------------- C 1 CONTINUE C --- B=IDENTITY, JACOBIAN A FULL MATRIX CALL solradau (N,LDE,E,DEL,IP) RETURN C C ----------------------------------------------------------- C 11 CONTINUE C --- B=IDENTITY, JACOBIAN A FULL MATRIX, SECOND ORDER MM=M1/M2 DO J=1,M2 SUM=0.D0 DO K=MM-1,0,-1 JKM=J+K*M2 SUM=(DEL(JKM)+SUM)/FAC1 DO I=1,NM1 IM1=I+M1 DEL(IM1)=DEL(IM1)+FJAC(I,JKM)*SUM END DO END DO END DO CALL solradau (NM1,LDE,E,DEL(M1+1),IP) DO I=M1,1,-1 DEL(I)=(DEL(I)+DEL(M2+I))/FAC1 END DO RETURN C C ----------------------------------------------------------- C 2 CONTINUE C --- B=IDENTITY, JACOBIAN A BANDED MATRIX CALL SOLradB (N,LDE,E,MLE,MUE,DEL,IP) RETURN C C ----------------------------------------------------------- C 12 CONTINUE C --- B=IDENTITY, JACOBIAN A BANDED MATRIX, SECOND ORDER MM=M1/M2 DO J=1,M2 SUM=0.D0 DO K=MM-1,0,-1 JKM=J+K*M2 SUM=(DEL(JKM)+SUM)/FAC1 DO I=MAX(1,J-MUJAC),MIN(NM1,J+MLJAC) IM1=I+M1 DEL(IM1)=DEL(IM1)+FJAC(I+MUJAC+1-J,JKM)*SUM END DO END DO END DO CALL SOLradB (NM1,LDE,E,MLE,MUE,DEL(M1+1),IP) DO I=M1,1,-1 DEL(I)=(DEL(I)+DEL(M2+I))/FAC1 END DO RETURN C C ----------------------------------------------------------- C 7 CONTINUE C --- HESSENBERG OPTION DO MMM=N-2,1,-1 MP=N-MMM MP1=MP-1 I=IPHES(MP) IF (I.EQ.MP) GOTO 110 ZSAFE=DEL(MP) DEL(MP)=DEL(I) DEL(I)=ZSAFE 110 CONTINUE DO I=MP+1,N DEL(I)=DEL(I)-FJAC(I,MP1)*DEL(MP) END DO END DO CALL SOLH(N,LDE,E,1,DEL,IP) DO MMM=1,N-2 MP=N-MMM MP1=MP-1 DO I=MP+1,N DEL(I)=DEL(I)+FJAC(I,MP1)*DEL(MP) END DO I=IPHES(MP) IF (I.EQ.MP) GOTO 240 ZSAFE=DEL(MP) DEL(MP)=DEL(I) DEL(I)=ZSAFE 240 CONTINUE END DO RETURN C C ----------------------------------------------------------- C 55 CONTINUE RETURN END C C END OF SUBROUTINE SLVSEU C SUBROUTINE DECradau (N, NDIM, A, IP, IER) C VERSION REAL DOUBLE PRECISION INTEGER N,NDIM,IP,IER,NM1,K,KP1,M,I,J DOUBLE PRECISION A,T DIMENSION A(NDIM,N), IP(N) C----------------------------------------------------------------------- C MATRIX TRIANGULARIZATION BY GAUSSIAN ELIMINATION. C INPUT.. C N = ORDER OF MATRIX. C NDIM = DECLARED DIMENSION OF ARRAY A . C A = MATRIX TO BE TRIANGULARIZED. C OUTPUT.. C A(I,J), I.LE.J = UPPER TRIANGULAR FACTOR, U . C A(I,J), I.GT.J = MULTIPLIERS = LOWER TRIANGULAR FACTOR, I - L. C IP(K), K.LT.N = INDEX OF K-TH PIVOT ROW. C IP(N) = (-1)**(NUMBER OF INTERCHANGES) OR O . C IER = 0 IF MATRIX A IS NONSINGULAR, OR K IF FOUND TO BE C SINGULAR AT STAGE K. C USE solradau TO OBTAIN SOLUTION OF LINEAR SYSTEM. C DETERM(A) = IP(N)*A(1,1)*A(2,2)*...*A(N,N). C IF IP(N)=O, A IS SINGULAR, solradau WILL DIVIDE BY ZERO. C C REFERENCE.. C C. B. MOLER, ALGORITHM 423, LINEAR EQUATION SOLVER, C C.A.C.M. 15 (1972), P. 274. C----------------------------------------------------------------------- IER = 0 IP(N) = 1 IF (N .EQ. 1) GO TO 70 NM1 = N - 1 DO 60 K = 1,NM1 KP1 = K + 1 M = K DO 10 I = KP1,N IF (DABS(A(I,K)) .GT. DABS(A(M,K))) M = I 10 CONTINUE IP(K) = M T = A(M,K) IF (M .EQ. K) GO TO 20 IP(N) = -IP(N) A(M,K) = A(K,K) A(K,K) = T 20 CONTINUE IF (T .EQ. 0.D0) GO TO 80 T = 1.D0/T DO 30 I = KP1,N A(I,K) = -A(I,K)*T 30 CONTINUE DO 50 J = KP1,N T = A(M,J) A(M,J) = A(K,J) A(K,J) = T IF (T .EQ. 0.D0) GO TO 45 DO 40 I = KP1,N A(I,J) = A(I,J) + A(I,K)*T 40 CONTINUE 45 CONTINUE 50 CONTINUE 60 CONTINUE 70 K = N IF (A(N,N) .EQ. 0.D0) GO TO 80 RETURN 80 IER = K IP(N) = 0 RETURN C----------------------- END OF SUBROUTINE DECradau ------------------------- END C C SUBROUTINE solradau (N, NDIM, A, B, IP) C VERSION REAL DOUBLE PRECISION INTEGER N,NDIM,IP,NM1,K,KP1,M,I,KB,KM1 DOUBLE PRECISION A,B,T DIMENSION A(NDIM,N), B(N), IP(N) C----------------------------------------------------------------------- C SOLUTION OF LINEAR SYSTEM, A*X = B . C INPUT.. C N = ORDER OF MATRIX. C NDIM = DECLARED DIMENSION OF ARRAY A . C A = TRIANGULARIZED MATRIX OBTAINED FROM DECradau. C B = RIGHT HAND SIDE VECTOR. C IP = PIVOT VECTOR OBTAINED FROM DECradau. C DO NOT USE IF DECradau HAS SET IER .NE. 0. C OUTPUT.. C B = SOLUTION VECTOR, X . C----------------------------------------------------------------------- IF (N .EQ. 1) GO TO 50 NM1 = N - 1 DO 20 K = 1,NM1 KP1 = K + 1 M = IP(K) T = B(M) B(M) = B(K) B(K) = T DO 10 I = KP1,N B(I) = B(I) + A(I,K)*T 10 CONTINUE 20 CONTINUE DO 40 KB = 1,NM1 KM1 = N - KB K = KM1 + 1 B(K) = B(K)/A(K,K) T = -B(K) DO 30 I = 1,KM1 B(I) = B(I) + A(I,K)*T 30 CONTINUE 40 CONTINUE 50 B(1) = B(1)/A(1,1) RETURN C----------------------- END OF SUBROUTINE solradau ------------------------- END c c SUBROUTINE DECH (N, NDIM, A, LB, IP, IER) C VERSION REAL DOUBLE PRECISION INTEGER N,NDIM,IP,IER,NM1,K,KP1,M,I,J,LB,NA DOUBLE PRECISION A,T DIMENSION A(NDIM,N), IP(N) C----------------------------------------------------------------------- C MATRIX TRIANGULARIZATION BY GAUSSIAN ELIMINATION OF A HESSENBERG C MATRIX WITH LOWER BANDWIDTH LB C INPUT.. C N = ORDER OF MATRIX A. C NDIM = DECLARED DIMENSION OF ARRAY A . C A = MATRIX TO BE TRIANGULARIZED. C LB = LOWER BANDWIDTH OF A (DIAGONAL IS NOT COUNTED, LB.GE.1). C OUTPUT.. C A(I,J), I.LE.J = UPPER TRIANGULAR FACTOR, U . C A(I,J), I.GT.J = MULTIPLIERS = LOWER TRIANGULAR FACTOR, I - L. C IP(K), K.LT.N = INDEX OF K-TH PIVOT ROW. C IP(N) = (-1)**(NUMBER OF INTERCHANGES) OR O . C IER = 0 IF MATRIX A IS NONSINGULAR, OR K IF FOUND TO BE C SINGULAR AT STAGE K. C USE SOLH TO OBTAIN SOLUTION OF LINEAR SYSTEM. C DETERM(A) = IP(N)*A(1,1)*A(2,2)*...*A(N,N). C IF IP(N)=O, A IS SINGULAR, solradau WILL DIVIDE BY ZERO. C C REFERENCE.. C THIS IS A SLIGHT MODIFICATION OF C C. B. MOLER, ALGORITHM 423, LINEAR EQUATION SOLVER, C C.A.C.M. 15 (1972), P. 274. C----------------------------------------------------------------------- IER = 0 IP(N) = 1 IF (N .EQ. 1) GO TO 70 NM1 = N - 1 DO 60 K = 1,NM1 KP1 = K + 1 M = K NA = MIN0(N,LB+K) DO 10 I = KP1,NA IF (DABS(A(I,K)) .GT. DABS(A(M,K))) M = I 10 CONTINUE IP(K) = M T = A(M,K) IF (M .EQ. K) GO TO 20 IP(N) = -IP(N) A(M,K) = A(K,K) A(K,K) = T 20 CONTINUE IF (T .EQ. 0.D0) GO TO 80 T = 1.D0/T DO 30 I = KP1,NA A(I,K) = -A(I,K)*T 30 CONTINUE DO 50 J = KP1,N T = A(M,J) A(M,J) = A(K,J) A(K,J) = T IF (T .EQ. 0.D0) GO TO 45 DO 40 I = KP1,NA A(I,J) = A(I,J) + A(I,K)*T 40 CONTINUE 45 CONTINUE 50 CONTINUE 60 CONTINUE 70 K = N IF (A(N,N) .EQ. 0.D0) GO TO 80 RETURN 80 IER = K IP(N) = 0 RETURN C----------------------- END OF SUBROUTINE DECH ------------------------ END C C SUBROUTINE SOLH (N, NDIM, A, LB, B, IP) C VERSION REAL DOUBLE PRECISION INTEGER N,NDIM,IP,NM1,K,KP1,M,I,KB,KM1,LB,NA DOUBLE PRECISION A,B,T DIMENSION A(NDIM,N), B(N), IP(N) C----------------------------------------------------------------------- C SOLUTION OF LINEAR SYSTEM, A*X = B . C INPUT.. C N = ORDER OF MATRIX A. C NDIM = DECLARED DIMENSION OF ARRAY A . C A = TRIANGULARIZED MATRIX OBTAINED FROM DECH. C LB = LOWER BANDWIDTH OF A. C B = RIGHT HAND SIDE VECTOR. C IP = PIVOT VECTOR OBTAINED FROM DECradau. C DO NOT USE IF DECH HAS SET IER .NE. 0. C OUTPUT.. C B = SOLUTION VECTOR, X . C----------------------------------------------------------------------- IF (N .EQ. 1) GO TO 50 NM1 = N - 1 DO 20 K = 1,NM1 KP1 = K + 1 M = IP(K) T = B(M) B(M) = B(K) B(K) = T NA = MIN0(N,LB+K) DO 10 I = KP1,NA B(I) = B(I) + A(I,K)*T 10 CONTINUE 20 CONTINUE DO 40 KB = 1,NM1 KM1 = N - KB K = KM1 + 1 B(K) = B(K)/A(K,K) T = -B(K) DO 30 I = 1,KM1 B(I) = B(I) + A(I,K)*T 30 CONTINUE 40 CONTINUE 50 B(1) = B(1)/A(1,1) RETURN C----------------------- END OF SUBROUTINE SOLH ------------------------ END C SUBROUTINE DECC (N, NDIM, AR, AI, IP, IER) C VERSION COMPLEX DOUBLE PRECISION IMPLICIT REAL(KIND=8) (A-H,O-Z) INTEGER N,NDIM,IP,IER,NM1,K,KP1,M,I,J DIMENSION AR(NDIM,N), AI(NDIM,N), IP(N) C----------------------------------------------------------------------- C MATRIX TRIANGULARIZATION BY GAUSSIAN ELIMINATION C ------ MODIFICATION FOR COMPLEX MATRICES -------- C INPUT.. C N = ORDER OF MATRIX. C NDIM = DECLARED DIMENSION OF ARRAYS AR AND AI . C (AR, AI) = MATRIX TO BE TRIANGULARIZED. C OUTPUT.. C AR(I,J), I.LE.J = UPPER TRIANGULAR FACTOR, U ; REAL PART. C AI(I,J), I.LE.J = UPPER TRIANGULAR FACTOR, U ; IMAGINARY PART. C AR(I,J), I.GT.J = MULTIPLIERS = LOWER TRIANGULAR FACTOR, I - L. C REAL PART. C AI(I,J), I.GT.J = MULTIPLIERS = LOWER TRIANGULAR FACTOR, I - L. C IMAGINARY PART. C IP(K), K.LT.N = INDEX OF K-TH PIVOT ROW. C IP(N) = (-1)**(NUMBER OF INTERCHANGES) OR O . C IER = 0 IF MATRIX A IS NONSINGULAR, OR K IF FOUND TO BE C SINGULAR AT STAGE K. C USE solradau TO OBTAIN SOLUTION OF LINEAR SYSTEM. C IF IP(N)=O, A IS SINGULAR, solradau WILL DIVIDE BY ZERO. C C REFERENCE.. C C. B. MOLER, ALGORITHM 423, LINEAR EQUATION SOLVER, C C.A.C.M. 15 (1972), P. 274. C----------------------------------------------------------------------- IER = 0 IP(N) = 1 IF (N .EQ. 1) GO TO 70 NM1 = N - 1 DO 60 K = 1,NM1 KP1 = K + 1 M = K DO 10 I = KP1,N IF (DABS(AR(I,K))+DABS(AI(I,K)) .GT. & DABS(AR(M,K))+DABS(AI(M,K))) M = I 10 CONTINUE IP(K) = M TR = AR(M,K) TI = AI(M,K) IF (M .EQ. K) GO TO 20 IP(N) = -IP(N) AR(M,K) = AR(K,K) AI(M,K) = AI(K,K) AR(K,K) = TR AI(K,K) = TI 20 CONTINUE IF (DABS(TR)+DABS(TI) .EQ. 0.D0) GO TO 80 DEN=TR*TR+TI*TI TR=TR/DEN TI=-TI/DEN DO 30 I = KP1,N PRODR=AR(I,K)*TR-AI(I,K)*TI PRODI=AI(I,K)*TR+AR(I,K)*TI AR(I,K)=-PRODR AI(I,K)=-PRODI 30 CONTINUE DO 50 J = KP1,N TR = AR(M,J) TI = AI(M,J) AR(M,J) = AR(K,J) AI(M,J) = AI(K,J) AR(K,J) = TR AI(K,J) = TI IF (DABS(TR)+DABS(TI) .EQ. 0.D0) GO TO 48 IF (TI .EQ. 0.D0) THEN DO 40 I = KP1,N PRODR=AR(I,K)*TR PRODI=AI(I,K)*TR AR(I,J) = AR(I,J) + PRODR AI(I,J) = AI(I,J) + PRODI 40 CONTINUE GO TO 48 END IF IF (TR .EQ. 0.D0) THEN DO 45 I = KP1,N PRODR=-AI(I,K)*TI PRODI=AR(I,K)*TI AR(I,J) = AR(I,J) + PRODR AI(I,J) = AI(I,J) + PRODI 45 CONTINUE GO TO 48 END IF DO 47 I = KP1,N PRODR=AR(I,K)*TR-AI(I,K)*TI PRODI=AI(I,K)*TR+AR(I,K)*TI AR(I,J) = AR(I,J) + PRODR AI(I,J) = AI(I,J) + PRODI 47 CONTINUE 48 CONTINUE 50 CONTINUE 60 CONTINUE 70 K = N IF (DABS(AR(N,N))+DABS(AI(N,N)) .EQ. 0.D0) GO TO 80 RETURN 80 IER = K IP(N) = 0 RETURN C----------------------- END OF SUBROUTINE DECC ------------------------ END C C SUBROUTINE SOLC (N, NDIM, AR, AI, BR, BI, IP) C VERSION COMPLEX DOUBLE PRECISION IMPLICIT REAL(KIND=8) (A-H,O-Z) INTEGER N,NDIM,IP,NM1,K,KP1,M,I,KB,KM1 DIMENSION AR(NDIM,N), AI(NDIM,N), BR(N), BI(N), IP(N) C----------------------------------------------------------------------- C SOLUTION OF LINEAR SYSTEM, A*X = B . C INPUT.. C N = ORDER OF MATRIX. C NDIM = DECLARED DIMENSION OF ARRAYS AR AND AI. C (AR,AI) = TRIANGULARIZED MATRIX OBTAINED FROM DECradau. C (BR,BI) = RIGHT HAND SIDE VECTOR. C IP = PIVOT VECTOR OBTAINED FROM DECradau. C DO NOT USE IF DECradau HAS SET IER .NE. 0. C OUTPUT.. C (BR,BI) = SOLUTION VECTOR, X . C----------------------------------------------------------------------- IF (N .EQ. 1) GO TO 50 NM1 = N - 1 DO 20 K = 1,NM1 KP1 = K + 1 M = IP(K) TR = BR(M) TI = BI(M) BR(M) = BR(K) BI(M) = BI(K) BR(K) = TR BI(K) = TI DO 10 I = KP1,N PRODR=AR(I,K)*TR-AI(I,K)*TI PRODI=AI(I,K)*TR+AR(I,K)*TI BR(I) = BR(I) + PRODR BI(I) = BI(I) + PRODI 10 CONTINUE 20 CONTINUE DO 40 KB = 1,NM1 KM1 = N - KB K = KM1 + 1 DEN=AR(K,K)*AR(K,K)+AI(K,K)*AI(K,K) PRODR=BR(K)*AR(K,K)+BI(K)*AI(K,K) PRODI=BI(K)*AR(K,K)-BR(K)*AI(K,K) BR(K)=PRODR/DEN BI(K)=PRODI/DEN TR = -BR(K) TI = -BI(K) DO 30 I = 1,KM1 PRODR=AR(I,K)*TR-AI(I,K)*TI PRODI=AI(I,K)*TR+AR(I,K)*TI BR(I) = BR(I) + PRODR BI(I) = BI(I) + PRODI 30 CONTINUE 40 CONTINUE 50 CONTINUE DEN=AR(1,1)*AR(1,1)+AI(1,1)*AI(1,1) PRODR=BR(1)*AR(1,1)+BI(1)*AI(1,1) PRODI=BI(1)*AR(1,1)-BR(1)*AI(1,1) BR(1)=PRODR/DEN BI(1)=PRODI/DEN RETURN C----------------------- END OF SUBROUTINE SOLC ------------------------ END C C SUBROUTINE DECHC (N, NDIM, AR, AI, LB, IP, IER) C VERSION COMPLEX DOUBLE PRECISION IMPLICIT REAL(KIND=8) (A-H,O-Z) INTEGER N,NDIM,IP,IER,NM1,K,KP1,M,I,J DIMENSION AR(NDIM,N), AI(NDIM,N), IP(N) C----------------------------------------------------------------------- C MATRIX TRIANGULARIZATION BY GAUSSIAN ELIMINATION C ------ MODIFICATION FOR COMPLEX MATRICES -------- C INPUT.. C N = ORDER OF MATRIX. C NDIM = DECLARED DIMENSION OF ARRAYS AR AND AI . C (AR, AI) = MATRIX TO BE TRIANGULARIZED. C OUTPUT.. C AR(I,J), I.LE.J = UPPER TRIANGULAR FACTOR, U ; REAL PART. C AI(I,J), I.LE.J = UPPER TRIANGULAR FACTOR, U ; IMAGINARY PART. C AR(I,J), I.GT.J = MULTIPLIERS = LOWER TRIANGULAR FACTOR, I - L. C REAL PART. C AI(I,J), I.GT.J = MULTIPLIERS = LOWER TRIANGULAR FACTOR, I - L. C IMAGINARY PART. C LB = LOWER BANDWIDTH OF A (DIAGONAL NOT COUNTED), LB.GE.1. C IP(K), K.LT.N = INDEX OF K-TH PIVOT ROW. C IP(N) = (-1)**(NUMBER OF INTERCHANGES) OR O . C IER = 0 IF MATRIX A IS NONSINGULAR, OR K IF FOUND TO BE C SINGULAR AT STAGE K. C USE solradau TO OBTAIN SOLUTION OF LINEAR SYSTEM. C IF IP(N)=O, A IS SINGULAR, solradau WILL DIVIDE BY ZERO. C C REFERENCE.. C C. B. MOLER, ALGORITHM 423, LINEAR EQUATION SOLVER, C C.A.C.M. 15 (1972), P. 274. C----------------------------------------------------------------------- IER = 0 IP(N) = 1 IF (LB .EQ. 0) GO TO 70 IF (N .EQ. 1) GO TO 70 NM1 = N - 1 DO 60 K = 1,NM1 KP1 = K + 1 M = K NA = MIN0(N,LB+K) DO 10 I = KP1,NA IF (DABS(AR(I,K))+DABS(AI(I,K)) .GT. & DABS(AR(M,K))+DABS(AI(M,K))) M = I 10 CONTINUE IP(K) = M TR = AR(M,K) TI = AI(M,K) IF (M .EQ. K) GO TO 20 IP(N) = -IP(N) AR(M,K) = AR(K,K) AI(M,K) = AI(K,K) AR(K,K) = TR AI(K,K) = TI 20 CONTINUE IF (DABS(TR)+DABS(TI) .EQ. 0.D0) GO TO 80 DEN=TR*TR+TI*TI TR=TR/DEN TI=-TI/DEN DO 30 I = KP1,NA PRODR=AR(I,K)*TR-AI(I,K)*TI PRODI=AI(I,K)*TR+AR(I,K)*TI AR(I,K)=-PRODR AI(I,K)=-PRODI 30 CONTINUE DO 50 J = KP1,N TR = AR(M,J) TI = AI(M,J) AR(M,J) = AR(K,J) AI(M,J) = AI(K,J) AR(K,J) = TR AI(K,J) = TI IF (DABS(TR)+DABS(TI) .EQ. 0.D0) GO TO 48 IF (TI .EQ. 0.D0) THEN DO 40 I = KP1,NA PRODR=AR(I,K)*TR PRODI=AI(I,K)*TR AR(I,J) = AR(I,J) + PRODR AI(I,J) = AI(I,J) + PRODI 40 CONTINUE GO TO 48 END IF IF (TR .EQ. 0.D0) THEN DO 45 I = KP1,NA PRODR=-AI(I,K)*TI PRODI=AR(I,K)*TI AR(I,J) = AR(I,J) + PRODR AI(I,J) = AI(I,J) + PRODI 45 CONTINUE GO TO 48 END IF DO 47 I = KP1,NA PRODR=AR(I,K)*TR-AI(I,K)*TI PRODI=AI(I,K)*TR+AR(I,K)*TI AR(I,J) = AR(I,J) + PRODR AI(I,J) = AI(I,J) + PRODI 47 CONTINUE 48 CONTINUE 50 CONTINUE 60 CONTINUE 70 K = N IF (DABS(AR(N,N))+DABS(AI(N,N)) .EQ. 0.D0) GO TO 80 RETURN 80 IER = K IP(N) = 0 RETURN C----------------------- END OF SUBROUTINE DECHC ----------------------- END C C SUBROUTINE SOLHC (N, NDIM, AR, AI, LB, BR, BI, IP) C VERSION COMPLEX DOUBLE PRECISION IMPLICIT REAL(KIND=8) (A-H,O-Z) INTEGER N,NDIM,IP,NM1,K,KP1,M,I,KB,KM1 DIMENSION AR(NDIM,N), AI(NDIM,N), BR(N), BI(N), IP(N) C----------------------------------------------------------------------- C SOLUTION OF LINEAR SYSTEM, A*X = B . C INPUT.. C N = ORDER OF MATRIX. C NDIM = DECLARED DIMENSION OF ARRAYS AR AND AI. C (AR,AI) = TRIANGULARIZED MATRIX OBTAINED FROM DECradau. C (BR,BI) = RIGHT HAND SIDE VECTOR. C LB = LOWER BANDWIDTH OF A. C IP = PIVOT VECTOR OBTAINED FROM DECradau. C DO NOT USE IF DECradau HAS SET IER .NE. 0. C OUTPUT.. C (BR,BI) = SOLUTION VECTOR, X . C----------------------------------------------------------------------- IF (N .EQ. 1) GO TO 50 NM1 = N - 1 IF (LB .EQ. 0) GO TO 25 DO 20 K = 1,NM1 KP1 = K + 1 M = IP(K) TR = BR(M) TI = BI(M) BR(M) = BR(K) BI(M) = BI(K) BR(K) = TR BI(K) = TI DO 10 I = KP1,MIN0(N,LB+K) PRODR=AR(I,K)*TR-AI(I,K)*TI PRODI=AI(I,K)*TR+AR(I,K)*TI BR(I) = BR(I) + PRODR BI(I) = BI(I) + PRODI 10 CONTINUE 20 CONTINUE 25 CONTINUE DO 40 KB = 1,NM1 KM1 = N - KB K = KM1 + 1 DEN=AR(K,K)*AR(K,K)+AI(K,K)*AI(K,K) PRODR=BR(K)*AR(K,K)+BI(K)*AI(K,K) PRODI=BI(K)*AR(K,K)-BR(K)*AI(K,K) BR(K)=PRODR/DEN BI(K)=PRODI/DEN TR = -BR(K) TI = -BI(K) DO 30 I = 1,KM1 PRODR=AR(I,K)*TR-AI(I,K)*TI PRODI=AI(I,K)*TR+AR(I,K)*TI BR(I) = BR(I) + PRODR BI(I) = BI(I) + PRODI 30 CONTINUE 40 CONTINUE 50 CONTINUE DEN=AR(1,1)*AR(1,1)+AI(1,1)*AI(1,1) PRODR=BR(1)*AR(1,1)+BI(1)*AI(1,1) PRODI=BI(1)*AR(1,1)-BR(1)*AI(1,1) BR(1)=PRODR/DEN BI(1)=PRODI/DEN RETURN C----------------------- END OF SUBROUTINE SOLHC ----------------------- END C SUBROUTINE DECradB (N, NDIM, A, ML, MU, IP, IER) REAL(KIND=8) A,T DIMENSION A(NDIM,N), IP(N) C----------------------------------------------------------------------- C MATRIX TRIANGULARIZATION BY GAUSSIAN ELIMINATION OF A BANDED C MATRIX WITH LOWER BANDWIDTH ML AND UPPER BANDWIDTH MU C INPUT.. C N ORDER OF THE ORIGINAL MATRIX A. C NDIM DECLARED DIMENSION OF ARRAY A. C A CONTAINS THE MATRIX IN BAND STORAGE. THE COLUMNS C OF THE MATRIX ARE STORED IN THE COLUMNS OF A AND C THE DIAGONALS OF THE MATRIX ARE STORED IN ROWS C ML+1 THROUGH 2*ML+MU+1 OF A. C ML LOWER BANDWIDTH OF A (DIAGONAL IS NOT COUNTED). C MU UPPER BANDWIDTH OF A (DIAGONAL IS NOT COUNTED). C OUTPUT.. C A AN UPPER TRIANGULAR MATRIX IN BAND STORAGE AND C THE MULTIPLIERS WHICH WERE USED TO OBTAIN IT. C IP INDEX VECTOR OF PIVOT INDICES. C IP(N) (-1)**(NUMBER OF INTERCHANGES) OR O . C IER = 0 IF MATRIX A IS NONSINGULAR, OR = K IF FOUND TO BE C SINGULAR AT STAGE K. C USE SOLradB TO OBTAIN SOLUTION OF LINEAR SYSTEM. C DETERM(A) = IP(N)*A(MD,1)*A(MD,2)*...*A(MD,N) WITH MD=ML+MU+1. C IF IP(N)=O, A IS SINGULAR, SOLradB WILL DIVIDE BY ZERO. C C REFERENCE.. C THIS IS A MODIFICATION OF C C. B. MOLER, ALGORITHM 423, LINEAR EQUATION SOLVER, C C.A.C.M. 15 (1972), P. 274. C----------------------------------------------------------------------- IER = 0 IP(N) = 1 MD = ML + MU + 1 MD1 = MD + 1 JU = 0 IF (ML .EQ. 0) GO TO 70 IF (N .EQ. 1) GO TO 70 IF (N .LT. MU+2) GO TO 7 DO 6 J = MU+2,N DO 5 I = 1,ML A(I,J) = 0.D0 5 CONTINUE 6 CONTINUE 7 NM1 = N - 1 DO 60 K = 1,NM1 KP1 = K + 1 M = MD MDL = MIN(ML,N-K) + MD DO 10 I = MD1,MDL IF (DABS(A(I,K)) .GT. DABS(A(M,K))) M = I 10 CONTINUE IP(K) = M + K - MD T = A(M,K) IF (M .EQ. MD) GO TO 20 IP(N) = -IP(N) A(M,K) = A(MD,K) A(MD,K) = T 20 CONTINUE IF (T .EQ. 0.D0) GO TO 80 T = 1.D0/T DO 30 I = MD1,MDL A(I,K) = -A(I,K)*T 30 CONTINUE JU = MIN0(MAX0(JU,MU+IP(K)),N) MM = MD IF (JU .LT. KP1) GO TO 55 DO 50 J = KP1,JU M = M - 1 MM = MM - 1 T = A(M,J) IF (M .EQ. MM) GO TO 35 A(M,J) = A(MM,J) A(MM,J) = T 35 CONTINUE IF (T .EQ. 0.D0) GO TO 45 JK = J - K DO 40 I = MD1,MDL IJK = I - JK A(IJK,J) = A(IJK,J) + A(I,K)*T 40 CONTINUE 45 CONTINUE 50 CONTINUE 55 CONTINUE 60 CONTINUE 70 K = N IF (A(MD,N) .EQ. 0.D0) GO TO 80 RETURN 80 IER = K IP(N) = 0 RETURN C----------------------- END OF SUBROUTINE DECradB ------------------------ END C C SUBROUTINE SOLradB (N, NDIM, A, ML, MU, B, IP) REAL(KIND=8) A,B,T DIMENSION A(NDIM,N), B(N), IP(N) C----------------------------------------------------------------------- C SOLUTION OF LINEAR SYSTEM, A*X = B . C INPUT.. C N ORDER OF MATRIX A. C NDIM DECLARED DIMENSION OF ARRAY A . C A TRIANGULARIZED MATRIX OBTAINED FROM DECradB. C ML LOWER BANDWIDTH OF A (DIAGONAL IS NOT COUNTED). C MU UPPER BANDWIDTH OF A (DIAGONAL IS NOT COUNTED). C B RIGHT HAND SIDE VECTOR. C IP PIVOT VECTOR OBTAINED FROM DECradB. C DO NOT USE IF DECradB HAS SET IER .NE. 0. C OUTPUT.. C B SOLUTION VECTOR, X . C----------------------------------------------------------------------- MD = ML + MU + 1 MD1 = MD + 1 MDM = MD - 1 NM1 = N - 1 IF (ML .EQ. 0) GO TO 25 IF (N .EQ. 1) GO TO 50 DO 20 K = 1,NM1 M = IP(K) T = B(M) B(M) = B(K) B(K) = T MDL = MIN(ML,N-K) + MD DO 10 I = MD1,MDL IMD = I + K - MD B(IMD) = B(IMD) + A(I,K)*T 10 CONTINUE 20 CONTINUE 25 CONTINUE DO 40 KB = 1,NM1 K = N + 1 - KB B(K) = B(K)/A(MD,K) T = -B(K) KMD = MD - K LM = MAX0(1,KMD+1) DO 30 I = LM,MDM IMD = I - KMD B(IMD) = B(IMD) + A(I,K)*T 30 CONTINUE 40 CONTINUE 50 B(1) = B(1)/A(MD,1) RETURN C----------------------- END OF SUBROUTINE SOLradB ------------------------ END C SUBROUTINE DECBC (N, NDIM, AR, AI, ML, MU, IP, IER) IMPLICIT REAL(KIND=8) (A-H,O-Z) DIMENSION AR(NDIM,N), AI(NDIM,N), IP(N) C----------------------------------------------------------------------- C MATRIX TRIANGULARIZATION BY GAUSSIAN ELIMINATION OF A BANDED COMPLEX C MATRIX WITH LOWER BANDWIDTH ML AND UPPER BANDWIDTH MU C INPUT.. C N ORDER OF THE ORIGINAL MATRIX A. C NDIM DECLARED DIMENSION OF ARRAY A. C AR, AI CONTAINS THE MATRIX IN BAND STORAGE. THE COLUMNS C OF THE MATRIX ARE STORED IN THE COLUMNS OF AR (REAL C PART) AND AI (IMAGINARY PART) AND C THE DIAGONALS OF THE MATRIX ARE STORED IN ROWS C ML+1 THROUGH 2*ML+MU+1 OF AR AND AI. C ML LOWER BANDWIDTH OF A (DIAGONAL IS NOT COUNTED). C MU UPPER BANDWIDTH OF A (DIAGONAL IS NOT COUNTED). C OUTPUT.. C AR, AI AN UPPER TRIANGULAR MATRIX IN BAND STORAGE AND C THE MULTIPLIERS WHICH WERE USED TO OBTAIN IT. C IP INDEX VECTOR OF PIVOT INDICES. C IP(N) (-1)**(NUMBER OF INTERCHANGES) OR O . C IER = 0 IF MATRIX A IS NONSINGULAR, OR = K IF FOUND TO BE C SINGULAR AT STAGE K. C USE SOLBC TO OBTAIN SOLUTION OF LINEAR SYSTEM. C DETERM(A) = IP(N)*A(MD,1)*A(MD,2)*...*A(MD,N) WITH MD=ML+MU+1. C IF IP(N)=O, A IS SINGULAR, SOLBC WILL DIVIDE BY ZERO. C C REFERENCE.. C THIS IS A MODIFICATION OF C C. B. MOLER, ALGORITHM 423, LINEAR EQUATION SOLVER, C C.A.C.M. 15 (1972), P. 274. C----------------------------------------------------------------------- IER = 0 IP(N) = 1 MD = ML + MU + 1 MD1 = MD + 1 JU = 0 IF (ML .EQ. 0) GO TO 70 IF (N .EQ. 1) GO TO 70 IF (N .LT. MU+2) GO TO 7 DO 6 J = MU+2,N DO 5 I = 1,ML AR(I,J) = 0.D0 AI(I,J) = 0.D0 5 CONTINUE 6 CONTINUE 7 NM1 = N - 1 DO 60 K = 1,NM1 KP1 = K + 1 M = MD MDL = MIN(ML,N-K) + MD DO 10 I = MD1,MDL IF (DABS(AR(I,K))+DABS(AI(I,K)) .GT. & DABS(AR(M,K))+DABS(AI(M,K))) M = I 10 CONTINUE IP(K) = M + K - MD TR = AR(M,K) TI = AI(M,K) IF (M .EQ. MD) GO TO 20 IP(N) = -IP(N) AR(M,K) = AR(MD,K) AI(M,K) = AI(MD,K) AR(MD,K) = TR AI(MD,K) = TI 20 IF (DABS(TR)+DABS(TI) .EQ. 0.D0) GO TO 80 DEN=TR*TR+TI*TI TR=TR/DEN TI=-TI/DEN DO 30 I = MD1,MDL PRODR=AR(I,K)*TR-AI(I,K)*TI PRODI=AI(I,K)*TR+AR(I,K)*TI AR(I,K)=-PRODR AI(I,K)=-PRODI 30 CONTINUE JU = MIN0(MAX0(JU,MU+IP(K)),N) MM = MD IF (JU .LT. KP1) GO TO 55 DO 50 J = KP1,JU M = M - 1 MM = MM - 1 TR = AR(M,J) TI = AI(M,J) IF (M .EQ. MM) GO TO 35 AR(M,J) = AR(MM,J) AI(M,J) = AI(MM,J) AR(MM,J) = TR AI(MM,J) = TI 35 CONTINUE IF (DABS(TR)+DABS(TI) .EQ. 0.D0) GO TO 48 JK = J - K IF (TI .EQ. 0.D0) THEN DO 40 I = MD1,MDL IJK = I - JK PRODR=AR(I,K)*TR PRODI=AI(I,K)*TR AR(IJK,J) = AR(IJK,J) + PRODR AI(IJK,J) = AI(IJK,J) + PRODI 40 CONTINUE GO TO 48 END IF IF (TR .EQ. 0.D0) THEN DO 45 I = MD1,MDL IJK = I - JK PRODR=-AI(I,K)*TI PRODI=AR(I,K)*TI AR(IJK,J) = AR(IJK,J) + PRODR AI(IJK,J) = AI(IJK,J) + PRODI 45 CONTINUE GO TO 48 END IF DO 47 I = MD1,MDL IJK = I - JK PRODR=AR(I,K)*TR-AI(I,K)*TI PRODI=AI(I,K)*TR+AR(I,K)*TI AR(IJK,J) = AR(IJK,J) + PRODR AI(IJK,J) = AI(IJK,J) + PRODI 47 CONTINUE 48 CONTINUE 50 CONTINUE 55 CONTINUE 60 CONTINUE 70 K = N IF (DABS(AR(MD,N))+DABS(AI(MD,N)) .EQ. 0.D0) GO TO 80 RETURN 80 IER = K IP(N) = 0 RETURN C----------------------- END OF SUBROUTINE DECBC ------------------------ END C C SUBROUTINE SOLBC (N, NDIM, AR, AI, ML, MU, BR, BI, IP) IMPLICIT REAL(KIND=8) (A-H,O-Z) DIMENSION AR(NDIM,N), AI(NDIM,N), BR(N), BI(N), IP(N) C----------------------------------------------------------------------- C SOLUTION OF LINEAR SYSTEM, A*X = B , C VERSION BANDED AND COMPLEX-DOUBLE PRECISION. C INPUT.. C N ORDER OF MATRIX A. C NDIM DECLARED DIMENSION OF ARRAY A . C AR, AI TRIANGULARIZED MATRIX OBTAINED FROM DECradB (REAL AND IMAG. PART). C ML LOWER BANDWIDTH OF A (DIAGONAL IS NOT COUNTED). C MU UPPER BANDWIDTH OF A (DIAGONAL IS NOT COUNTED). C BR, BI RIGHT HAND SIDE VECTOR (REAL AND IMAG. PART). C IP PIVOT VECTOR OBTAINED FROM DECBC. C DO NOT USE IF DECradB HAS SET IER .NE. 0. C OUTPUT.. C BR, BI SOLUTION VECTOR, X (REAL AND IMAG. PART). C----------------------------------------------------------------------- MD = ML + MU + 1 MD1 = MD + 1 MDM = MD - 1 NM1 = N - 1 IF (ML .EQ. 0) GO TO 25 IF (N .EQ. 1) GO TO 50 DO 20 K = 1,NM1 M = IP(K) TR = BR(M) TI = BI(M) BR(M) = BR(K) BI(M) = BI(K) BR(K) = TR BI(K) = TI MDL = MIN(ML,N-K) + MD DO 10 I = MD1,MDL IMD = I + K - MD PRODR=AR(I,K)*TR-AI(I,K)*TI PRODI=AI(I,K)*TR+AR(I,K)*TI BR(IMD) = BR(IMD) + PRODR BI(IMD) = BI(IMD) + PRODI 10 CONTINUE 20 CONTINUE 25 CONTINUE DO 40 KB = 1,NM1 K = N + 1 - KB DEN=AR(MD,K)*AR(MD,K)+AI(MD,K)*AI(MD,K) PRODR=BR(K)*AR(MD,K)+BI(K)*AI(MD,K) PRODI=BI(K)*AR(MD,K)-BR(K)*AI(MD,K) BR(K)=PRODR/DEN BI(K)=PRODI/DEN TR = -BR(K) TI = -BI(K) KMD = MD - K LM = MAX0(1,KMD+1) DO 30 I = LM,MDM IMD = I - KMD PRODR=AR(I,K)*TR-AI(I,K)*TI PRODI=AI(I,K)*TR+AR(I,K)*TI BR(IMD) = BR(IMD) + PRODR BI(IMD) = BI(IMD) + PRODI 30 CONTINUE 40 CONTINUE DEN=AR(MD,1)*AR(MD,1)+AI(MD,1)*AI(MD,1) PRODR=BR(1)*AR(MD,1)+BI(1)*AI(MD,1) PRODI=BI(1)*AR(MD,1)-BR(1)*AI(MD,1) BR(1)=PRODR/DEN BI(1)=PRODI/DEN 50 CONTINUE RETURN C----------------------- END OF SUBROUTINE SOLBC ------------------------ END c C subroutine elmhes(nm,n,low,igh,a,int) C integer i,j,m,n,la,nm,igh,kp1,low,mm1,mp1 real(kind=8) a(nm,n) real(kind=8) x,y real(kind=8) dabs integer int(igh) C C this subroutine is a translation of the algol procedure elmhes, C num. math. 12, 349-368(1968) by martin and wilkinson. C handbook for auto. comp., vol.ii-linear algebra, 339-358(1971). C C given a real general matrix, this subroutine C reduces a submatrix situated in rows and columns C low through igh to upper hessenberg form by C stabilized elementary similarity transformations. C C on input: C C nm must be set to the row dimension of two-dimensional C array parameters as declared in the calling program C dimension statement; C C n is the order of the matrix; C C low and igh are integers determined by the balancing C subroutine balanc. if balanc has not been used, C set low=1, igh=n; C C a contains the input matrix. C C on output: C C a contains the hessenberg matrix. the multipliers C which were used in the reduction are stored in the C remaining triangle under the hessenberg matrix; C C int contains information on the rows and columns C interchanged in the reduction. C only elements low through igh are used. C C questions and comments should be directed to b. s. garbow, C applied mathematics division, argonne national laboratory C C ------------------------------------------------------------------ C la = igh - 1 kp1 = low + 1 if (la .lt. kp1) go to 200 C do 180 m = kp1, la mm1 = m - 1 x = 0.0d0 i = m C do 100 j = m, igh if (dabs(a(j,mm1)) .le. dabs(x)) go to 100 x = a(j,mm1) i = j 100 continue C int(m) = i if (i .eq. m) go to 130 C :::::::::: interchange rows and columns of a :::::::::: do 110 j = mm1, n y = a(i,j) a(i,j) = a(m,j) a(m,j) = y 110 continue C do 120 j = 1, igh y = a(j,i) a(j,i) = a(j,m) a(j,m) = y 120 continue C :::::::::: end interchange :::::::::: 130 if (x .eq. 0.0d0) go to 180 mp1 = m + 1 C do 160 i = mp1, igh y = a(i,mm1) if (y .eq. 0.0d0) go to 160 y = y / x a(i,mm1) = y C do 140 j = m, n a(i,j) = a(i,j) - y * a(m,j) 140 continue C do 150 j = 1, igh a(j,m) = a(j,m) + y * a(j,i) 150 continue C 160 continue C 180 continue C 200 return C :::::::::: last card of elmhes :::::::::: end deSolve/src/radau5.f0000754000175100001440000013323013131751003014006 0ustar hornikusersC------------------------------------------------------------------------ C COPYRIGHT DISCLAIMER: C Copyright (c) 2004, Ernst Hairer C Redistribution and use in source and binary forms, with or without C modification, are permitted provided that the following conditions are C met: C - Redistributions of source code must retain the above copyright C notice, this list of conditions and the following disclaimer. C - Redistributions in binary form must reproduce the above copyright C notice, this list of conditions and the following disclaimer in the C documentation and/or other materials provided with the distribution. C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS **AS C IS** AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A C PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR C CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, C EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, C PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR C PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF C LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING C NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS C SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. C------------------------------------------------------------------------ C KS: write statements rewritten C Francesca Mazzia: small changes to avoid overflow SUBROUTINE RADAU5(N,FCN,X,Y,XEND,H, & RTOL,ATOL,ITOL, & JAC ,IJAC,MLJAC,MUJAC, & MAS ,IMAS,MLMAS,MUMAS, & SOLOUT,IOUT, & WORK,LWORK,IWORK,LIWORK,RPAR,IPAR,IDID) C ---------------------------------------------------------- C NUMERICAL SOLUTION OF A STIFF (OR DIFFERENTIAL ALGEBRAIC) C SYSTEM OF FIRST 0RDER ORDINARY DIFFERENTIAL EQUATIONS C M*Y'=F(X,Y). C THE SYSTEM CAN BE (LINEARLY) IMPLICIT (MASS-MATRIX M .NE. I) C OR EXPLICIT (M=I). C THE METHOD USED IS AN IMPLICIT RUNGE-KUTTA METHOD (RADAU IIA) C OF ORDER 5 WITH STEP SIZE CONTROL AND CONTINUOUS OUTPUT. C CF. SECTION IV.8 C C AUTHORS: E. HAIRER AND G. WANNER C UNIVERSITE DE GENEVE, DEPT. DE MATHEMATIQUES C CH-1211 GENEVE 24, SWITZERLAND C E-MAIL: Ernst.Hairer@math.unige.ch C Gerhard.Wanner@math.unige.ch C C THIS CODE IS PART OF THE BOOK: C E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL C EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS. C SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS 14, C SPRINGER-VERLAG 1991, SECOND EDITION 1996. C C VERSION OF JULY 9, 1996 C (latest small correction: January 18, 2002) C C INPUT PARAMETERS C ---------------- C N DIMENSION OF THE SYSTEM C C FCN NAME (EXTERNAL) OF SUBROUTINE COMPUTING THE C VALUE OF F(X,Y): C SUBROUTINE FCN(N,X,Y,F,RPAR,IPAR) C DOUBLE PRECISION X,Y(N),F(N) C F(1)=... ETC. C RPAR, IPAR (SEE BELOW) C C X INITIAL X-VALUE C C Y(N) INITIAL VALUES FOR Y C C XEND FINAL X-VALUE (XEND-X MAY BE POSITIVE OR NEGATIVE) C C H INITIAL STEP SIZE GUESS; C FOR STIFF EQUATIONS WITH INITIAL TRANSIENT, C H=1.D0/(NORM OF F'), USUALLY 1.D-3 OR 1.D-5, IS GOOD. C THIS CHOICE IS NOT VERY IMPORTANT, THE STEP SIZE IS C QUICKLY ADAPTED. (IF H=0.D0, THE CODE PUTS H=1.D-6). C C RTOL,ATOL RELATIVE AND ABSOLUTE ERROR TOLERANCES. THEY C CAN BE BOTH SCALARS OR ELSE BOTH VECTORS OF LENGTH N. C C ITOL SWITCH FOR RTOL AND ATOL: C ITOL=0: BOTH RTOL AND ATOL ARE SCALARS. C THE CODE KEEPS, ROUGHLY, THE LOCAL ERROR OF C Y(I) BELOW RTOL*ABS(Y(I))+ATOL C ITOL=1: BOTH RTOL AND ATOL ARE VECTORS. C THE CODE KEEPS THE LOCAL ERROR OF Y(I) BELOW C RTOL(I)*ABS(Y(I))+ATOL(I). C C JAC NAME (EXTERNAL) OF THE SUBROUTINE WHICH COMPUTES C THE PARTIAL DERIVATIVES OF F(X,Y) WITH RESPECT TO Y C (THIS ROUTINE IS ONLY CALLED IF IJAC=1; SUPPLY C A DUMMY SUBROUTINE IN THE CASE IJAC=0). C FOR IJAC=1, THIS SUBROUTINE MUST HAVE THE FORM C SUBROUTINE JAC(N,X,Y,DFY,LDFY,RPAR,IPAR) C DOUBLE PRECISION X,Y(N),DFY(LDFY,N) C DFY(1,1)= ... C LDFY, THE COLUMN-LENGTH OF THE ARRAY, IS C FURNISHED BY THE CALLING PROGRAM. C IF (MLJAC.EQ.N) THE JACOBIAN IS SUPPOSED TO C BE FULL AND THE PARTIAL DERIVATIVES ARE C STORED IN DFY AS C DFY(I,J) = PARTIAL F(I) / PARTIAL Y(J) C ELSE, THE JACOBIAN IS TAKEN AS BANDED AND C THE PARTIAL DERIVATIVES ARE STORED C DIAGONAL-WISE AS C DFY(I-J+MUJAC+1,J) = PARTIAL F(I) / PARTIAL Y(J). C C IJAC SWITCH FOR THE COMPUTATION OF THE JACOBIAN: C IJAC=0: JACOBIAN IS COMPUTED INTERNALLY BY FINITE C DIFFERENCES, SUBROUTINE "JAC" IS NEVER CALLED. C IJAC=1: JACOBIAN IS SUPPLIED BY SUBROUTINE JAC. C C MLJAC SWITCH FOR THE BANDED STRUCTURE OF THE JACOBIAN: C MLJAC=N: JACOBIAN IS A FULL MATRIX. THE LINEAR C ALGEBRA IS DONE BY FULL-MATRIX GAUSS-ELIMINATION. C 0<=MLJAC= NUMBER OF NON-ZERO DIAGONALS BELOW C THE MAIN DIAGONAL). C C MUJAC UPPER BANDWITH OF JACOBIAN MATRIX (>= NUMBER OF NON- C ZERO DIAGONALS ABOVE THE MAIN DIAGONAL). C NEED NOT BE DEFINED IF MLJAC=N. C C ---- MAS,IMAS,MLMAS, AND MUMAS HAVE ANALOG MEANINGS ----- C ---- FOR THE "MASS MATRIX" (THE MATRIX "M" OF SECTION IV.8): - C C MAS NAME (EXTERNAL) OF SUBROUTINE COMPUTING THE MASS- C MATRIX M. C IF IMAS=0, THIS MATRIX IS ASSUMED TO BE THE IDENTITY C MATRIX AND NEEDS NOT TO BE DEFINED; C SUPPLY A DUMMY SUBROUTINE IN THIS CASE. C IF IMAS=1, THE SUBROUTINE MAS IS OF THE FORM C SUBROUTINE MAS(N,AM,LMAS,RPAR,IPAR) C DOUBLE PRECISION AM(LMAS,N) C AM(1,1)= .... C IF (MLMAS.EQ.N) THE MASS-MATRIX IS STORED C AS FULL MATRIX LIKE C AM(I,J) = M(I,J) C ELSE, THE MATRIX IS TAKEN AS BANDED AND STORED C DIAGONAL-WISE AS C AM(I-J+MUMAS+1,J) = M(I,J). C C IMAS GIVES INFORMATION ON THE MASS-MATRIX: C IMAS=0: M IS SUPPOSED TO BE THE IDENTITY C MATRIX, MAS IS NEVER CALLED. C IMAS=1: MASS-MATRIX IS SUPPLIED. C C MLMAS SWITCH FOR THE BANDED STRUCTURE OF THE MASS-MATRIX: C MLMAS=N: THE FULL MATRIX CASE. THE LINEAR C ALGEBRA IS DONE BY FULL-MATRIX GAUSS-ELIMINATION. C 0<=MLMAS= NUMBER OF NON-ZERO DIAGONALS BELOW C THE MAIN DIAGONAL). C MLMAS IS SUPPOSED TO BE .LE. MLJAC. C C MUMAS UPPER BANDWITH OF MASS-MATRIX (>= NUMBER OF NON- C ZERO DIAGONALS ABOVE THE MAIN DIAGONAL). C NEED NOT BE DEFINED IF MLMAS=N. C MUMAS IS SUPPOSED TO BE .LE. MUJAC. C C SOLOUT NAME (EXTERNAL) OF SUBROUTINE PROVIDING THE C NUMERICAL SOLUTION DURING INTEGRATION. C IF IOUT=1, IT IS CALLED AFTER EVERY SUCCESSFUL STEP. C SUPPLY A DUMMY SUBROUTINE IF IOUT=0. C IT MUST HAVE THE FORM C SUBROUTINE SOLOUT (NR,XOLD,X,Y,CONT,LRC,N, C RPAR,IPAR,IRTRN) C DOUBLE PRECISION X,Y(N),CONT(LRC) C .... C SOLOUT FURNISHES THE SOLUTION "Y" AT THE NR-TH C GRID-POINT "X" (THEREBY THE INITIAL VALUE IS C THE FIRST GRID-POINT). C "XOLD" IS THE PRECEEDING GRID-POINT. C "IRTRN" SERVES TO INTERRUPT THE INTEGRATION. IF IRTRN C IS SET <0, RADAU5 RETURNS TO THE CALLING PROGRAM. C C ----- CONTINUOUS OUTPUT: ----- C DURING CALLS TO "SOLOUT", A CONTINUOUS SOLUTION C FOR THE INTERVAL [XOLD,X] IS AVAILABLE THROUGH C THE FUNCTION C >>> CONTR5(I,S,CONT,LRC) <<< C WHICH PROVIDES AN APPROXIMATION TO THE I-TH C COMPONENT OF THE SOLUTION AT THE POINT S. THE VALUE C S SHOULD LIE IN THE INTERVAL [XOLD,X]. C DO NOT CHANGE THE ENTRIES OF CONT(LRC), IF THE C DENSE OUTPUT FUNCTION IS USED. C C IOUT SWITCH FOR CALLING THE SUBROUTINE SOLOUT: C IOUT=0: SUBROUTINE IS NEVER CALLED C IOUT=1: SUBROUTINE IS AVAILABLE FOR OUTPUT. C C WORK ARRAY OF WORKING SPACE OF LENGTH "LWORK". C WORK(1), WORK(2),.., WORK(20) SERVE AS PARAMETERS C FOR THE CODE. FOR STANDARD USE OF THE CODE C WORK(1),..,WORK(20) MUST BE SET TO ZERO BEFORE C CALLING. SEE BELOW FOR A MORE SOPHISTICATED USE. C WORK(21),..,WORK(LWORK) SERVE AS WORKING SPACE C FOR ALL VECTORS AND MATRICES. C "LWORK" MUST BE AT LEAST C N*(LJAC+LMAS+3*LE+12)+20 C WHERE C LJAC=N IF MLJAC=N (FULL JACOBIAN) C LJAC=MLJAC+MUJAC+1 IF MLJAC0 THEN "LWORK" MUST BE AT LEAST C N*(LJAC+12)+(N-M1)*(LMAS+3*LE)+20 C WHERE IN THE DEFINITIONS OF LJAC, LMAS AND LE THE C NUMBER N CAN BE REPLACED BY N-M1. C C LWORK DECLARED LENGTH OF ARRAY "WORK". C C IWORK INTEGER WORKING SPACE OF LENGTH "LIWORK". C IWORK(1),IWORK(2),...,IWORK(20) SERVE AS PARAMETERS C FOR THE CODE. FOR STANDARD USE, SET IWORK(1),.., C IWORK(20) TO ZERO BEFORE CALLING. C IWORK(21),...,IWORK(LIWORK) SERVE AS WORKING AREA. C "LIWORK" MUST BE AT LEAST 3*N+20. C C LIWORK DECLARED LENGTH OF ARRAY "IWORK". C C RPAR, IPAR REAL AND INTEGER PARAMETERS (OR PARAMETER ARRAYS) WHICH C CAN BE USED FOR COMMUNICATION BETWEEN YOUR CALLING C PROGRAM AND THE FCN, JAC, MAS, SOLOUT SUBROUTINES. C C ---------------------------------------------------------------------- C C SOPHISTICATED SETTING OF PARAMETERS C ----------------------------------- C SEVERAL PARAMETERS OF THE CODE ARE TUNED TO MAKE IT WORK C WELL. THEY MAY BE DEFINED BY SETTING WORK(1),... C AS WELL AS IWORK(1),... DIFFERENT FROM ZERO. C FOR ZERO INPUT, THE CODE CHOOSES DEFAULT VALUES: C C IWORK(1) IF IWORK(1).NE.0, THE CODE TRANSFORMS THE JACOBIAN C MATRIX TO HESSENBERG FORM. THIS IS PARTICULARLY C ADVANTAGEOUS FOR LARGE SYSTEMS WITH FULL JACOBIAN. C IT DOES NOT WORK FOR BANDED JACOBIAN (MLJAC 1. C THE FUNCTION-SUBROUTINE SHOULD BE WRITTEN SUCH THAT C THE INDEX 1,2,3 VARIABLES APPEAR IN THIS ORDER. C IN ESTIMATING THE ERROR THE INDEX 2 VARIABLES ARE C MULTIPLIED BY H, THE INDEX 3 VARIABLES BY H**2. C C IWORK(5) DIMENSION OF THE INDEX 1 VARIABLES (MUST BE > 0). FOR C ODE'S THIS EQUALS THE DIMENSION OF THE SYSTEM. C DEFAULT IWORK(5)=N. C C IWORK(6) DIMENSION OF THE INDEX 2 VARIABLES. DEFAULT IWORK(6)=0. C C IWORK(7) DIMENSION OF THE INDEX 3 VARIABLES. DEFAULT IWORK(7)=0. C C IWORK(8) SWITCH FOR STEP SIZE STRATEGY C IF IWORK(8).EQ.1 MOD. PREDICTIVE CONTROLLER (GUSTAFSSON) C IF IWORK(8).EQ.2 CLASSICAL STEP SIZE CONTROL C THE DEFAULT VALUE (FOR IWORK(8)=0) IS IWORK(8)=1. C THE CHOICE IWORK(8).EQ.1 SEEMS TO PRODUCE SAFER RESULTS; C FOR SIMPLE PROBLEMS, THE CHOICE IWORK(8).EQ.2 PRODUCES C OFTEN SLIGHTLY FASTER RUNS C C IF THE DIFFERENTIAL SYSTEM HAS THE SPECIAL STRUCTURE THAT C Y(I)' = Y(I+M2) FOR I=1,...,M1, C WITH M1 A MULTIPLE OF M2, A SUBSTANTIAL GAIN IN COMPUTERTIME C CAN BE ACHIEVED BY SETTING THE PARAMETERS IWORK(9) AND IWORK(10). C E.G., FOR SECOND ORDER SYSTEMS P'=V, V'=G(P,V), WHERE P AND V ARE C VECTORS OF DIMENSION N/2, ONE HAS TO PUT M1=M2=N/2. C FOR M1>0 SOME OF THE INPUT PARAMETERS HAVE DIFFERENT MEANINGS: C - JAC: ONLY THE ELEMENTS OF THE NON-TRIVIAL PART OF THE C JACOBIAN HAVE TO BE STORED C IF (MLJAC.EQ.N-M1) THE JACOBIAN IS SUPPOSED TO BE FULL C DFY(I,J) = PARTIAL F(I+M1) / PARTIAL Y(J) C FOR I=1,N-M1 AND J=1,N. C ELSE, THE JACOBIAN IS BANDED ( M1 = M2 * MM ) C DFY(I-J+MUJAC+1,J+K*M2) = PARTIAL F(I+M1) / PARTIAL Y(J+K*M2) C FOR I=1,MLJAC+MUJAC+1 AND J=1,M2 AND K=0,MM. C - MLJAC: MLJAC=N-M1: IF THE NON-TRIVIAL PART OF THE JACOBIAN IS FULL C 0<=MLJAC1.0D0 IF (WORK(1).EQ.0.0D0) THEN UROUND=1.0D-16 ELSE UROUND=WORK(1) IF (UROUND.LE.1.0D-19.OR.UROUND.GE.1.0D0) THEN CALL rprintfd1( & ' COEFFICIENTS HAVE 20 DIGITS, UROUND= %g'//char(0), WORK(1)) ARRET=.TRUE. END IF END IF C -------- CHECK AND CHANGE THE TOLERANCES EXPM=2.0D0/3.0D0 IF (ITOL.EQ.0) THEN IF (ATOL(1).LE.0.D0.OR.RTOL(1).LE.10.D0*UROUND) THEN CALL rprintf( ' TOLERANCES ARE TOO SMALL'//char(0)) ARRET=.TRUE. ELSE QUOT=ATOL(1)/RTOL(1) RTOL(1)=0.1D0*RTOL(1)**EXPM ATOL(1)=RTOL(1)*QUOT END IF ELSE DO I=1,N IF (ATOL(I).LE.0.D0.OR.RTOL(I).LE.10.D0*UROUND) THEN CALL rprintfi1( ' TOLERANCES (%i) ARE TOO SMALL' & //char(0), I) ARRET=.TRUE. ELSE QUOT=ATOL(I)/RTOL(I) RTOL(I)=0.1D0*RTOL(I)**EXPM ATOL(I)=RTOL(I)*QUOT END IF END DO END IF C -------- NMAX , THE MAXIMAL NUMBER OF STEPS ----- IF (IWORK(2).EQ.0) THEN NMAX=100000 ELSE NMAX=IWORK(2) IF (NMAX.LE.0) THEN CALL rprintfi1(' WRONG INPUT IWORK(2)= %i' & // char(0), IWORK(2)) ARRET=.TRUE. END IF END IF C -------- NIT MAXIMAL NUMBER OF NEWTON ITERATIONS IF (IWORK(3).EQ.0) THEN NIT=7 ELSE NIT=IWORK(3) IF (NIT.LE.0) THEN CALL rprintfi1(' CURIOUS INPUT IWORK(3)= %i' & // char(0), IWORK(3)) ARRET=.TRUE. END IF END IF C -------- STARTN SWITCH FOR STARTING VALUES OF NEWTON ITERATIONS IF(IWORK(4).EQ.0)THEN STARTN=.FALSE. ELSE STARTN=.TRUE. END IF C -------- PARAMETER FOR DIFFERENTIAL-ALGEBRAIC COMPONENTS NIND1=IWORK(5) NIND2=IWORK(6) NIND3=IWORK(7) IF (NIND1.EQ.0) NIND1=N IF (NIND1+NIND2+NIND3.NE.N) THEN call rprintfi3( &' CURIOUS INPUT FOR IWORK(5,6,7)= %i, %i, %i' //char(0), & NIND1, NIND2, NIND3) ARRET=.TRUE. END IF C -------- PRED STEP SIZE CONTROL IF(IWORK(8).LE.1)THEN PRED=.TRUE. ELSE PRED=.FALSE. END IF C -------- PARAMETER FOR SECOND ORDER EQUATIONS M1=IWORK(9) M2=IWORK(10) NM1=N-M1 IF (M1.EQ.0) M2=N IF (M2.EQ.0) M2=M1 IF (M1.LT.0.OR.M2.LT.0.OR.M1+M2.GT.N) THEN CALL rprintfi2(' CURIOUS INPUT FOR IWORK(9,10)= %i, %i' & // char(0), M1, M2) ARRET=.TRUE. END IF C --------- SAFE SAFETY FACTOR IN STEP SIZE PREDICTION IF (WORK(2).EQ.0.0D0) THEN SAFE=0.9D0 ELSE SAFE=WORK(2) IF (SAFE.LE.0.001D0.OR.SAFE.GE.1.0D0) THEN Call rprintfd1(' CURIOUS INPUT FOR WORK(2)= %g' & // char(0), WORK(2)) ARRET=.TRUE. END IF END IF C ------ THET DECIDES WHETHER THE JACOBIAN SHOULD BE RECOMPUTED; IF (WORK(3).EQ.0.D0) THEN THET=0.001D0 ELSE THET=WORK(3) IF (THET.GE.1.0D0) THEN Call rprintfd1(' CURIOUS INPUT FOR WORK(3)= %g' & // char(0), WORK(3)) ARRET=.TRUE. END IF END IF C --- FNEWT STOPPING CRITERION FOR NEWTON'S METHOD, USUALLY CHOSEN <1. TOLST=RTOL(1) IF (WORK(4).EQ.0.D0) THEN FNEWT=MAX(10*UROUND/TOLST,MIN(0.03D0,TOLST**0.5D0)) ELSE FNEWT=WORK(4) IF (FNEWT.LE.UROUND/TOLST) THEN Call rprintfd1(' CURIOUS INPUT FOR WORK(4)= %g' & // char(0), WORK(4)) ARRET=.TRUE. END IF END IF C --- QUOT1 AND QUOT2: IF QUOT1 < HNEW/HOLD < QUOT2, STEP SIZE = CONST. IF (WORK(5).EQ.0.D0) THEN QUOT1=1.D0 ELSE QUOT1=WORK(5) END IF IF (WORK(6).EQ.0.D0) THEN QUOT2=1.2D0 ELSE QUOT2=WORK(6) END IF IF (QUOT1.GT.1.0D0.OR.QUOT2.LT.1.0D0) THEN CALL rprintfd2(' CURIOUS INPUT FOR WORK(5,6)= %g, %g' & // char(0), QUOT1, QUOT2) ARRET=.TRUE. END IF C -------- MAXIMAL STEP SIZE IF (WORK(7).EQ.0.D0) THEN HMAX=XEND-X ELSE HMAX=WORK(7) END IF C ------- FACL,FACR PARAMETERS FOR STEP SIZE SELECTION IF(WORK(8).EQ.0.D0)THEN FACL=5.D0 ELSE FACL=1.D0/WORK(8) END IF IF(WORK(9).EQ.0.D0)THEN FACR=1.D0/8.0D0 ELSE FACR=1.D0/WORK(9) END IF IF (FACL.LT.1.0D0.OR.FACR.GT.1.0D0) THEN CALL rprintfd2(' CURIOUS INPUT WORK(8,9)= %g, %g' & // char(0), WORK(8), WORK(9)) ARRET=.TRUE. END IF C *** *** *** *** *** *** *** *** *** *** *** *** *** C COMPUTATION OF ARRAY ENTRIES C *** *** *** *** *** *** *** *** *** *** *** *** *** C ---- IMPLICIT, BANDED OR NOT ? IMPLCT=IMAS.NE.0 JBAND=MLJAC.LT.NM1 C -------- COMPUTATION OF THE ROW-DIMENSIONS OF THE 2-ARRAYS --- C -- JACOBIAN AND MATRICES E1, E2 IF (JBAND) THEN LDJAC=MLJAC+MUJAC+1 LDE1=MLJAC+LDJAC ELSE MLJAC=NM1 MUJAC=NM1 LDJAC=NM1 LDE1=NM1 END IF C -- MASS MATRIX IF (IMPLCT) THEN IF (MLMAS.NE.NM1) THEN LDMAS=MLMAS+MUMAS+1 IF (JBAND) THEN IJOB=4 ELSE IJOB=3 END IF ELSE MUMAS=NM1 LDMAS=NM1 IJOB=5 END IF C ------ BANDWITH OF "MAS" NOT SMALLER THAN BANDWITH OF "JAC" IF (MLMAS.GT.MLJAC.OR.MUMAS.GT.MUJAC) THEN CALL rprintf( & 'BANDWITH OF "MAS" NOT SMALLER THAN BANDWITH OF "JAC"' & // char(0)) ARRET=.TRUE. END IF ELSE LDMAS=0 IF (JBAND) THEN IJOB=2 ELSE IJOB=1 IF (N.GT.2.AND.IWORK(1).NE.0) IJOB=7 END IF END IF LDMAS2=MAX(1,LDMAS) C ------ HESSENBERG OPTION ONLY FOR EXPLICIT EQU. WITH FULL JACOBIAN IF ((IMPLCT.OR.JBAND).AND.IJOB.EQ.7) THEN CALL rprintf( &' HESSENBERG OPTION ONLY FOR EXPLICIT EQUATIONS & WITH FULL JACOBIAN' // char(0)) ARRET=.TRUE. END IF C ------- PREPARE THE ENTRY-POINTS FOR THE ARRAYS IN WORK ----- IEZ1=21 IEZ2=IEZ1+N IEZ3=IEZ2+N IEY0=IEZ3+N IESCAL=IEY0+N IEF1=IESCAL+N IEF2=IEF1+N IEF3=IEF2+N IECON=IEF3+N IEJAC=IECON+4*N IEMAS=IEJAC+N*LDJAC IEE1=IEMAS+NM1*LDMAS IEE2R=IEE1+NM1*LDE1 IEE2I=IEE2R+NM1*LDE1 C ------ TOTAL STORAGE REQUIREMENT ----------- ISTORE=IEE2I+NM1*LDE1-1 IF(ISTORE.GT.LWORK)THEN CALL rprintfi1( & ' INSUFFICIENT STORAGE FOR WORK, MIN. LWORK= %i' & // char(0), ISTORE) ARRET=.TRUE. END IF C ------- ENTRY POINTS FOR INTEGER WORKSPACE ----- IEIP1=21 IEIP2=IEIP1+NM1 IEIPH=IEIP2+NM1 C --------- TOTAL REQUIREMENT --------------- ISTORE=IEIPH+NM1-1 IF (ISTORE.GT.LIWORK) THEN CALL rprintfi1( & ' INSUFF. STORAGE FOR IWORK, MIN. LIWORK= %i' & // char(0), ISTORE) ARRET=.TRUE. END IF C ------ WHEN A FAIL HAS OCCURED, WE RETURN WITH IDID=-1 IF (ARRET) THEN IDID=-1 RETURN END IF C -------- CALL TO CORE INTEGRATOR ------------ CALL RADCOR(N,FCN,X,Y,XEND,HMAX,H,RTOL,ATOL,ITOL, & JAC,IJAC,MLJAC,MUJAC,MAS,MLMAS,MUMAS,SOLOUT,IOUT,IDID, & NMAX,UROUND,SAFE,THET,FNEWT,QUOT1,QUOT2,NIT,IJOB,STARTN, & NIND1,NIND2,NIND3,PRED,FACL,FACR,M1,M2,NM1, & IMPLCT,JBAND,LDJAC,LDE1,LDMAS2,WORK(IEZ1),WORK(IEZ2), & WORK(IEZ3),WORK(IEY0),WORK(IESCAL),WORK(IEF1),WORK(IEF2), & WORK(IEF3),WORK(IEJAC),WORK(IEE1),WORK(IEE2R),WORK(IEE2I), & WORK(IEMAS),IWORK(IEIP1),IWORK(IEIP2),IWORK(IEIPH), & WORK(IECON),NFCN,NJAC,NSTEP,NACCPT,NREJCT,NDEC,NSOL,RPAR,IPAR) IWORK(14)=NFCN IWORK(15)=NJAC IWORK(16)=NSTEP IWORK(17)=NACCPT IWORK(18)=NREJCT IWORK(19)=NDEC IWORK(20)=NSOL C -------- RESTORE TOLERANCES EXPM=1.0D0/EXPM IF (ITOL.EQ.0) THEN QUOT=ATOL(1)/RTOL(1) RTOL(1)=(10.0D0*RTOL(1))**EXPM ATOL(1)=RTOL(1)*QUOT ELSE DO I=1,N QUOT=ATOL(I)/RTOL(I) RTOL(I)=(10.0D0*RTOL(I))**EXPM ATOL(I)=RTOL(I)*QUOT END DO END IF C ----------- RETURN ----------- RETURN END C C END OF SUBROUTINE RADAU5 C C *********************************************************** C SUBROUTINE RADCOR(N,FCN,X,Y,XEND,HMAX,H,RTOL,ATOL,ITOL, & JAC,IJAC,MLJAC,MUJAC,MAS,MLMAS,MUMAS,SOLOUT,IOUT,IDID, & NMAX,UROUND,SAFE,THET,FNEWT,QUOT1,QUOT2,NIT,IJOB,STARTN, & NIND1,NIND2,NIND3,PRED,FACL,FACR,M1,M2,NM1, & IMPLCT,BANDED,LDJAC,LDE1,LDMAS,Z1,Z2,Z3, & Y0,SCAL,F1,F2,F3,FJAC,E1,E2R,E2I,FMAS,IP1,IP2,IPHES, & CONT,NFCN,NJAC,NSTEP,NACCPT,NREJCT,NDEC,NSOL,RPAR,IPAR) C ---------------------------------------------------------- C CORE INTEGRATOR FOR RADAU5 C PARAMETERS SAME AS IN RADAU5 WITH WORKSPACE ADDED C ---------------------------------------------------------- C DECLARATIONS C ---------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION Y(N),Z1(N),Z2(N),Z3(N),Y0(N),SCAL(N),F1(N),F2(N),F3(N) DIMENSION FJAC(LDJAC,N),FMAS(LDMAS,NM1),CONT(4*N) DIMENSION E1(LDE1,NM1),E2R(LDE1,NM1),E2I(LDE1,NM1) DIMENSION ATOL(*),RTOL(*),RPAR(*),IPAR(*) INTEGER IP1(NM1),IP2(NM1),IPHES(NM1) COMMON /CONRA5/NN,NN2,NN3,NN4,XSOL,HSOL,C2M1,C1M1 COMMON/LINAL/MLE,MUE,MBJAC,MBB,MDIAG,MDIFF,MBDIAG LOGICAL REJECT,FIRST,IMPLCT,BANDED,CALJAC,STARTN,CALHES LOGICAL INDEX1,INDEX2,INDEX3,LAST,PRED EXTERNAL FCN C *** *** *** *** *** *** *** C INITIALISATIONS C *** *** *** *** *** *** *** C --------- DUPLIFY N FOR COMMON BLOCK CONT ----- NN=N NN2=2*N NN3=3*N LRC=4*N C -------- CHECK THE INDEX OF THE PROBLEM ----- INDEX1=NIND1.NE.0 INDEX2=NIND2.NE.0 INDEX3=NIND3.NE.0 C ------- COMPUTE MASS MATRIX FOR IMPLICIT CASE ---------- IF (IMPLCT) CALL MAS(NM1,FMAS,LDMAS,RPAR,IPAR) C ---------- CONSTANTS --------- SQ6=DSQRT(6.D0) C1=(4.D0-SQ6)/10.D0 C2=(4.D0+SQ6)/10.D0 C1M1=C1-1.D0 C2M1=C2-1.D0 C1MC2=C1-C2 DD1=-(13.D0+7.D0*SQ6)/3.D0 DD2=(-13.D0+7.D0*SQ6)/3.D0 DD3=-1.D0/3.D0 U1=(6.D0+81.D0**(1.D0/3.D0)-9.D0**(1.D0/3.D0))/30.D0 ALPH=(12.D0-81.D0**(1.D0/3.D0)+9.D0**(1.D0/3.D0))/60.D0 BETA=(81.D0**(1.D0/3.D0)+9.D0**(1.D0/3.D0))*DSQRT(3.D0)/60.D0 CNO=ALPH**2+BETA**2 U1=1.0D0/U1 ALPH=ALPH/CNO BETA=BETA/CNO T11=9.1232394870892942792D-02 T12=-0.14125529502095420843D0 T13=-3.0029194105147424492D-02 T21=0.24171793270710701896D0 T22=0.20412935229379993199D0 T23=0.38294211275726193779D0 T31=0.96604818261509293619D0 TI11=4.3255798900631553510D0 TI12=0.33919925181580986954D0 TI13=0.54177053993587487119D0 TI21=-4.1787185915519047273D0 TI22=-0.32768282076106238708D0 TI23=0.47662355450055045196D0 TI31=-0.50287263494578687595D0 TI32=2.5719269498556054292D0 TI33=-0.59603920482822492497D0 IF (M1.GT.0) IJOB=IJOB+10 POSNEG=SIGN(1.D0,XEND-X) HMAXN=MIN(ABS(HMAX),ABS(XEND-X)) IF (ABS(H).LE.10.D0*UROUND) H=1.0D-6 H=MIN(ABS(H),HMAXN) H=SIGN(H,POSNEG) HOLD=H REJECT=.FALSE. FIRST=.TRUE. LAST=.FALSE. IF ((X+H*1.0001D0-XEND)*POSNEG.GE.0.D0) THEN H=XEND-X LAST=.TRUE. END IF HOPT=H FACCON=1.D0 CFAC=SAFE*(1+2*NIT) NSING=0 XOLD=X IF (IOUT.NE.0) THEN IRTRN=1 NRSOL=1 XOSOL=XOLD XSOL=X DO I=1,N CONT(I)=Y(I) END DO NSOLU=N HSOL=HOLD CALL SOLOUT(NRSOL,XOSOL,XSOL,Y,CONT,LRC,NSOLU, & RPAR,IPAR,IRTRN) IF (IRTRN.LT.0) GOTO 179 END IF MLE=MLJAC MUE=MUJAC MBJAC=MLJAC+MUJAC+1 MBB=MLMAS+MUMAS+1 MDIAG=MLE+MUE+1 MDIFF=MLE+MUE-MUMAS MBDIAG=MUMAS+1 N2=2*N N3=3*N IF (ITOL.EQ.0) THEN DO I=1,N SCAL(I)=ATOL(1)+RTOL(1)*ABS(Y(I)) END DO ELSE DO I=1,N SCAL(I)=ATOL(I)+RTOL(I)*ABS(Y(I)) END DO END IF HHFAC=H CALL FCN(N,X,Y,Y0,RPAR,IPAR) NFCN=NFCN+1 C --- BASIC INTEGRATION STEP 10 CONTINUE C *** *** *** *** *** *** *** C COMPUTATION OF THE JACOBIAN C *** *** *** *** *** *** *** NJAC=NJAC+1 IF (IJAC.EQ.0) THEN C --- COMPUTE JACOBIAN MATRIX NUMERICALLY IF (BANDED) THEN C --- JACOBIAN IS BANDED MUJACP=MUJAC+1 MD=MIN(MBJAC,M2) DO MM=1,M1/M2+1 DO K=1,MD J=K+(MM-1)*M2 12 F1(J)=Y(J) F2(J)=DSQRT(UROUND*MAX(1.D-5,ABS(Y(J)))) Y(J)=Y(J)+F2(J) J=J+MD IF (J.LE.MM*M2) GOTO 12 CALL FCN(N,X,Y,CONT,RPAR,IPAR) J=K+(MM-1)*M2 J1=K LBEG=MAX(1,J1-MUJAC)+M1 14 LEND=MIN(M2,J1+MLJAC)+M1 Y(J)=F1(J) MUJACJ=MUJACP-J1-M1 DO L=LBEG,LEND FJAC(L+MUJACJ,J)=(CONT(L)-Y0(L))/F2(J) END DO J=J+MD J1=J1+MD LBEG=LEND+1 IF (J.LE.MM*M2) GOTO 14 END DO NFCN=NFCN+MD END DO ELSE C --- JACOBIAN IS FULL DO I=1,N YSAFE=Y(I) DELT=DSQRT(UROUND*MAX(1.D-5,ABS(YSAFE))) Y(I)=YSAFE+DELT CALL FCN(N,X,Y,CONT,RPAR,IPAR) DO J=M1+1,N FJAC(J-M1,I)=(CONT(J)-Y0(J))/DELT END DO Y(I)=YSAFE END DO NFCN=NFCN+N END IF ELSE C --- COMPUTE JACOBIAN MATRIX ANALYTICALLY CALL JAC(N,X,Y,MLJAC,MUJAC,FJAC,LDJAC,RPAR,IPAR) END IF CALJAC=.TRUE. CALHES=.TRUE. 20 CONTINUE C --- COMPUTE THE MATRICES E1 AND E2 AND THEIR DECOMPOSITIONS FAC1=U1/H ALPHN=ALPH/H BETAN=BETA/H CALL DECOMR(N,FJAC,LDJAC,FMAS,LDMAS,MLMAS,MUMAS, & M1,M2,NM1,FAC1,E1,LDE1,IP1,IER,IJOB,CALHES,IPHES) IF (IER.NE.0) GOTO 78 CALL DECOMC(N,FJAC,LDJAC,FMAS,LDMAS,MLMAS,MUMAS, & M1,M2,NM1,ALPHN,BETAN,E2R,E2I,LDE1,IP2,IER,IJOB) IF (IER.NE.0) GOTO 78 NDEC=NDEC+1 30 CONTINUE NSTEP=NSTEP+1 IF (NSTEP.GT.NMAX) GOTO 178 IF (0.1D0*ABS(H).LE.ABS(X)*UROUND) GOTO 177 IF (INDEX2) THEN DO I=NIND1+1,NIND1+NIND2 SCAL(I)=SCAL(I)/HHFAC END DO END IF IF (INDEX3) THEN DO I=NIND1+NIND2+1,NIND1+NIND2+NIND3 SCAL(I)=SCAL(I)/(HHFAC*HHFAC) END DO END IF XPH=X+H C *** *** *** *** *** *** *** C STARTING VALUES FOR NEWTON ITERATION C *** *** *** *** *** *** *** IF (FIRST.OR.STARTN) THEN DO I=1,N Z1(I)=0.D0 Z2(I)=0.D0 Z3(I)=0.D0 F1(I)=0.D0 F2(I)=0.D0 F3(I)=0.D0 END DO ELSE C3Q=H/HOLD C1Q=C1*C3Q C2Q=C2*C3Q DO I=1,N AK1=CONT(I+N) AK2=CONT(I+N2) AK3=CONT(I+N3) Z1I=C1Q*(AK1+(C1Q-C2M1)*(AK2+(C1Q-C1M1)*AK3)) Z2I=C2Q*(AK1+(C2Q-C2M1)*(AK2+(C2Q-C1M1)*AK3)) Z3I=C3Q*(AK1+(C3Q-C2M1)*(AK2+(C3Q-C1M1)*AK3)) Z1(I)=Z1I Z2(I)=Z2I Z3(I)=Z3I F1(I)=TI11*Z1I+TI12*Z2I+TI13*Z3I F2(I)=TI21*Z1I+TI22*Z2I+TI23*Z3I F3(I)=TI31*Z1I+TI32*Z2I+TI33*Z3I END DO END IF C *** *** *** *** *** *** *** C LOOP FOR THE SIMPLIFIED NEWTON ITERATION C *** *** *** *** *** *** *** NEWT=0 C--- December, 2011 FRANCESCA MAZZIA added this line to avoid owerflow DYNO = 1.0d0 FACCON=MAX(FACCON,UROUND)**0.8D0 THETA=ABS(THET) 40 CONTINUE IF (NEWT.GE.NIT) GOTO 78 C--- December, 2011 FRANCESCA MAZZIA added this line to avoid owerflow IF ( .NOT. (DYNO .GT. 0.0d0) ) GOTO 78 C --- COMPUTE THE RIGHT-HAND SIDE DO I=1,N CONT(I)=Y(I)+Z1(I) END DO CALL FCN(N,X+C1*H,CONT,Z1,RPAR,IPAR) DO I=1,N CONT(I)=Y(I)+Z2(I) END DO CALL FCN(N,X+C2*H,CONT,Z2,RPAR,IPAR) DO I=1,N CONT(I)=Y(I)+Z3(I) END DO CALL FCN(N,XPH,CONT,Z3,RPAR,IPAR) NFCN=NFCN+3 C --- SOLVE THE LINEAR SYSTEMS DO I=1,N A1=Z1(I) A2=Z2(I) A3=Z3(I) Z1(I)=TI11*A1+TI12*A2+TI13*A3 Z2(I)=TI21*A1+TI22*A2+TI23*A3 Z3(I)=TI31*A1+TI32*A2+TI33*A3 END DO CALL SLVRAD(N,FJAC,LDJAC,MLJAC,MUJAC,FMAS,LDMAS,MLMAS,MUMAS, & M1,M2,NM1,FAC1,ALPHN,BETAN,E1,E2R,E2I,LDE1,Z1,Z2,Z3, & F1,F2,F3,CONT,IP1,IP2,IPHES,IER,IJOB) NSOL=NSOL+1 NEWT=NEWT+1 DYNO=0.D0 DO I=1,N DENOM=SCAL(I) DYNO=DYNO+(Z1(I)/DENOM)**2+(Z2(I)/DENOM)**2 & +(Z3(I)/DENOM)**2 END DO DYNO=DSQRT(DYNO/N3) C --- BAD CONVERGENCE OR NUMBER OF ITERATIONS TO LARGE IF (NEWT.GT.1.AND.NEWT.LT.NIT) THEN THQ=DYNO/DYNOLD IF (NEWT.EQ.2) THEN THETA=THQ ELSE THETA=SQRT(THQ*THQOLD) END IF THQOLD=THQ IF (THETA.LT.0.99D0) THEN FACCON=THETA/(1.0D0-THETA) DYTH=FACCON*DYNO*THETA**(NIT-1-NEWT)/FNEWT IF (DYTH.GE.1.0D0) THEN QNEWT=DMAX1(1.0D-4,DMIN1(20.0D0,DYTH)) HHFAC=.8D0*QNEWT**(-1.0D0/(4.0D0+NIT-1-NEWT)) H=HHFAC*H REJECT=.TRUE. LAST=.FALSE. IF (CALJAC) GOTO 20 GOTO 10 END IF ELSE GOTO 78 END IF END IF DYNOLD=MAX(DYNO,UROUND) DO I=1,N F1I=F1(I)+Z1(I) F2I=F2(I)+Z2(I) F3I=F3(I)+Z3(I) F1(I)=F1I F2(I)=F2I F3(I)=F3I Z1(I)=T11*F1I+T12*F2I+T13*F3I Z2(I)=T21*F1I+T22*F2I+T23*F3I Z3(I)=T31*F1I+ F2I END DO IF (FACCON*DYNO.GT.FNEWT) GOTO 40 C --- ERROR ESTIMATION CALL ESTRAD (N,FJAC,LDJAC,MLJAC,MUJAC,FMAS,LDMAS,MLMAS,MUMAS, & H,DD1,DD2,DD3,FCN,NFCN,Y0,Y,IJOB,X,M1,M2,NM1, & E1,LDE1,Z1,Z2,Z3,CONT,F1,F2,IP1,IPHES,SCAL,ERR, & FIRST,REJECT,FAC1,RPAR,IPAR) C --- COMPUTATION OF HNEW C --- WE REQUIRE .2<=HNEW/H<=8. FAC=MIN(SAFE,CFAC/(NEWT+2*NIT)) QUOT=MAX(FACR,MIN(FACL,ERR**.25D0/FAC)) HNEW=H/QUOT C *** *** *** *** *** *** *** C IS THE ERROR SMALL ENOUGH ? C *** *** *** *** *** *** *** IF (ERR.LT.1.D0) THEN C --- STEP IS ACCEPTED FIRST=.FALSE. NACCPT=NACCPT+1 IF (PRED) THEN C --- PREDICTIVE CONTROLLER OF GUSTAFSSON IF (NACCPT.GT.1) THEN FACGUS=(HACC/H)*(ERR**2/ERRACC)**0.25D0/SAFE FACGUS=MAX(FACR,MIN(FACL,FACGUS)) QUOT=MAX(QUOT,FACGUS) HNEW=H/QUOT END IF HACC=H ERRACC=MAX(1.0D-2,ERR) END IF XOLD=X HOLD=H X=XPH DO I=1,N Y(I)=Y(I)+Z3(I) Z2I=Z2(I) Z1I=Z1(I) CONT(I+N)=(Z2I-Z3(I))/C2M1 AK=(Z1I-Z2I)/C1MC2 ACONT3=Z1I/C1 ACONT3=(AK-ACONT3)/C2 CONT(I+N2)=(AK-CONT(I+N))/C1M1 CONT(I+N3)=CONT(I+N2)-ACONT3 END DO IF (ITOL.EQ.0) THEN DO I=1,N SCAL(I)=ATOL(1)+RTOL(1)*ABS(Y(I)) END DO ELSE DO I=1,N SCAL(I)=ATOL(I)+RTOL(I)*ABS(Y(I)) END DO END IF IF (IOUT.NE.0) THEN NRSOL=NACCPT+1 XSOL=X XOSOL=XOLD DO I=1,N CONT(I)=Y(I) END DO NSOLU=N HSOL=HOLD CALL SOLOUT(NRSOL,XOSOL,XSOL,Y,CONT,LRC,NSOLU, & RPAR,IPAR,IRTRN) IF (IRTRN.LT.0) GOTO 179 END IF CALJAC=.FALSE. IF (LAST) THEN H=HOPT IDID=1 RETURN END IF CALL FCN(N,X,Y,Y0,RPAR,IPAR) NFCN=NFCN+1 HNEW=POSNEG*MIN(ABS(HNEW),HMAXN) HOPT=HNEW HOPT=MIN(H,HNEW) IF (REJECT) HNEW=POSNEG*MIN(ABS(HNEW),ABS(H)) REJECT=.FALSE. IF ((X+HNEW/QUOT1-XEND)*POSNEG.GE.0.D0) THEN H=XEND-X LAST=.TRUE. ELSE QT=HNEW/H HHFAC=H IF (THETA.LE.THET.AND.QT.GE.QUOT1.AND.QT.LE.QUOT2) GOTO 30 H=HNEW END IF HHFAC=H IF (THETA.LE.THET) GOTO 20 GOTO 10 ELSE C --- STEP IS REJECTED REJECT=.TRUE. LAST=.FALSE. IF (FIRST) THEN H=H*0.1D0 HHFAC=0.1D0 ELSE HHFAC=HNEW/H H=HNEW END IF IF (NACCPT.GE.1) NREJCT=NREJCT+1 IF (CALJAC) GOTO 20 GOTO 10 END IF C --- UNEXPECTED STEP-REJECTION 78 CONTINUE IF (IER.NE.0) THEN NSING=NSING+1 IF (NSING.GE.5) GOTO 176 END IF H=H*0.5D0 HHFAC=0.5D0 REJECT=.TRUE. LAST=.FALSE. IF (CALJAC) GOTO 20 GOTO 10 C --- FAIL EXIT 176 CONTINUE CALL rprintfd1(' EXIT OF RADAU5 AT X= %g' // char(0), X) CALL rprintfi1(' MATRIX IS REPEATEDLY SINGULAR, IER= %i' & //char(0), IER) IDID=-4 RETURN 177 CONTINUE CALL rprintfd1(' EXIT OF RADAU5 AT X= %g' // char(0), X) CALL rprintfd1(' STEP SIZE T0O SMALL, H= %g' // char(0), H) IDID=-3 RETURN 178 CONTINUE CALL rprintfd1(' EXIT OF RADAU5 AT X= %g'//char(0), X ) CALL rprintfi1(' MORE THAN NMAX (I1),STEPS ARE NEEDED %i' & //char(0), NMAX) IDID=-2 RETURN C --- EXIT CAUSED BY SOLOUT 179 CONTINUE C karline: toggled this off C WRITE(MSG,979)X C CALL rprint(MSG) C 979 FORMAT(' EXIT OF RADAU5 AT X=',E18.4) IDID=2 RETURN END C C END OF SUBROUTINE RADCOR C C *********************************************************** C SUBROUTINE CONTR5(NEQ,X,CONT,LRC, RES) C ---------------------------------------------------------- C THIS FUNCTION CAN BE USED FOR CONINUOUS OUTPUT. IT PROVIDES AN C APPROXIMATION TO THE SOLUTION AT X. C IT GIVES THE VALUE OF THE COLLOCATION POLYNOMIAL, DEFINED FOR C THE LAST SUCCESSFULLY COMPUTED STEP (BY RADAU5). C ---------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION CONT(LRC) DOUBLE PRECISION RES(NEQ) INTEGER I COMMON /CONRA5/NN,NN2,NN3,NN4,XSOL,HSOL,C2M1,C1M1 S=(X-XSOL)/HSOL DO I = 1,NEQ RES(I)=CONT(I)+S*(CONT(I+NN)+(S-C2M1)*(CONT(I+NN2) & +(S-C1M1)*CONT(I+NN3))) ENDDO RETURN END C C END OF FUNCTION CONTR5 -KARLINE changed to SUBROUTINE THAT RETURNS ALL C C *********************************************************** C SUBROUTINE GETCONRA(RCONRA) C ---------------------------------------------------------- C THIS FUNCTION CAN BE USED FOR STANDALONE CONINUOUS OUTPUT. C IT RETURNS THE VALUES OF COMMON CONRA as used in CONTR5 C ---------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) DOUBLE PRECISION RCONRA(2) COMMON /CONRA5/NN,NN2,NN3,NN4,XSOL,HSOL,C2M1,C1M1 RCONRA(1) = XSOL RCONRA(2) = HSOL RETURN END C C END OF FUNCTION CONTR5 -KARLINE changed to SUBROUTINE C C *********************************************************** SUBROUTINE CONTR5ALONE(I, NEQ,X,CONT,LRC, RCONRA, RES, Itype) C ---------------------------------------------------------- C THIS FUNCTION CAN BE USED FOR STANDALONE CONINUOUS OUTPUT. C IT PROVIDES AN APPROXIMATION TO THE Ith SOLUTION AT X. C IT GIVES THE VALUE OF THE COLLOCATION POLYNOMIAL, DEFINED FOR C THE LAST SUCCESSFULLY COMPUTED STEP (BY RADAU5). C ---------------------------------------------------------- IMPLICIT NONE INTEGER LRC, NEQ, Itype DOUBLE PRECISION RCONRA(2),CONT(LRC), RES,X DOUBLE PRECISION XSOL,HSOL,C2M1,C1M1,SQ6,C1,C2,S INTEGER I, NN, NN2, NN3, NN4 NN = NEQ NN2 = NEQ*2 NN3 = NEQ*3 NN4 = NEQ*4 XSOL = RCONRA(1) HSOL = RCONRA(2) SQ6=DSQRT(6.D0) C1=(4.D0-SQ6)/10.D0 C2=(4.D0+SQ6)/10.D0 C1M1=C1-1.D0 C2M1=C2-1.D0 S=(X-XSOL)/HSOL IF(IType .eq. 1) THEN ! value RES=CONT(I)+S*(CONT(I+NN)+(S-C2M1)*(CONT(I+NN2) & +(S-C1M1)*CONT(I+NN3))) ELSE ! derivative.... RES=1.d0/HSOL*(CONT(I+NN)-C2M1*CONT(I+NN2)+C2M1*C1M1*CONT(I+NN3) & + 2*S*(CONT(I+NN2)-CONT(I+NN3)*C2M1-CONT(I+NN3)*C1M1) & + 3*S*S*CONT(I+NN3) ) ENDIF RETURN END deSolve/src/ex_Aquaphy.c0000754000175100001440000001536613131751003014737 0ustar hornikusers/* file ex_aquaphy.c The Aquaphy algal model -------- ex_Aquaphy.c -> ex_Aquaphy.dll ------ compile in R with: system("gcc -shared -o Aquaphy Aquaphy") or with system("R CMD SHLIB ex_Aquaphy") */ #include static double parms[19]; #define maxPhotoSynt parms[0] #define rMortPHY parms[1] #define alpha parms[2] #define pExudation parms[3] #define maxProteinSynt parms[4] #define ksDIN parms[5] #define minpLMW parms[6] #define maxpLMW parms[7] #define minQuotum parms[8] #define maxStorage parms[9] #define respirationRate parms[10] #define pResp parms[11] #define catabolismRate parms[12] #define dilutionRate parms[13] #define rNCProtein parms[14] #define inputDIN parms[15] #define rChlN parms[16] #define parMean parms[17] #define dayLength parms[18] static double forcs[1]; #define Light forcs[0] #define DIN y[0] #define PROTEIN y[1] #define RESERVE y[2] #define LMW y[3] #define dDIN ydot[0] #define dPROTEIN ydot[1] #define dRESERVE ydot[2] #define dLMW ydot[3] #define PAR out[0] #define TotalN out[1] #define PhotoSynthesis out[2] #define NCratio out[3] #define ChlCratio out[4] #define Chlorophyll out[5] /*======================================================================= c======================================================================= c Model initialisation c======================================================================= c======================================================================= c======================================================================= c Initialise parameter common block c======================================================================= */ void iniaqua(void (* odeparms)(int *, double *)) { int N=19; odeparms(&N, parms); } /* c======================================================================= c Initialise forcing function common block c======================================================================= */ void initaqforc(void (* odeforc)(int *, double *)) { int N=1; odeforc(&N, forcs); } /* c======================================================================= c Algal dynamics - light an on-off function c======================================================================= */ void aquaphy (int *neq, double *t, double *y, double *ydot, double *out, int *ip) { double PhytoC,PhytoN,PartLMW,Limfac,Exudation,MonodQuotum,hourofday, ProteinSynthesis,Storage,Respiration,Catabolism; if(ip[0] < 6) error("nout should at least be 6"); /* PAR, on-off function depending on the hour within a day*/ hourofday = fmod(*t,24.0); if (hourofday < dayLength) PAR = parMean; else PAR = 0.0; /* the output variables - all components contain carbon only proteins contain nitrogen */ PhytoC = PROTEIN + RESERVE + LMW; PhytoN = PROTEIN * rNCProtein; NCratio = PhytoN / PhytoC; Chlorophyll = PhytoN * rChlN; TotalN = PhytoN + DIN; ChlCratio = Chlorophyll / PhytoC; /* the rates, in mmol/hr */ PartLMW = LMW / PhytoC; Limfac = fmin(1.0,(maxpLMW -PartLMW)/(maxpLMW-minpLMW)); Limfac = fmax(0.0,Limfac); PhotoSynthesis = maxPhotoSynt*Limfac * (1.0-exp(alpha*PAR/maxPhotoSynt)) * PROTEIN; Exudation = pExudation * PhotoSynthesis; MonodQuotum = fmax(0.0,LMW / PROTEIN - minQuotum); ProteinSynthesis= maxProteinSynt*MonodQuotum * DIN / (DIN+ksDIN) * PROTEIN; Storage = maxStorage *MonodQuotum * PROTEIN; Respiration = respirationRate * LMW + pResp * ProteinSynthesis; Catabolism = catabolismRate * RESERVE; /* the rates of change of state variables; includes dilution effects (last term) */ dLMW = PhotoSynthesis + Catabolism - Exudation - Storage - Respiration - ProteinSynthesis - dilutionRate * LMW; dRESERVE = Storage - Catabolism - dilutionRate * RESERVE; dPROTEIN = ProteinSynthesis - dilutionRate * PROTEIN; dDIN = -ProteinSynthesis * rNCProtein - dilutionRate * (DIN - inputDIN); } /* Algal dynamics with forcings c======================================================================= */ void aquaphyforc (int *neq, double *t, double *y, double *ydot, double *out, int *ip) { double PhytoC,PhytoN,PartLMW,Limfac,Exudation,MonodQuotum, ProteinSynthesis,Storage,Respiration,Catabolism; if(ip[0] < 6) error("nout should at least be 6"); PAR = Light; /* the output variables - all components contain carbon only proteins contain nitrogen */ PhytoC = PROTEIN + RESERVE + LMW; PhytoN = PROTEIN * rNCProtein; NCratio = PhytoN / PhytoC; Chlorophyll = PhytoN * rChlN; TotalN = PhytoN + DIN; ChlCratio = Chlorophyll / PhytoC; /* the rates, in mmol/hr */ PartLMW = LMW / PhytoC; Limfac = fmin(1.0,(maxpLMW -PartLMW)/(maxpLMW-minpLMW)); Limfac = fmax(0.0,Limfac); PhotoSynthesis = maxPhotoSynt*Limfac * (1.0-exp(alpha*PAR/maxPhotoSynt)) * PROTEIN; Exudation = pExudation * PhotoSynthesis; MonodQuotum = fmax(0.0,LMW / PROTEIN - minQuotum); ProteinSynthesis= maxProteinSynt*MonodQuotum * DIN / (DIN+ksDIN) * PROTEIN; Storage = maxStorage *MonodQuotum * PROTEIN; Respiration = respirationRate * LMW + pResp * ProteinSynthesis; Catabolism = catabolismRate * RESERVE; /* the rates of change of state variables; includes dilution effects (last term) */ dLMW = PhotoSynthesis + Catabolism - Exudation - Storage - Respiration - ProteinSynthesis - dilutionRate * LMW; dRESERVE = Storage - Catabolism - dilutionRate * RESERVE; dPROTEIN = ProteinSynthesis - dilutionRate * PROTEIN; dDIN = -ProteinSynthesis * rNCProtein - dilutionRate * (DIN - inputDIN); } deSolve/src/zvode.h0000754000175100001440000000321113131751003013751 0ustar hornikusers#include #include /* global variables */ typedef void C_zderiv_func_type (int *, double *, Rcomplex *,Rcomplex *, Rcomplex *, int *); C_zderiv_func_type *DLL_cderiv_func; SEXP cY; /* livermore solver globals */ extern SEXP cvode_deriv_func; extern SEXP cvode_jac_func; extern SEXP vode_envir; Rcomplex *zout; void initOutComplex(int isDll, int *nout, int *ntot, int neq, SEXP nOut, SEXP Rpar, SEXP Ipar) { int j, lrpar, lipar; * nout = INTEGER(nOut)[0]; /* number of output variables */ if (isDll) /* function is a dll */ { if (*nout > 0) isOut = 1; *ntot = neq + *nout; /* length of yout */ lrpar = *nout + LENGTH(Rpar); /* length of rpar; LENGTH(Rpar) is always >0 */ lipar = 3 + LENGTH(Ipar); /* length of ipar */ } else /* function is not a dll */ { isOut = 0; *ntot = neq; lipar = 1; lrpar = 1; } zout = (Rcomplex *) R_alloc(lrpar, sizeof(Rcomplex)); ipar = (int *) R_alloc(lipar, sizeof(int)); if (isDll ==1) { ipar[0] = *nout; /* first 3 elements of ipar are special */ ipar[1] = lrpar; ipar[2] = lipar; /* other elements of ipar are set in R-function lsodx via argument *ipar* */ for (j = 0; j < LENGTH(Ipar);j++) ipar[j+3] = INTEGER(Ipar)[j]; /* first nout elements of rpar reserved for output variables other elements are set in R-function zvode via argument *rpar* */ // for (j = 0; j < nout; j++) zout[j] = 0+0i; for (j = 0; j < LENGTH(Rpar);j++) zout[*nout+j] = COMPLEX(Rpar)[j]; } } deSolve/src/opkda1.f0000754000175100001440000106346213131751003014016 0ustar hornikusers*DECK DUMACH DOUBLE PRECISION FUNCTION DUMACH () C***BEGIN PROLOGUE DUMACH C***PURPOSE Compute the unit roundoff of the machine. C***CATEGORY R1 C***TYPE DOUBLE PRECISION (RUMACH-S, DUMACH-D) C***KEYWORDS MACHINE CONSTANTS C***AUTHOR Hindmarsh, Alan C., (LLNL) C***DESCRIPTION C *Usage: C DOUBLE PRECISION A, DUMACH C A = DUMACH() C C *Function Return Values: C A : the unit roundoff of the machine. C C *Description: C The unit roundoff is defined as the smallest positive machine C number u such that 1.0 + u .ne. 1.0. This is computed by DUMACH C in a machine-independent manner. C C***REFERENCES (NONE) C***ROUTINES CALLED DUMSUM C***REVISION HISTORY (YYYYMMDD) C 19930216 DATE WRITTEN C 19930818 Added SLATEC-format prologue. (FNF) C 20030707 Added DUMSUM to force normal storage of COMP. (ACH) C***END PROLOGUE DUMACH C DOUBLE PRECISION U, COMP C***FIRST EXECUTABLE STATEMENT DUMACH U = 1.0D0 10 U = U*0.5D0 CALL DUMSUM(1.0D0, U, COMP) IF (COMP .NE. 1.0D0) GO TO 10 DUMACH = U*2.0D0 RETURN C----------------------- End of Function DUMACH ------------------------ END SUBROUTINE DUMSUM(A,B,C) C Routine to force normal storing of A + B, for DUMACH. DOUBLE PRECISION A, B, C C = A + B RETURN END *DECK DCFODE SUBROUTINE DCFODE (METH, ELCO, TESCO) C***BEGIN PROLOGUE DCFODE C***SUBSIDIARY C***PURPOSE Set ODE integrator coefficients. C***TYPE DOUBLE PRECISION (SCFODE-S, DCFODE-D) C***AUTHOR Hindmarsh, Alan C., (LLNL) C***DESCRIPTION C C DCFODE is called by the integrator routine to set coefficients C needed there. The coefficients for the current method, as C given by the value of METH, are set for all orders and saved. C The maximum order assumed here is 12 if METH = 1 and 5 if METH = 2. C (A smaller value of the maximum order is also allowed.) C DCFODE is called once at the beginning of the problem, C and is not called again unless and until METH is changed. C C The ELCO array contains the basic method coefficients. C The coefficients el(i), 1 .le. i .le. nq+1, for the method of C order nq are stored in ELCO(i,nq). They are given by a genetrating C polynomial, i.e., C l(x) = el(1) + el(2)*x + ... + el(nq+1)*x**nq. C For the implicit Adams methods, l(x) is given by C dl/dx = (x+1)*(x+2)*...*(x+nq-1)/factorial(nq-1), l(-1) = 0. C For the BDF methods, l(x) is given by C l(x) = (x+1)*(x+2)* ... *(x+nq)/K, C where K = factorial(nq)*(1 + 1/2 + ... + 1/nq). C C The TESCO array contains test constants used for the C local error test and the selection of step size and/or order. C At order nq, TESCO(k,nq) is used for the selection of step C size at order nq - 1 if k = 1, at order nq if k = 2, and at order C nq + 1 if k = 3. C C***SEE ALSO DLSODE C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 791129 DATE WRITTEN C 890501 Modified prologue to SLATEC/LDOC format. (FNF) C 890503 Minor cosmetic changes. (FNF) C 930809 Renamed to allow single/double precision versions. (ACH) C***END PROLOGUE DCFODE C**End INTEGER METH INTEGER I, IB, NQ, NQM1, NQP1 DOUBLE PRECISION ELCO, TESCO DOUBLE PRECISION AGAMQ, FNQ, FNQM1, PC, PINT, RAGQ, 1 RQFAC, RQ1FAC, TSIGN, XPIN DIMENSION ELCO(13,12), TESCO(3,12) DIMENSION PC(12) C C***FIRST EXECUTABLE STATEMENT DCFODE IF (METH .EQ. 1) THEN GOTO 100 ELSE IF (METH .EQ. 2) THEN GOTO 200 ENDIF C GO TO (100, 200), METH C 100 ELCO(1,1) = 1.0D0 ELCO(2,1) = 1.0D0 TESCO(1,1) = 0.0D0 TESCO(2,1) = 2.0D0 TESCO(1,2) = 1.0D0 TESCO(3,12) = 0.0D0 PC(1) = 1.0D0 RQFAC = 1.0D0 DO 140 NQ = 2,12 C----------------------------------------------------------------------- C The PC array will contain the coefficients of the polynomial C p(x) = (x+1)*(x+2)*...*(x+nq-1). C Initially, p(x) = 1. C----------------------------------------------------------------------- RQ1FAC = RQFAC RQFAC = RQFAC/NQ NQM1 = NQ - 1 FNQM1 = NQM1 NQP1 = NQ + 1 C Form coefficients of p(x)*(x+nq-1). ---------------------------------- PC(NQ) = 0.0D0 DO 110 IB = 1,NQM1 I = NQP1 - IB PC(I) = PC(I-1) + FNQM1*PC(I) 110 CONTINUE PC(1) = FNQM1*PC(1) C Compute integral, -1 to 0, of p(x) and x*p(x). ----------------------- PINT = PC(1) XPIN = PC(1)/2.0D0 TSIGN = 1.0D0 DO 120 I = 2,NQ TSIGN = -TSIGN PINT = PINT + TSIGN*PC(I)/I XPIN = XPIN + TSIGN*PC(I)/(I+1) 120 CONTINUE C Store coefficients in ELCO and TESCO. -------------------------------- ELCO(1,NQ) = PINT*RQ1FAC ELCO(2,NQ) = 1.0D0 DO 130 I = 2,NQ ELCO(I+1,NQ) = RQ1FAC*PC(I)/I 130 CONTINUE AGAMQ = RQFAC*XPIN RAGQ = 1.0D0/AGAMQ TESCO(2,NQ) = RAGQ IF (NQ .LT. 12) TESCO(1,NQP1) = RAGQ*RQFAC/NQP1 TESCO(3,NQM1) = RAGQ 140 CONTINUE RETURN C 200 PC(1) = 1.0D0 RQ1FAC = 1.0D0 DO 230 NQ = 1,5 C----------------------------------------------------------------------- C The PC array will contain the coefficients of the polynomial C p(x) = (x+1)*(x+2)*...*(x+nq). C Initially, p(x) = 1. C----------------------------------------------------------------------- FNQ = NQ NQP1 = NQ + 1 C Form coefficients of p(x)*(x+nq). ------------------------------------ PC(NQP1) = 0.0D0 DO 210 IB = 1,NQ I = NQ + 2 - IB PC(I) = PC(I-1) + FNQ*PC(I) 210 CONTINUE PC(1) = FNQ*PC(1) C Store coefficients in ELCO and TESCO. -------------------------------- DO 220 I = 1,NQP1 ELCO(I,NQ) = PC(I)/PC(2) 220 CONTINUE ELCO(2,NQ) = 1.0D0 TESCO(1,NQ) = RQ1FAC TESCO(2,NQ) = NQP1/ELCO(1,NQ) TESCO(3,NQ) = (NQ+2)/ELCO(1,NQ) RQ1FAC = RQ1FAC/FNQ 230 CONTINUE RETURN C----------------------- END OF SUBROUTINE DCFODE ---------------------- END *DECK DINTDY SUBROUTINE DINTDY (T, K, YH, NYH, DKY, IFLAG) C***BEGIN PROLOGUE DINTDY C***SUBSIDIARY C***PURPOSE Interpolate solution derivatives. C***TYPE DOUBLE PRECISION (SINTDY-S, DINTDY-D) C***AUTHOR Hindmarsh, Alan C., (LLNL) C***DESCRIPTION C C DINTDY computes interpolated values of the K-th derivative of the C dependent variable vector y, and stores it in DKY. This routine C is called within the package with K = 0 and T = TOUT, but may C also be called by the user for any K up to the current order. C (See detailed instructions in the usage documentation.) C C The computed values in DKY are gotten by interpolation using the C Nordsieck history array YH. This array corresponds uniquely to a C vector-valued polynomial of degree NQCUR or less, and DKY is set C to the K-th derivative of this polynomial at T. C The formula for DKY is: C q C DKY(i) = sum c(j,K) * (T - tn)**(j-K) * h**(-j) * YH(i,j+1) C j=K C where c(j,K) = j*(j-1)*...*(j-K+1), q = NQCUR, tn = TCUR, h = HCUR. C The quantities nq = NQCUR, l = nq+1, N = NEQ, tn, and h are C communicated by COMMON. The above sum is done in reverse order. C IFLAG is returned negative if either K or T is out of bounds. C C***SEE ALSO DLSODE C***ROUTINES CALLED XERRWD C***COMMON BLOCKS DLS001 C***REVISION HISTORY (YYMMDD) C 791129 DATE WRITTEN C 890501 Modified prologue to SLATEC/LDOC format. (FNF) C 890503 Minor cosmetic changes. (FNF) C 930809 Renamed to allow single/double precision versions. (ACH) C 010418 Reduced size of Common block /DLS001/. (ACH) C 031105 Restored 'own' variables to Common block /DLS001/, to C enable interrupt/restart feature. (ACH) C 050427 Corrected roundoff decrement in TP. (ACH) C***END PROLOGUE DINTDY C**End INTEGER K, NYH, IFLAG DOUBLE PRECISION T, YH, DKY DIMENSION YH(NYH,*), DKY(*) INTEGER IOWND, IOWNS, 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU DOUBLE PRECISION ROWNS, 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND COMMON /DLS001/ ROWNS(209), 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 2 IOWND(6), IOWNS(6), 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU INTEGER I, IC, J, JB, JB2, JJ, JJ1, JP1 DOUBLE PRECISION C, R, S, TP CHARACTER(LEN=80) MSG C C***FIRST EXECUTABLE STATEMENT DINTDY IFLAG = 0 IF (K .LT. 0 .OR. K .GT. NQ) GO TO 80 TP = TN - HU - 100.0D0*UROUND*SIGN(ABS(TN) + ABS(HU), HU) IF ((T-TP)*(T-TN) .GT. 0.0D0) GO TO 90 C S = (T - TN)/H IC = 1 IF (K .EQ. 0) GO TO 15 JJ1 = L - K DO 10 JJ = JJ1,NQ IC = IC*JJ 10 CONTINUE 15 C = IC DO 20 I = 1,N DKY(I) = C*YH(I,L) 20 CONTINUE IF (K .EQ. NQ) GO TO 55 JB2 = NQ - K DO 50 JB = 1,JB2 J = NQ - JB JP1 = J + 1 IC = 1 IF (K .EQ. 0) GO TO 35 JJ1 = JP1 - K DO 30 JJ = JJ1,J IC = IC*JJ 30 CONTINUE 35 C = IC DO 40 I = 1,N DKY(I) = C*YH(I,JP1) + S*DKY(I) 40 CONTINUE 50 CONTINUE IF (K .EQ. 0) RETURN 55 R = H**(-K) DO 60 I = 1,N DKY(I) = R*DKY(I) 60 CONTINUE RETURN C 80 MSG = 'DINTDY- K (=I1) illegal ' CALL XERRWD (MSG, 30, 51, 0, 1, K, 0, 0, 0.0D0, 0.0D0) IFLAG = -1 RETURN 90 MSG = 'DINTDY- T (=R1) illegal ' CALL XERRWD (MSG, 30, 52, 0, 0, 0, 0, 1, T, 0.0D0) MSG=' T not in interval TCUR - HU (= R1) to TCUR (=R2) ' CALL XERRWD (MSG, 60, 52, 0, 0, 0, 0, 2, TP, TN) IFLAG = -2 RETURN C----------------------- END OF SUBROUTINE DINTDY ---------------------- END *DECK DPREPJ SUBROUTINE DPREPJ (NEQ, Y, YH, NYH, EWT, FTEM, SAVF, WM, IWM, 1 F, JAC,rpar,ipar) C***BEGIN PROLOGUE DPREPJ C***SUBSIDIARY C***PURPOSE Compute and process Newton iteration matrix. C***TYPE DOUBLE PRECISION (SPREPJ-S, DPREPJ-D) C***AUTHOR Hindmarsh, Alan C., (LLNL) C***DESCRIPTION C C DPREPJ is called by DSTODE to compute and process the matrix C P = I - h*el(1)*J , where J is an approximation to the Jacobian. C Here J is computed by the user-supplied routine JAC if C MITER = 1 or 4, or by finite differencing if MITER = 2, 3, or 5. C If MITER = 3, a diagonal approximation to J is used. C J is stored in WM and replaced by P. If MITER .ne. 3, P is then C subjected to LU decomposition in preparation for later solution C of linear systems with P as coefficient matrix. This is done C by DGEFA if MITER = 1 or 2, and by DGBFA if MITER = 4 or 5. C C In addition to variables described in DSTODE and DLSODE prologues, C communication with DPREPJ uses the following: C Y = array containing predicted values on entry. C FTEM = work array of length N (ACOR in DSTODE). C SAVF = array containing f evaluated at predicted y. C WM = real work space for matrices. On output it contains the C inverse diagonal matrix if MITER = 3 and the LU decomposition C of P if MITER is 1, 2 , 4, or 5. C Storage of matrix elements starts at WM(3). C WM also contains the following matrix-related data: C WM(1) = SQRT(UROUND), used in numerical Jacobian increments. C WM(2) = H*EL0, saved for later use if MITER = 3. C IWM = integer work space containing pivot information, starting at C IWM(21), if MITER is 1, 2, 4, or 5. IWM also contains band C parameters ML = IWM(1) and MU = IWM(2) if MITER is 4 or 5. C EL0 = EL(1) (input). C IERPJ = output error flag, = 0 if no trouble, .gt. 0 if C P matrix found to be singular. C JCUR = output flag = 1 to indicate that the Jacobian matrix C (or approximation) is now current. C This routine also uses the COMMON variables EL0, H, TN, UROUND, C MITER, N, NFE, and NJE. C C***SEE ALSO DLSODE C***ROUTINES CALLED DGBFA, DGEFA, DVNORM C***COMMON BLOCKS DLS001 C***REVISION HISTORY (YYMMDD) C 791129 DATE WRITTEN C 890501 Modified prologue to SLATEC/LDOC format. (FNF) C 890504 Minor cosmetic changes. (FNF) C 930809 Renamed to allow single/double precision versions. (ACH) C 010418 Reduced size of Common block /DLS001/. (ACH) C 031105 Restored 'own' variables to Common block /DLS001/, to C enable interrupt/restart feature. (ACH) C***END PROLOGUE DPREPJ C**End EXTERNAL F, JAC CKS: added rpar,ipar integer ipar(*) double precision rpar(*) INTEGER NEQ, NYH, IWM DOUBLE PRECISION Y, YH, EWT, FTEM, SAVF, WM DIMENSION NEQ(*), Y(*), YH(NYH,*), EWT(*), FTEM(*), SAVF(*), 1 WM(*), IWM(*) INTEGER IOWND, IOWNS, 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU DOUBLE PRECISION ROWNS, 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND COMMON /DLS001/ ROWNS(209), 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 2 IOWND(6), IOWNS(6), 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU INTEGER I, I1, I2, IER, II, J, J1, JJ, LENP, 1 MBA, MBAND, MEB1, MEBAND, ML, ML3, MU, NP1 DOUBLE PRECISION CON, DI, FAC, HL0, R, R0, SRUR, YI, YJ, YJJ, 1 DVNORM C C***FIRST EXECUTABLE STATEMENT DPREPJ NJE = NJE + 1 IERPJ = 0 JCUR = 1 HL0 = H*EL0 IF (MITER .EQ. 1) THEN GOTO 100 ELSE IF (MITER .EQ. 2) THEN GOTO 200 ELSE IF (MITER .EQ. 3) THEN GOTO 300 ELSE IF (MITER .EQ. 4) THEN GOTO 400 ELSE IF (MITER .EQ. 5) THEN GOTO 500 ENDIF C GO TO (100, 200, 300, 400, 500), MITER C If MITER = 1, call JAC and multiply by scalar. ----------------------- 100 LENP = N*N DO 110 I = 1,LENP WM(I+2) = 0.0D0 110 CONTINUE CKS CALL JAC (NEQ, TN, Y, 0, 0, WM(3), N,RPAR,IPAR) CON = -HL0 DO 120 I = 1,LENP WM(I+2) = WM(I+2)*CON 120 CONTINUE GO TO 240 C If MITER = 2, make N calls to F to approximate J. -------------------- 200 FAC = DVNORM (N, SAVF, EWT) R0 = 1000.0D0*ABS(H)*UROUND*N*FAC IF (R0 .EQ. 0.0D0) R0 = 1.0D0 SRUR = WM(1) J1 = 2 DO 230 J = 1,N YJ = Y(J) R = MAX(SRUR*ABS(YJ),R0/EWT(J)) Y(J) = Y(J) + R FAC = -HL0/R CKS CALL F (NEQ, TN, Y, FTEM, rpar, ipar) DO 220 I = 1,N WM(I+J1) = (FTEM(I) - SAVF(I))*FAC 220 CONTINUE Y(J) = YJ J1 = J1 + N 230 CONTINUE NFE = NFE + N C Add identity matrix. ------------------------------------------------- 240 J = 3 NP1 = N + 1 DO 250 I = 1,N WM(J) = WM(J) + 1.0D0 J = J + NP1 250 CONTINUE C Do LU decomposition on P. -------------------------------------------- CALL DGEFA (WM(3), N, N, IWM(21), IER) IF (IER .NE. 0) IERPJ = 1 RETURN C If MITER = 3, construct a diagonal approximation to J and P. --------- 300 WM(2) = HL0 R = EL0*0.1D0 DO 310 I = 1,N Y(I) = Y(I) + R*(H*SAVF(I) - YH(I,2)) 310 CONTINUE CKS CALL F (NEQ, TN, Y, WM(3), rpar, ipar) NFE = NFE + 1 DO 320 I = 1,N R0 = H*SAVF(I) - YH(I,2) DI = 0.1D0*R0 - H*(WM(I+2) - SAVF(I)) WM(I+2) = 1.0D0 IF (ABS(R0) .LT. UROUND/EWT(I)) GO TO 320 IF (ABS(DI) .EQ. 0.0D0) GO TO 330 WM(I+2) = 0.1D0*R0/DI 320 CONTINUE RETURN 330 IERPJ = 1 RETURN C If MITER = 4, call JAC and multiply by scalar. ----------------------- 400 ML = IWM(1) MU = IWM(2) ML3 = ML + 3 MBAND = ML + MU + 1 MEBAND = MBAND + ML LENP = MEBAND*N DO 410 I = 1,LENP WM(I+2) = 0.0D0 410 CONTINUE CKS CALL JAC (NEQ, TN, Y, ML, MU, WM(ML3), MEBAND,RPAR,IPAR) CON = -HL0 DO 420 I = 1,LENP WM(I+2) = WM(I+2)*CON 420 CONTINUE GO TO 570 C If MITER = 5, make MBAND calls to F to approximate J. ---------------- 500 ML = IWM(1) MU = IWM(2) MBAND = ML + MU + 1 MBA = MIN(MBAND,N) MEBAND = MBAND + ML MEB1 = MEBAND - 1 SRUR = WM(1) FAC = DVNORM (N, SAVF, EWT) R0 = 1000.0D0*ABS(H)*UROUND*N*FAC IF (R0 .EQ. 0.0D0) R0 = 1.0D0 DO 560 J = 1,MBA DO 530 I = J,N,MBAND YI = Y(I) R = MAX(SRUR*ABS(YI),R0/EWT(I)) Y(I) = Y(I) + R 530 CONTINUE CKS CALL F (NEQ, TN, Y, FTEM, rpar, ipar) DO 550 JJ = J,N,MBAND Y(JJ) = YH(JJ,1) YJJ = Y(JJ) R = MAX(SRUR*ABS(YJJ),R0/EWT(JJ)) FAC = -HL0/R I1 = MAX(JJ-MU,1) I2 = MIN(JJ+ML,N) II = JJ*MEB1 - ML + 2 DO 540 I = I1,I2 WM(II+I) = (FTEM(I) - SAVF(I))*FAC 540 CONTINUE 550 CONTINUE 560 CONTINUE NFE = NFE + MBA C Add identity matrix. ------------------------------------------------- 570 II = MBAND + 2 DO 580 I = 1,N WM(II) = WM(II) + 1.0D0 II = II + MEBAND 580 CONTINUE C Do LU decomposition of P. -------------------------------------------- CALL DGBFA (WM(3), MEBAND, N, ML, MU, IWM(21), IER) IF (IER .NE. 0) IERPJ = 1 RETURN C----------------------- END OF SUBROUTINE DPREPJ ---------------------- END *DECK DSOLSY SUBROUTINE DSOLSY (WM, IWM, X, TEM) C***BEGIN PROLOGUE DSOLSY C***SUBSIDIARY C***PURPOSE ODEPACK linear system solver. C***TYPE DOUBLE PRECISION (SSOLSY-S, DSOLSY-D) C***AUTHOR Hindmarsh, Alan C., (LLNL) C***DESCRIPTION C C This routine manages the solution of the linear system arising from C a chord iteration. It is called if MITER .ne. 0. C If MITER is 1 or 2, it calls DGESL to accomplish this. C If MITER = 3 it updates the coefficient h*EL0 in the diagonal C matrix, and then computes the solution. C If MITER is 4 or 5, it calls DGBSL. C Communication with DSOLSY uses the following variables: C WM = real work space containing the inverse diagonal matrix if C MITER = 3 and the LU decomposition of the matrix otherwise. C Storage of matrix elements starts at WM(3). C WM also contains the following matrix-related data: C WM(1) = SQRT(UROUND) (not used here), C WM(2) = HL0, the previous value of h*EL0, used if MITER = 3. C IWM = integer work space containing pivot information, starting at C IWM(21), if MITER is 1, 2, 4, or 5. IWM also contains band C parameters ML = IWM(1) and MU = IWM(2) if MITER is 4 or 5. C X = the right-hand side vector on input, and the solution vector C on output, of length N. C TEM = vector of work space of length N, not used in this version. C IERSL = output flag (in COMMON). IERSL = 0 if no trouble occurred. C IERSL = 1 if a singular matrix arose with MITER = 3. C This routine also uses the COMMON variables EL0, H, MITER, and N. C C***SEE ALSO DLSODE C***ROUTINES CALLED DGBSL, DGESL C***COMMON BLOCKS DLS001 C***REVISION HISTORY (YYMMDD) C 791129 DATE WRITTEN C 890501 Modified prologue to SLATEC/LDOC format. (FNF) C 890503 Minor cosmetic changes. (FNF) C 930809 Renamed to allow single/double precision versions. (ACH) C 010418 Reduced size of Common block /DLS001/. (ACH) C 031105 Restored 'own' variables to Common block /DLS001/, to C enable interrupt/restart feature. (ACH) C***END PROLOGUE DSOLSY C**End INTEGER IWM DOUBLE PRECISION WM, X, TEM DIMENSION WM(*), IWM(*), X(*), TEM(*) INTEGER IOWND, IOWNS, 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU DOUBLE PRECISION ROWNS, 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND COMMON /DLS001/ ROWNS(209), 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 2 IOWND(6), IOWNS(6), 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU INTEGER I, MEBAND, ML, MU DOUBLE PRECISION DI, HL0, PHL0, R C C***FIRST EXECUTABLE STATEMENT DSOLSY IERSL = 0 IF (MITER .EQ. 1 .OR. MITER .EQ. 2) THEN GOTO 100 ELSE IF (MITER .EQ. 3) THEN GOTO 300 ELSE IF (MITER .EQ. 4 .OR. MITER .EQ. 5) THEN GOTO 400 ENDIF C GO TO (100, 100, 300, 400, 400), MITER 100 CALL DGESL (WM(3), N, N, IWM(21), X, 0) RETURN C 300 PHL0 = WM(2) HL0 = H*EL0 WM(2) = HL0 IF (HL0 .EQ. PHL0) GO TO 330 R = HL0/PHL0 DO 320 I = 1,N DI = 1.0D0 - R*(1.0D0 - 1.0D0/WM(I+2)) IF (ABS(DI) .EQ. 0.0D0) GO TO 390 WM(I+2) = 1.0D0/DI 320 CONTINUE 330 DO 340 I = 1,N X(I) = WM(I+2)*X(I) 340 CONTINUE RETURN 390 IERSL = 1 RETURN C 400 ML = IWM(1) MU = IWM(2) MEBAND = 2*ML + MU + 1 CALL DGBSL (WM(3), MEBAND, N, ML, MU, IWM(21), X, 0) RETURN C----------------------- END OF SUBROUTINE DSOLSY ---------------------- END *DECK DSRCOM *DECK DSTODE SUBROUTINE DSTODE (NEQ, Y, YH, NYH, YH1, EWT, SAVF, ACOR, 1 WM, IWM, F, JAC, PJAC, SLVS,RPAR,IPAR) C***BEGIN PROLOGUE DSTODE C***SUBSIDIARY C***PURPOSE Performs one step of an ODEPACK integration. C***TYPE DOUBLE PRECISION (SSTODE-S, DSTODE-D) C***AUTHOR Hindmarsh, Alan C., (LLNL) C***DESCRIPTION C C DSTODE performs one step of the integration of an initial value C problem for a system of ordinary differential equations. C Note: DSTODE is independent of the value of the iteration method C indicator MITER, when this is .ne. 0, and hence is independent C of the type of chord method used, or the Jacobian structure. C Communication with DSTODE is done with the following variables: C C NEQ = integer array containing problem size in NEQ(1), and C passed as the NEQ argument in all calls to F and JAC. C Y = an array of length .ge. N used as the Y argument in C all calls to F and JAC. C YH = an NYH by LMAX array containing the dependent variables C and their approximate scaled derivatives, where C LMAX = MAXORD + 1. YH(i,j+1) contains the approximate C j-th derivative of y(i), scaled by h**j/factorial(j) C (j = 0,1,...,NQ). on entry for the first step, the first C two columns of YH must be set from the initial values. C NYH = a constant integer .ge. N, the first dimension of YH. C YH1 = a one-dimensional array occupying the same space as YH. C EWT = an array of length N containing multiplicative weights C for local error measurements. Local errors in Y(i) are C compared to 1.0/EWT(i) in various error tests. C SAVF = an array of working storage, of length N. C Also used for input of YH(*,MAXORD+2) when JSTART = -1 C and MAXORD .lt. the current order NQ. C ACOR = a work array of length N, used for the accumulated C corrections. On a successful return, ACOR(i) contains C the estimated one-step local error in Y(i). C WM,IWM = real and integer work arrays associated with matrix C operations in chord iteration (MITER .ne. 0). C PJAC = name of routine to evaluate and preprocess Jacobian matrix C and P = I - h*el0*JAC, if a chord method is being used. C SLVS = name of routine to solve linear system in chord iteration. C CCMAX = maximum relative change in h*el0 before PJAC is called. C H = the step size to be attempted on the next step. C H is altered by the error control algorithm during the C problem. H can be either positive or negative, but its C sign must remain constant throughout the problem. C HMIN = the minimum absolute value of the step size h to be used. C HMXI = inverse of the maximum absolute value of h to be used. C HMXI = 0.0 is allowed and corresponds to an infinite hmax. C HMIN and HMXI may be changed at any time, but will not C take effect until the next change of h is considered. C TN = the independent variable. TN is updated on each step taken. C JSTART = an integer used for input only, with the following C values and meanings: C 0 perform the first step. C .gt.0 take a new step continuing from the last. C -1 take the next step with a new value of H, MAXORD, C N, METH, MITER, and/or matrix parameters. C -2 take the next step with a new value of H, C but with other inputs unchanged. C On return, JSTART is set to 1 to facilitate continuation. C KFLAG = a completion code with the following meanings: C 0 the step was succesful. C -1 the requested error could not be achieved. C -2 corrector convergence could not be achieved. C -3 fatal error in PJAC or SLVS. C A return with KFLAG = -1 or -2 means either C abs(H) = HMIN or 10 consecutive failures occurred. C On a return with KFLAG negative, the values of TN and C the YH array are as of the beginning of the last C step, and H is the last step size attempted. C MAXORD = the maximum order of integration method to be allowed. C MAXCOR = the maximum number of corrector iterations allowed. C MSBP = maximum number of steps between PJAC calls (MITER .gt. 0). C MXNCF = maximum number of convergence failures allowed. C METH/MITER = the method flags. See description in driver. C N = the number of first-order differential equations. C The values of CCMAX, H, HMIN, HMXI, TN, JSTART, KFLAG, MAXORD, C MAXCOR, MSBP, MXNCF, METH, MITER, and N are communicated via COMMON. C C***SEE ALSO DLSODE C***ROUTINES CALLED DCFODE, DVNORM C***COMMON BLOCKS DLS001 C***REVISION HISTORY (YYMMDD) C 791129 DATE WRITTEN C 890501 Modified prologue to SLATEC/LDOC format. (FNF) C 890503 Minor cosmetic changes. (FNF) C 930809 Renamed to allow single/double precision versions. (ACH) C 010418 Reduced size of Common block /DLS001/. (ACH) C 031105 Restored 'own' variables to Common block /DLS001/, to C enable interrupt/restart feature. (ACH) C***END PROLOGUE DSTODE C**End EXTERNAL F, JAC, PJAC, SLVS INTEGER NEQ, NYH, IWM CKS: added rpar,ipar integer ipar(*) double precision rpar(*) DOUBLE PRECISION Y, YH, YH1, EWT, SAVF, ACOR, WM DIMENSION NEQ(*), Y(*), YH(NYH,*), YH1(*), EWT(*), SAVF(*), 1 ACOR(*), WM(*), IWM(*) INTEGER IOWND, IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU INTEGER I, I1, IREDO, IRET, J, JB, M, NCF, NEWQ DOUBLE PRECISION CONIT, CRATE, EL, ELCO, HOLD, RMAX, TESCO, 2 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND DOUBLE PRECISION DCON, DDN, DEL, DELP, DSM, DUP, EXDN, EXSM, EXUP, 1 R, RH, RHDN, RHSM, RHUP, TOLD, DVNORM COMMON /DLS001/ CONIT, CRATE, EL(13), ELCO(13,12), 1 HOLD, RMAX, TESCO(3,12), 2 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 3 IOWND(6), IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU C C***FIRST EXECUTABLE STATEMENT DSTODE KFLAG = 0 TOLD = TN NCF = 0 IERPJ = 0 IERSL = 0 JCUR = 0 ICF = 0 DELP = 0.0D0 IF (JSTART .GT. 0) GO TO 200 IF (JSTART .EQ. -1) GO TO 100 IF (JSTART .EQ. -2) GO TO 160 C----------------------------------------------------------------------- C On the first call, the order is set to 1, and other variables are C initialized. RMAX is the maximum ratio by which H can be increased C in a single step. It is initially 1.E4 to compensate for the small C initial H, but then is normally equal to 10. If a failure C occurs (in corrector convergence or error test), RMAX is set to 2 C for the next increase. C----------------------------------------------------------------------- LMAX = MAXORD + 1 NQ = 1 L = 2 IALTH = 2 RMAX = 10000.0D0 RC = 0.0D0 EL0 = 1.0D0 CRATE = 0.7D0 HOLD = H MEO = METH NSLP = 0 IPUP = MITER IRET = 3 GO TO 140 C----------------------------------------------------------------------- C The following block handles preliminaries needed when JSTART = -1. C IPUP is set to MITER to force a matrix update. C If an order increase is about to be considered (IALTH = 1), C IALTH is reset to 2 to postpone consideration one more step. C If the caller has changed METH, DCFODE is called to reset C the coefficients of the method. C If the caller has changed MAXORD to a value less than the current C order NQ, NQ is reduced to MAXORD, and a new H chosen accordingly. C If H is to be changed, YH must be rescaled. C If H or METH is being changed, IALTH is reset to L = NQ + 1 C to prevent further changes in H for that many steps. C----------------------------------------------------------------------- 100 IPUP = MITER LMAX = MAXORD + 1 IF (IALTH .EQ. 1) IALTH = 2 IF (METH .EQ. MEO) GO TO 110 CALL DCFODE (METH, ELCO, TESCO) MEO = METH IF (NQ .GT. MAXORD) GO TO 120 IALTH = L IRET = 1 GO TO 150 110 IF (NQ .LE. MAXORD) GO TO 160 120 NQ = MAXORD L = LMAX DO 125 I = 1,L EL(I) = ELCO(I,NQ) 125 CONTINUE NQNYH = NQ*NYH RC = RC*EL(1)/EL0 EL0 = EL(1) CONIT = 0.5D0/(NQ+2) DDN = DVNORM (N, SAVF, EWT)/TESCO(1,L) EXDN = 1.0D0/L RHDN = 1.0D0/(1.3D0*DDN**EXDN + 0.0000013D0) RH = MIN(RHDN,1.0D0) IREDO = 3 IF (H .EQ. HOLD) GO TO 170 RH = MIN(RH,ABS(H/HOLD)) H = HOLD GO TO 175 C----------------------------------------------------------------------- C DCFODE is called to get all the integration coefficients for the C current METH. Then the EL vector and related constants are reset C whenever the order NQ is changed, or at the start of the problem. C----------------------------------------------------------------------- 140 CALL DCFODE (METH, ELCO, TESCO) 150 DO 155 I = 1,L EL(I) = ELCO(I,NQ) 155 CONTINUE NQNYH = NQ*NYH RC = RC*EL(1)/EL0 EL0 = EL(1) CONIT = 0.5D0/(NQ+2) IF (IRET .EQ. 1) THEN GOTO 160 ELSE IF (IRET .EQ. 2) THEN GOTO 170 ELSE IF (IRET .EQ. 3) THEN GOTO 200 ENDIF C GO TO (160, 170, 200), IRET C----------------------------------------------------------------------- C If H is being changed, the H ratio RH is checked against C RMAX, HMIN, and HMXI, and the YH array rescaled. IALTH is set to C L = NQ + 1 to prevent a change of H for that many steps, unless C forced by a convergence or error test failure. C----------------------------------------------------------------------- 160 IF (H .EQ. HOLD) GO TO 200 RH = H/HOLD H = HOLD IREDO = 3 GO TO 175 170 RH = MAX(RH,HMIN/ABS(H)) 175 RH = MIN(RH,RMAX) RH = RH/MAX(1.0D0,ABS(H)*HMXI*RH) R = 1.0D0 DO 190 J = 2,L R = R*RH DO 180 I = 1,N YH(I,J) = YH(I,J)*R 180 CONTINUE 190 CONTINUE H = H*RH RC = RC*RH IALTH = L IF (IREDO .EQ. 0) GO TO 690 C----------------------------------------------------------------------- C This section computes the predicted values by effectively C multiplying the YH array by the Pascal Triangle matrix. C RC is the ratio of new to old values of the coefficient H*EL(1). C When RC differs from 1 by more than CCMAX, IPUP is set to MITER C to force PJAC to be called, if a Jacobian is involved. C In any case, PJAC is called at least every MSBP steps. C----------------------------------------------------------------------- 200 IF (ABS(RC-1.0D0) .GT. CCMAX) IPUP = MITER IF (NST .GE. NSLP+MSBP) IPUP = MITER TN = TN + H I1 = NQNYH + 1 DO 215 JB = 1,NQ I1 = I1 - NYH Cdir$ ivdep DO 210 I = I1,NQNYH YH1(I) = YH1(I) + YH1(I+NYH) 210 CONTINUE 215 CONTINUE C----------------------------------------------------------------------- C Up to MAXCOR corrector iterations are taken. A convergence test is C made on the R.M.S. norm of each correction, weighted by the error C weight vector EWT. The sum of the corrections is accumulated in the C vector ACOR(i). The YH array is not altered in the corrector loop. C----------------------------------------------------------------------- 220 M = 0 DO 230 I = 1,N Y(I) = YH(I,1) 230 CONTINUE CKS CALL F (NEQ, TN, Y, SAVF, rpar, ipar) NFE = NFE + 1 IF (IPUP .LE. 0) GO TO 250 C----------------------------------------------------------------------- C If indicated, the matrix P = I - h*el(1)*J is reevaluated and C preprocessed before starting the corrector iteration. IPUP is set C to 0 as an indicator that this has been done. C----------------------------------------------------------------------- CKS CALL PJAC (NEQ, Y, YH, NYH, EWT, ACOR, SAVF, WM, IWM, F, JAC, &rpar,ipar) IPUP = 0 RC = 1.0D0 NSLP = NST CRATE = 0.7D0 IF (IERPJ .NE. 0) GO TO 430 250 DO 260 I = 1,N ACOR(I) = 0.0D0 260 CONTINUE 270 IF (MITER .NE. 0) GO TO 350 C----------------------------------------------------------------------- C In the case of functional iteration, update Y directly from C the result of the last function evaluation. C----------------------------------------------------------------------- DO 290 I = 1,N SAVF(I) = H*SAVF(I) - YH(I,2) Y(I) = SAVF(I) - ACOR(I) 290 CONTINUE DEL = DVNORM (N, Y, EWT) DO 300 I = 1,N Y(I) = YH(I,1) + EL(1)*SAVF(I) ACOR(I) = SAVF(I) 300 CONTINUE GO TO 400 C----------------------------------------------------------------------- C In the case of the chord method, compute the corrector error, C and solve the linear system with that as right-hand side and C P as coefficient matrix. C----------------------------------------------------------------------- 350 DO 360 I = 1,N Y(I) = H*SAVF(I) - (YH(I,2) + ACOR(I)) 360 CONTINUE CALL SLVS (WM, IWM, Y, SAVF) IF (IERSL .LT. 0) GO TO 430 IF (IERSL .GT. 0) GO TO 410 DEL = DVNORM (N, Y, EWT) DO 380 I = 1,N ACOR(I) = ACOR(I) + Y(I) Y(I) = YH(I,1) + EL(1)*ACOR(I) 380 CONTINUE C----------------------------------------------------------------------- C Test for convergence. If M.gt.0, an estimate of the convergence C rate constant is stored in CRATE, and this is used in the test. C----------------------------------------------------------------------- 400 IF (M .NE. 0) CRATE = MAX(0.2D0*CRATE,DEL/DELP) DCON = DEL*MIN(1.0D0,1.5D0*CRATE)/(TESCO(2,NQ)*CONIT) IF (DCON .LE. 1.0D0) GO TO 450 M = M + 1 IF (M .EQ. MAXCOR) GO TO 410 IF (M .GE. 2 .AND. DEL .GT. 2.0D0*DELP) GO TO 410 DELP = DEL CKS CALL F (NEQ, TN, Y, SAVF, rpar, ipar) NFE = NFE + 1 GO TO 270 C----------------------------------------------------------------------- C The corrector iteration failed to converge. C If MITER .ne. 0 and the Jacobian is out of date, PJAC is called for C the next try. Otherwise the YH array is retracted to its values C before prediction, and H is reduced, if possible. If H cannot be C reduced or MXNCF failures have occurred, exit with KFLAG = -2. C----------------------------------------------------------------------- 410 IF (MITER .EQ. 0 .OR. JCUR .EQ. 1) GO TO 430 ICF = 1 IPUP = MITER GO TO 220 430 ICF = 2 NCF = NCF + 1 RMAX = 2.0D0 TN = TOLD I1 = NQNYH + 1 DO 445 JB = 1,NQ I1 = I1 - NYH Cdir$ ivdep DO 440 I = I1,NQNYH YH1(I) = YH1(I) - YH1(I+NYH) 440 CONTINUE 445 CONTINUE IF (IERPJ .LT. 0 .OR. IERSL .LT. 0) GO TO 680 IF (ABS(H) .LE. HMIN*1.00001D0) GO TO 670 IF (NCF .EQ. MXNCF) GO TO 670 RH = 0.25D0 IPUP = MITER IREDO = 1 GO TO 170 C----------------------------------------------------------------------- C The corrector has converged. JCUR is set to 0 C to signal that the Jacobian involved may need updating later. C The local error test is made and control passes to statement 500 C if it fails. C----------------------------------------------------------------------- 450 JCUR = 0 IF (M .EQ. 0) DSM = DEL/TESCO(2,NQ) IF (M .GT. 0) DSM = DVNORM (N, ACOR, EWT)/TESCO(2,NQ) IF (DSM .GT. 1.0D0) GO TO 500 C----------------------------------------------------------------------- C After a successful step, update the YH array. C Consider changing H if IALTH = 1. Otherwise decrease IALTH by 1. C If IALTH is then 1 and NQ .lt. MAXORD, then ACOR is saved for C use in a possible order increase on the next step. C If a change in H is considered, an increase or decrease in order C by one is considered also. A change in H is made only if it is by a C factor of at least 1.1. If not, IALTH is set to 3 to prevent C testing for that many steps. C----------------------------------------------------------------------- KFLAG = 0 IREDO = 0 NST = NST + 1 HU = H NQU = NQ DO 480 J = 1,L DO 470 I = 1,N YH(I,J) = YH(I,J) + EL(J)*ACOR(I) 470 CONTINUE 480 CONTINUE IALTH = IALTH - 1 IF (IALTH .EQ. 0) GO TO 520 IF (IALTH .GT. 1) GO TO 700 IF (L .EQ. LMAX) GO TO 700 DO 490 I = 1,N YH(I,LMAX) = ACOR(I) 490 CONTINUE GO TO 700 C----------------------------------------------------------------------- C The error test failed. KFLAG keeps track of multiple failures. C Restore TN and the YH array to their previous values, and prepare C to try the step again. Compute the optimum step size for this or C one lower order. After 2 or more failures, H is forced to decrease C by a factor of 0.2 or less. C----------------------------------------------------------------------- 500 KFLAG = KFLAG - 1 TN = TOLD I1 = NQNYH + 1 DO 515 JB = 1,NQ I1 = I1 - NYH Cdir$ ivdep DO 510 I = I1,NQNYH YH1(I) = YH1(I) - YH1(I+NYH) 510 CONTINUE 515 CONTINUE RMAX = 2.0D0 IF (ABS(H) .LE. HMIN*1.00001D0) GO TO 660 IF (KFLAG .LE. -3) GO TO 640 IREDO = 2 RHUP = 0.0D0 GO TO 540 C----------------------------------------------------------------------- C Regardless of the success or failure of the step, factors C RHDN, RHSM, and RHUP are computed, by which H could be multiplied C at order NQ - 1, order NQ, or order NQ + 1, respectively. C In the case of failure, RHUP = 0.0 to avoid an order increase. C The largest of these is determined and the new order chosen C accordingly. If the order is to be increased, we compute one C additional scaled derivative. C----------------------------------------------------------------------- 520 RHUP = 0.0D0 IF (L .EQ. LMAX) GO TO 540 DO 530 I = 1,N SAVF(I) = ACOR(I) - YH(I,LMAX) 530 CONTINUE DUP = DVNORM (N, SAVF, EWT)/TESCO(3,NQ) EXUP = 1.0D0/(L+1) RHUP = 1.0D0/(1.4D0*DUP**EXUP + 0.0000014D0) 540 EXSM = 1.0D0/L RHSM = 1.0D0/(1.2D0*DSM**EXSM + 0.0000012D0) RHDN = 0.0D0 IF (NQ .EQ. 1) GO TO 560 DDN = DVNORM (N, YH(1,L), EWT)/TESCO(1,NQ) EXDN = 1.0D0/NQ RHDN = 1.0D0/(1.3D0*DDN**EXDN + 0.0000013D0) 560 IF (RHSM .GE. RHUP) GO TO 570 IF (RHUP .GT. RHDN) GO TO 590 GO TO 580 570 IF (RHSM .LT. RHDN) GO TO 580 NEWQ = NQ RH = RHSM GO TO 620 580 NEWQ = NQ - 1 RH = RHDN IF (KFLAG .LT. 0 .AND. RH .GT. 1.0D0) RH = 1.0D0 GO TO 620 590 NEWQ = L RH = RHUP IF (RH .LT. 1.1D0) GO TO 610 R = EL(L)/L DO 600 I = 1,N YH(I,NEWQ+1) = ACOR(I)*R 600 CONTINUE GO TO 630 610 IALTH = 3 GO TO 700 620 IF ((KFLAG .EQ. 0) .AND. (RH .LT. 1.1D0)) GO TO 610 IF (KFLAG .LE. -2) RH = MIN(RH,0.2D0) C----------------------------------------------------------------------- C If there is a change of order, reset NQ, l, and the coefficients. C In any case H is reset according to RH and the YH array is rescaled. C Then exit from 690 if the step was OK, or redo the step otherwise. C----------------------------------------------------------------------- IF (NEWQ .EQ. NQ) GO TO 170 630 NQ = NEWQ L = NQ + 1 IRET = 2 GO TO 150 C----------------------------------------------------------------------- C Control reaches this section if 3 or more failures have occured. C If 10 failures have occurred, exit with KFLAG = -1. C It is assumed that the derivatives that have accumulated in the C YH array have errors of the wrong order. Hence the first C derivative is recomputed, and the order is set to 1. Then C H is reduced by a factor of 10, and the step is retried, C until it succeeds or H reaches HMIN. C----------------------------------------------------------------------- 640 IF (KFLAG .EQ. -10) GO TO 660 RH = 0.1D0 RH = MAX(HMIN/ABS(H),RH) H = H*RH DO 645 I = 1,N Y(I) = YH(I,1) 645 CONTINUE CKS CALL F (NEQ, TN, Y, SAVF, rpar, ipar) NFE = NFE + 1 DO 650 I = 1,N YH(I,2) = H*SAVF(I) 650 CONTINUE IPUP = MITER IALTH = 5 IF (NQ .EQ. 1) GO TO 200 NQ = 1 L = 2 IRET = 3 GO TO 150 C----------------------------------------------------------------------- C All returns are made through this section. H is saved in HOLD C to allow the caller to change H on the next step. C----------------------------------------------------------------------- 660 KFLAG = -1 GO TO 720 670 KFLAG = -2 GO TO 720 680 KFLAG = -3 GO TO 720 690 RMAX = 10.0D0 700 R = 1.0D0/TESCO(2,NQU) DO 710 I = 1,N ACOR(I) = ACOR(I)*R 710 CONTINUE 720 HOLD = H JSTART = 1 RETURN C----------------------- END OF SUBROUTINE DSTODE ---------------------- END *DECK DEWSET SUBROUTINE DEWSET (N, ITOL, RTOL, ATOL, YCUR, EWT) C***BEGIN PROLOGUE DEWSET C***SUBSIDIARY C***PURPOSE Set error weight vector. C***TYPE DOUBLE PRECISION (SEWSET-S, DEWSET-D) C***AUTHOR Hindmarsh, Alan C., (LLNL) C***DESCRIPTION C C This subroutine sets the error weight vector EWT according to C EWT(i) = RTOL(i)*ABS(YCUR(i)) + ATOL(i), i = 1,...,N, C with the subscript on RTOL and/or ATOL possibly replaced by 1 above, C depending on the value of ITOL. C C***SEE ALSO DLSODE C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 791129 DATE WRITTEN C 890501 Modified prologue to SLATEC/LDOC format. (FNF) C 890503 Minor cosmetic changes. (FNF) C 930809 Renamed to allow single/double precision versions. (ACH) C***END PROLOGUE DEWSET C**End INTEGER N, ITOL INTEGER I DOUBLE PRECISION RTOL, ATOL, YCUR, EWT DIMENSION RTOL(*), ATOL(*), YCUR(N), EWT(N) C C***FIRST EXECUTABLE STATEMENT DEWSET IF (ITOL .EQ. 1) THEN GOTO 10 ELSE IF (ITOL .EQ. 2) THEN GOTO 20 ELSE IF (ITOL .EQ. 3) THEN GOTO 30 ELSE IF (ITOL .EQ. 4) THEN GOTO 40 ENDIF C GO TO (10, 20, 30, 40), ITOL 10 CONTINUE DO 15 I = 1,N EWT(I) = RTOL(1)*ABS(YCUR(I)) + ATOL(1) 15 CONTINUE RETURN 20 CONTINUE DO 25 I = 1,N EWT(I) = RTOL(1)*ABS(YCUR(I)) + ATOL(I) 25 CONTINUE RETURN 30 CONTINUE DO 35 I = 1,N EWT(I) = RTOL(I)*ABS(YCUR(I)) + ATOL(1) 35 CONTINUE RETURN 40 CONTINUE DO 45 I = 1,N EWT(I) = RTOL(I)*ABS(YCUR(I)) + ATOL(I) 45 CONTINUE RETURN C----------------------- END OF SUBROUTINE DEWSET ---------------------- END *DECK DVNORM DOUBLE PRECISION FUNCTION DVNORM (N, V, W) C***BEGIN PROLOGUE DVNORM C***SUBSIDIARY C***PURPOSE Weighted root-mean-square vector norm. C***TYPE DOUBLE PRECISION (SVNORM-S, DVNORM-D) C***AUTHOR Hindmarsh, Alan C., (LLNL) C***DESCRIPTION C C This function routine computes the weighted root-mean-square norm C of the vector of length N contained in the array V, with weights C contained in the array W of length N: C DVNORM = SQRT( (1/N) * SUM( V(i)*W(i) )**2 ) C C***SEE ALSO DLSODE C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 791129 DATE WRITTEN C 890501 Modified prologue to SLATEC/LDOC format. (FNF) C 890503 Minor cosmetic changes. (FNF) C 930809 Renamed to allow single/double precision versions. (ACH) C***END PROLOGUE DVNORM C**End INTEGER N, I DOUBLE PRECISION V, W, SUM DIMENSION V(N), W(N) C C***FIRST EXECUTABLE STATEMENT DVNORM SUM = 0.0D0 DO 10 I = 1,N SUM = SUM + (V(I)*W(I))**2 10 CONTINUE DVNORM = SQRT(SUM/N) RETURN C----------------------- END OF FUNCTION DVNORM ------------------------ END *DECK DIPREP SUBROUTINE DIPREP (NEQ, Y, RWORK, IWK, IA, JA, IPFLAG, F, JAC, &rpar,ipar) EXTERNAL F, JAC CKS: added rpar,ipar integer ipar(*) double precision rpar(*) INTEGER NEQ, IA, JA, IPFLAG, IWK(*) DOUBLE PRECISION Y, RWORK DIMENSION NEQ(*), Y(*), RWORK(*), IA(*), JA(*) INTEGER IOWND, IOWNS, 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU INTEGER IPLOST, IESP, ISTATC, IYS, IBA, IBIAN, IBJAN, IBJGP, 1 IPIAN, IPJAN, IPJGP, IPIGP, IPR, IPC, IPIC, IPISP, IPRSP, IPA, 2 LENYH, LENYHM, LENWK, LREQ, LRAT, LREST, LWMIN, MOSS, MSBJ, 3 NSLJ, NGP, NLU, NNZ, NSP, NZL, NZU DOUBLE PRECISION ROWNS, 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND DOUBLE PRECISION RLSS COMMON /DLS001/ ROWNS(209), 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 2 IOWND(6), IOWNS(6), 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU COMMON /DLSS01/ RLSS(6), 1 IPLOST, IESP, ISTATC, IYS, IBA, IBIAN, IBJAN, IBJGP, 2 IPIAN, IPJAN, IPJGP, IPIGP, IPR, IPC, IPIC, IPISP, IPRSP, IPA, 3 LENYH, LENYHM, LENWK, LREQ, LRAT, LREST, LWMIN, MOSS, MSBJ, 4 NSLJ, NGP, NLU, NNZ, NSP, NZL, NZU INTEGER I, IMAX, LEWTN, LYHD, LYHN C----------------------------------------------------------------------- C This routine serves as an interface between the driver and C Subroutine DPREP. It is called only if MITER is 1 or 2. C Tasks performed here are: C * call DPREP, C * reset the required WM segment length LENWK, C * move YH back to its final location (following WM in RWORK), C * reset pointers for YH, SAVF, EWT, and ACOR, and C * move EWT to its new position if ISTATE = 1. C IPFLAG is an output error indication flag. IPFLAG = 0 if there was C no trouble, and IPFLAG is the value of the DPREP error flag IPPER C if there was trouble in Subroutine DPREP. C----------------------------------------------------------------------- IPFLAG = 0 C Call DPREP to do matrix preprocessing operations. -------------------- CALL DPREP (NEQ, Y, RWORK(LYH), RWORK(LSAVF), RWORK(LEWT), 1 RWORK(LACOR),IA,JA,RWORK(LWM),IWK(2*LWM-1),IPFLAG, F, JAC, & rpar,ipar) LENWK = MAX(LREQ,LWMIN) IF (IPFLAG .LT. 0) RETURN C If DPREP was successful, move YH to end of required space for WM. ---- LYHN = LWM + LENWK IF (LYHN .GT. LYH) RETURN LYHD = LYH - LYHN IF (LYHD .EQ. 0) GO TO 20 IMAX = LYHN - 1 + LENYHM DO 10 I = LYHN,IMAX RWORK(I) = RWORK(I+LYHD) 10 CONTINUE LYH = LYHN C Reset pointers for SAVF, EWT, and ACOR. ------------------------------ 20 LSAVF = LYH + LENYH LEWTN = LSAVF + N LACOR = LEWTN + N IF (ISTATC .EQ. 3) GO TO 40 C If ISTATE = 1, move EWT (left) to its new position. ------------------ IF (LEWTN .GT. LEWT) RETURN DO 30 I = 1,N RWORK(I+LEWTN-1) = RWORK(I+LEWT-1) 30 CONTINUE 40 LEWT = LEWTN RETURN C----------------------- End of Subroutine DIPREP ---------------------- END *DECK DPREP SUBROUTINE DPREP (NEQ, Y, YH, SAVF, EWT, FTEM, IA, JA, 1 WK, IWK, IPPER, F, JAC,rpar,ipar) EXTERNAL F,JAC CKS: added rpar,ipar integer ipar(*) double precision rpar(*) INTEGER NEQ, IA, JA, IWK, IPPER DOUBLE PRECISION Y, YH, SAVF, EWT, FTEM, WK DIMENSION NEQ(*), Y(*), YH(*), SAVF(*), EWT(*), FTEM(*), 1 IA(*), JA(*), WK(*), IWK(*) INTEGER IOWND, IOWNS, 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU INTEGER IPLOST, IESP, ISTATC, IYS, IBA, IBIAN, IBJAN, IBJGP, 1 IPIAN, IPJAN, IPJGP, IPIGP, IPR, IPC, IPIC, IPISP, IPRSP, IPA, 2 LENYH, LENYHM, LENWK, LREQ, LRAT, LREST, LWMIN, MOSS, MSBJ, 3 NSLJ, NGP, NLU, NNZ, NSP, NZL, NZU DOUBLE PRECISION ROWNS, 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND DOUBLE PRECISION CON0, CONMIN, CCMXJ, PSMALL, RBIG, SETH COMMON /DLS001/ ROWNS(209), 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 2 IOWND(6), IOWNS(6), 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU COMMON /DLSS01/ CON0, CONMIN, CCMXJ, PSMALL, RBIG, SETH, 1 IPLOST, IESP, ISTATC, IYS, IBA, IBIAN, IBJAN, IBJGP, 2 IPIAN, IPJAN, IPJGP, IPIGP, IPR, IPC, IPIC, IPISP, IPRSP, IPA, 3 LENYH, LENYHM, LENWK, LREQ, LRAT, LREST, LWMIN, MOSS, MSBJ, 4 NSLJ, NGP, NLU, NNZ, NSP, NZL, NZU INTEGER I, IBR, IER, IPIL, IPIU, IPTT1, IPTT2, J, JFOUND, K, 1 KNEW, KMAX, KMIN, LDIF, LENIGP, LIWK, MAXG, NP1, NZSUT DOUBLE PRECISION DQ, DYJ, ERWT, FAC, YJ C----------------------------------------------------------------------- C This routine performs preprocessing related to the sparse linear C systems that must be solved if MITER = 1 or 2. C The operations that are performed here are: C * compute sparseness structure of Jacobian according to MOSS, C * compute grouping of column indices (MITER = 2), C * compute a new ordering of rows and columns of the matrix, C * reorder JA corresponding to the new ordering, C * perform a symbolic LU factorization of the matrix, and C * set pointers for segments of the IWK/WK array. C In addition to variables described previously, DPREP uses the C following for communication: C YH = the history array. Only the first column, containing the C current Y vector, is used. Used only if MOSS .ne. 0. C SAVF = a work array of length NEQ, used only if MOSS .ne. 0. C EWT = array of length NEQ containing (inverted) error weights. C Used only if MOSS = 2 or if ISTATE = MOSS = 1. C FTEM = a work array of length NEQ, identical to ACOR in the driver, C used only if MOSS = 2. C WK = a real work array of length LENWK, identical to WM in C the driver. C IWK = integer work array, assumed to occupy the same space as WK. C LENWK = the length of the work arrays WK and IWK. C ISTATC = a copy of the driver input argument ISTATE (= 1 on the C first call, = 3 on a continuation call). C IYS = flag value from ODRV or CDRV. C IPPER = output error flag with the following values and meanings: C 0 no error. C -1 insufficient storage for internal structure pointers. C -2 insufficient storage for JGROUP. C -3 insufficient storage for ODRV. C -4 other error flag from ODRV (should never occur). C -5 insufficient storage for CDRV. C -6 other error flag from CDRV. C----------------------------------------------------------------------- IBIAN = LRAT*2 IPIAN = IBIAN + 1 NP1 = N + 1 IPJAN = IPIAN + NP1 IBJAN = IPJAN - 1 LIWK = LENWK*LRAT IF (IPJAN+N-1 .GT. LIWK) GO TO 210 IF (MOSS .EQ. 0) GO TO 30 C IF (ISTATC .EQ. 3) GO TO 20 C ISTATE = 1 and MOSS .ne. 0. Perturb Y for structure determination. -- DO 10 I = 1,N ERWT = 1.0D0/EWT(I) FAC = 1.0D0 + 1.0D0/(I + 1.0D0) Y(I) = Y(I) + FAC*SIGN(ERWT,Y(I)) 10 CONTINUE IF (MOSS .EQ. 1) THEN GOTO 70 ELSE IF (MOSS .EQ. 2) THEN GOTO 100 ENDIF C GO TO (70, 100), MOSS C 20 CONTINUE C ISTATE = 3 and MOSS .ne. 0. Load Y from YH(*,1). -------------------- DO 25 I = 1,N Y(I) = YH(I) 25 CONTINUE IF (MOSS .EQ. 1) THEN GOTO 70 ELSE IF (MOSS .EQ. 2) THEN GOTO 100 ENDIF C GO TO (70, 100), MOSS C C MOSS = 0. Process user's IA,JA. Add diagonal entries if necessary. - 30 KNEW = IPJAN KMIN = IA(1) IWK(IPIAN) = 1 DO 60 J = 1,N JFOUND = 0 KMAX = IA(J+1) - 1 IF (KMIN .GT. KMAX) GO TO 45 DO 40 K = KMIN,KMAX I = JA(K) IF (I .EQ. J) JFOUND = 1 IF (KNEW .GT. LIWK) GO TO 210 IWK(KNEW) = I KNEW = KNEW + 1 40 CONTINUE IF (JFOUND .EQ. 1) GO TO 50 45 IF (KNEW .GT. LIWK) GO TO 210 IWK(KNEW) = J KNEW = KNEW + 1 50 IWK(IPIAN+J) = KNEW + 1 - IPJAN KMIN = KMAX + 1 60 CONTINUE GO TO 140 C C MOSS = 1. Compute structure from user-supplied Jacobian routine JAC. 70 CONTINUE C A dummy call to F allows user to create temporaries for use in JAC. -- CKS CALL F (NEQ, TN, Y, SAVF, rpar, ipar) K = IPJAN IWK(IPIAN) = 1 DO 90 J = 1,N IF (K .GT. LIWK) GO TO 210 IWK(K) = J K = K + 1 DO 75 I = 1,N SAVF(I) = 0.0D0 75 CONTINUE CKS CALL JAC (NEQ, TN, Y, J, IWK(IPIAN), IWK(IPJAN), SAVF, & rpar,ipar) DO 80 I = 1,N IF (ABS(SAVF(I)) .LE. SETH) GO TO 80 IF (I .EQ. J) GO TO 80 IF (K .GT. LIWK) GO TO 210 IWK(K) = I K = K + 1 80 CONTINUE IWK(IPIAN+J) = K + 1 - IPJAN 90 CONTINUE GO TO 140 C C MOSS = 2. Compute structure from results of N + 1 calls to F. ------- 100 K = IPJAN IWK(IPIAN) = 1 CKS CALL F (NEQ, TN, Y, SAVF, rpar, ipar) DO 120 J = 1,N IF (K .GT. LIWK) GO TO 210 IWK(K) = J K = K + 1 YJ = Y(J) ERWT = 1.0D0/EWT(J) DYJ = SIGN(ERWT,YJ) Y(J) = YJ + DYJ CKS CALL F (NEQ, TN, Y, FTEM, rpar, ipar) Y(J) = YJ DO 110 I = 1,N DQ = (FTEM(I) - SAVF(I))/DYJ IF (ABS(DQ) .LE. SETH) GO TO 110 IF (I .EQ. J) GO TO 110 IF (K .GT. LIWK) GO TO 210 IWK(K) = I K = K + 1 110 CONTINUE IWK(IPIAN+J) = K + 1 - IPJAN 120 CONTINUE C 140 CONTINUE IF (MOSS .EQ. 0 .OR. ISTATC .NE. 1) GO TO 150 C If ISTATE = 1 and MOSS .ne. 0, restore Y from YH. -------------------- DO 145 I = 1,N Y(I) = YH(I) 145 CONTINUE 150 NNZ = IWK(IPIAN+N) - 1 LENIGP = 0 IPIGP = IPJAN + NNZ IF (MITER .NE. 2) GO TO 160 C C Compute grouping of column indices (MITER = 2). ---------------------- MAXG = NP1 IPJGP = IPJAN + NNZ IBJGP = IPJGP - 1 IPIGP = IPJGP + N IPTT1 = IPIGP + NP1 IPTT2 = IPTT1 + N LREQ = IPTT2 + N - 1 IF (LREQ .GT. LIWK) GO TO 220 CALL JGROUP (N, IWK(IPIAN), IWK(IPJAN), MAXG, NGP, IWK(IPIGP), 1 IWK(IPJGP), IWK(IPTT1), IWK(IPTT2), IER) IF (IER .NE. 0) GO TO 220 LENIGP = NGP + 1 C C Compute new ordering of rows/columns of Jacobian. -------------------- 160 IPR = IPIGP + LENIGP IPC = IPR IPIC = IPC + N IPISP = IPIC + N IPRSP = (IPISP - 2)/LRAT + 2 IESP = LENWK + 1 - IPRSP IF (IESP .LT. 0) GO TO 230 IBR = IPR - 1 DO 170 I = 1,N IWK(IBR+I) = I 170 CONTINUE NSP = LIWK + 1 - IPISP CALL ODRV (N, IWK(IPIAN), IWK(IPJAN), WK, IWK(IPR), IWK(IPIC), 1 NSP, IWK(IPISP), 1, IYS) IF (IYS .EQ. 11*N+1) GO TO 240 IF (IYS .NE. 0) GO TO 230 C C Reorder JAN and do symbolic LU factorization of matrix. -------------- IPA = LENWK + 1 - NNZ NSP = IPA - IPRSP LREQ = MAX(12*N/LRAT, 6*N/LRAT+2*N+NNZ) + 3 LREQ = LREQ + IPRSP - 1 + NNZ IF (LREQ .GT. LENWK) GO TO 250 IBA = IPA - 1 DO 180 I = 1,NNZ WK(IBA+I) = 0.0D0 180 CONTINUE IPISP = LRAT*(IPRSP - 1) + 1 CALL CDRV (N,IWK(IPR),IWK(IPC),IWK(IPIC),IWK(IPIAN),IWK(IPJAN), 1 WK(IPA),WK(IPA),WK(IPA),NSP,IWK(IPISP),WK(IPRSP),IESP,5,IYS) LREQ = LENWK - IESP IF (IYS .EQ. 10*N+1) GO TO 250 IF (IYS .NE. 0) GO TO 260 IPIL = IPISP IPIU = IPIL + 2*N + 1 NZU = IWK(IPIL+N) - IWK(IPIL) NZL = IWK(IPIU+N) - IWK(IPIU) IF (LRAT .GT. 1) GO TO 190 CALL ADJLR (N, IWK(IPISP), LDIF) LREQ = LREQ + LDIF 190 CONTINUE IF (LRAT .EQ. 2 .AND. NNZ .EQ. N) LREQ = LREQ + 1 NSP = NSP + LREQ - LENWK IPA = LREQ + 1 - NNZ IBA = IPA - 1 IPPER = 0 RETURN C 210 IPPER = -1 LREQ = 2 + (2*N + 1)/LRAT LREQ = MAX(LENWK+1,LREQ) RETURN C 220 IPPER = -2 LREQ = (LREQ - 1)/LRAT + 1 RETURN C 230 IPPER = -3 CALL CNTNZU (N, IWK(IPIAN), IWK(IPJAN), NZSUT) LREQ = LENWK - IESP + (3*N + 4*NZSUT - 1)/LRAT + 1 RETURN C 240 IPPER = -4 RETURN C 250 IPPER = -5 RETURN C 260 IPPER = -6 LREQ = LENWK RETURN C----------------------- End of Subroutine DPREP ----------------------- END *DECK JGROUP SUBROUTINE JGROUP (N,IA,JA,MAXG,NGRP,IGP,JGP,INCL,JDONE,IER) INTEGER N, IA, JA, MAXG, NGRP, IGP, JGP, INCL, JDONE, IER DIMENSION IA(*), JA(*), IGP(*), JGP(*), INCL(*), JDONE(*) C----------------------------------------------------------------------- C This subroutine constructs groupings of the column indices of C the Jacobian matrix, used in the numerical evaluation of the C Jacobian by finite differences. C C Input: C N = the order of the matrix. C IA,JA = sparse structure descriptors of the matrix by rows. C MAXG = length of available storage in the IGP array. C C Output: C NGRP = number of groups. C JGP = array of length N containing the column indices by groups. C IGP = pointer array of length NGRP + 1 to the locations in JGP C of the beginning of each group. C IER = error indicator. IER = 0 if no error occurred, or 1 if C MAXG was insufficient. C C INCL and JDONE are working arrays of length N. C----------------------------------------------------------------------- INTEGER I, J, K, KMIN, KMAX, NCOL, NG C IER = 0 DO 10 J = 1,N JDONE(J) = 0 10 CONTINUE NCOL = 1 DO 60 NG = 1,MAXG IGP(NG) = NCOL DO 20 I = 1,N INCL(I) = 0 20 CONTINUE DO 50 J = 1,N C Reject column J if it is already in a group.-------------------------- IF (JDONE(J) .EQ. 1) GO TO 50 KMIN = IA(J) KMAX = IA(J+1) - 1 DO 30 K = KMIN,KMAX C Reject column J if it overlaps any column already in this group.------ I = JA(K) IF (INCL(I) .EQ. 1) GO TO 50 30 CONTINUE C Accept column J into group NG.---------------------------------------- JGP(NCOL) = J NCOL = NCOL + 1 JDONE(J) = 1 DO 40 K = KMIN,KMAX I = JA(K) INCL(I) = 1 40 CONTINUE 50 CONTINUE C Stop if this group is empty (grouping is complete).------------------- IF (NCOL .EQ. IGP(NG)) GO TO 70 60 CONTINUE C Error return if not all columns were chosen (MAXG too small).--------- IF (NCOL .LE. N) GO TO 80 NG = MAXG 70 NGRP = NG - 1 RETURN 80 IER = 1 RETURN C----------------------- End of Subroutine JGROUP ---------------------- END *DECK ADJLR SUBROUTINE ADJLR (N, ISP, LDIF) INTEGER N, ISP, LDIF DIMENSION ISP(*) C----------------------------------------------------------------------- C This routine computes an adjustment, LDIF, to the required C integer storage space in IWK (sparse matrix work space). C It is called only if the word length ratio is LRAT = 1. C This is to account for the possibility that the symbolic LU phase C may require more storage than the numerical LU and solution phases. C----------------------------------------------------------------------- INTEGER IP, JLMAX, JUMAX, LNFC, LSFC, NZLU C IP = 2*N + 1 C Get JLMAX = IJL(N) and JUMAX = IJU(N) (sizes of JL and JU). ---------- JLMAX = ISP(IP) JUMAX = ISP(IP+IP) C NZLU = (size of L) + (size of U) = (IL(N+1)-IL(1)) + (IU(N+1)-IU(1)). NZLU = ISP(N+1) - ISP(1) + ISP(IP+N+1) - ISP(IP+1) LSFC = 12*N + 3 + 2*MAX(JLMAX,JUMAX) LNFC = 9*N + 2 + JLMAX + JUMAX + NZLU LDIF = MAX(0, LSFC - LNFC) RETURN C----------------------- End of Subroutine ADJLR ----------------------- END *DECK CNTNZU SUBROUTINE CNTNZU (N, IA, JA, NZSUT) INTEGER N, IA, JA, NZSUT DIMENSION IA(*), JA(*) C----------------------------------------------------------------------- C This routine counts the number of nonzero elements in the strict C upper triangle of the matrix M + M(transpose), where the sparsity C structure of M is given by pointer arrays IA and JA. C This is needed to compute the storage requirements for the C sparse matrix reordering operation in ODRV. C----------------------------------------------------------------------- INTEGER II, JJ, J, JMIN, JMAX, K, KMIN, KMAX, NUM C NUM = 0 DO 50 II = 1,N JMIN = IA(II) JMAX = IA(II+1) - 1 IF (JMIN .GT. JMAX) GO TO 50 DO 40 J = JMIN,JMAX IF (JA(J) - II .LT. 0) THEN GOTO 10 ELSE IF (JA(J) - II .EQ. 0) THEN GOTO 40 ElSE GOTO 30 ENDIF C IF (JA(J) - II) 10, 40, 30 10 JJ =JA(J) KMIN = IA(JJ) KMAX = IA(JJ+1) - 1 IF (KMIN .GT. KMAX) GO TO 30 DO 20 K = KMIN,KMAX IF (JA(K) .EQ. II) GO TO 40 20 CONTINUE 30 NUM = NUM + 1 40 CONTINUE 50 CONTINUE NZSUT = NUM RETURN C----------------------- End of Subroutine CNTNZU ---------------------- END *DECK DPRJS SUBROUTINE DPRJS (NEQ,Y,YH,NYH,EWT,FTEM,SAVF,WK,IWK,F,JAC, & rpar,ipar) EXTERNAL F,JAC CKS: added rpar,ipar integer ipar(*) double precision rpar(*) INTEGER NEQ, NYH, IWK DOUBLE PRECISION Y, YH, EWT, FTEM, SAVF, WK DIMENSION NEQ(*), Y(*), YH(NYH,*), EWT(*), FTEM(*), SAVF(*), 1 WK(*), IWK(*) INTEGER IOWND, IOWNS, 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU INTEGER IPLOST, IESP, ISTATC, IYS, IBA, IBIAN, IBJAN, IBJGP, 1 IPIAN, IPJAN, IPJGP, IPIGP, IPR, IPC, IPIC, IPISP, IPRSP, IPA, 2 LENYH, LENYHM, LENWK, LREQ, LRAT, LREST, LWMIN, MOSS, MSBJ, 3 NSLJ, NGP, NLU, NNZ, NSP, NZL, NZU DOUBLE PRECISION ROWNS, 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND DOUBLE PRECISION CON0, CONMIN, CCMXJ, PSMALL, RBIG, SETH COMMON /DLS001/ ROWNS(209), 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 2 IOWND(6), IOWNS(6), 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU COMMON /DLSS01/ CON0, CONMIN, CCMXJ, PSMALL, RBIG, SETH, 1 IPLOST, IESP, ISTATC, IYS, IBA, IBIAN, IBJAN, IBJGP, 2 IPIAN, IPJAN, IPJGP, IPIGP, IPR, IPC, IPIC, IPISP, IPRSP, IPA, 3 LENYH, LENYHM, LENWK, LREQ, LRAT, LREST, LWMIN, MOSS, MSBJ, 4 NSLJ, NGP, NLU, NNZ, NSP, NZL, NZU INTEGER I, IMUL, J, JJ, JOK, JMAX, JMIN, K, KMAX, KMIN, NG DOUBLE PRECISION CON, DI, FAC, HL0, PIJ, R, R0, RCON, RCONT, 1 SRUR, DVNORM C----------------------------------------------------------------------- C DPRJS is called to compute and process the matrix C P = I - H*EL(1)*J , where J is an approximation to the Jacobian. C J is computed by columns, either by the user-supplied routine JAC C if MITER = 1, or by finite differencing if MITER = 2. C if MITER = 3, a diagonal approximation to J is used. C if MITER = 1 or 2, and if the existing value of the Jacobian C (as contained in P) is considered acceptable, then a new value of C P is reconstructed from the old value. In any case, when MITER C is 1 or 2, the P matrix is subjected to LU decomposition in CDRV. C P and its LU decomposition are stored (separately) in WK. C C In addition to variables described previously, communication C with DPRJS uses the following: C Y = array containing predicted values on entry. C FTEM = work array of length N (ACOR in DSTODE). C SAVF = array containing f evaluated at predicted y. C WK = real work space for matrices. On output it contains the C inverse diagonal matrix if MITER = 3, and P and its sparse C LU decomposition if MITER is 1 or 2. C Storage of matrix elements starts at WK(3). C WK also contains the following matrix-related data: C WK(1) = SQRT(UROUND), used in numerical Jacobian increments. C WK(2) = H*EL0, saved for later use if MITER = 3. C IWK = integer work space for matrix-related data, assumed to C be equivalenced to WK. In addition, WK(IPRSP) and IWK(IPISP) C are assumed to have identical locations. C EL0 = EL(1) (input). C IERPJ = output error flag (in Common). C = 0 if no error. C = 1 if zero pivot found in CDRV. C = 2 if a singular matrix arose with MITER = 3. C = -1 if insufficient storage for CDRV (should not occur here). C = -2 if other error found in CDRV (should not occur here). C JCUR = output flag showing status of (approximate) Jacobian matrix: C = 1 to indicate that the Jacobian is now current, or C = 0 to indicate that a saved value was used. C This routine also uses other variables in Common. C----------------------------------------------------------------------- HL0 = H*EL0 CON = -HL0 IF (MITER .EQ. 3) GO TO 300 C See whether J should be reevaluated (JOK = 0) or not (JOK = 1). ------ JOK = 1 IF (NST .EQ. 0 .OR. NST .GE. NSLJ+MSBJ) JOK = 0 IF (ICF .EQ. 1 .AND. ABS(RC - 1.0D0) .LT. CCMXJ) JOK = 0 IF (ICF .EQ. 2) JOK = 0 IF (JOK .EQ. 1) GO TO 250 C C MITER = 1 or 2, and the Jacobian is to be reevaluated. --------------- 20 JCUR = 1 NJE = NJE + 1 NSLJ = NST IPLOST = 0 CONMIN = ABS(CON) IF (MITER .EQ. 1) THEN GOTO 100 ELSE IF (MITER .EQ. 2) THEN GOTO 200 ENDIF C GO TO (100, 200), MITER C C If MITER = 1, call JAC, multiply by scalar, and add identity. -------- 100 CONTINUE KMIN = IWK(IPIAN) DO 130 J = 1, N KMAX = IWK(IPIAN+J) - 1 DO 110 I = 1,N FTEM(I) = 0.0D0 110 CONTINUE CALL JAC (NEQ, TN, Y, J, IWK(IPIAN), IWK(IPJAN), FTEM, & rpar,ipar) DO 120 K = KMIN, KMAX I = IWK(IBJAN+K) WK(IBA+K) = FTEM(I)*CON IF (I .EQ. J) WK(IBA+K) = WK(IBA+K) + 1.0D0 120 CONTINUE KMIN = KMAX + 1 130 CONTINUE GO TO 290 C C If MITER = 2, make NGP calls to F to approximate J and P. ------------ 200 CONTINUE FAC = DVNORM(N, SAVF, EWT) R0 = 1000.0D0 * ABS(H) * UROUND * N * FAC IF (R0 .EQ. 0.0D0) R0 = 1.0D0 SRUR = WK(1) JMIN = IWK(IPIGP) DO 240 NG = 1,NGP JMAX = IWK(IPIGP+NG) - 1 DO 210 J = JMIN,JMAX JJ = IWK(IBJGP+J) R = MAX(SRUR*ABS(Y(JJ)),R0/EWT(JJ)) Y(JJ) = Y(JJ) + R 210 CONTINUE CKS CALL F (NEQ, TN, Y, FTEM, rpar, ipar) DO 230 J = JMIN,JMAX JJ = IWK(IBJGP+J) Y(JJ) = YH(JJ,1) R = MAX(SRUR*ABS(Y(JJ)),R0/EWT(JJ)) FAC = -HL0/R KMIN =IWK(IBIAN+JJ) KMAX =IWK(IBIAN+JJ+1) - 1 DO 220 K = KMIN,KMAX I = IWK(IBJAN+K) WK(IBA+K) = (FTEM(I) - SAVF(I))*FAC IF (I .EQ. JJ) WK(IBA+K) = WK(IBA+K) + 1.0D0 220 CONTINUE 230 CONTINUE JMIN = JMAX + 1 240 CONTINUE NFE = NFE + NGP GO TO 290 C C If JOK = 1, reconstruct new P from old P. ---------------------------- 250 JCUR = 0 RCON = CON/CON0 RCONT = ABS(CON)/CONMIN IF (RCONT .GT. RBIG .AND. IPLOST .EQ. 1) GO TO 20 KMIN = IWK(IPIAN) DO 275 J = 1,N KMAX = IWK(IPIAN+J) - 1 DO 270 K = KMIN,KMAX I = IWK(IBJAN+K) PIJ = WK(IBA+K) IF (I .NE. J) GO TO 260 PIJ = PIJ - 1.0D0 IF (ABS(PIJ) .GE. PSMALL) GO TO 260 IPLOST = 1 CONMIN = MIN(ABS(CON0),CONMIN) 260 PIJ = PIJ*RCON IF (I .EQ. J) PIJ = PIJ + 1.0D0 WK(IBA+K) = PIJ 270 CONTINUE KMIN = KMAX + 1 275 CONTINUE C C Do numerical factorization of P matrix. ------------------------------ 290 NLU = NLU + 1 CON0 = CON IERPJ = 0 DO 295 I = 1,N FTEM(I) = 0.0D0 295 CONTINUE CALL CDRV (N,IWK(IPR),IWK(IPC),IWK(IPIC),IWK(IPIAN),IWK(IPJAN), 1 WK(IPA),FTEM,FTEM,NSP,IWK(IPISP),WK(IPRSP),IESP,2,IYS) IF (IYS .EQ. 0) RETURN IMUL = (IYS - 1)/N IERPJ = -2 IF (IMUL .EQ. 8) IERPJ = 1 IF (IMUL .EQ. 10) IERPJ = -1 RETURN C C If MITER = 3, construct a diagonal approximation to J and P. --------- 300 CONTINUE JCUR = 1 NJE = NJE + 1 WK(2) = HL0 IERPJ = 0 R = EL0*0.1D0 DO 310 I = 1,N Y(I) = Y(I) + R*(H*SAVF(I) - YH(I,2)) 310 CONTINUE CKS CALL F (NEQ, TN, Y, WK(3), rpar, ipar) NFE = NFE + 1 DO 320 I = 1,N R0 = H*SAVF(I) - YH(I,2) DI = 0.1D0*R0 - H*(WK(I+2) - SAVF(I)) WK(I+2) = 1.0D0 IF (ABS(R0) .LT. UROUND/EWT(I)) GO TO 320 IF (ABS(DI) .EQ. 0.0D0) GO TO 330 WK(I+2) = 0.1D0*R0/DI 320 CONTINUE RETURN 330 IERPJ = 2 RETURN C----------------------- End of Subroutine DPRJS ----------------------- END *DECK DSOLSS SUBROUTINE DSOLSS (WK, IWK, X, TEM) INTEGER IWK DOUBLE PRECISION WK, X, TEM DIMENSION WK(*), IWK(*), X(*), TEM(*) INTEGER IOWND, IOWNS, 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU INTEGER IPLOST, IESP, ISTATC, IYS, IBA, IBIAN, IBJAN, IBJGP, 1 IPIAN, IPJAN, IPJGP, IPIGP, IPR, IPC, IPIC, IPISP, IPRSP, IPA, 2 LENYH, LENYHM, LENWK, LREQ, LRAT, LREST, LWMIN, MOSS, MSBJ, 3 NSLJ, NGP, NLU, NNZ, NSP, NZL, NZU DOUBLE PRECISION ROWNS, 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND DOUBLE PRECISION RLSS COMMON /DLS001/ ROWNS(209), 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 2 IOWND(6), IOWNS(6), 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU COMMON /DLSS01/ RLSS(6), 1 IPLOST, IESP, ISTATC, IYS, IBA, IBIAN, IBJAN, IBJGP, 2 IPIAN, IPJAN, IPJGP, IPIGP, IPR, IPC, IPIC, IPISP, IPRSP, IPA, 3 LENYH, LENYHM, LENWK, LREQ, LRAT, LREST, LWMIN, MOSS, MSBJ, 4 NSLJ, NGP, NLU, NNZ, NSP, NZL, NZU INTEGER I DOUBLE PRECISION DI, HL0, PHL0, R C----------------------------------------------------------------------- C This routine manages the solution of the linear system arising from C a chord iteration. It is called if MITER .ne. 0. C If MITER is 1 or 2, it calls CDRV to accomplish this. C If MITER = 3 it updates the coefficient H*EL0 in the diagonal C matrix, and then computes the solution. C communication with DSOLSS uses the following variables: C WK = real work space containing the inverse diagonal matrix if C MITER = 3 and the LU decomposition of the matrix otherwise. C Storage of matrix elements starts at WK(3). C WK also contains the following matrix-related data: C WK(1) = SQRT(UROUND) (not used here), C WK(2) = HL0, the previous value of H*EL0, used if MITER = 3. C IWK = integer work space for matrix-related data, assumed to C be equivalenced to WK. In addition, WK(IPRSP) and IWK(IPISP) C are assumed to have identical locations. C X = the right-hand side vector on input, and the solution vector C on output, of length N. C TEM = vector of work space of length N, not used in this version. C IERSL = output flag (in Common). C IERSL = 0 if no trouble occurred. C IERSL = -1 if CDRV returned an error flag (MITER = 1 or 2). C This should never occur and is considered fatal. C IERSL = 1 if a singular matrix arose with MITER = 3. C This routine also uses other variables in Common. C----------------------------------------------------------------------- IERSL = 0 IF (MITER .EQ. 1 .OR. MITER .EQ. 2) THEN GOTO 100 ELSE IF (MITER .EQ. 3) THEN GOTO 300 ENDIF C GO TO (100, 100, 300), MITER 100 CALL CDRV (N,IWK(IPR),IWK(IPC),IWK(IPIC),IWK(IPIAN),IWK(IPJAN), 1 WK(IPA),X,X,NSP,IWK(IPISP),WK(IPRSP),IESP,4,IERSL) IF (IERSL .NE. 0) IERSL = -1 RETURN C 300 PHL0 = WK(2) HL0 = H*EL0 WK(2) = HL0 IF (HL0 .EQ. PHL0) GO TO 330 R = HL0/PHL0 DO 320 I = 1,N DI = 1.0D0 - R*(1.0D0 - 1.0D0/WK(I+2)) IF (ABS(DI) .EQ. 0.0D0) GO TO 390 WK(I+2) = 1.0D0/DI 320 CONTINUE 330 DO 340 I = 1,N X(I) = WK(I+2)*X(I) 340 CONTINUE RETURN 390 IERSL = 1 RETURN C C----------------------- End of Subroutine DSOLSS ---------------------- END *DECK DSRCMS *DECK ODRV subroutine odrv * (n, ia,ja,a, p,ip, nsp,isp, path, flag) c 5/2/83 c*********************************************************************** c odrv -- driver for sparse matrix reordering routines c*********************************************************************** c c description c c odrv finds a minimum degree ordering of the rows and columns c of a matrix m stored in (ia,ja,a) format (see below). for the c reordered matrix, the work and storage required to perform c gaussian elimination is (usually) significantly less. c c note.. odrv and its subordinate routines have been modified to c compute orderings for general matrices, not necessarily having any c symmetry. the miminum degree ordering is computed for the c structure of the symmetric matrix m + m-transpose. c modifications to the original odrv module have been made in c the coding in subroutine mdi, and in the initial comments in c subroutines odrv and md. c c if only the nonzero entries in the upper triangle of m are being c stored, then odrv symmetrically reorders (ia,ja,a), (optionally) c with the diagonal entries placed first in each row. this is to c ensure that if m(i,j) will be in the upper triangle of m with c respect to the new ordering, then m(i,j) is stored in row i (and c thus m(j,i) is not stored), whereas if m(i,j) will be in the c strict lower triangle of m, then m(j,i) is stored in row j (and c thus m(i,j) is not stored). c c c storage of sparse matrices c c the nonzero entries of the matrix m are stored row-by-row in the c array a. to identify the individual nonzero entries in each row, c we need to know in which column each entry lies. these column c indices are stored in the array ja. i.e., if a(k) = m(i,j), then c ja(k) = j. to identify the individual rows, we need to know where c each row starts. these row pointers are stored in the array ia. c i.e., if m(i,j) is the first nonzero entry (stored) in the i-th row c and a(k) = m(i,j), then ia(i) = k. moreover, ia(n+1) points to c the first location following the last element in the last row. c thus, the number of entries in the i-th row is ia(i+1) - ia(i), c the nonzero entries in the i-th row are stored consecutively in c c a(ia(i)), a(ia(i)+1), ..., a(ia(i+1)-1), c c and the corresponding column indices are stored consecutively in c c ja(ia(i)), ja(ia(i)+1), ..., ja(ia(i+1)-1). c c when the coefficient matrix is symmetric, only the nonzero entries c in the upper triangle need be stored. for example, the matrix c c ( 1 0 2 3 0 ) c ( 0 4 0 0 0 ) c m = ( 2 0 5 6 0 ) c ( 3 0 6 7 8 ) c ( 0 0 0 8 9 ) c c could be stored as c c - 1 2 3 4 5 6 7 8 9 10 11 12 13 c ---+-------------------------------------- c ia - 1 4 5 8 12 14 c ja - 1 3 4 2 1 3 4 1 3 4 5 4 5 c a - 1 2 3 4 2 5 6 3 6 7 8 8 9 c c or (symmetrically) as c c - 1 2 3 4 5 6 7 8 9 c ---+-------------------------- c ia - 1 4 5 7 9 10 c ja - 1 3 4 2 3 4 4 5 5 c a - 1 2 3 4 5 6 7 8 9 . c c c parameters c c n - order of the matrix c c ia - integer one-dimensional array containing pointers to delimit c rows in ja and a. dimension = n+1 c c ja - integer one-dimensional array containing the column indices c corresponding to the elements of a. dimension = number of c nonzero entries in (the upper triangle of) m c c a - real one-dimensional array containing the nonzero entries in c (the upper triangle of) m, stored by rows. dimension = c number of nonzero entries in (the upper triangle of) m c c p - integer one-dimensional array used to return the permutation c of the rows and columns of m corresponding to the minimum c degree ordering. dimension = n c c ip - integer one-dimensional array used to return the inverse of c the permutation returned in p. dimension = n c c nsp - declared dimension of the one-dimensional array isp. nsp c must be at least 3n+4k, where k is the number of nonzeroes c in the strict upper triangle of m c c isp - integer one-dimensional array used for working storage. c dimension = nsp c c path - integer path specification. values and their meanings are - c 1 find minimum degree ordering only c 2 find minimum degree ordering and reorder symmetrically c stored matrix (used when only the nonzero entries in c the upper triangle of m are being stored) c 3 reorder symmetrically stored matrix as specified by c input permutation (used when an ordering has already c been determined and only the nonzero entries in the c upper triangle of m are being stored) c 4 same as 2 but put diagonal entries at start of each row c 5 same as 3 but put diagonal entries at start of each row c c flag - integer error flag. values and their meanings are - c 0 no errors detected c 9n+k insufficient storage in md c 10n+1 insufficient storage in odrv c 11n+1 illegal path specification c c c conversion from real to double precision c c change the real declarations in odrv and sro to double precision c declarations. c c----------------------------------------------------------------------- c integer ia(*), ja(*), p(*), ip(*), isp(*), path, flag, * v, l, head, tmp, q c... real a(*) double precision a(*) logical dflag c c----initialize error flag and validate path specification flag = 0 if (path.lt.1 .or. 5.lt.path) go to 111 c c----allocate storage and find minimum degree ordering if ((path-1) * (path-2) * (path-4) .ne. 0) go to 1 max = (nsp-n)/2 v = 1 l = v + max head = l + max next = head + n if (max.lt.n) go to 110 c call md * (n, ia,ja, max,isp(v),isp(l), isp(head),p,ip, isp(v), flag) if (flag.ne.0) go to 100 c c----allocate storage and symmetrically reorder matrix 1 if ((path-2) * (path-3) * (path-4) * (path-5) .ne. 0) go to 2 tmp = (nsp+1) - n q = tmp - (ia(n+1)-1) if (q.lt.1) go to 110 c dflag = path.eq.4 .or. path.eq.5 call sro * (n, ip, ia, ja, a, isp(tmp), isp(q), dflag) c 2 return c c ** error -- error detected in md 100 return c ** error -- insufficient storage 110 flag = 10*n + 1 return c ** error -- illegal path specified 111 flag = 11*n + 1 return end subroutine md * (n, ia,ja, max, v,l, head,last,next, mark, flag) c*********************************************************************** c md -- minimum degree algorithm (based on element model) c*********************************************************************** c c description c c md finds a minimum degree ordering of the rows and columns of a c general sparse matrix m stored in (ia,ja,a) format. c when the structure of m is nonsymmetric, the ordering is that c obtained for the symmetric matrix m + m-transpose. c c c additional parameters c c max - declared dimension of the one-dimensional arrays v and l. c max must be at least n+2k, where k is the number of c nonzeroes in the strict upper triangle of m + m-transpose c c v - integer one-dimensional work array. dimension = max c c l - integer one-dimensional work array. dimension = max c c head - integer one-dimensional work array. dimension = n c c last - integer one-dimensional array used to return the permutation c of the rows and columns of m corresponding to the minimum c degree ordering. dimension = n c c next - integer one-dimensional array used to return the inverse of c the permutation returned in last. dimension = n c c mark - integer one-dimensional work array (may be the same as v). c dimension = n c c flag - integer error flag. values and their meanings are - c 0 no errors detected c 9n+k insufficient storage in md c c c definitions of internal parameters c c ---------+--------------------------------------------------------- c v(s) - value field of list entry c ---------+--------------------------------------------------------- c l(s) - link field of list entry (0 =) end of list) c ---------+--------------------------------------------------------- c l(vi) - pointer to element list of uneliminated vertex vi c ---------+--------------------------------------------------------- c l(ej) - pointer to boundary list of active element ej c ---------+--------------------------------------------------------- c head(d) - vj =) vj head of d-list d c - 0 =) no vertex in d-list d c c c - vi uneliminated vertex c - vi in ek - vi not in ek c ---------+-----------------------------+--------------------------- c next(vi) - undefined but nonnegative - vj =) vj next in d-list c - - 0 =) vi tail of d-list c ---------+-----------------------------+--------------------------- c last(vi) - (not set until mdp) - -d =) vi head of d-list d c --vk =) compute degree - vj =) vj last in d-list c - ej =) vi prototype of ej - 0 =) vi not in any d-list c - 0 =) do not compute degree - c ---------+-----------------------------+--------------------------- c mark(vi) - mark(vk) - nonneg. tag .lt. mark(vk) c c c - vi eliminated vertex c - ei active element - otherwise c ---------+-----------------------------+--------------------------- c next(vi) - -j =) vi was j-th vertex - -j =) vi was j-th vertex c - to be eliminated - to be eliminated c ---------+-----------------------------+--------------------------- c last(vi) - m =) size of ei = m - undefined c ---------+-----------------------------+--------------------------- c mark(vi) - -m =) overlap count of ei - undefined c - with ek = m - c - otherwise nonnegative tag - c - .lt. mark(vk) - c c----------------------------------------------------------------------- c integer ia(*), ja(*), v(*), l(*), head(*), last(*), next(*), * mark(*), flag, tag, dmin, vk,ek, tail equivalence (vk,ek) c c----initialization tag = 0 call mdi * (n, ia,ja, max,v,l, head,last,next, mark,tag, flag) if (flag.ne.0) return c k = 0 dmin = 1 c c----while k .lt. n do 1 if (k.ge.n) go to 4 c c------search for vertex of minimum degree 2 if (head(dmin).gt.0) go to 3 dmin = dmin + 1 go to 2 c c------remove vertex vk of minimum degree from degree list 3 vk = head(dmin) head(dmin) = next(vk) if (head(dmin).gt.0) last(head(dmin)) = -dmin c c------number vertex vk, adjust tag, and tag vk k = k+1 next(vk) = -k last(ek) = dmin - 1 tag = tag + last(ek) mark(vk) = tag c c------form element ek from uneliminated neighbors of vk call mdm * (vk,tail, v,l, last,next, mark) c c------purge inactive elements and do mass elimination call mdp * (k,ek,tail, v,l, head,last,next, mark) c c------update degrees of uneliminated vertices in ek call mdu * (ek,dmin, v,l, head,last,next, mark) c go to 1 c c----generate inverse permutation from permutation 4 do 5 k=1,n next(k) = -next(k) last(next(k)) = k 5 continue c return end subroutine mdi * (n, ia,ja, max,v,l, head,last,next, mark,tag, flag) c*********************************************************************** c mdi -- initialization c*********************************************************************** integer ia(*), ja(*), v(*), l(*), head(*), last(*), next(*), * mark(*), tag, flag, sfs, vi,dvi, vj c c----initialize degrees, element lists, and degree lists do 1 vi=1,n mark(vi) = 1 l(vi) = 0 head(vi) = 0 1 continue sfs = n+1 c c----create nonzero structure c----for each nonzero entry a(vi,vj) do 6 vi=1,n jmin = ia(vi) jmax = ia(vi+1) - 1 if (jmin.gt.jmax) go to 6 do 5 j=jmin,jmax vj = ja(j) if (vj-vi .LT. 0) then goto 2 else if (vj-vi .EQ. 0) then goto 5 else goto 4 endif c if (vj-vi) 2, 5, 4 c c------if a(vi,vj) is in strict lower triangle c------check for previous occurrence of a(vj,vi) 2 lvk = vi kmax = mark(vi) - 1 if (kmax .eq. 0) go to 4 do 3 k=1,kmax lvk = l(lvk) if (v(lvk).eq.vj) go to 5 3 continue c----for unentered entries a(vi,vj) 4 if (sfs.ge.max) go to 101 c c------enter vj in element list for vi mark(vi) = mark(vi) + 1 v(sfs) = vj l(sfs) = l(vi) l(vi) = sfs sfs = sfs+1 c c------enter vi in element list for vj mark(vj) = mark(vj) + 1 v(sfs) = vi l(sfs) = l(vj) l(vj) = sfs sfs = sfs+1 5 continue 6 continue c c----create degree lists and initialize mark vector do 7 vi=1,n dvi = mark(vi) next(vi) = head(dvi) head(dvi) = vi last(vi) = -dvi nextvi = next(vi) if (nextvi.gt.0) last(nextvi) = vi mark(vi) = tag 7 continue c return c c ** error- insufficient storage 101 flag = 9*n + vi return end subroutine mdm * (vk,tail, v,l, last,next, mark) c*********************************************************************** c mdm -- form element from uneliminated neighbors of vk c*********************************************************************** integer vk, tail, v(*), l(*), last(*), next(*), mark(*), * tag, s,ls,vs,es, b,lb,vb, blp,blpmax equivalence (vs, es) c c----initialize tag and list of uneliminated neighbors tag = mark(vk) tail = vk c c----for each vertex/element vs/es in element list of vk ls = l(vk) 1 s = ls if (s.eq.0) go to 5 ls = l(s) vs = v(s) if (next(vs).lt.0) go to 2 c c------if vs is uneliminated vertex, then tag and append to list of c------uneliminated neighbors mark(vs) = tag l(tail) = s tail = s go to 4 c c------if es is active element, then ... c--------for each vertex vb in boundary list of element es 2 lb = l(es) blpmax = last(es) do 3 blp=1,blpmax b = lb lb = l(b) vb = v(b) c c----------if vb is untagged vertex, then tag and append to list of c----------uneliminated neighbors if (mark(vb).ge.tag) go to 3 mark(vb) = tag l(tail) = b tail = b 3 continue c c--------mark es inactive mark(es) = tag c 4 go to 1 c c----terminate list of uneliminated neighbors 5 l(tail) = 0 c return end subroutine mdp * (k,ek,tail, v,l, head,last,next, mark) c*********************************************************************** c mdp -- purge inactive elements and do mass elimination c*********************************************************************** integer ek, tail, v(*), l(*), head(*), last(*), next(*), * mark(*), tag, free, li,vi,lvi,evi, s,ls,es, ilp,ilpmax c c----initialize tag tag = mark(ek) c c----for each vertex vi in ek li = ek ilpmax = last(ek) if (ilpmax.le.0) go to 12 do 11 ilp=1,ilpmax i = li li = l(i) vi = v(li) c c------remove vi from degree list if (last(vi).eq.0) go to 3 if (last(vi).gt.0) go to 1 head(-last(vi)) = next(vi) go to 2 1 next(last(vi)) = next(vi) 2 if (next(vi).gt.0) last(next(vi)) = last(vi) c c------remove inactive items from element list of vi 3 ls = vi 4 s = ls ls = l(s) if (ls.eq.0) go to 6 es = v(ls) if (mark(es).lt.tag) go to 5 free = ls l(s) = l(ls) ls = s 5 go to 4 c c------if vi is interior vertex, then remove from list and eliminate 6 lvi = l(vi) if (lvi.ne.0) go to 7 l(i) = l(li) li = i c k = k+1 next(vi) = -k last(ek) = last(ek) - 1 go to 11 c c------else ... c--------classify vertex vi 7 if (l(lvi).ne.0) go to 9 evi = v(lvi) if (next(evi).ge.0) go to 9 if (mark(evi).lt.0) go to 8 c c----------if vi is prototype vertex, then mark as such, initialize c----------overlap count for corresponding element, and move vi to end c----------of boundary list last(vi) = evi mark(evi) = -1 l(tail) = li tail = li l(i) = l(li) li = i go to 10 c c----------else if vi is duplicate vertex, then mark as such and adjust c----------overlap count for corresponding element 8 last(vi) = 0 mark(evi) = mark(evi) - 1 go to 10 c c----------else mark vi to compute degree 9 last(vi) = -ek c c--------insert ek in element list of vi 10 v(free) = ek l(free) = l(vi) l(vi) = free 11 continue c c----terminate boundary list 12 l(tail) = 0 c return end subroutine mdu * (ek,dmin, v,l, head,last,next, mark) c*********************************************************************** c mdu -- update degrees of uneliminated vertices in ek c*********************************************************************** integer ek, dmin, v(*), l(*), head(*), last(*), next(*), * mark(*), tag, vi,evi,dvi, s,vs,es, b,vb, ilp,ilpmax, * blp,blpmax equivalence (vs, es) c c----initialize tag tag = mark(ek) - last(ek) c c----for each vertex vi in ek i = ek ilpmax = last(ek) if (ilpmax.le.0) go to 11 do 10 ilp=1,ilpmax i = l(i) vi = v(i) if (last(vi) .LT. 0) then goto 1 else if (last(vi) .EQ. 0) then goto 10 else if (last(vi) .GT. 0) then goto 8 endif c if (last(vi)) 1, 10, 8 c c------if vi neither prototype nor duplicate vertex, then merge elements c------to compute degree 1 tag = tag + 1 dvi = last(ek) c c--------for each vertex/element vs/es in element list of vi s = l(vi) 2 s = l(s) if (s.eq.0) go to 9 vs = v(s) if (next(vs).lt.0) go to 3 c c----------if vs is uneliminated vertex, then tag and adjust degree mark(vs) = tag dvi = dvi + 1 go to 5 c c----------if es is active element, then expand c------------check for outmatched vertex 3 if (mark(es).lt.0) go to 6 c c------------for each vertex vb in es b = es blpmax = last(es) do 4 blp=1,blpmax b = l(b) vb = v(b) c c--------------if vb is untagged, then tag and adjust degree if (mark(vb).ge.tag) go to 4 mark(vb) = tag dvi = dvi + 1 4 continue c 5 go to 2 c c------else if vi is outmatched vertex, then adjust overlaps but do not c------compute degree 6 last(vi) = 0 mark(es) = mark(es) - 1 7 s = l(s) if (s.eq.0) go to 10 es = v(s) if (mark(es).lt.0) mark(es) = mark(es) - 1 go to 7 c c------else if vi is prototype vertex, then calculate degree by c------inclusion/exclusion and reset overlap count 8 evi = last(vi) dvi = last(ek) + last(evi) + mark(evi) mark(evi) = 0 c c------insert vi in appropriate degree list 9 next(vi) = head(dvi) head(dvi) = vi last(vi) = -dvi if (next(vi).gt.0) last(next(vi)) = vi if (dvi.lt.dmin) dmin = dvi c 10 continue c 11 return end subroutine sro * (n, ip, ia,ja,a, q, r, dflag) c*********************************************************************** c sro -- symmetric reordering of sparse symmetric matrix c*********************************************************************** c c description c c the nonzero entries of the matrix m are assumed to be stored c symmetrically in (ia,ja,a) format (i.e., not both m(i,j) and m(j,i) c are stored if i ne j). c c sro does not rearrange the order of the rows, but does move c nonzeroes from one row to another to ensure that if m(i,j) will be c in the upper triangle of m with respect to the new ordering, then c m(i,j) is stored in row i (and thus m(j,i) is not stored), whereas c if m(i,j) will be in the strict lower triangle of m, then m(j,i) is c stored in row j (and thus m(i,j) is not stored). c c c additional parameters c c q - integer one-dimensional work array. dimension = n c c r - integer one-dimensional work array. dimension = number of c nonzero entries in the upper triangle of m c c dflag - logical variable. if dflag = .true., then store nonzero c diagonal elements at the beginning of the row c c----------------------------------------------------------------------- c integer ip(*), ia(*), ja(*), q(*), r(*) c... real a(*), ak double precision a(*), ak logical dflag c c c--phase 1 -- find row in which to store each nonzero c----initialize count of nonzeroes to be stored in each row do 1 i=1,n q(i) = 0 1 continue c c----for each nonzero element a(j) do 3 i=1,n jmin = ia(i) jmax = ia(i+1) - 1 if (jmin.gt.jmax) go to 3 do 2 j=jmin,jmax c c--------find row (=r(j)) and column (=ja(j)) in which to store a(j) ... k = ja(j) if (ip(k).lt.ip(i)) ja(j) = i if (ip(k).ge.ip(i)) k = i r(j) = k c c--------... and increment count of nonzeroes (=q(r(j)) in that row q(k) = q(k) + 1 2 continue 3 continue c c c--phase 2 -- find new ia and permutation to apply to (ja,a) c----determine pointers to delimit rows in permuted (ja,a) do 4 i=1,n ia(i+1) = ia(i) + q(i) q(i) = ia(i+1) 4 continue c c----determine where each (ja(j),a(j)) is stored in permuted (ja,a) c----for each nonzero element (in reverse order) ilast = 0 jmin = ia(1) jmax = ia(n+1) - 1 j = jmax do 6 jdummy=jmin,jmax i = r(j) if (.not.dflag .or. ja(j).ne.i .or. i.eq.ilast) go to 5 c c------if dflag, then put diagonal nonzero at beginning of row r(j) = ia(i) ilast = i go to 6 c c------put (off-diagonal) nonzero in last unused location in row 5 q(i) = q(i) - 1 r(j) = q(i) c j = j-1 6 continue c c c--phase 3 -- permute (ja,a) to upper triangular form (wrt new ordering) do 8 j=jmin,jmax 7 if (r(j).eq.j) go to 8 k = r(j) r(j) = r(k) r(k) = k jak = ja(k) ja(k) = ja(j) ja(j) = jak ak = a(k) a(k) = a(j) a(j) = ak go to 7 8 continue c return end *DECK CDRV subroutine cdrv * (n, r,c,ic, ia,ja,a, b, z, nsp,isp,rsp,esp, path, flag) c*** subroutine cdrv c*** driver for subroutines for solving sparse nonsymmetric systems of c linear equations (compressed pointer storage) c c c parameters c class abbreviations are-- c n - integer variable c f - real variable c v - supplies a value to the driver c r - returns a result from the driver c i - used internally by the driver c a - array c c class - parameter c ------+---------- c - c the nonzero entries of the coefficient matrix m are stored c row-by-row in the array a. to identify the individual nonzero c entries in each row, we need to know in which column each entry c lies. the column indices which correspond to the nonzero entries c of m are stored in the array ja. i.e., if a(k) = m(i,j), then c ja(k) = j. in addition, we need to know where each row starts and c how long it is. the index positions in ja and a where the rows of c m begin are stored in the array ia. i.e., if m(i,j) is the first c nonzero entry (stored) in the i-th row and a(k) = m(i,j), then c ia(i) = k. moreover, the index in ja and a of the first location c following the last element in the last row is stored in ia(n+1). c thus, the number of entries in the i-th row is given by c ia(i+1) - ia(i), the nonzero entries of the i-th row are stored c consecutively in c a(ia(i)), a(ia(i)+1), ..., a(ia(i+1)-1), c and the corresponding column indices are stored consecutively in c ja(ia(i)), ja(ia(i)+1), ..., ja(ia(i+1)-1). c for example, the 5 by 5 matrix c ( 1. 0. 2. 0. 0.) c ( 0. 3. 0. 0. 0.) c m = ( 0. 4. 5. 6. 0.) c ( 0. 0. 0. 7. 0.) c ( 0. 0. 0. 8. 9.) c would be stored as c - 1 2 3 4 5 6 7 8 9 c ---+-------------------------- c ia - 1 3 4 7 8 10 c ja - 1 3 2 2 3 4 4 4 5 c a - 1. 2. 3. 4. 5. 6. 7. 8. 9. . c c nv - n - number of variables/equations. c fva - a - nonzero entries of the coefficient matrix m, stored c - by rows. c - size = number of nonzero entries in m. c nva - ia - pointers to delimit the rows in a. c - size = n+1. c nva - ja - column numbers corresponding to the elements of a. c - size = size of a. c fva - b - right-hand side b. b and z can the same array. c - size = n. c fra - z - solution x. b and z can be the same array. c - size = n. c c the rows and columns of the original matrix m can be c reordered (e.g., to reduce fillin or ensure numerical stability) c before calling the driver. if no reordering is done, then set c r(i) = c(i) = ic(i) = i for i=1,...,n. the solution z is returned c in the original order. c if the columns have been reordered (i.e., c(i).ne.i for some c i), then the driver will call a subroutine (nroc) which rearranges c each row of ja and a, leaving the rows in the original order, but c placing the elements of each row in increasing order with respect c to the new ordering. if path.ne.1, then nroc is assumed to have c been called already. c c nva - r - ordering of the rows of m. c - size = n. c nva - c - ordering of the columns of m. c - size = n. c nva - ic - inverse of the ordering of the columns of m. i.e., c - ic(c(i)) = i for i=1,...,n. c - size = n. c c the solution of the system of linear equations is divided into c three stages -- c nsfc -- the matrix m is processed symbolically to determine where c fillin will occur during the numeric factorization. c nnfc -- the matrix m is factored numerically into the product ldu c of a unit lower triangular matrix l, a diagonal matrix c d, and a unit upper triangular matrix u, and the system c mx = b is solved. c nnsc -- the linear system mx = b is solved using the ldu c or factorization from nnfc. c nntc -- the transposed linear system mt x = b is solved using c the ldu factorization from nnf. c for several systems whose coefficient matrices have the same c nonzero structure, nsfc need be done only once (for the first c system). then nnfc is done once for each additional system. for c several systems with the same coefficient matrix, nsfc and nnfc c need be done only once (for the first system). then nnsc or nntc c is done once for each additional right-hand side. c c nv - path - path specification. values and their meanings are -- c - 1 perform nroc, nsfc, and nnfc. c - 2 perform nnfc only (nsfc is assumed to have been c - done in a manner compatible with the storage c - allocation used in the driver). c - 3 perform nnsc only (nsfc and nnfc are assumed to c - have been done in a manner compatible with the c - storage allocation used in the driver). c - 4 perform nntc only (nsfc and nnfc are assumed to c - have been done in a manner compatible with the c - storage allocation used in the driver). c - 5 perform nroc and nsfc. c c various errors are detected by the driver and the individual c subroutines. c c nr - flag - error flag. values and their meanings are -- c - 0 no errors detected c - n+k null row in a -- row = k c - 2n+k duplicate entry in a -- row = k c - 3n+k insufficient storage in nsfc -- row = k c - 4n+1 insufficient storage in nnfc c - 5n+k null pivot -- row = k c - 6n+k insufficient storage in nsfc -- row = k c - 7n+1 insufficient storage in nnfc c - 8n+k zero pivot -- row = k c - 10n+1 insufficient storage in cdrv c - 11n+1 illegal path specification c c working storage is needed for the factored form of the matrix c m plus various temporary vectors. the arrays isp and rsp should be c equivalenced. integer storage is allocated from the beginning of c isp and real storage from the end of rsp. c c nv - nsp - declared dimension of rsp. nsp generally must c - be larger than 8n+2 + 2k (where k = (number of c - nonzero entries in m)). c nvira - isp - integer working storage divided up into various arrays c - needed by the subroutines. isp and rsp should be c - equivalenced. c - size = lratio*nsp. c fvira - rsp - real working storage divided up into various arrays c - needed by the subroutines. isp and rsp should be c - equivalenced. c - size = nsp. c nr - esp - if sufficient storage was available to perform the c - symbolic factorization (nsfc), then esp is set to c - the amount of excess storage provided (negative if c - insufficient storage was available to perform the c - numeric factorization (nnfc)). c c c conversion to double precision c c to convert these routines for double precision arrays.. c (1) use the double precision declarations in place of the real c declarations in each subprogram, as given in comment cards. c (2) change the data-loaded value of the integer lratio c in subroutine cdrv, as indicated below. c (3) change e0 to d0 in the constants in statement number 10 c in subroutine nnfc and the line following that. c integer r(*), c(*), ic(*), ia(*), ja(*), isp(*), esp, path, * flag, d, u, q, row, tmp, ar, umax c real a(*), b(*), z(*), rsp(*) double precision a(*), b(*), z(*), rsp(*) c c set lratio equal to the ratio between the length of floating point c and integer array data. e. g., lratio = 1 for (real, integer), c lratio = 2 for (double precision, integer) c data lratio/2/ c if (path.lt.1 .or. 5.lt.path) go to 111 c******initialize and divide up temporary storage ******************* il = 1 ijl = il + (n+1) iu = ijl + n iju = iu + (n+1) irl = iju + n jrl = irl + n jl = jrl + n c c ****** reorder a if necessary, call nsfc if flag is set *********** if ((path-1) * (path-5) .ne. 0) go to 5 max = (lratio*nsp + 1 - jl) - (n+1) - 5*n jlmax = max/2 q = jl + jlmax ira = q + (n+1) jra = ira + n irac = jra + n iru = irac + n jru = iru + n jutmp = jru + n jumax = lratio*nsp + 1 - jutmp esp = max/lratio if (jlmax.le.0 .or. jumax.le.0) go to 110 c do 1 i=1,n if (c(i).ne.i) go to 2 1 continue go to 3 2 ar = nsp + 1 - n call nroc * (n, ic, ia,ja,a, isp(il), rsp(ar), isp(iu), flag) if (flag.ne.0) go to 100 c 3 call nsfc * (n, r, ic, ia,ja, * jlmax, isp(il), isp(jl), isp(ijl), * jumax, isp(iu), isp(jutmp), isp(iju), * isp(q), isp(ira), isp(jra), isp(irac), * isp(irl), isp(jrl), isp(iru), isp(jru), flag) if(flag .ne. 0) go to 100 c ****** move ju next to jl ***************************************** jlmax = isp(ijl+n-1) ju = jl + jlmax jumax = isp(iju+n-1) if (jumax.le.0) go to 5 do 4 j=1,jumax isp(ju+j-1) = isp(jutmp+j-1) 4 continue c c ****** call remaining subroutines ********************************* 5 jlmax = isp(ijl+n-1) ju = jl + jlmax jumax = isp(iju+n-1) l = (ju + jumax - 2 + lratio) / lratio + 1 lmax = isp(il+n) - 1 d = l + lmax u = d + n row = nsp + 1 - n tmp = row - n umax = tmp - u esp = umax - (isp(iu+n) - 1) c if ((path-1) * (path-2) .ne. 0) go to 6 if (umax.lt.0) go to 110 call nnfc * (n, r, c, ic, ia, ja, a, z, b, * lmax, isp(il), isp(jl), isp(ijl), rsp(l), rsp(d), * umax, isp(iu), isp(ju), isp(iju), rsp(u), * rsp(row), rsp(tmp), isp(irl), isp(jrl), flag) if(flag .ne. 0) go to 100 c 6 if ((path-3) .ne. 0) go to 7 call nnsc * (n, r, c, isp(il), isp(jl), isp(ijl), rsp(l), * rsp(d), isp(iu), isp(ju), isp(iju), rsp(u), * z, b, rsp(tmp)) c 7 if ((path-4) .ne. 0) go to 8 call nntc * (n, r, c, isp(il), isp(jl), isp(ijl), rsp(l), * rsp(d), isp(iu), isp(ju), isp(iju), rsp(u), * z, b, rsp(tmp)) 8 return c c ** error.. error detected in nroc, nsfc, nnfc, or nnsc 100 return c ** error.. insufficient storage 110 flag = 10*n + 1 return c ** error.. illegal path specification 111 flag = 11*n + 1 return end subroutine nroc (n, ic, ia, ja, a, jar, ar, p, flag) c c ---------------------------------------------------------------- c c yale sparse matrix package - nonsymmetric codes c solving the system of equations mx = b c c i. calling sequences c the coefficient matrix can be processed by an ordering routine c (e.g., to reduce fillin or ensure numerical stability) before using c the remaining subroutines. if no reordering is done, then set c r(i) = c(i) = ic(i) = i for i=1,...,n. if an ordering subroutine c is used, then nroc should be used to reorder the coefficient matrix c the calling sequence is -- c ( (matrix ordering)) c (nroc (matrix reordering)) c nsfc (symbolic factorization to determine where fillin will c occur during numeric factorization) c nnfc (numeric factorization into product ldu of unit lower c triangular matrix l, diagonal matrix d, and unit c upper triangular matrix u, and solution of linear c system) c nnsc (solution of linear system for additional right-hand c side using ldu factorization from nnfc) c (if only one system of equations is to be solved, then the c subroutine trk should be used.) c c ii. storage of sparse matrices c the nonzero entries of the coefficient matrix m are stored c row-by-row in the array a. to identify the individual nonzero c entries in each row, we need to know in which column each entry c lies. the column indices which correspond to the nonzero entries c of m are stored in the array ja. i.e., if a(k) = m(i,j), then c ja(k) = j. in addition, we need to know where each row starts and c how long it is. the index positions in ja and a where the rows of c m begin are stored in the array ia. i.e., if m(i,j) is the first c (leftmost) entry in the i-th row and a(k) = m(i,j), then c ia(i) = k. moreover, the index in ja and a of the first location c following the last element in the last row is stored in ia(n+1). c thus, the number of entries in the i-th row is given by c ia(i+1) - ia(i), the nonzero entries of the i-th row are stored c consecutively in c a(ia(i)), a(ia(i)+1), ..., a(ia(i+1)-1), c and the corresponding column indices are stored consecutively in c ja(ia(i)), ja(ia(i)+1), ..., ja(ia(i+1)-1). c for example, the 5 by 5 matrix c ( 1. 0. 2. 0. 0.) c ( 0. 3. 0. 0. 0.) c m = ( 0. 4. 5. 6. 0.) c ( 0. 0. 0. 7. 0.) c ( 0. 0. 0. 8. 9.) c would be stored as c - 1 2 3 4 5 6 7 8 9 c ---+-------------------------- c ia - 1 3 4 7 8 10 c ja - 1 3 2 2 3 4 4 4 5 c a - 1. 2. 3. 4. 5. 6. 7. 8. 9. . c c the strict upper (lower) triangular portion of the matrix c u (l) is stored in a similar fashion using the arrays iu, ju, u c (il, jl, l) except that an additional array iju (ijl) is used to c compress storage of ju (jl) by allowing some sequences of column c (row) indices to used for more than one row (column) (n.b., l is c stored by columns). iju(k) (ijl(k)) points to the starting c location in ju (jl) of entries for the kth row (column). c compression in ju (jl) occurs in two ways. first, if a row c (column) i was merged into the current row (column) k, and the c number of elements merged in from (the tail portion of) row c (column) i is the same as the final length of row (column) k, then c the kth row (column) and the tail of row (column) i are identical c and iju(k) (ijl(k)) points to the start of the tail. second, if c some tail portion of the (k-1)st row (column) is identical to the c head of the kth row (column), then iju(k) (ijl(k)) points to the c start of that tail portion. for example, the nonzero structure of c the strict upper triangular part of the matrix c d 0 x x x c 0 d 0 x x c 0 0 d x 0 c 0 0 0 d x c 0 0 0 0 d c would be represented as c - 1 2 3 4 5 6 c ----+------------ c iu - 1 4 6 7 8 8 c ju - 3 4 5 4 c iju - 1 2 4 3 . c the diagonal entries of l and u are assumed to be equal to one and c are not stored. the array d contains the reciprocals of the c diagonal entries of the matrix d. c c iii. additional storage savings c in nsfc, r and ic can be the same array in the calling c sequence if no reordering of the coefficient matrix has been done. c in nnfc, r, c, and ic can all be the same array if no c reordering has been done. if only the rows have been reordered, c then c and ic can be the same array. if the row and column c orderings are the same, then r and c can be the same array. z and c row can be the same array. c in nnsc or nntc, r and c can be the same array if no c reordering has been done or if the row and column orderings are the c same. z and b can be the same array. however, then b will be c destroyed. c c iv. parameters c following is a list of parameters to the programs. names are c uniform among the various subroutines. class abbreviations are -- c n - integer variable c f - real variable c v - supplies a value to a subroutine c r - returns a result from a subroutine c i - used internally by a subroutine c a - array c c class - parameter c ------+---------- c fva - a - nonzero entries of the coefficient matrix m, stored c - by rows. c - size = number of nonzero entries in m. c fva - b - right-hand side b. c - size = n. c nva - c - ordering of the columns of m. c - size = n. c fvra - d - reciprocals of the diagonal entries of the matrix d. c - size = n. c nr - flag - error flag. values and their meanings are -- c - 0 no errors detected c - n+k null row in a -- row = k c - 2n+k duplicate entry in a -- row = k c - 3n+k insufficient storage for jl -- row = k c - 4n+1 insufficient storage for l c - 5n+k null pivot -- row = k c - 6n+k insufficient storage for ju -- row = k c - 7n+1 insufficient storage for u c - 8n+k zero pivot -- row = k c nva - ia - pointers to delimit the rows of a. c - size = n+1. c nvra - ijl - pointers to the first element in each column in jl, c - used to compress storage in jl. c - size = n. c nvra - iju - pointers to the first element in each row in ju, used c - to compress storage in ju. c - size = n. c nvra - il - pointers to delimit the columns of l. c - size = n+1. c nvra - iu - pointers to delimit the rows of u. c - size = n+1. c nva - ja - column numbers corresponding to the elements of a. c - size = size of a. c nvra - jl - row numbers corresponding to the elements of l. c - size = jlmax. c nv - jlmax - declared dimension of jl. jlmax must be larger than c - the number of nonzeros in the strict lower triangle c - of m plus fillin minus compression. c nvra - ju - column numbers corresponding to the elements of u. c - size = jumax. c nv - jumax - declared dimension of ju. jumax must be larger than c - the number of nonzeros in the strict upper triangle c - of m plus fillin minus compression. c fvra - l - nonzero entries in the strict lower triangular portion c - of the matrix l, stored by columns. c - size = lmax. c nv - lmax - declared dimension of l. lmax must be larger than c - the number of nonzeros in the strict lower triangle c - of m plus fillin (il(n+1)-1 after nsfc). c nv - n - number of variables/equations. c nva - r - ordering of the rows of m. c - size = n. c fvra - u - nonzero entries in the strict upper triangular portion c - of the matrix u, stored by rows. c - size = umax. c nv - umax - declared dimension of u. umax must be larger than c - the number of nonzeros in the strict upper triangle c - of m plus fillin (iu(n+1)-1 after nsfc). c fra - z - solution x. c - size = n. c c ---------------------------------------------------------------- c c*** subroutine nroc c*** reorders rows of a, leaving row order unchanged c c c input parameters.. n, ic, ia, ja, a c output parameters.. ja, a, flag c c parameters used internally.. c nia - p - at the kth step, p is a linked list of the reordered c - column indices of the kth row of a. p(n+1) points c - to the first entry in the list. c - size = n+1. c nia - jar - at the kth step,jar contains the elements of the c - reordered column indices of a. c - size = n. c fia - ar - at the kth step, ar contains the elements of the c - reordered row of a. c - size = n. c integer ic(*), ia(*), ja(*), jar(*), p(*), flag c real a(*), ar(*) double precision a(*), ar(*) c c ****** for each nonempty row ******************************* do 5 k=1,n jmin = ia(k) jmax = ia(k+1) - 1 if(jmin .gt. jmax) go to 5 p(n+1) = n + 1 c ****** insert each element in the list ********************* do 3 j=jmin,jmax newj = ic(ja(j)) i = n + 1 1 if(p(i) .ge. newj) go to 2 i = p(i) go to 1 2 if(p(i) .eq. newj) go to 102 p(newj) = p(i) p(i) = newj jar(newj) = ja(j) ar(newj) = a(j) 3 continue c ****** replace old row in ja and a ************************* i = n + 1 do 4 j=jmin,jmax i = p(i) ja(j) = jar(i) a(j) = ar(i) 4 continue 5 continue flag = 0 return c c ** error.. duplicate entry in a 102 flag = n + k return end subroutine nsfc * (n, r, ic, ia,ja, jlmax,il,jl,ijl, jumax,iu,ju,iju, * q, ira,jra, irac, irl,jrl, iru,jru, flag) c*** subroutine nsfc c*** symbolic ldu-factorization of nonsymmetric sparse matrix c (compressed pointer storage) c c c input variables.. n, r, ic, ia, ja, jlmax, jumax. c output variables.. il, jl, ijl, iu, ju, iju, flag. c c parameters used internally.. c nia - q - suppose m* is the result of reordering m. if c - processing of the ith row of m* (hence the ith c - row of u) is being done, q(j) is initially c - nonzero if m*(i,j) is nonzero (j.ge.i). since c - values need not be stored, each entry points to the c - next nonzero and q(n+1) points to the first. n+1 c - indicates the end of the list. for example, if n=9 c - and the 5th row of m* is c - 0 x x 0 x 0 0 x 0 c - then q will initially be c - a a a a 8 a a 10 5 (a - arbitrary). c - as the algorithm proceeds, other elements of q c - are inserted in the list because of fillin. c - q is used in an analogous manner to compute the c - ith column of l. c - size = n+1. c nia - ira, - vectors used to find the columns of m. at the kth c nia - jra, step of the factorization, irac(k) points to the c nia - irac head of a linked list in jra of row indices i c - such that i .ge. k and m(i,k) is nonzero. zero c - indicates the end of the list. ira(i) (i.ge.k) c - points to the smallest j such that j .ge. k and c - m(i,j) is nonzero. c - size of each = n. c nia - irl, - vectors used to find the rows of l. at the kth step c nia - jrl of the factorization, jrl(k) points to the head c - of a linked list in jrl of column indices j c - such j .lt. k and l(k,j) is nonzero. zero c - indicates the end of the list. irl(j) (j.lt.k) c - points to the smallest i such that i .ge. k and c - l(i,j) is nonzero. c - size of each = n. c nia - iru, - vectors used in a manner analogous to irl and jrl c nia - jru to find the columns of u. c - size of each = n. c c internal variables.. c jlptr - points to the last position used in jl. c juptr - points to the last position used in ju. c jmin,jmax - are the indices in a or u of the first and last c elements to be examined in a given row. c for example, jmin=ia(k), jmax=ia(k+1)-1. c integer cend, qm, rend, rk, vj integer ia(*), ja(*), ira(*), jra(*), il(*), jl(*), ijl(*) integer iu(*), ju(*), iju(*), irl(*), jrl(*), iru(*), jru(*) integer r(*), ic(*), q(*), irac(*), flag c c ****** initialize pointers **************************************** np1 = n + 1 jlmin = 1 jlptr = 0 il(1) = 1 jumin = 1 juptr = 0 iu(1) = 1 do 1 k=1,n irac(k) = 0 jra(k) = 0 jrl(k) = 0 jru(k) = 0 1 continue c ****** initialize column pointers for a *************************** do 2 k=1,n rk = r(k) iak = ia(rk) if (iak .ge. ia(rk+1)) go to 101 jaiak = ic(ja(iak)) if (jaiak .gt. k) go to 105 jra(k) = irac(jaiak) irac(jaiak) = k ira(k) = iak 2 continue c c ****** for each column of l and row of u ************************** do 41 k=1,n c c ****** initialize q for computing kth column of l ***************** q(np1) = np1 luk = -1 c ****** by filling in kth column of a ****************************** vj = irac(k) if (vj .eq. 0) go to 5 3 qm = np1 4 m = qm qm = q(m) if (qm .lt. vj) go to 4 if (qm .eq. vj) go to 102 luk = luk + 1 q(m) = vj q(vj) = qm vj = jra(vj) if (vj .ne. 0) go to 3 c ****** link through jru ******************************************* 5 lastid = 0 lasti = 0 ijl(k) = jlptr i = k 6 i = jru(i) if (i .eq. 0) go to 10 qm = np1 jmin = irl(i) jmax = ijl(i) + il(i+1) - il(i) - 1 long = jmax - jmin if (long .lt. 0) go to 6 jtmp = jl(jmin) if (jtmp .ne. k) long = long + 1 if (jtmp .eq. k) r(i) = -r(i) if (lastid .ge. long) go to 7 lasti = i lastid = long c ****** and merge the corresponding columns into the kth column **** 7 do 9 j=jmin,jmax vj = jl(j) 8 m = qm qm = q(m) if (qm .lt. vj) go to 8 if (qm .eq. vj) go to 9 luk = luk + 1 q(m) = vj q(vj) = qm qm = vj 9 continue go to 6 c ****** lasti is the longest column merged into the kth ************ c ****** see if it equals the entire kth column ********************* 10 qm = q(np1) if (qm .ne. k) go to 105 if (luk .eq. 0) go to 17 if (lastid .ne. luk) go to 11 c ****** if so, jl can be compressed ******************************** irll = irl(lasti) ijl(k) = irll + 1 if (jl(irll) .ne. k) ijl(k) = ijl(k) - 1 go to 17 c ****** if not, see if kth column can overlap the previous one ***** 11 if (jlmin .gt. jlptr) go to 15 qm = q(qm) do 12 j=jlmin,jlptr if (jl(j) - qm .LT. 0) then goto 12 else if (jl(j) - qm .EQ. 0) then goto 13 else goto 15 endif c if (jl(j) - qm) 12, 13, 15 12 continue go to 15 13 ijl(k) = j do 14 i=j,jlptr if (jl(i) .ne. qm) go to 15 qm = q(qm) if (qm .gt. n) go to 17 14 continue jlptr = j - 1 c ****** move column indices from q to jl, update vectors *********** 15 jlmin = jlptr + 1 ijl(k) = jlmin if (luk .eq. 0) go to 17 jlptr = jlptr + luk if (jlptr .gt. jlmax) go to 103 qm = q(np1) do 16 j=jlmin,jlptr qm = q(qm) jl(j) = qm 16 continue 17 irl(k) = ijl(k) il(k+1) = il(k) + luk c c ****** initialize q for computing kth row of u ******************** q(np1) = np1 luk = -1 c ****** by filling in kth row of reordered a *********************** rk = r(k) jmin = ira(k) jmax = ia(rk+1) - 1 if (jmin .gt. jmax) go to 20 do 19 j=jmin,jmax vj = ic(ja(j)) qm = np1 18 m = qm qm = q(m) if (qm .lt. vj) go to 18 if (qm .eq. vj) go to 102 luk = luk + 1 q(m) = vj q(vj) = qm 19 continue c ****** link through jrl, ****************************************** 20 lastid = 0 lasti = 0 iju(k) = juptr i = k i1 = jrl(k) 21 i = i1 if (i .eq. 0) go to 26 i1 = jrl(i) qm = np1 jmin = iru(i) jmax = iju(i) + iu(i+1) - iu(i) - 1 long = jmax - jmin if (long .lt. 0) go to 21 jtmp = ju(jmin) if (jtmp .eq. k) go to 22 c ****** update irl and jrl, ***************************************** long = long + 1 cend = ijl(i) + il(i+1) - il(i) irl(i) = irl(i) + 1 if (irl(i) .ge. cend) go to 22 j = jl(irl(i)) jrl(i) = jrl(j) jrl(j) = i 22 if (lastid .ge. long) go to 23 lasti = i lastid = long c ****** and merge the corresponding rows into the kth row ********** 23 do 25 j=jmin,jmax vj = ju(j) 24 m = qm qm = q(m) if (qm .lt. vj) go to 24 if (qm .eq. vj) go to 25 luk = luk + 1 q(m) = vj q(vj) = qm qm = vj 25 continue go to 21 c ****** update jrl(k) and irl(k) *********************************** 26 if (il(k+1) .le. il(k)) go to 27 j = jl(irl(k)) jrl(k) = jrl(j) jrl(j) = k c ****** lasti is the longest row merged into the kth *************** c ****** see if it equals the entire kth row ************************ 27 qm = q(np1) if (qm .ne. k) go to 105 if (luk .eq. 0) go to 34 if (lastid .ne. luk) go to 28 c ****** if so, ju can be compressed ******************************** irul = iru(lasti) iju(k) = irul + 1 if (ju(irul) .ne. k) iju(k) = iju(k) - 1 go to 34 c ****** if not, see if kth row can overlap the previous one ******** 28 if (jumin .gt. juptr) go to 32 qm = q(qm) do 29 j=jumin,juptr if (ju(j) - qm .LT. 0) then goto 29 else if (ju(j) - qm .EQ. 0) then goto 30 else if (ju(j) - qm .GT. 0) then goto 32 endif C if (ju(j) - qm) 29, 30, 32 29 continue go to 32 30 iju(k) = j do 31 i=j,juptr if (ju(i) .ne. qm) go to 32 qm = q(qm) if (qm .gt. n) go to 34 31 continue juptr = j - 1 c ****** move row indices from q to ju, update vectors ************** 32 jumin = juptr + 1 iju(k) = jumin if (luk .eq. 0) go to 34 juptr = juptr + luk if (juptr .gt. jumax) go to 106 qm = q(np1) do 33 j=jumin,juptr qm = q(qm) ju(j) = qm 33 CONTINUE 34 iru(k) = iju(k) iu(k+1) = iu(k) + luk c c ****** update iru, jru ******************************************** i = k 35 i1 = jru(i) if (r(i) .lt. 0) go to 36 rend = iju(i) + iu(i+1) - iu(i) if (iru(i) .ge. rend) go to 37 j = ju(iru(i)) jru(i) = jru(j) jru(j) = i go to 37 36 r(i) = -r(i) 37 i = i1 if (i .eq. 0) go to 38 iru(i) = iru(i) + 1 go to 35 c c ****** update ira, jra, irac ************************************** 38 i = irac(k) if (i .eq. 0) go to 41 39 i1 = jra(i) ira(i) = ira(i) + 1 if (ira(i) .ge. ia(r(i)+1)) go to 40 irai = ira(i) jairai = ic(ja(irai)) if (jairai .gt. i) go to 40 jra(i) = irac(jairai) irac(jairai) = i 40 i = i1 if (i .ne. 0) go to 39 41 continue c ijl(n) = jlptr iju(n) = juptr flag = 0 return c c ** error.. null row in a 101 flag = n + rk return c ** error.. duplicate entry in a 102 flag = 2*n + rk return c ** error.. insufficient storage for jl 103 flag = 3*n + k return c ** error.. null pivot 105 flag = 5*n + k return c ** error.. insufficient storage for ju 106 flag = 6*n + k return end subroutine nnfc * (n, r,c,ic, ia,ja,a, z, b, * lmax,il,jl,ijl,l, d, umax,iu,ju,iju,u, * row, tmp, irl,jrl, flag) c*** subroutine nnfc c*** numerical ldu-factorization of sparse nonsymmetric matrix and c solution of system of linear equations (compressed pointer c storage) c c c input variables.. n, r, c, ic, ia, ja, a, b, c il, jl, ijl, lmax, iu, ju, iju, umax c output variables.. z, l, d, u, flag c c parameters used internally.. c nia - irl, - vectors used to find the rows of l. at the kth step c nia - jrl of the factorization, jrl(k) points to the head c - of a linked list in jrl of column indices j c - such j .lt. k and l(k,j) is nonzero. zero c - indicates the end of the list. irl(j) (j.lt.k) c - points to the smallest i such that i .ge. k and c - l(i,j) is nonzero. c - size of each = n. c fia - row - holds intermediate values in calculation of u and l. c - size = n. c fia - tmp - holds new right-hand side b* for solution of the c - equation ux = b*. c - size = n. c c internal variables.. c jmin, jmax - indices of the first and last positions in a row to c be examined. c sum - used in calculating tmp. c integer rk,umax integer r(*), c(*), ic(*), ia(*), ja(*), il(*), jl(*), ijl(*) integer iu(*), ju(*), iju(*), irl(*), jrl(*), flag c real a(*), l(*), d(*), u(*), z(*), b(*), row(*) c real tmp(*), lki, sum, dk double precision a(*), l(*), d(*), u(*), z(*), b(*), row(*) double precision tmp(*), lki, sum, dk c c ****** initialize pointers and test storage *********************** if(il(n+1)-1 .gt. lmax) go to 104 if(iu(n+1)-1 .gt. umax) go to 107 do 1 k=1,n irl(k) = il(k) jrl(k) = 0 1 continue c c ****** for each row *********************************************** do 19 k=1,n c ****** reverse jrl and zero row where kth row of l will fill in *** row(k) = 0 i1 = 0 if (jrl(k) .eq. 0) go to 3 i = jrl(k) 2 i2 = jrl(i) jrl(i) = i1 i1 = i row(i) = 0 i = i2 if (i .ne. 0) go to 2 c ****** set row to zero where u will fill in *********************** 3 jmin = iju(k) jmax = jmin + iu(k+1) - iu(k) - 1 if (jmin .gt. jmax) go to 5 do 4 j=jmin,jmax row(ju(j)) = 0 4 CONTINUE c ****** place kth row of a in row ********************************** 5 rk = r(k) jmin = ia(rk) jmax = ia(rk+1) - 1 do 6 j=jmin,jmax row(ic(ja(j))) = a(j) 6 continue c ****** initialize sum, and link through jrl *********************** sum = b(rk) i = i1 if (i .eq. 0) go to 10 c ****** assign the kth row of l and adjust row, sum **************** 7 lki = -row(i) c ****** if l is not required, then comment out the following line ** l(irl(i)) = -lki sum = sum + lki * tmp(i) jmin = iu(i) jmax = iu(i+1) - 1 if (jmin .gt. jmax) go to 9 mu = iju(i) - jmin do 8 j=jmin,jmax row(ju(mu+j)) = row(ju(mu+j)) + lki * u(j) 8 CONTINUE 9 i = jrl(i) if (i .ne. 0) go to 7 c c ****** assign kth row of u and diagonal d, set tmp(k) ************* 10 if (row(k) .eq. 0.0d0) go to 108 dk = 1.0d0 / row(k) d(k) = dk tmp(k) = sum * dk if (k .eq. n) go to 19 jmin = iu(k) jmax = iu(k+1) - 1 if (jmin .gt. jmax) go to 12 mu = iju(k) - jmin do 11 j=jmin,jmax u(j) = row(ju(mu+j)) * dk 11 CONTINUE 12 continue c c ****** update irl and jrl, keeping jrl in decreasing order ******** i = i1 if (i .eq. 0) go to 18 14 irl(i) = irl(i) + 1 i1 = jrl(i) if (irl(i) .ge. il(i+1)) go to 17 ijlb = irl(i) - il(i) + ijl(i) j = jl(ijlb) 15 if (i .gt. jrl(j)) go to 16 j = jrl(j) go to 15 16 jrl(i) = jrl(j) jrl(j) = i 17 i = i1 if (i .ne. 0) go to 14 18 if (irl(k) .ge. il(k+1)) go to 19 j = jl(ijl(k)) jrl(k) = jrl(j) jrl(j) = k 19 continue c c ****** solve ux = tmp by back substitution ********************** k = n do 22 i=1,n sum = tmp(k) jmin = iu(k) jmax = iu(k+1) - 1 if (jmin .gt. jmax) go to 21 mu = iju(k) - jmin do 20 j=jmin,jmax sum = sum - u(j) * tmp(ju(mu+j)) 20 CONTINUE 21 tmp(k) = sum z(c(k)) = sum k = k-1 22 CONTINUE flag = 0 return c c ** error.. insufficient storage for l 104 flag = 4*n + 1 return c ** error.. insufficient storage for u 107 flag = 7*n + 1 return c ** error.. zero pivot 108 flag = 8*n + k return end subroutine nnsc * (n, r, c, il, jl, ijl, l, d, iu, ju, iju, u, z, b, tmp) c*** subroutine nnsc c*** numerical solution of sparse nonsymmetric system of linear c equations given ldu-factorization (compressed pointer storage) c c c input variables.. n, r, c, il, jl, ijl, l, d, iu, ju, iju, u, b c output variables.. z c c parameters used internally.. c fia - tmp - temporary vector which gets result of solving ly = b. c - size = n. c c internal variables.. c jmin, jmax - indices of the first and last positions in a row of c u or l to be used. c integer r(*), c(*), il(*), jl(*), ijl(*), iu(*), ju(*), iju(*) c real l(*), d(*), u(*), b(*), z(*), tmp(*), tmpk, sum double precision l(*), d(*), u(*), b(*), z(*), tmp(*), tmpk,sum c c ****** set tmp to reordered b ************************************* do 1 k=1,n tmp(k) = b(r(k)) 1 CONTINUE c ****** solve ly = b by forward substitution ********************* do 3 k=1,n jmin = il(k) jmax = il(k+1) - 1 tmpk = -d(k) * tmp(k) tmp(k) = -tmpk if (jmin .gt. jmax) go to 3 ml = ijl(k) - jmin do 2 j=jmin,jmax tmp(jl(ml+j)) = tmp(jl(ml+j)) + tmpk * l(j) 2 CONTINUE 3 continue c ****** solve ux = y by back substitution ************************ k = n do 6 i=1,n sum = -tmp(k) jmin = iu(k) jmax = iu(k+1) - 1 if (jmin .gt. jmax) go to 5 mu = iju(k) - jmin do 4 j=jmin,jmax sum = sum + u(j) * tmp(ju(mu+j)) 4 CONTINUE 5 tmp(k) = -sum z(c(k)) = -sum k = k - 1 6 continue return end subroutine nntc * (n, r, c, il, jl, ijl, l, d, iu, ju, iju, u, z, b, tmp) c*** subroutine nntc c*** numeric solution of the transpose of a sparse nonsymmetric system c of linear equations given lu-factorization (compressed pointer c storage) c c c input variables.. n, r, c, il, jl, ijl, l, d, iu, ju, iju, u, b c output variables.. z c c parameters used internally.. c fia - tmp - temporary vector which gets result of solving ut y = b c - size = n. c c internal variables.. c jmin, jmax - indices of the first and last positions in a row of c u or l to be used. c integer r(*), c(*), il(*), jl(*), ijl(*), iu(*), ju(*), iju(*) c real l(*), d(*), u(*), b(*), z(*), tmp(*), tmpk,sum double precision l(*), d(*), u(*), b(*), z(*), tmp(*), tmpk,sum c c ****** set tmp to reordered b ************************************* do 1 k=1,n tmp(k) = b(c(k)) 1 CONTINUE c ****** solve ut y = b by forward substitution ******************* do 3 k=1,n jmin = iu(k) jmax = iu(k+1) - 1 tmpk = -tmp(k) if (jmin .gt. jmax) go to 3 mu = iju(k) - jmin do 2 j=jmin,jmax tmp(ju(mu+j)) = tmp(ju(mu+j)) + tmpk * u(j) 2 CONTINUE 3 continue c ****** solve lt x = y by back substitution ********************** k = n do 6 i=1,n sum = -tmp(k) jmin = il(k) jmax = il(k+1) - 1 if (jmin .gt. jmax) go to 5 ml = ijl(k) - jmin do 4 j=jmin,jmax sum = sum + l(j) * tmp(jl(ml+j)) 4 CONTINUE 5 tmp(k) = -sum * d(k) z(r(k)) = tmp(k) k = k - 1 6 continue return end *DECK DSTODA SUBROUTINE DSTODA (NEQ, Y, YH, NYH, YH1, EWT, SAVF, ACOR, 1 WM, IWM, F, JAC, PJAC, SLVS,rpar,ipar) EXTERNAL F, JAC, PJAC, SLVS CKS: added rpar,ipar integer ipar(*) double precision rpar(*) INTEGER NEQ, NYH, IWM DOUBLE PRECISION Y, YH, YH1, EWT, SAVF, ACOR, WM DIMENSION NEQ(*), Y(*), YH(NYH,*), YH1(*), EWT(*), SAVF(*), 1 ACOR(*), WM(*), IWM(*) INTEGER IOWND, IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU INTEGER IOWND2, ICOUNT, IRFLAG, JTYP, MUSED, MXORDN, MXORDS DOUBLE PRECISION CONIT, CRATE, EL, ELCO, HOLD, RMAX, TESCO, 2 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND DOUBLE PRECISION ROWND2, CM1, CM2, PDEST, PDLAST, RATIO, 1 PDNORM COMMON /DLS001/ CONIT, CRATE, EL(13), ELCO(13,12), 1 HOLD, RMAX, TESCO(3,12), 2 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 3 IOWND(6), IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, 4 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 5 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 6 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU COMMON /DLSA01/ ROWND2, CM1(12), CM2(5), PDEST, PDLAST, RATIO, 1 PDNORM, 2 IOWND2(3), ICOUNT, IRFLAG, JTYP, MUSED, MXORDN, MXORDS INTEGER I, I1, IREDO, IRET, J, JB, M, NCF, NEWQ INTEGER LM1, LM1P1, LM2, LM2P1, NQM1, NQM2 DOUBLE PRECISION DCON, DDN, DEL, DELP, DSM, DUP, EXDN, EXSM, EXUP, 1 R, RH, RHDN, RHSM, RHUP, TOLD, DMNORM DOUBLE PRECISION ALPHA, DM1,DM2, EXM1,EXM2, 1 PDH, PNORM, RATE, RH1, RH1IT, RH2, RM, SM1(12) SAVE SM1 DATA SM1/0.5D0, 0.575D0, 0.55D0, 0.45D0, 0.35D0, 0.25D0, 1 0.20D0, 0.15D0, 0.10D0, 0.075D0, 0.050D0, 0.025D0/ C----------------------------------------------------------------------- C DSTODA performs one step of the integration of an initial value C problem for a system of ordinary differential equations. C Note: DSTODA is independent of the value of the iteration method C indicator MITER, when this is .ne. 0, and hence is independent C of the type of chord method used, or the Jacobian structure. C Communication with DSTODA is done with the following variables: C C Y = an array of length .ge. N used as the Y argument in C all calls to F and JAC. C NEQ = integer array containing problem size in NEQ(1), and C passed as the NEQ argument in all calls to F and JAC. C YH = an NYH by LMAX array containing the dependent variables C and their approximate scaled derivatives, where C LMAX = MAXORD + 1. YH(i,j+1) contains the approximate C j-th derivative of y(i), scaled by H**j/factorial(j) C (j = 0,1,...,NQ). On entry for the first step, the first C two columns of YH must be set from the initial values. C NYH = a constant integer .ge. N, the first dimension of YH. C YH1 = a one-dimensional array occupying the same space as YH. C EWT = an array of length N containing multiplicative weights C for local error measurements. Local errors in y(i) are C compared to 1.0/EWT(i) in various error tests. C SAVF = an array of working storage, of length N. C ACOR = a work array of length N, used for the accumulated C corrections. On a successful return, ACOR(i) contains C the estimated one-step local error in y(i). C WM,IWM = real and integer work arrays associated with matrix C operations in chord iteration (MITER .ne. 0). C PJAC = name of routine to evaluate and preprocess Jacobian matrix C and P = I - H*EL0*Jac, if a chord method is being used. C It also returns an estimate of norm(Jac) in PDNORM. C SLVS = name of routine to solve linear system in chord iteration. C CCMAX = maximum relative change in H*EL0 before PJAC is called. C H = the step size to be attempted on the next step. C H is altered by the error control algorithm during the C problem. H can be either positive or negative, but its C sign must remain constant throughout the problem. C HMIN = the minimum absolute value of the step size H to be used. C HMXI = inverse of the maximum absolute value of H to be used. C HMXI = 0.0 is allowed and corresponds to an infinite HMAX. C HMIN and HMXI may be changed at any time, but will not C take effect until the next change of H is considered. C TN = the independent variable. TN is updated on each step taken. C JSTART = an integer used for input only, with the following C values and meanings: C 0 perform the first step. C .gt.0 take a new step continuing from the last. C -1 take the next step with a new value of H, C N, METH, MITER, and/or matrix parameters. C -2 take the next step with a new value of H, C but with other inputs unchanged. C On return, JSTART is set to 1 to facilitate continuation. C KFLAG = a completion code with the following meanings: C 0 the step was succesful. C -1 the requested error could not be achieved. C -2 corrector convergence could not be achieved. C -3 fatal error in PJAC or SLVS. C A return with KFLAG = -1 or -2 means either C ABS(H) = HMIN or 10 consecutive failures occurred. C On a return with KFLAG negative, the values of TN and C the YH array are as of the beginning of the last C step, and H is the last step size attempted. C MAXORD = the maximum order of integration method to be allowed. C MAXCOR = the maximum number of corrector iterations allowed. C MSBP = maximum number of steps between PJAC calls (MITER .gt. 0). C MXNCF = maximum number of convergence failures allowed. C METH = current method. C METH = 1 means Adams method (nonstiff) C METH = 2 means BDF method (stiff) C METH may be reset by DSTODA. C MITER = corrector iteration method. C MITER = 0 means functional iteration. C MITER = JT .gt. 0 means a chord iteration corresponding C to Jacobian type JT. (The DLSODA/DLSODAR argument JT is C communicated here as JTYP, but is not used in DSTODA C except to load MITER following a method switch.) C MITER may be reset by DSTODA. C N = the number of first-order differential equations. C----------------------------------------------------------------------- KFLAG = 0 TOLD = TN NCF = 0 IERPJ = 0 IERSL = 0 JCUR = 0 ICF = 0 DELP = 0.0D0 IF (JSTART .GT. 0) GO TO 200 IF (JSTART .EQ. -1) GO TO 100 IF (JSTART .EQ. -2) GO TO 160 C----------------------------------------------------------------------- C On the first call, the order is set to 1, and other variables are C initialized. RMAX is the maximum ratio by which H can be increased C in a single step. It is initially 1.E4 to compensate for the small C initial H, but then is normally equal to 10. If a failure C occurs (in corrector convergence or error test), RMAX is set at 2 C for the next increase. C DCFODE is called to get the needed coefficients for both methods. C----------------------------------------------------------------------- LMAX = MAXORD + 1 NQ = 1 L = 2 IALTH = 2 RMAX = 10000.0D0 RC = 0.0D0 EL0 = 1.0D0 CRATE = 0.7D0 HOLD = H NSLP = 0 IPUP = MITER IRET = 3 C Initialize switching parameters. METH = 1 is assumed initially. ----- ICOUNT = 20 IRFLAG = 0 PDEST = 0.0D0 PDLAST = 0.0D0 RATIO = 5.0D0 CALL DCFODE (2, ELCO, TESCO) DO 10 I = 1,5 CM2(I) = TESCO(2,I)*ELCO(I+1,I) 10 CONTINUE CALL DCFODE (1, ELCO, TESCO) DO 20 I = 1,12 CM1(I) = TESCO(2,I)*ELCO(I+1,I) 20 CONTINUE GO TO 150 C----------------------------------------------------------------------- C The following block handles preliminaries needed when JSTART = -1. C IPUP is set to MITER to force a matrix update. C If an order increase is about to be considered (IALTH = 1), C IALTH is reset to 2 to postpone consideration one more step. C If the caller has changed METH, DCFODE is called to reset C the coefficients of the method. C If H is to be changed, YH must be rescaled. C If H or METH is being changed, IALTH is reset to L = NQ + 1 C to prevent further changes in H for that many steps. C----------------------------------------------------------------------- 100 IPUP = MITER LMAX = MAXORD + 1 IF (IALTH .EQ. 1) IALTH = 2 IF (METH .EQ. MUSED) GO TO 160 CALL DCFODE (METH, ELCO, TESCO) IALTH = L IRET = 1 C----------------------------------------------------------------------- C The el vector and related constants are reset C whenever the order NQ is changed, or at the start of the problem. C----------------------------------------------------------------------- 150 DO 155 I = 1,L EL(I) = ELCO(I,NQ) 155 CONTINUE NQNYH = NQ*NYH RC = RC*EL(1)/EL0 EL0 = EL(1) CONIT = 0.5D0/(NQ+2) IF (IRET .EQ. 1) THEN GOTO 160 ELSE IF (IRET .EQ. 2) THEN GOTO 170 ELSE IF (IRET .EQ. 3) THEN GOTO 200 ENDIF C GO TO (160, 170, 200), IRET C----------------------------------------------------------------------- C If H is being changed, the H ratio RH is checked against C RMAX, HMIN, and HMXI, and the YH array rescaled. IALTH is set to C L = NQ + 1 to prevent a change of H for that many steps, unless C forced by a convergence or error test failure. C----------------------------------------------------------------------- 160 IF (H .EQ. HOLD) GO TO 200 RH = H/HOLD H = HOLD IREDO = 3 GO TO 175 170 RH = MAX(RH,HMIN/ABS(H)) 175 RH = MIN(RH,RMAX) RH = RH/MAX(1.0D0,ABS(H)*HMXI*RH) C----------------------------------------------------------------------- C If METH = 1, also restrict the new step size by the stability region. C If this reduces H, set IRFLAG to 1 so that if there are roundoff C problems later, we can assume that is the cause of the trouble. C----------------------------------------------------------------------- IF (METH .EQ. 2) GO TO 178 IRFLAG = 0 PDH = MAX(ABS(H)*PDLAST,0.000001D0) IF (RH*PDH*1.00001D0 .LT. SM1(NQ)) GO TO 178 RH = SM1(NQ)/PDH IRFLAG = 1 178 CONTINUE R = 1.0D0 DO 190 J = 2,L R = R*RH DO 180 I = 1,N YH(I,J) = YH(I,J)*R 180 CONTINUE 190 CONTINUE H = H*RH RC = RC*RH IALTH = L IF (IREDO .EQ. 0) GO TO 690 C----------------------------------------------------------------------- C This section computes the predicted values by effectively C multiplying the YH array by the Pascal triangle matrix. C RC is the ratio of new to old values of the coefficient H*EL(1). C When RC differs from 1 by more than CCMAX, IPUP is set to MITER C to force PJAC to be called, if a Jacobian is involved. C In any case, PJAC is called at least every MSBP steps. C----------------------------------------------------------------------- 200 IF (ABS(RC-1.0D0) .GT. CCMAX) IPUP = MITER IF (NST .GE. NSLP+MSBP) IPUP = MITER TN = TN + H I1 = NQNYH + 1 DO 215 JB = 1,NQ I1 = I1 - NYH CDIR$ IVDEP DO 210 I = I1,NQNYH YH1(I) = YH1(I) + YH1(I+NYH) 210 CONTINUE 215 CONTINUE PNORM = DMNORM (N, YH1, EWT) C----------------------------------------------------------------------- C Up to MAXCOR corrector iterations are taken. A convergence test is C made on the RMS-norm of each correction, weighted by the error C weight vector EWT. The sum of the corrections is accumulated in the C vector ACOR(i). The YH array is not altered in the corrector loop. C----------------------------------------------------------------------- 220 M = 0 RATE = 0.0D0 DEL = 0.0D0 DO 230 I = 1,N Y(I) = YH(I,1) 230 CONTINUE CKS CALL F (NEQ, TN, Y, SAVF, rpar, ipar) NFE = NFE + 1 IF (IPUP .LE. 0) GO TO 250 C----------------------------------------------------------------------- C If indicated, the matrix P = I - H*EL(1)*J is reevaluated and C preprocessed before starting the corrector iteration. IPUP is set C to 0 as an indicator that this has been done. C----------------------------------------------------------------------- CKS CALL PJAC (NEQ, Y, YH, NYH, EWT, ACOR, SAVF, WM, IWM, F, JAC, &rpar,ipar) IPUP = 0 RC = 1.0D0 NSLP = NST CRATE = 0.7D0 IF (IERPJ .NE. 0) GO TO 430 250 DO 260 I = 1,N ACOR(I) = 0.0D0 260 CONTINUE 270 IF (MITER .NE. 0) GO TO 350 C----------------------------------------------------------------------- C In the case of functional iteration, update Y directly from C the result of the last function evaluation. C----------------------------------------------------------------------- DO 290 I = 1,N SAVF(I) = H*SAVF(I) - YH(I,2) Y(I) = SAVF(I) - ACOR(I) 290 CONTINUE DEL = DMNORM (N, Y, EWT) DO 300 I = 1,N Y(I) = YH(I,1) + EL(1)*SAVF(I) ACOR(I) = SAVF(I) 300 CONTINUE GO TO 400 C----------------------------------------------------------------------- C In the case of the chord method, compute the corrector error, C and solve the linear system with that as right-hand side and C P as coefficient matrix. C----------------------------------------------------------------------- 350 DO 360 I = 1,N Y(I) = H*SAVF(I) - (YH(I,2) + ACOR(I)) 360 CONTINUE CALL SLVS (WM, IWM, Y, SAVF) IF (IERSL .LT. 0) GO TO 430 IF (IERSL .GT. 0) GO TO 410 DEL = DMNORM (N, Y, EWT) DO 380 I = 1,N ACOR(I) = ACOR(I) + Y(I) Y(I) = YH(I,1) + EL(1)*ACOR(I) 380 CONTINUE C----------------------------------------------------------------------- C Test for convergence. If M .gt. 0, an estimate of the convergence C rate constant is stored in CRATE, and this is used in the test. C C We first check for a change of iterates that is the size of C roundoff error. If this occurs, the iteration has converged, and a C new rate estimate is not formed. C In all other cases, force at least two iterations to estimate a C local Lipschitz constant estimate for Adams methods. C On convergence, form PDEST = local maximum Lipschitz constant C estimate. PDLAST is the most recent nonzero estimate. C----------------------------------------------------------------------- 400 CONTINUE IF (DEL .LE. 100.0D0*PNORM*UROUND) GO TO 450 IF (M .EQ. 0 .AND. METH .EQ. 1) GO TO 405 IF (M .EQ. 0) GO TO 402 RM = 1024.0D0 IF (DEL .LE. 1024.0D0*DELP) RM = DEL/DELP RATE = MAX(RATE,RM) CRATE = MAX(0.2D0*CRATE,RM) 402 DCON = DEL*MIN(1.0D0,1.5D0*CRATE)/(TESCO(2,NQ)*CONIT) IF (DCON .GT. 1.0D0) GO TO 405 PDEST = MAX(PDEST,RATE/ABS(H*EL(1))) IF (PDEST .NE. 0.0D0) PDLAST = PDEST GO TO 450 405 CONTINUE M = M + 1 IF (M .EQ. MAXCOR) GO TO 410 IF (M .GE. 2 .AND. DEL .GT. 2.0D0*DELP) GO TO 410 DELP = DEL CKS CALL F (NEQ, TN, Y, SAVF, rpar, ipar) NFE = NFE + 1 GO TO 270 C----------------------------------------------------------------------- C The corrector iteration failed to converge. C If MITER .ne. 0 and the Jacobian is out of date, PJAC is called for C the next try. Otherwise the YH array is retracted to its values C before prediction, and H is reduced, if possible. If H cannot be C reduced or MXNCF failures have occurred, exit with KFLAG = -2. C----------------------------------------------------------------------- 410 IF (MITER .EQ. 0 .OR. JCUR .EQ. 1) GO TO 430 ICF = 1 IPUP = MITER GO TO 220 430 ICF = 2 NCF = NCF + 1 RMAX = 2.0D0 TN = TOLD I1 = NQNYH + 1 DO 445 JB = 1,NQ I1 = I1 - NYH CDIR$ IVDEP DO 440 I = I1,NQNYH YH1(I) = YH1(I) - YH1(I+NYH) 440 CONTINUE 445 CONTINUE IF (IERPJ .LT. 0 .OR. IERSL .LT. 0) GO TO 680 IF (ABS(H) .LE. HMIN*1.00001D0) GO TO 670 IF (NCF .EQ. MXNCF) GO TO 670 RH = 0.25D0 IPUP = MITER IREDO = 1 GO TO 170 C----------------------------------------------------------------------- C The corrector has converged. JCUR is set to 0 C to signal that the Jacobian involved may need updating later. C The local error test is made and control passes to statement 500 C if it fails. C----------------------------------------------------------------------- 450 JCUR = 0 IF (M .EQ. 0) DSM = DEL/TESCO(2,NQ) IF (M .GT. 0) DSM = DMNORM (N, ACOR, EWT)/TESCO(2,NQ) IF (DSM .GT. 1.0D0) GO TO 500 C----------------------------------------------------------------------- C After a successful step, update the YH array. C Decrease ICOUNT by 1, and if it is -1, consider switching methods. C If a method switch is made, reset various parameters, C rescale the YH array, and exit. If there is no switch, C consider changing H if IALTH = 1. Otherwise decrease IALTH by 1. C If IALTH is then 1 and NQ .lt. MAXORD, then ACOR is saved for C use in a possible order increase on the next step. C If a change in H is considered, an increase or decrease in order C by one is considered also. A change in H is made only if it is by a C factor of at least 1.1. If not, IALTH is set to 3 to prevent C testing for that many steps. C----------------------------------------------------------------------- KFLAG = 0 IREDO = 0 NST = NST + 1 HU = H NQU = NQ MUSED = METH DO 465 J = 1,L DO 460 I = 1,N YH(I,J) = YH(I,J) + EL(J)*ACOR(I) 460 CONTINUE 465 CONTINUE ICOUNT = ICOUNT - 1 IF (ICOUNT .GE. 0) GO TO 488 IF (METH .EQ. 2) GO TO 480 C----------------------------------------------------------------------- C We are currently using an Adams method. Consider switching to BDF. C If the current order is greater than 5, assume the problem is C not stiff, and skip this section. C If the Lipschitz constant and error estimate are not polluted C by roundoff, go to 470 and perform the usual test. C Otherwise, switch to the BDF methods if the last step was C restricted to insure stability (irflag = 1), and stay with Adams C method if not. When switching to BDF with polluted error estimates, C in the absence of other information, double the step size. C C When the estimates are OK, we make the usual test by computing C the step size we could have (ideally) used on this step, C with the current (Adams) method, and also that for the BDF. C If NQ .gt. MXORDS, we consider changing to order MXORDS on switching. C Compare the two step sizes to decide whether to switch. C The step size advantage must be at least RATIO = 5 to switch. C----------------------------------------------------------------------- IF (NQ .GT. 5) GO TO 488 IF (DSM .GT. 100.0D0*PNORM*UROUND .AND. PDEST .NE. 0.0D0) 1 GO TO 470 IF (IRFLAG .EQ. 0) GO TO 488 RH2 = 2.0D0 NQM2 = MIN(NQ,MXORDS) GO TO 478 470 CONTINUE EXSM = 1.0D0/L RH1 = 1.0D0/(1.2D0*DSM**EXSM + 0.0000012D0) RH1IT = 2.0D0*RH1 PDH = PDLAST*ABS(H) IF (PDH*RH1 .GT. 0.00001D0) RH1IT = SM1(NQ)/PDH RH1 = MIN(RH1,RH1IT) IF (NQ .LE. MXORDS) GO TO 474 NQM2 = MXORDS LM2 = MXORDS + 1 EXM2 = 1.0D0/LM2 LM2P1 = LM2 + 1 DM2 = DMNORM (N, YH(1,LM2P1), EWT)/CM2(MXORDS) RH2 = 1.0D0/(1.2D0*DM2**EXM2 + 0.0000012D0) GO TO 476 474 DM2 = DSM*(CM1(NQ)/CM2(NQ)) RH2 = 1.0D0/(1.2D0*DM2**EXSM + 0.0000012D0) NQM2 = NQ 476 CONTINUE IF (RH2 .LT. RATIO*RH1) GO TO 488 C THE SWITCH TEST PASSED. RESET RELEVANT QUANTITIES FOR BDF. ---------- 478 RH = RH2 ICOUNT = 20 METH = 2 MITER = JTYP PDLAST = 0.0D0 NQ = NQM2 L = NQ + 1 GO TO 170 C----------------------------------------------------------------------- C We are currently using a BDF method. Consider switching to Adams. C Compute the step size we could have (ideally) used on this step, C with the current (BDF) method, and also that for the Adams. C If NQ .gt. MXORDN, we consider changing to order MXORDN on switching. C Compare the two step sizes to decide whether to switch. C The step size advantage must be at least 5/RATIO = 1 to switch. C If the step size for Adams would be so small as to cause C roundoff pollution, we stay with BDF. C----------------------------------------------------------------------- 480 CONTINUE EXSM = 1.0D0/L IF (MXORDN .GE. NQ) GO TO 484 NQM1 = MXORDN LM1 = MXORDN + 1 EXM1 = 1.0D0/LM1 LM1P1 = LM1 + 1 DM1 = DMNORM (N, YH(1,LM1P1), EWT)/CM1(MXORDN) RH1 = 1.0D0/(1.2D0*DM1**EXM1 + 0.0000012D0) GO TO 486 484 DM1 = DSM*(CM2(NQ)/CM1(NQ)) RH1 = 1.0D0/(1.2D0*DM1**EXSM + 0.0000012D0) NQM1 = NQ EXM1 = EXSM 486 RH1IT = 2.0D0*RH1 PDH = PDNORM*ABS(H) IF (PDH*RH1 .GT. 0.00001D0) RH1IT = SM1(NQM1)/PDH RH1 = MIN(RH1,RH1IT) RH2 = 1.0D0/(1.2D0*DSM**EXSM + 0.0000012D0) IF (RH1*RATIO .LT. 5.0D0*RH2) GO TO 488 ALPHA = MAX(0.001D0,RH1) DM1 = (ALPHA**EXM1)*DM1 IF (DM1 .LE. 1000.0D0*UROUND*PNORM) GO TO 488 C The switch test passed. Reset relevant quantities for Adams. -------- RH = RH1 ICOUNT = 20 METH = 1 MITER = 0 PDLAST = 0.0D0 NQ = NQM1 L = NQ + 1 GO TO 170 C C No method switch is being made. Do the usual step/order selection. -- 488 CONTINUE IALTH = IALTH - 1 IF (IALTH .EQ. 0) GO TO 520 IF (IALTH .GT. 1) GO TO 700 IF (L .EQ. LMAX) GO TO 700 DO 490 I = 1,N YH(I,LMAX) = ACOR(I) 490 CONTINUE GO TO 700 C----------------------------------------------------------------------- C The error test failed. KFLAG keeps track of multiple failures. C Restore TN and the YH array to their previous values, and prepare C to try the step again. Compute the optimum step size for this or C one lower order. After 2 or more failures, H is forced to decrease C by a factor of 0.2 or less. C----------------------------------------------------------------------- 500 KFLAG = KFLAG - 1 TN = TOLD I1 = NQNYH + 1 DO 515 JB = 1,NQ I1 = I1 - NYH CDIR$ IVDEP DO 510 I = I1,NQNYH YH1(I) = YH1(I) - YH1(I+NYH) 510 CONTINUE 515 CONTINUE RMAX = 2.0D0 IF (ABS(H) .LE. HMIN*1.00001D0) GO TO 660 IF (KFLAG .LE. -3) GO TO 640 IREDO = 2 RHUP = 0.0D0 GO TO 540 C----------------------------------------------------------------------- C Regardless of the success or failure of the step, factors C RHDN, RHSM, and RHUP are computed, by which H could be multiplied C at order NQ - 1, order NQ, or order NQ + 1, respectively. C In the case of failure, RHUP = 0.0 to avoid an order increase. C The largest of these is determined and the new order chosen C accordingly. If the order is to be increased, we compute one C additional scaled derivative. C----------------------------------------------------------------------- 520 RHUP = 0.0D0 IF (L .EQ. LMAX) GO TO 540 DO 530 I = 1,N SAVF(I) = ACOR(I) - YH(I,LMAX) 530 CONTINUE DUP = DMNORM (N, SAVF, EWT)/TESCO(3,NQ) EXUP = 1.0D0/(L+1) RHUP = 1.0D0/(1.4D0*DUP**EXUP + 0.0000014D0) 540 EXSM = 1.0D0/L RHSM = 1.0D0/(1.2D0*DSM**EXSM + 0.0000012D0) RHDN = 0.0D0 IF (NQ .EQ. 1) GO TO 550 DDN = DMNORM (N, YH(1,L), EWT)/TESCO(1,NQ) EXDN = 1.0D0/NQ RHDN = 1.0D0/(1.3D0*DDN**EXDN + 0.0000013D0) C If METH = 1, limit RH according to the stability region also. -------- 550 IF (METH .EQ. 2) GO TO 560 PDH = MAX(ABS(H)*PDLAST,0.000001D0) IF (L .LT. LMAX) RHUP = MIN(RHUP,SM1(L)/PDH) RHSM = MIN(RHSM,SM1(NQ)/PDH) IF (NQ .GT. 1) RHDN = MIN(RHDN,SM1(NQ-1)/PDH) PDEST = 0.0D0 560 IF (RHSM .GE. RHUP) GO TO 570 IF (RHUP .GT. RHDN) GO TO 590 GO TO 580 570 IF (RHSM .LT. RHDN) GO TO 580 NEWQ = NQ RH = RHSM GO TO 620 580 NEWQ = NQ - 1 RH = RHDN IF (KFLAG .LT. 0 .AND. RH .GT. 1.0D0) RH = 1.0D0 GO TO 620 590 NEWQ = L RH = RHUP IF (RH .LT. 1.1D0) GO TO 610 R = EL(L)/L DO 600 I = 1,N YH(I,NEWQ+1) = ACOR(I)*R 600 CONTINUE GO TO 630 610 IALTH = 3 GO TO 700 C If METH = 1 and H is restricted by stability, bypass 10 percent test. 620 IF (METH .EQ. 2) GO TO 622 IF (RH*PDH*1.00001D0 .GE. SM1(NEWQ)) GO TO 625 622 IF (KFLAG .EQ. 0 .AND. RH .LT. 1.1D0) GO TO 610 625 IF (KFLAG .LE. -2) RH = MIN(RH,0.2D0) C----------------------------------------------------------------------- C If there is a change of order, reset NQ, L, and the coefficients. C In any case H is reset according to RH and the YH array is rescaled. C Then exit from 690 if the step was OK, or redo the step otherwise. C----------------------------------------------------------------------- IF (NEWQ .EQ. NQ) GO TO 170 630 NQ = NEWQ L = NQ + 1 IRET = 2 GO TO 150 C----------------------------------------------------------------------- C Control reaches this section if 3 or more failures have occured. C If 10 failures have occurred, exit with KFLAG = -1. C It is assumed that the derivatives that have accumulated in the C YH array have errors of the wrong order. Hence the first C derivative is recomputed, and the order is set to 1. Then C H is reduced by a factor of 10, and the step is retried, C until it succeeds or H reaches HMIN. C----------------------------------------------------------------------- 640 IF (KFLAG .EQ. -10) GO TO 660 RH = 0.1D0 RH = MAX(HMIN/ABS(H),RH) H = H*RH DO 645 I = 1,N Y(I) = YH(I,1) 645 CONTINUE CKS CALL F (NEQ, TN, Y, SAVF, rpar, ipar) NFE = NFE + 1 DO 650 I = 1,N YH(I,2) = H*SAVF(I) 650 CONTINUE IPUP = MITER IALTH = 5 IF (NQ .EQ. 1) GO TO 200 NQ = 1 L = 2 IRET = 3 GO TO 150 C----------------------------------------------------------------------- C All returns are made through this section. H is saved in HOLD C to allow the caller to change H on the next step. C----------------------------------------------------------------------- 660 KFLAG = -1 GO TO 720 670 KFLAG = -2 GO TO 720 680 KFLAG = -3 GO TO 720 690 RMAX = 10.0D0 700 R = 1.0D0/TESCO(2,NQU) DO 710 I = 1,N ACOR(I) = ACOR(I)*R 710 CONTINUE 720 HOLD = H JSTART = 1 RETURN C----------------------- End of Subroutine DSTODA ---------------------- END *DECK DPRJA SUBROUTINE DPRJA (NEQ, Y, YH, NYH, EWT, FTEM, SAVF, WM, IWM, 1 F, JAC,rpar,ipar) EXTERNAL F, JAC CKS: added rpar,ipar integer ipar(*) double precision rpar(*) INTEGER NEQ, NYH, IWM DOUBLE PRECISION Y, YH, EWT, FTEM, SAVF, WM DIMENSION NEQ(*), Y(*), YH(NYH,*), EWT(*), FTEM(*), SAVF(*), 1 WM(*), IWM(*) INTEGER IOWND, IOWNS, 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU INTEGER IOWND2, IOWNS2, JTYP, MUSED, MXORDN, MXORDS DOUBLE PRECISION ROWNS, 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND DOUBLE PRECISION ROWND2, ROWNS2, PDNORM COMMON /DLS001/ ROWNS(209), 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 2 IOWND(6), IOWNS(6), 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU COMMON /DLSA01/ ROWND2, ROWNS2(20), PDNORM, 1 IOWND2(3), IOWNS2(2), JTYP, MUSED, MXORDN, MXORDS INTEGER I, I1, I2, IER, II, J, J1, JJ, LENP, 1 MBA, MBAND, MEB1, MEBAND, ML, ML3, MU, NP1 DOUBLE PRECISION CON, FAC, HL0, R, R0, SRUR, YI, YJ, YJJ, 1 DMNORM, DFNORM, DBNORM C----------------------------------------------------------------------- C DPRJA is called by DSTODA to compute and process the matrix C P = I - H*EL(1)*J , where J is an approximation to the Jacobian. C Here J is computed by the user-supplied routine JAC if C MITER = 1 or 4 or by finite differencing if MITER = 2 or 5. C J, scaled by -H*EL(1), is stored in WM. Then the norm of J (the C matrix norm consistent with the weighted max-norm on vectors given C by DMNORM) is computed, and J is overwritten by P. P is then C subjected to LU decomposition in preparation for later solution C of linear systems with P as coefficient matrix. This is done C by DGEFA if MITER = 1 or 2, and by DGBFA if MITER = 4 or 5. C C In addition to variables described previously, communication C with DPRJA uses the following: C Y = array containing predicted values on entry. C FTEM = work array of length N (ACOR in DSTODA). C SAVF = array containing f evaluated at predicted y. C WM = real work space for matrices. On output it contains the C LU decomposition of P. C Storage of matrix elements starts at WM(3). C WM also contains the following matrix-related data: C WM(1) = SQRT(UROUND), used in numerical Jacobian increments. C IWM = integer work space containing pivot information, starting at C IWM(21). IWM also contains the band parameters C ML = IWM(1) and MU = IWM(2) if MITER is 4 or 5. C EL0 = EL(1) (input). C PDNORM= norm of Jacobian matrix. (Output). C IERPJ = output error flag, = 0 if no trouble, .gt. 0 if C P matrix found to be singular. C JCUR = output flag = 1 to indicate that the Jacobian matrix C (or approximation) is now current. C This routine also uses the Common variables EL0, H, TN, UROUND, C MITER, N, NFE, and NJE. C----------------------------------------------------------------------- NJE = NJE + 1 IERPJ = 0 JCUR = 1 HL0 = H*EL0 IF (MITER .EQ. 1) THEN GOTO 100 ELSE IF (MITER .EQ. 2) THEN GOTO 200 ELSE IF (MITER .EQ. 3) THEN GOTO 300 ELSE IF (MITER .EQ. 4) THEN GOTO 400 ELSE IF (MITER .EQ. 5) THEN GOTO 500 ENDIF C karline C GO TO (100, 200, 300, 400, 500), MITER C If MITER = 1, call JAC and multiply by scalar. ----------------------- 100 LENP = N*N DO 110 I = 1,LENP WM(I+2) = 0.0D0 110 CONTINUE CALL JAC (NEQ, TN, Y, 0, 0, WM(3), N,rpar,ipar) CON = -HL0 DO 120 I = 1,LENP WM(I+2) = WM(I+2)*CON 120 CONTINUE GO TO 240 C If MITER = 2, make N calls to F to approximate J. -------------------- 200 FAC = DMNORM (N, SAVF, EWT) R0 = 1000.0D0*ABS(H)*UROUND*N*FAC IF (R0 .EQ. 0.0D0) R0 = 1.0D0 SRUR = WM(1) J1 = 2 DO 230 J = 1,N YJ = Y(J) R = MAX(SRUR*ABS(YJ),R0/EWT(J)) Y(J) = Y(J) + R FAC = -HL0/R CKS CALL F (NEQ, TN, Y, FTEM, rpar, ipar) DO 220 I = 1,N WM(I+J1) = (FTEM(I) - SAVF(I))*FAC 220 CONTINUE Y(J) = YJ J1 = J1 + N 230 CONTINUE NFE = NFE + N 240 CONTINUE C Compute norm of Jacobian. -------------------------------------------- PDNORM = DFNORM (N, WM(3), EWT)/ABS(HL0) C Add identity matrix. ------------------------------------------------- J = 3 NP1 = N + 1 DO 250 I = 1,N WM(J) = WM(J) + 1.0D0 J = J + NP1 250 CONTINUE C Do LU decomposition on P. -------------------------------------------- CALL DGEFA (WM(3), N, N, IWM(21), IER) IF (IER .NE. 0) IERPJ = 1 RETURN C Dummy block only, since MITER is never 3 in this routine. ------------ 300 RETURN C If MITER = 4, call JAC and multiply by scalar. ----------------------- 400 ML = IWM(1) MU = IWM(2) ML3 = ML + 3 MBAND = ML + MU + 1 MEBAND = MBAND + ML LENP = MEBAND*N DO 410 I = 1,LENP WM(I+2) = 0.0D0 410 CONTINUE CALL JAC (NEQ, TN, Y, ML, MU, WM(ML3), MEBAND,rpar,ipar) CON = -HL0 DO 420 I = 1,LENP WM(I+2) = WM(I+2)*CON 420 CONTINUE GO TO 570 C If MITER = 5, make MBAND calls to F to approximate J. ---------------- 500 ML = IWM(1) MU = IWM(2) MBAND = ML + MU + 1 MBA = MIN(MBAND,N) MEBAND = MBAND + ML MEB1 = MEBAND - 1 SRUR = WM(1) FAC = DMNORM (N, SAVF, EWT) R0 = 1000.0D0*ABS(H)*UROUND*N*FAC IF (R0 .EQ. 0.0D0) R0 = 1.0D0 DO 560 J = 1,MBA DO 530 I = J,N,MBAND YI = Y(I) R = MAX(SRUR*ABS(YI),R0/EWT(I)) Y(I) = Y(I) + R 530 CONTINUE CKS CALL F (NEQ, TN, Y, FTEM, rpar, ipar) DO 550 JJ = J,N,MBAND Y(JJ) = YH(JJ,1) YJJ = Y(JJ) R = MAX(SRUR*ABS(YJJ),R0/EWT(JJ)) FAC = -HL0/R I1 = MAX(JJ-MU,1) I2 = MIN(JJ+ML,N) II = JJ*MEB1 - ML + 2 DO 540 I = I1,I2 WM(II+I) = (FTEM(I) - SAVF(I))*FAC 540 CONTINUE 550 CONTINUE 560 CONTINUE NFE = NFE + MBA 570 CONTINUE C Compute norm of Jacobian. -------------------------------------------- PDNORM = DBNORM (N, WM(ML+3), MEBAND, ML, MU, EWT)/ABS(HL0) C Add identity matrix. ------------------------------------------------- II = MBAND + 2 DO 580 I = 1,N WM(II) = WM(II) + 1.0D0 II = II + MEBAND 580 CONTINUE C Do LU decomposition of P. -------------------------------------------- CALL DGBFA (WM(3), MEBAND, N, ML, MU, IWM(21), IER) IF (IER .NE. 0) IERPJ = 1 RETURN C----------------------- End of Subroutine DPRJA ----------------------- END *DECK DMNORM DOUBLE PRECISION FUNCTION DMNORM (N, V, W) C----------------------------------------------------------------------- C This function routine computes the weighted max-norm C of the vector of length N contained in the array V, with weights C contained in the array w of length N: C DMNORM = MAX(i=1,...,N) ABS(V(i))*W(i) C----------------------------------------------------------------------- INTEGER N, I DOUBLE PRECISION V, W, VM DIMENSION V(N), W(N) VM = 0.0D0 DO 10 I = 1,N VM = MAX(VM,ABS(V(I))*W(I)) 10 CONTINUE DMNORM = VM RETURN C----------------------- End of Function DMNORM ------------------------ END *DECK DFNORM DOUBLE PRECISION FUNCTION DFNORM (N, A, W) C----------------------------------------------------------------------- C This function computes the norm of a full N by N matrix, C stored in the array A, that is consistent with the weighted max-norm C on vectors, with weights stored in the array W: C DFNORM = MAX(i=1,...,N) ( W(i) * Sum(j=1,...,N) ABS(a(i,j))/W(j) ) C----------------------------------------------------------------------- INTEGER N, I, J DOUBLE PRECISION A, W, AN, SUM DIMENSION A(N,N), W(N) AN = 0.0D0 DO 20 I = 1,N SUM = 0.0D0 DO 10 J = 1,N SUM = SUM + ABS(A(I,J))/W(J) 10 CONTINUE AN = MAX(AN,SUM*W(I)) 20 CONTINUE DFNORM = AN RETURN C----------------------- End of Function DFNORM ------------------------ END *DECK DBNORM DOUBLE PRECISION FUNCTION DBNORM (N, A, NRA, ML, MU, W) C----------------------------------------------------------------------- C This function computes the norm of a banded N by N matrix, C stored in the array A, that is consistent with the weighted max-norm C on vectors, with weights stored in the array W. C ML and MU are the lower and upper half-bandwidths of the matrix. C NRA is the first dimension of the A array, NRA .ge. ML+MU+1. C In terms of the matrix elements a(i,j), the norm is given by: C DBNORM = MAX(i=1,...,N) ( W(i) * Sum(j=1,...,N) ABS(a(i,j))/W(j) ) C----------------------------------------------------------------------- INTEGER N, NRA, ML, MU INTEGER I, I1, JLO, JHI, J DOUBLE PRECISION A, W DOUBLE PRECISION AN, SUM DIMENSION A(NRA,N), W(N) AN = 0.0D0 DO 20 I = 1,N SUM = 0.0D0 I1 = I + MU + 1 JLO = MAX(I-ML,1) JHI = MIN(I+MU,N) DO 10 J = JLO,JHI SUM = SUM + ABS(A(I1-J,J))/W(J) 10 CONTINUE AN = MAX(AN,SUM*W(I)) 20 CONTINUE DBNORM = AN RETURN C----------------------- End of Function DBNORM ------------------------ END *DECK DSRCMA *DECK DRCHEK SUBROUTINE DRCHEK (JOB, G, NEQ, Y, YH,NYH, G0, G1, GX, JROOT, IRT, & 1 rpar, ipar) EXTERNAL G INTEGER JOB, NEQ, NYH, JROOT, IRT, ipar(*) DOUBLE PRECISION Y, YH, G0, G1, GX, rpar(*) DIMENSION NEQ(*), Y(*), YH(NYH,*), G0(*), G1(*), GX(*), JROOT(*) INTEGER IOWND, IOWNS, 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU INTEGER IOWND3, IOWNR3, IRFND, ITASKC, NGC, NGE DOUBLE PRECISION ROWNS, 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND DOUBLE PRECISION ROWNR3, T0, TLAST, TOUTC COMMON /DLS001/ ROWNS(209), 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 2 IOWND(6), IOWNS(6), 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU COMMON /DLSR01/ ROWNR3(2), T0, TLAST, TOUTC, 1 IOWND3(3), IOWNR3(2), IRFND, ITASKC, NGC, NGE INTEGER I, IFLAG, JFLAG DOUBLE PRECISION HMING, T1, TEMP1, TEMP2, X LOGICAL ZROOT C----------------------------------------------------------------------- C This routine checks for the presence of a root in the vicinity of C the current T, in a manner depending on the input flag JOB. It calls C Subroutine DROOTS to locate the root as precisely as possible. C C In addition to variables described previously, DRCHEK C uses the following for communication: C JOB = integer flag indicating type of call: C JOB = 1 means the problem is being initialized, and DRCHEK C is to look for a root at or very near the initial T. C JOB = 2 means a continuation call to the solver was just C made, and DRCHEK is to check for a root in the C relevant part of the step last taken. C JOB = 3 means a successful step was just taken, and DRCHEK C is to look for a root in the interval of the step. C G0 = array of length NG, containing the value of g at T = T0. C G0 is input for JOB .ge. 2, and output in all cases. C G1,GX = arrays of length NG for work space. C IRT = completion flag: C IRT = 0 means no root was found. C IRT = -1 means JOB = 1 and a root was found too near to T. C IRT = 1 means a legitimate root was found (JOB = 2 or 3). C On return, T0 is the root location, and Y is the C corresponding solution vector. C T0 = value of T at one endpoint of interval of interest. Only C roots beyond T0 in the direction of integration are sought. C T0 is input if JOB .ge. 2, and output in all cases. C T0 is updated by DRCHEK, whether a root is found or not. C TLAST = last value of T returned by the solver (input only). C TOUTC = copy of TOUT (input only). C IRFND = input flag showing whether the last step taken had a root. C IRFND = 1 if it did, = 0 if not. C ITASKC = copy of ITASK (input only). C NGC = copy of NG (input only). C----------------------------------------------------------------------- IRT = 0 DO 10 I = 1,NGC JROOT(I) = 0 10 CONTINUE HMING = (ABS(TN) + ABS(H))*UROUND*100.0D0 C IF (JOB .EQ. 1) THEN GOTO 100 ELSE IF (JOB .EQ. 2) THEN GOTO 200 ELSE IF (JOB .EQ. 3) THEN GOTO 300 ENDIF C karline: C GO TO (100, 200, 300), JOB C C Evaluate g at initial T, and check for zero values. ------------------ 100 CONTINUE T0 = TN CALL G (NEQ, T0, Y, NGC, G0, rpar, ipar) NGE = 1 ZROOT = .FALSE. DO 110 I = 1,NGC IF (ABS(G0(I)) .LE. 0.0D0) ZROOT = .TRUE. 110 CONTINUE IF (.NOT. ZROOT) GO TO 190 C g has a zero at T. Look at g at T + (small increment). -------------- TEMP2 = MAX(HMING/ABS(H), 0.1D0) TEMP1 = TEMP2*H T0 = T0 + TEMP1 DO 120 I = 1,N Y(I) = Y(I) + TEMP2*YH(I,2) 120 CONTINUE CALL G (NEQ, T0, Y, NGC, G0, rpar, ipar) NGE = NGE + 1 ZROOT = .FALSE. DO 130 I = 1,NGC IF (ABS(G0(I)) .LE. 0.0D0) ZROOT = .TRUE. 130 CONTINUE IF (.NOT. ZROOT) GO TO 190 C g has a zero at T and also close to T. Take error return. ----------- IRT = -1 RETURN C 190 CONTINUE RETURN C C 200 CONTINUE IF (IRFND .EQ. 0) GO TO 260 C If a root was found on the previous step, evaluate G0 = g(T0). ------- CALL DINTDY (T0, 0, YH, NYH, Y, IFLAG) CALL G (NEQ, T0, Y, NGC, G0, rpar, ipar) NGE = NGE + 1 ZROOT = .FALSE. DO 210 I = 1,NGC IF (ABS(G0(I)) .LE. 0.0D0) ZROOT = .TRUE. 210 CONTINUE IF (.NOT. ZROOT) GO TO 260 C g has a zero at T0. Look at g at T + (small increment). ------------- TEMP1 = SIGN(HMING,H) T0 = T0 + TEMP1 IF ((T0 - TN)*H .LT. 0.0D0) GO TO 230 TEMP2 = TEMP1/H DO 220 I = 1,N Y(I) = Y(I) + TEMP2*YH(I,2) 220 CONTINUE GO TO 240 230 CALL DINTDY (T0, 0, YH, NYH, Y, IFLAG) 240 CALL G (NEQ, T0, Y, NGC, G0, rpar, ipar) NGE = NGE + 1 ZROOT = .FALSE. DO 250 I = 1,NGC IF (ABS(G0(I)) .GT. 0.0D0) GO TO 250 JROOT(I) = 1 ZROOT = .TRUE. 250 CONTINUE IF (.NOT. ZROOT) GO TO 260 C g has a zero at T0 and also close to T0. Return root. --------------- IRT = 1 RETURN C G0 has no zero components. Proceed to check relevant interval. ------ 260 IF (TN .EQ. TLAST) GO TO 390 C 300 CONTINUE C Set T1 to TN or TOUTC, whichever comes first, and get g at T1. ------- IF (ITASKC.EQ.2 .OR. ITASKC.EQ.3 .OR. ITASKC.EQ.5) GO TO 310 IF ((TOUTC - TN)*H .GE. 0.0D0) GO TO 310 T1 = TOUTC IF ((T1 - T0)*H .LE. 0.0D0) GO TO 390 CALL DINTDY (T1, 0, YH, NYH, Y, IFLAG) GO TO 330 310 T1 = TN DO 320 I = 1,N Y(I) = YH(I,1) 320 CONTINUE 330 CALL G (NEQ, T1, Y, NGC, G1, rpar, ipar) NGE = NGE + 1 C Call DROOTS to search for root in interval from T0 to T1. ------------ JFLAG = 0 350 CONTINUE CALL DROOTS (NGC, HMING, JFLAG, T0, T1, G0, G1, GX, X, JROOT) IF (JFLAG .GT. 1) GO TO 360 CALL DINTDY (X, 0, YH, NYH, Y, IFLAG) CALL G (NEQ, X, Y, NGC, GX, rpar, ipar) NGE = NGE + 1 GO TO 350 360 T0 = X CALL DCOPY (NGC, GX, 1, G0, 1) IF (JFLAG .EQ. 4) GO TO 390 C Found a root. Interpolate to X and return. -------------------------- CALL DINTDY (X, 0, YH, NYH, Y, IFLAG) IRT = 1 RETURN C 390 CONTINUE RETURN C----------------------- End of Subroutine DRCHEK ---------------------- END *DECK DROOTS SUBROUTINE DROOTS (NG, HMIN, JFLAG, X0, X1, G0, G1, GX, X, JROOT) INTEGER NG, JFLAG, JROOT DOUBLE PRECISION HMIN, X0, X1, G0, G1, GX, X DIMENSION G0(NG), G1(NG), GX(NG), JROOT(NG) INTEGER IOWND3, IMAX, LAST, IDUM3 DOUBLE PRECISION ALPHA, X2, RDUM3 COMMON /DLSR01/ ALPHA, X2, RDUM3(3), 1 IOWND3(3), IMAX, LAST, IDUM3(4) C----------------------------------------------------------------------- C This subroutine finds the leftmost root of a set of arbitrary C functions gi(x) (i = 1,...,NG) in an interval (X0,X1). Only roots C of odd multiplicity (i.e. changes of sign of the gi) are found. C Here the sign of X1 - X0 is arbitrary, but is constant for a given C problem, and -leftmost- means nearest to X0. C The values of the vector-valued function g(x) = (gi, i=1...NG) C are communicated through the call sequence of DROOTS. C The method used is the Illinois algorithm. C C Reference: C Kathie L. Hiebert and Lawrence F. Shampine, Implicitly Defined C Output Points for Solutions of ODEs, Sandia Report SAND80-0180, C February 1980. C C Description of parameters. C C NG = number of functions gi, or the number of components of C the vector valued function g(x). Input only. C C HMIN = resolution parameter in X. Input only. When a root is C found, it is located only to within an error of HMIN in X. C Typically, HMIN should be set to something on the order of C 100 * UROUND * MAX(ABS(X0),ABS(X1)), C where UROUND is the unit roundoff of the machine. C C JFLAG = integer flag for input and output communication. C C On input, set JFLAG = 0 on the first call for the problem, C and leave it unchanged until the problem is completed. C (The problem is completed when JFLAG .ge. 2 on return.) C C On output, JFLAG has the following values and meanings: C JFLAG = 1 means DROOTS needs a value of g(x). Set GX = g(X) C and call DROOTS again. C JFLAG = 2 means a root has been found. The root is C at X, and GX contains g(X). (Actually, X is the C rightmost approximation to the root on an interval C (X0,X1) of size HMIN or less.) C JFLAG = 3 means X = X1 is a root, with one or more of the gi C being zero at X1 and no sign changes in (X0,X1). C GX contains g(X) on output. C JFLAG = 4 means no roots (of odd multiplicity) were C found in (X0,X1) (no sign changes). C C X0,X1 = endpoints of the interval where roots are sought. C X1 and X0 are input when JFLAG = 0 (first call), and C must be left unchanged between calls until the problem is C completed. X0 and X1 must be distinct, but X1 - X0 may be C of either sign. However, the notion of -left- and -right- C will be used to mean nearer to X0 or X1, respectively. C When JFLAG .ge. 2 on return, X0 and X1 are output, and C are the endpoints of the relevant interval. C C G0,G1 = arrays of length NG containing the vectors g(X0) and g(X1), C respectively. When JFLAG = 0, G0 and G1 are input and C none of the G0(i) should be zero. C When JFLAG .ge. 2 on return, G0 and G1 are output. C C GX = array of length NG containing g(X). GX is input C when JFLAG = 1, and output when JFLAG .ge. 2. C C X = independent variable value. Output only. C When JFLAG = 1 on output, X is the point at which g(x) C is to be evaluated and loaded into GX. C When JFLAG = 2 or 3, X is the root. C When JFLAG = 4, X is the right endpoint of the interval, X1. C C JROOT = integer array of length NG. Output only. C When JFLAG = 2 or 3, JROOT indicates which components C of g(x) have a root at X. JROOT(i) is 1 if the i-th C component has a root, and JROOT(i) = 0 otherwise. C----------------------------------------------------------------------- INTEGER I, IMXOLD, NXLAST DOUBLE PRECISION T2, TMAX, FRACINT, FRACSUB, ZERO,HALF,TENTH,FIVE LOGICAL ZROOT, SGNCHG, XROOT SAVE ZERO, HALF, TENTH, FIVE DATA ZERO/0.0D0/, HALF/0.5D0/, TENTH/0.1D0/, FIVE/5.0D0/ C IF (JFLAG .EQ. 1) GO TO 200 C JFLAG .ne. 1. Check for change in sign of g or zero at X1. ---------- IMAX = 0 TMAX = ZERO ZROOT = .FALSE. DO 120 I = 1,NG IF (ABS(G1(I)) .GT. ZERO) GO TO 110 ZROOT = .TRUE. GO TO 120 C At this point, G0(i) has been checked and cannot be zero. ------------ 110 IF (SIGN(1.0D0,G0(I)) .EQ. SIGN(1.0D0,G1(I))) GO TO 120 T2 = ABS(G1(I)/(G1(I)-G0(I))) IF (T2 .LE. TMAX) GO TO 120 TMAX = T2 IMAX = I 120 CONTINUE IF (IMAX .GT. 0) GO TO 130 SGNCHG = .FALSE. GO TO 140 130 SGNCHG = .TRUE. 140 IF (.NOT. SGNCHG) GO TO 400 C There is a sign change. Find the first root in the interval. -------- XROOT = .FALSE. NXLAST = 0 LAST = 1 C C Repeat until the first root in the interval is found. Loop point. --- 150 CONTINUE IF (XROOT) GO TO 300 IF (NXLAST .EQ. LAST) GO TO 160 ALPHA = 1.0D0 GO TO 180 160 IF (LAST .EQ. 0) GO TO 170 ALPHA = 0.5D0*ALPHA GO TO 180 170 ALPHA = 2.0D0*ALPHA 180 X2 = X1 - (X1 - X0)*G1(IMAX) / (G1(IMAX) - ALPHA*G0(IMAX)) C If X2 is too close to X0 or X1, adjust it inward, by a fractional ---- C distance that is between 0.1 and 0.5. -------------------------------- IF (ABS(X2 - X0) < HALF*HMIN) THEN FRACINT = ABS(X1 - X0)/HMIN FRACSUB = TENTH IF (FRACINT .LE. FIVE) FRACSUB = HALF/FRACINT X2 = X0 + FRACSUB*(X1 - X0) ENDIF IF (ABS(X1 - X2) < HALF*HMIN) THEN FRACINT = ABS(X1 - X0)/HMIN FRACSUB = TENTH IF (FRACINT .LE. FIVE) FRACSUB = HALF/FRACINT X2 = X1 - FRACSUB*(X1 - X0) ENDIF JFLAG = 1 X = X2 C Return to the calling routine to get a value of GX = g(X). ----------- RETURN C Check to see in which interval g changes sign. ----------------------- 200 IMXOLD = IMAX IMAX = 0 TMAX = ZERO ZROOT = .FALSE. DO 220 I = 1,NG IF (ABS(GX(I)) .GT. ZERO) GO TO 210 ZROOT = .TRUE. GO TO 220 C Neither G0(i) nor GX(i) can be zero at this point. ------------------- 210 IF (SIGN(1.0D0,G0(I)) .EQ. SIGN(1.0D0,GX(I))) GO TO 220 T2 = ABS(GX(I)/(GX(I) - G0(I))) IF (T2 .LE. TMAX) GO TO 220 TMAX = T2 IMAX = I 220 CONTINUE IF (IMAX .GT. 0) GO TO 230 SGNCHG = .FALSE. IMAX = IMXOLD GO TO 240 230 SGNCHG = .TRUE. 240 NXLAST = LAST IF (.NOT. SGNCHG) GO TO 250 C Sign change between X0 and X2, so replace X1 with X2. ---------------- X1 = X2 CALL DCOPY (NG, GX, 1, G1, 1) LAST = 1 XROOT = .FALSE. GO TO 270 250 IF (.NOT. ZROOT) GO TO 260 C Zero value at X2 and no sign change in (X0,X2), so X2 is a root. ----- X1 = X2 CALL DCOPY (NG, GX, 1, G1, 1) XROOT = .TRUE. GO TO 270 C No sign change between X0 and X2. Replace X0 with X2. --------------- 260 CONTINUE CALL DCOPY (NG, GX, 1, G0, 1) X0 = X2 LAST = 0 XROOT = .FALSE. 270 IF (ABS(X1-X0) .LE. HMIN) XROOT = .TRUE. GO TO 150 C C Return with X1 as the root. Set JROOT. Set X = X1 and GX = G1. ----- 300 JFLAG = 2 X = X1 CALL DCOPY (NG, G1, 1, GX, 1) DO 320 I = 1,NG JROOT(I) = 0 IF (ABS(G1(I)) .GT. ZERO) GO TO 310 JROOT(I) = 1 GO TO 320 310 IF (SIGN(1.0D0,G0(I)) .NE. SIGN(1.0D0,G1(I))) JROOT(I) = 1 320 CONTINUE RETURN C C No sign change in the interval. Check for zero at right endpoint. --- 400 IF (.NOT. ZROOT) GO TO 420 C C Zero value at X1 and no sign change in (X0,X1). Return JFLAG = 3. --- X = X1 CALL DCOPY (NG, G1, 1, GX, 1) DO 410 I = 1,NG JROOT(I) = 0 IF (ABS(G1(I)) .LE. ZERO) JROOT (I) = 1 410 CONTINUE JFLAG = 3 RETURN C C No sign changes in this interval. Set X = X1, return JFLAG = 4. ----- 420 CALL DCOPY (NG, G1, 1, GX, 1) X = X1 JFLAG = 4 RETURN C----------------------- End of Subroutine DROOTS ---------------------- END *DECK DSRCAR *DECK DSTODPK SUBROUTINE DSTODPK (NEQ, Y, YH, NYH, YH1, EWT, SAVF, SAVX, ACOR, 1 WM, IWM, F, JAC, PSOL,rpar,ipar) EXTERNAL F, JAC, PSOL CKS: added rpar,ipar integer ipar(*) double precision rpar(*) INTEGER NEQ, NYH, IWM DOUBLE PRECISION Y, YH, YH1, EWT, SAVF, SAVX, ACOR, WM DIMENSION NEQ(*), Y(*), YH(NYH,*), YH1(*), EWT(*), SAVF(*), 1 SAVX(*), ACOR(*), WM(*), IWM(*) INTEGER IOWND, IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU INTEGER JPRE, JACFLG, LOCWP, LOCIWP, LSAVX, KMP, MAXL, MNEWT, 1 NNI, NLI, NPS, NCFN, NCFL DOUBLE PRECISION CONIT, CRATE, EL, ELCO, HOLD, RMAX, TESCO, 2 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND DOUBLE PRECISION DELT, EPCON, SQRTN, RSQRTN COMMON /DLS001/ CONIT, CRATE, EL(13), ELCO(13,12), 1 HOLD, RMAX, TESCO(3,12), 2 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 3 IOWND(6), IALTH, IPUP, LMAX, MEO, NQNYH, NSLP, 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU COMMON /DLPK01/ DELT, EPCON, SQRTN, RSQRTN, 1 JPRE, JACFLG, LOCWP, LOCIWP, LSAVX, KMP, MAXL, MNEWT, 2 NNI, NLI, NPS, NCFN, NCFL C----------------------------------------------------------------------- C DSTODPK performs one step of the integration of an initial value C problem for a system of Ordinary Differential Equations. C----------------------------------------------------------------------- C The following changes were made to generate Subroutine DSTODPK C from Subroutine DSTODE: C 1. The array SAVX was added to the call sequence. C 2. PJAC and SLVS were replaced by PSOL in the call sequence. C 3. The Common block /DLPK01/ was added for communication. C 4. The test constant EPCON is loaded into Common below statement C numbers 125 and 155, and used below statement 400. C 5. The Newton iteration counter MNEWT is set below 220 and 400. C 6. The call to PJAC was replaced with a call to DPKSET (fixed name), C with a longer call sequence, called depending on JACFLG. C 7. The corrector residual is stored in SAVX (not Y) at 360, C and the solution vector is in SAVX in the 380 loop. C 8. SLVS was renamed DSOLPK and includes NEQ, SAVX, EWT, F, and JAC. C SAVX was added because DSOLPK now needs Y and SAVF undisturbed. C 9. The nonlinear convergence failure count NCFN is set at 430. C----------------------------------------------------------------------- C Note: DSTODPK is independent of the value of the iteration method C indicator MITER, when this is .ne. 0, and hence is independent C of the type of chord method used, or the Jacobian structure. C Communication with DSTODPK is done with the following variables: C C NEQ = integer array containing problem size in NEQ(1), and C passed as the NEQ argument in all calls to F and JAC. C Y = an array of length .ge. N used as the Y argument in C all calls to F and JAC. C YH = an NYH by LMAX array containing the dependent variables C and their approximate scaled derivatives, where C LMAX = MAXORD + 1. YH(i,j+1) contains the approximate C j-th derivative of y(i), scaled by H**j/factorial(j) C (j = 0,1,...,NQ). On entry for the first step, the first C two columns of YH must be set from the initial values. C NYH = a constant integer .ge. N, the first dimension of YH. C YH1 = a one-dimensional array occupying the same space as YH. C EWT = an array of length N containing multiplicative weights C for local error measurements. Local errors in y(i) are C compared to 1.0/EWT(i) in various error tests. C SAVF = an array of working storage, of length N. C Also used for input of YH(*,MAXORD+2) when JSTART = -1 C and MAXORD .lt. the current order NQ. C SAVX = an array of working storage, of length N. C ACOR = a work array of length N, used for the accumulated C corrections. On a successful return, ACOR(i) contains C the estimated one-step local error in y(i). C WM,IWM = real and integer work arrays associated with matrix C operations in chord iteration (MITER .ne. 0). C CCMAX = maximum relative change in H*EL0 before DPKSET is called. C H = the step size to be attempted on the next step. C H is altered by the error control algorithm during the C problem. H can be either positive or negative, but its C sign must remain constant throughout the problem. C HMIN = the minimum absolute value of the step size H to be used. C HMXI = inverse of the maximum absolute value of H to be used. C HMXI = 0.0 is allowed and corresponds to an infinite HMAX. C HMIN and HMXI may be changed at any time, but will not C take effect until the next change of H is considered. C TN = the independent variable. TN is updated on each step taken. C JSTART = an integer used for input only, with the following C values and meanings: C 0 perform the first step. C .gt.0 take a new step continuing from the last. C -1 take the next step with a new value of H, MAXORD, C N, METH, MITER, and/or matrix parameters. C -2 take the next step with a new value of H, C but with other inputs unchanged. C On return, JSTART is set to 1 to facilitate continuation. C KFLAG = a completion code with the following meanings: C 0 the step was succesful. C -1 the requested error could not be achieved. C -2 corrector convergence could not be achieved. C -3 fatal error in DPKSET or DSOLPK. C A return with KFLAG = -1 or -2 means either C ABS(H) = HMIN or 10 consecutive failures occurred. C On a return with KFLAG negative, the values of TN and C the YH array are as of the beginning of the last C step, and H is the last step size attempted. C MAXORD = the maximum order of integration method to be allowed. C MAXCOR = the maximum number of corrector iterations allowed. C MSBP = maximum number of steps between DPKSET calls (MITER .gt. 0). C MXNCF = maximum number of convergence failures allowed. C METH/MITER = the method flags. See description in driver. C N = the number of first-order differential equations. C----------------------------------------------------------------------- INTEGER I, I1, IREDO, IRET, J, JB, M, NCF, NEWQ DOUBLE PRECISION DCON, DDN, DEL, DELP, DSM, DUP, EXDN, EXSM, EXUP, 1 R, RH, RHDN, RHSM, RHUP, TOLD, DVNORM C KFLAG = 0 TOLD = TN NCF = 0 IERPJ = 0 IERSL = 0 JCUR = 0 ICF = 0 DELP = 0.0D0 IF (JSTART .GT. 0) GO TO 200 IF (JSTART .EQ. -1) GO TO 100 IF (JSTART .EQ. -2) GO TO 160 C----------------------------------------------------------------------- C On the first call, the order is set to 1, and other variables are C initialized. RMAX is the maximum ratio by which H can be increased C in a single step. It is initially 1.E4 to compensate for the small C initial H, but then is normally equal to 10. If a failure C occurs (in corrector convergence or error test), RMAX is set at 2 C for the next increase. C----------------------------------------------------------------------- LMAX = MAXORD + 1 NQ = 1 L = 2 IALTH = 2 RMAX = 10000.0D0 RC = 0.0D0 EL0 = 1.0D0 CRATE = 0.7D0 HOLD = H MEO = METH NSLP = 0 IPUP = MITER IRET = 3 GO TO 140 C----------------------------------------------------------------------- C The following block handles preliminaries needed when JSTART = -1. C IPUP is set to MITER to force a matrix update. C If an order increase is about to be considered (IALTH = 1), C IALTH is reset to 2 to postpone consideration one more step. C If the caller has changed METH, DCFODE is called to reset C the coefficients of the method. C If the caller has changed MAXORD to a value less than the current C order NQ, NQ is reduced to MAXORD, and a new H chosen accordingly. C If H is to be changed, YH must be rescaled. C If H or METH is being changed, IALTH is reset to L = NQ + 1 C to prevent further changes in H for that many steps. C----------------------------------------------------------------------- 100 IPUP = MITER LMAX = MAXORD + 1 IF (IALTH .EQ. 1) IALTH = 2 IF (METH .EQ. MEO) GO TO 110 CALL DCFODE (METH, ELCO, TESCO) MEO = METH IF (NQ .GT. MAXORD) GO TO 120 IALTH = L IRET = 1 GO TO 150 110 IF (NQ .LE. MAXORD) GO TO 160 120 NQ = MAXORD L = LMAX DO 125 I = 1,L EL(I) = ELCO(I,NQ) 125 CONTINUE NQNYH = NQ*NYH RC = RC*EL(1)/EL0 EL0 = EL(1) CONIT = 0.5D0/(NQ+2) EPCON = CONIT*TESCO(2,NQ) DDN = DVNORM (N, SAVF, EWT)/TESCO(1,L) EXDN = 1.0D0/L RHDN = 1.0D0/(1.3D0*DDN**EXDN + 0.0000013D0) RH = MIN(RHDN,1.0D0) IREDO = 3 IF (H .EQ. HOLD) GO TO 170 RH = MIN(RH,ABS(H/HOLD)) H = HOLD GO TO 175 C----------------------------------------------------------------------- C DCFODE is called to get all the integration coefficients for the C current METH. Then the EL vector and related constants are reset C whenever the order NQ is changed, or at the start of the problem. C----------------------------------------------------------------------- 140 CALL DCFODE (METH, ELCO, TESCO) 150 DO 155 I = 1,L EL(I) = ELCO(I,NQ) 155 CONTINUE NQNYH = NQ*NYH RC = RC*EL(1)/EL0 EL0 = EL(1) CONIT = 0.5D0/(NQ+2) EPCON = CONIT*TESCO(2,NQ) IF (IRET .EQ. 1) THEN GOTO 160 ELSE IF (IRET .EQ. 2) THEN GOTO 170 ELSE IF (IRET .EQ. 3) THEN GOTO 200 ENDIF C karline changed from C GO TO (160, 170, 200), IRET C----------------------------------------------------------------------- C If H is being changed, the H ratio RH is checked against C RMAX, HMIN, and HMXI, and the YH array rescaled. IALTH is set to C L = NQ + 1 to prevent a change of H for that many steps, unless C forced by a convergence or error test failure. C----------------------------------------------------------------------- 160 IF (H .EQ. HOLD) GO TO 200 RH = H/HOLD H = HOLD IREDO = 3 GO TO 175 170 RH = MAX(RH,HMIN/ABS(H)) 175 RH = MIN(RH,RMAX) RH = RH/MAX(1.0D0,ABS(H)*HMXI*RH) R = 1.0D0 DO 190 J = 2,L R = R*RH DO 180 I = 1,N YH(I,J) = YH(I,J)*R 180 CONTINUE 190 CONTINUE H = H*RH RC = RC*RH IALTH = L IF (IREDO .EQ. 0) GO TO 690 C----------------------------------------------------------------------- C This section computes the predicted values by effectively C multiplying the YH array by the Pascal triangle matrix. C The flag IPUP is set according to whether matrix data is involved C (JACFLG .ne. 0) or not (JACFLG = 0), to trigger a call to DPKSET. C IPUP is set to MITER when RC differs from 1 by more than CCMAX, C and at least every MSBP steps, when JACFLG = 1. C RC is the ratio of new to old values of the coefficient H*EL(1). C----------------------------------------------------------------------- 200 IF (JACFLG .NE. 0) GO TO 202 IPUP = 0 CRATE = 0.7D0 GO TO 205 202 IF (ABS(RC-1.0D0) .GT. CCMAX) IPUP = MITER IF (NST .GE. NSLP+MSBP) IPUP = MITER 205 TN = TN + H I1 = NQNYH + 1 DO 215 JB = 1,NQ I1 = I1 - NYH CDIR$ IVDEP DO 210 I = I1,NQNYH YH1(I) = YH1(I) + YH1(I+NYH) 210 CONTINUE 215 CONTINUE C----------------------------------------------------------------------- C Up to MAXCOR corrector iterations are taken. A convergence test is C made on the RMS-norm of each correction, weighted by the error C weight vector EWT. The sum of the corrections is accumulated in the C vector ACOR(i). The YH array is not altered in the corrector loop. C----------------------------------------------------------------------- 220 M = 0 MNEWT = 0 DO 230 I = 1,N Y(I) = YH(I,1) 230 CONTINUE CKS CALL F (NEQ, TN, Y, SAVF, rpar, ipar) NFE = NFE + 1 IF (IPUP .LE. 0) GO TO 250 C----------------------------------------------------------------------- C If indicated, DPKSET is called to update any matrix data needed, C before starting the corrector iteration. C IPUP is set to 0 as an indicator that this has been done. C----------------------------------------------------------------------- CALL DPKSET (NEQ, Y, YH1, EWT, ACOR, SAVF, WM, IWM, F, JAC, &rpar,ipar) IPUP = 0 RC = 1.0D0 NSLP = NST CRATE = 0.7D0 IF (IERPJ .NE. 0) GO TO 430 250 DO 260 I = 1,N ACOR(I) = 0.0D0 260 CONTINUE 270 IF (MITER .NE. 0) GO TO 350 C----------------------------------------------------------------------- C In the case of functional iteration, update Y directly from C the result of the last function evaluation. C----------------------------------------------------------------------- DO 290 I = 1,N SAVF(I) = H*SAVF(I) - YH(I,2) Y(I) = SAVF(I) - ACOR(I) 290 CONTINUE DEL = DVNORM (N, Y, EWT) DO 300 I = 1,N Y(I) = YH(I,1) + EL(1)*SAVF(I) ACOR(I) = SAVF(I) 300 CONTINUE GO TO 400 C----------------------------------------------------------------------- C In the case of the chord method, compute the corrector error, C and solve the linear system with that as right-hand side and C P as coefficient matrix. C----------------------------------------------------------------------- 350 DO 360 I = 1,N SAVX(I) = H*SAVF(I) - (YH(I,2) + ACOR(I)) 360 CONTINUE CALL DSOLPK (NEQ, Y, SAVF, SAVX, EWT, WM, IWM, F,PSOL,rpar,ipar) IF (IERSL .LT. 0) GO TO 430 IF (IERSL .GT. 0) GO TO 410 DEL = DVNORM (N, SAVX, EWT) DO 380 I = 1,N ACOR(I) = ACOR(I) + SAVX(I) Y(I) = YH(I,1) + EL(1)*ACOR(I) 380 CONTINUE C----------------------------------------------------------------------- C Test for convergence. If M .gt. 0, an estimate of the convergence C rate constant is stored in CRATE, and this is used in the test. C----------------------------------------------------------------------- 400 IF (M .NE. 0) CRATE = MAX(0.2D0*CRATE,DEL/DELP) DCON = DEL*MIN(1.0D0,1.5D0*CRATE)/EPCON IF (DCON .LE. 1.0D0) GO TO 450 M = M + 1 IF (M .EQ. MAXCOR) GO TO 410 IF (M .GE. 2 .AND. DEL .GT. 2.0D0*DELP) GO TO 410 MNEWT = M DELP = DEL CKS CALL F (NEQ, TN, Y, SAVF, rpar, ipar) NFE = NFE + 1 GO TO 270 C----------------------------------------------------------------------- C The corrector iteration failed to converge. C If MITER .ne. 0 and the Jacobian is out of date, DPKSET is called for C the next try. Otherwise the YH array is retracted to its values C before prediction, and H is reduced, if possible. If H cannot be C reduced or MXNCF failures have occurred, exit with KFLAG = -2. C----------------------------------------------------------------------- 410 IF (MITER.EQ.0 .OR. JCUR.EQ.1 .OR. JACFLG.EQ.0) GO TO 430 ICF = 1 IPUP = MITER GO TO 220 430 ICF = 2 NCF = NCF + 1 NCFN = NCFN + 1 RMAX = 2.0D0 TN = TOLD I1 = NQNYH + 1 DO 445 JB = 1,NQ I1 = I1 - NYH CDIR$ IVDEP DO 440 I = I1,NQNYH YH1(I) = YH1(I) - YH1(I+NYH) 440 CONTINUE 445 CONTINUE IF (IERPJ .LT. 0 .OR. IERSL .LT. 0) GO TO 680 IF (ABS(H) .LE. HMIN*1.00001D0) GO TO 670 IF (NCF .EQ. MXNCF) GO TO 670 RH = 0.5D0 IPUP = MITER IREDO = 1 GO TO 170 C----------------------------------------------------------------------- C The corrector has converged. JCUR is set to 0 C to signal that the Jacobian involved may need updating later. C The local error test is made and control passes to statement 500 C if it fails. C----------------------------------------------------------------------- 450 JCUR = 0 IF (M .EQ. 0) DSM = DEL/TESCO(2,NQ) IF (M .GT. 0) DSM = DVNORM (N, ACOR, EWT)/TESCO(2,NQ) IF (DSM .GT. 1.0D0) GO TO 500 C----------------------------------------------------------------------- C After a successful step, update the YH array. C Consider changing H if IALTH = 1. Otherwise decrease IALTH by 1. C If IALTH is then 1 and NQ .lt. MAXORD, then ACOR is saved for C use in a possible order increase on the next step. C If a change in H is considered, an increase or decrease in order C by one is considered also. A change in H is made only if it is by a C factor of at least 1.1. If not, IALTH is set to 3 to prevent C testing for that many steps. C----------------------------------------------------------------------- KFLAG = 0 IREDO = 0 NST = NST + 1 HU = H NQU = NQ DO 480 J = 1,L DO 470 I = 1,N YH(I,J) = YH(I,J) + EL(J)*ACOR(I) 470 CONTINUE 480 CONTINUE IALTH = IALTH - 1 IF (IALTH .EQ. 0) GO TO 520 IF (IALTH .GT. 1) GO TO 700 IF (L .EQ. LMAX) GO TO 700 DO 490 I = 1,N YH(I,LMAX) = ACOR(I) 490 CONTINUE GO TO 700 C----------------------------------------------------------------------- C The error test failed. KFLAG keeps track of multiple failures. C Restore TN and the YH array to their previous values, and prepare C to try the step again. Compute the optimum step size for this or C one lower order. After 2 or more failures, H is forced to decrease C by a factor of 0.2 or less. C----------------------------------------------------------------------- 500 KFLAG = KFLAG - 1 TN = TOLD I1 = NQNYH + 1 DO 515 JB = 1,NQ I1 = I1 - NYH CDIR$ IVDEP DO 510 I = I1,NQNYH YH1(I) = YH1(I) - YH1(I+NYH) 510 CONTINUE 515 CONTINUE RMAX = 2.0D0 IF (ABS(H) .LE. HMIN*1.00001D0) GO TO 660 IF (KFLAG .LE. -3) GO TO 640 IREDO = 2 RHUP = 0.0D0 GO TO 540 C----------------------------------------------------------------------- C Regardless of the success or failure of the step, factors C RHDN, RHSM, and RHUP are computed, by which H could be multiplied C at order NQ - 1, order NQ, or order NQ + 1, respectively. C In the case of failure, RHUP = 0.0 to avoid an order increase. C the largest of these is determined and the new order chosen C accordingly. If the order is to be increased, we compute one C additional scaled derivative. C----------------------------------------------------------------------- 520 RHUP = 0.0D0 IF (L .EQ. LMAX) GO TO 540 DO 530 I = 1,N SAVF(I) = ACOR(I) - YH(I,LMAX) 530 CONTINUE DUP = DVNORM (N, SAVF, EWT)/TESCO(3,NQ) EXUP = 1.0D0/(L+1) RHUP = 1.0D0/(1.4D0*DUP**EXUP + 0.0000014D0) 540 EXSM = 1.0D0/L RHSM = 1.0D0/(1.2D0*DSM**EXSM + 0.0000012D0) RHDN = 0.0D0 IF (NQ .EQ. 1) GO TO 560 DDN = DVNORM (N, YH(1,L), EWT)/TESCO(1,NQ) EXDN = 1.0D0/NQ RHDN = 1.0D0/(1.3D0*DDN**EXDN + 0.0000013D0) 560 IF (RHSM .GE. RHUP) GO TO 570 IF (RHUP .GT. RHDN) GO TO 590 GO TO 580 570 IF (RHSM .LT. RHDN) GO TO 580 NEWQ = NQ RH = RHSM GO TO 620 580 NEWQ = NQ - 1 RH = RHDN IF (KFLAG .LT. 0 .AND. RH .GT. 1.0D0) RH = 1.0D0 GO TO 620 590 NEWQ = L RH = RHUP IF (RH .LT. 1.1D0) GO TO 610 R = EL(L)/L DO 600 I = 1,N YH(I,NEWQ+1) = ACOR(I)*R 600 CONTINUE GO TO 630 610 IALTH = 3 GO TO 700 620 IF ((KFLAG .EQ. 0) .AND. (RH .LT. 1.1D0)) GO TO 610 IF (KFLAG .LE. -2) RH = MIN(RH,0.2D0) C----------------------------------------------------------------------- C If there is a change of order, reset NQ, L, and the coefficients. C In any case H is reset according to RH and the YH array is rescaled. C Then exit from 690 if the step was OK, or redo the step otherwise. C----------------------------------------------------------------------- IF (NEWQ .EQ. NQ) GO TO 170 630 NQ = NEWQ L = NQ + 1 IRET = 2 GO TO 150 C----------------------------------------------------------------------- C Control reaches this section if 3 or more failures have occured. C If 10 failures have occurred, exit with KFLAG = -1. C It is assumed that the derivatives that have accumulated in the C YH array have errors of the wrong order. Hence the first C derivative is recomputed, and the order is set to 1. Then C H is reduced by a factor of 10, and the step is retried, C until it succeeds or H reaches HMIN. C----------------------------------------------------------------------- 640 IF (KFLAG .EQ. -10) GO TO 660 RH = 0.1D0 RH = MAX(HMIN/ABS(H),RH) H = H*RH DO 645 I = 1,N Y(I) = YH(I,1) 645 CONTINUE CKS CALL F (NEQ, TN, Y, SAVF, rpar, ipar) NFE = NFE + 1 DO 650 I = 1,N YH(I,2) = H*SAVF(I) 650 CONTINUE IPUP = MITER IALTH = 5 IF (NQ .EQ. 1) GO TO 200 NQ = 1 L = 2 IRET = 3 GO TO 150 C----------------------------------------------------------------------- C All returns are made through this section. H is saved in HOLD C to allow the caller to change H on the next step. C----------------------------------------------------------------------- 660 KFLAG = -1 GO TO 720 670 KFLAG = -2 GO TO 720 680 KFLAG = -3 GO TO 720 690 RMAX = 10.0D0 700 R = 1.0D0/TESCO(2,NQU) DO 710 I = 1,N ACOR(I) = ACOR(I)*R 710 CONTINUE 720 HOLD = H JSTART = 1 RETURN C----------------------- End of Subroutine DSTODPK --------------------- END *DECK DPKSET SUBROUTINE DPKSET (NEQ, Y, YSV, EWT, FTEM, SAVF, WM, IWM, F, JAC, &rpar,ipar) EXTERNAL F, JAC CKS: added rpar,ipar integer ipar(*) double precision rpar(*) INTEGER NEQ, IWM DOUBLE PRECISION Y, YSV, EWT, FTEM, SAVF, WM DIMENSION NEQ(*), Y(*), YSV(*), EWT(*), FTEM(*), SAVF(*), 1 WM(*), IWM(*) INTEGER IOWND, IOWNS, 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU INTEGER JPRE, JACFLG, LOCWP, LOCIWP, LSAVX, KMP, MAXL, MNEWT, 1 NNI, NLI, NPS, NCFN, NCFL DOUBLE PRECISION ROWNS, 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND DOUBLE PRECISION DELT, EPCON, SQRTN, RSQRTN COMMON /DLS001/ ROWNS(209), 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 2 IOWND(6), IOWNS(6), 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU COMMON /DLPK01/ DELT, EPCON, SQRTN, RSQRTN, 1 JPRE, JACFLG, LOCWP, LOCIWP, LSAVX, KMP, MAXL, MNEWT, 2 NNI, NLI, NPS, NCFN, NCFL C----------------------------------------------------------------------- C DPKSET is called by DSTODPK to interface with the user-supplied C routine JAC, to compute and process relevant parts of C the matrix P = I - H*EL(1)*J , where J is the Jacobian df/dy, C as need for preconditioning matrix operations later. C C In addition to variables described previously, communication C with DPKSET uses the following: C Y = array containing predicted values on entry. C YSV = array containing predicted y, to be saved (YH1 in DSTODPK). C FTEM = work array of length N (ACOR in DSTODPK). C SAVF = array containing f evaluated at predicted y. C WM = real work space for matrices. C Space for preconditioning data starts at WM(LOCWP). C IWM = integer work space. C Space for preconditioning data starts at IWM(LOCIWP). C IERPJ = output error flag, = 0 if no trouble, .gt. 0 if C JAC returned an error flag. C JCUR = output flag = 1 to indicate that the Jacobian matrix C (or approximation) is now current. C This routine also uses Common variables EL0, H, TN, IERPJ, JCUR, NJE. C----------------------------------------------------------------------- INTEGER IER DOUBLE PRECISION HL0 C IERPJ = 0 JCUR = 1 HL0 = EL0*H CALL JAC (F, NEQ, TN, Y, YSV, EWT, SAVF, FTEM, HL0, 1 WM(LOCWP), IWM(LOCIWP), IER,rpar,ipar) NJE = NJE + 1 IF (IER .EQ. 0) RETURN IERPJ = 1 RETURN C----------------------- End of Subroutine DPKSET ---------------------- END *DECK DSOLPK SUBROUTINE DSOLPK (NEQ, Y, SAVF, X, EWT, WM, IWM, F, PSOL, 1 rpar,ipar) EXTERNAL F, PSOL INTEGER NEQ, IWM ,ipar(*) DOUBLE PRECISION Y, SAVF, X, EWT, WM,rpar(*) DIMENSION NEQ(*), Y(*), SAVF(*), X(*), EWT(*), WM(*), IWM(*) INTEGER IOWND, IOWNS, 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU INTEGER JPRE, JACFLG, LOCWP, LOCIWP, LSAVX, KMP, MAXL, MNEWT, 1 NNI, NLI, NPS, NCFN, NCFL DOUBLE PRECISION ROWNS, 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND DOUBLE PRECISION DELT, EPCON, SQRTN, RSQRTN COMMON /DLS001/ ROWNS(209), 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 2 IOWND(6), IOWNS(6), 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU COMMON /DLPK01/ DELT, EPCON, SQRTN, RSQRTN, 1 JPRE, JACFLG, LOCWP, LOCIWP, LSAVX, KMP, MAXL, MNEWT, 2 NNI, NLI, NPS, NCFN, NCFL C----------------------------------------------------------------------- C This routine interfaces to one of DSPIOM, DSPIGMR, DPCG, DPCGS, or C DUSOL, for the solution of the linear system arising from a Newton C iteration. It is called if MITER .ne. 0. C In addition to variables described elsewhere, C communication with DSOLPK uses the following variables: C WM = real work space containing data for the algorithm C (Krylov basis vectors, Hessenberg matrix, etc.) C IWM = integer work space containing data for the algorithm C X = the right-hand side vector on input, and the solution vector C on output, of length N. C IERSL = output flag (in Common): C IERSL = 0 means no trouble occurred. C IERSL = 1 means the iterative method failed to converge. C If the preconditioner is out of date, the step C is repeated with a new preconditioner. C Otherwise, the stepsize is reduced (forcing a C new evaluation of the preconditioner) and the C step is repeated. C IERSL = -1 means there was a nonrecoverable error in the C iterative solver, and an error exit occurs. C This routine also uses the Common variables TN, EL0, H, N, MITER, C DELT, EPCON, SQRTN, RSQRTN, MAXL, KMP, MNEWT, NNI, NLI, NPS, NCFL, C LOCWP, LOCIWP. C----------------------------------------------------------------------- INTEGER IFLAG, LB, LDL, LHES, LIOM, LGMR, LPCG, LP, LQ, LR, 1 LV, LW, LWK, LZ, MAXLP1, NPSL DOUBLE PRECISION DELTA, HL0 C IERSL = 0 HL0 = H*EL0 DELTA = DELT*EPCON IF (MITER .EQ. 1) THEN GOTO 100 ELSE IF (MITER .EQ. 2) THEN GOTO 200 ELSE IF (MITER .EQ. 3) THEN GOTO 300 ELSE IF (MITER .EQ. 4) THEN GOTO 400 ELSE IF (MITER .LE. 9) THEN GOTO 900 ENDIF C karline: changed from C GO TO (100, 200, 300, 400, 900, 900, 900, 900, 900), MITER C----------------------------------------------------------------------- C Use the SPIOM algorithm to solve the linear system P*x = -f. C----------------------------------------------------------------------- 100 CONTINUE LV = 1 LB = LV + N*MAXL LHES = LB + N LWK = LHES + MAXL*MAXL CALL DCOPY (N, X, 1, WM(LB), 1) CALL DSCAL (N, RSQRTN, EWT, 1) CALL DSPIOM (NEQ, TN, Y, SAVF, WM(LB), EWT, N, MAXL, KMP, DELTA, 1 HL0, JPRE, MNEWT, F, PSOL, NPSL, X, WM(LV), WM(LHES), IWM, 2 LIOM, WM(LOCWP), IWM(LOCIWP), WM(LWK), IFLAG, rpar,ipar) NNI = NNI + 1 NLI = NLI + LIOM NPS = NPS + NPSL CALL DSCAL (N, SQRTN, EWT, 1) IF (IFLAG .NE. 0) NCFL = NCFL + 1 IF (IFLAG .GE. 2) IERSL = 1 IF (IFLAG .LT. 0) IERSL = -1 RETURN C----------------------------------------------------------------------- C Use the SPIGMR algorithm to solve the linear system P*x = -f. C----------------------------------------------------------------------- 200 CONTINUE MAXLP1 = MAXL + 1 LV = 1 LB = LV + N*MAXL LHES = LB + N + 1 LQ = LHES + MAXL*MAXLP1 LWK = LQ + 2*MAXL LDL = LWK + MIN(1,MAXL-KMP)*N CALL DCOPY (N, X, 1, WM(LB), 1) CALL DSCAL (N, RSQRTN, EWT, 1) CALL DSPIGMR (NEQ, TN, Y, SAVF, WM(LB), EWT, N, MAXL, MAXLP1, KMP, 1 DELTA, HL0, JPRE, MNEWT, F, PSOL, NPSL, X, WM(LV), WM(LHES), 2 WM(LQ), LGMR, WM(LOCWP), IWM(LOCIWP), WM(LWK), WM(LDL), IFLAG, 3 rpar,ipar) NNI = NNI + 1 NLI = NLI + LGMR NPS = NPS + NPSL CALL DSCAL (N, SQRTN, EWT, 1) IF (IFLAG .NE. 0) NCFL = NCFL + 1 IF (IFLAG .GE. 2) IERSL = 1 IF (IFLAG .LT. 0) IERSL = -1 RETURN C----------------------------------------------------------------------- C Use DPCG to solve the linear system P*x = -f C----------------------------------------------------------------------- 300 CONTINUE LR = 1 LP = LR + N LW = LP + N LZ = LW + N LWK = LZ + N CALL DCOPY (N, X, 1, WM(LR), 1) CALL DPCG (NEQ, TN, Y, SAVF, WM(LR), EWT, N, MAXL, DELTA, HL0, 1 JPRE, MNEWT, F, PSOL, NPSL, X, WM(LP), WM(LW), WM(LZ), 2 LPCG, WM(LOCWP), IWM(LOCIWP),WM(LWK),IFLAG,rpar, ipar) NNI = NNI + 1 NLI = NLI + LPCG NPS = NPS + NPSL IF (IFLAG .NE. 0) NCFL = NCFL + 1 IF (IFLAG .GE. 2) IERSL = 1 IF (IFLAG .LT. 0) IERSL = -1 RETURN C----------------------------------------------------------------------- C Use DPCGS to solve the linear system P*x = -f C----------------------------------------------------------------------- 400 CONTINUE LR = 1 LP = LR + N LW = LP + N LZ = LW + N LWK = LZ + N CALL DCOPY (N, X, 1, WM(LR), 1) CALL DPCGS (NEQ, TN, Y, SAVF, WM(LR), EWT, N, MAXL, DELTA, HL0, 1 JPRE, MNEWT, F, PSOL, NPSL, X, WM(LP), WM(LW), WM(LZ), 2 LPCG, WM(LOCWP), IWM(LOCIWP), WM(LWK), IFLAG,rpar,ipar) NNI = NNI + 1 NLI = NLI + LPCG NPS = NPS + NPSL IF (IFLAG .NE. 0) NCFL = NCFL + 1 IF (IFLAG .GE. 2) IERSL = 1 IF (IFLAG .LT. 0) IERSL = -1 RETURN C----------------------------------------------------------------------- C Use DUSOL, which interfaces to PSOL, to solve the linear system C (no Krylov iteration). C----------------------------------------------------------------------- 900 CONTINUE LB = 1 LWK = LB + N CALL DCOPY (N, X, 1, WM(LB), 1) CALL DUSOL (NEQ, TN, Y, SAVF, WM(LB), EWT, N, DELTA, HL0, MNEWT, 1 PSOL, NPSL, X, WM(LOCWP), IWM(LOCIWP), WM(LWK), IFLAG) NNI = NNI + 1 NPS = NPS + NPSL IF (IFLAG .NE. 0) NCFL = NCFL + 1 IF (IFLAG .EQ. 3) IERSL = 1 IF (IFLAG .LT. 0) IERSL = -1 RETURN C----------------------- End of Subroutine DSOLPK ---------------------- END *DECK DSPIOM SUBROUTINE DSPIOM (NEQ, TN, Y, SAVF, B, WGHT, N, MAXL, KMP, DELTA, 1 HL0, JPRE, MNEWT, F, PSOL, NPSL, X, V, HES, IPVT, 2 LIOM, WP, IWP, WK, IFLAG,rpar,ipar) EXTERNAL F, PSOL INTEGER NEQ,N,MAXL,KMP,JPRE,MNEWT,NPSL,IPVT,LIOM,IWP,IFLAG,ipar(*) DOUBLE PRECISION TN,Y,SAVF,B,WGHT,DELTA,HL0,X,V,HES,WP,WK,rpar(*) DIMENSION NEQ(*), Y(*), SAVF(*), B(*), WGHT(*), X(*), V(N,*), 1 HES(MAXL,MAXL), IPVT(*), WP(*), IWP(*), WK(*) C----------------------------------------------------------------------- C This routine solves the linear system A * x = b using a scaled C preconditioned version of the Incomplete Orthogonalization Method. C An initial guess of x = 0 is assumed. C----------------------------------------------------------------------- C C On entry C C NEQ = problem size, passed to F and PSOL (NEQ(1) = N). C C TN = current value of t. C C Y = array containing current dependent variable vector. C C SAVF = array containing current value of f(t,y). C C B = the right hand side of the system A*x = b. C B is also used as work space when computing the C final approximation. C (B is the same as V(*,MAXL+1) in the call to DSPIOM.) C C WGHT = array of length N containing scale factors. C 1/WGHT(i) are the diagonal elements of the diagonal C scaling matrix D. C C N = the order of the matrix A, and the lengths C of the vectors Y, SAVF, B, WGHT, and X. C C MAXL = the maximum allowable order of the matrix HES. C C KMP = the number of previous vectors the new vector VNEW C must be made orthogonal to. KMP .le. MAXL. C C DELTA = tolerance on residuals b - A*x in weighted RMS-norm. C C HL0 = current value of (step size h) * (coefficient l0). C C JPRE = preconditioner type flag. C C MNEWT = Newton iteration counter (.ge. 0). C C WK = real work array of length N used by DATV and PSOL. C C WP = real work array used by preconditioner PSOL. C C IWP = integer work array used by preconditioner PSOL. C C On return C C X = the final computed approximation to the solution C of the system A*x = b. C C V = the N by (LIOM+1) array containing the LIOM C orthogonal vectors V(*,1) to V(*,LIOM). C C HES = the LU factorization of the LIOM by LIOM upper C Hessenberg matrix whose entries are the C scaled inner products of A*V(*,k) and V(*,i). C C IPVT = an integer array containg pivoting information. C It is loaded in DHEFA and used in DHESL. C C LIOM = the number of iterations performed, and current C order of the upper Hessenberg matrix HES. C C NPSL = the number of calls to PSOL. C C IFLAG = integer error flag: C 0 means convergence in LIOM iterations, LIOM.le.MAXL. C 1 means the convergence test did not pass in MAXL C iterations, but the residual norm is .lt. 1, C or .lt. norm(b) if MNEWT = 0, and so X is computed. C 2 means the convergence test did not pass in MAXL C iterations, residual .gt. 1, and X is undefined. C 3 means there was a recoverable error in PSOL C caused by the preconditioner being out of date. C -1 means there was a nonrecoverable error in PSOL. C C----------------------------------------------------------------------- INTEGER I, IER, INFO, J, K, LL, LM1 DOUBLE PRECISION BNRM, BNRM0, PROD, RHO, SNORMW, DNRM2, TEM C IFLAG = 0 LIOM = 0 NPSL = 0 C----------------------------------------------------------------------- C The initial residual is the vector b. Apply scaling to b, and test C for an immediate return with X = 0 or X = b. C----------------------------------------------------------------------- DO 10 I = 1,N V(I,1) = B(I)*WGHT(I) 10 CONTINUE BNRM0 = DNRM2 (N, V, 1) BNRM = BNRM0 IF (BNRM0 .GT. DELTA) GO TO 30 IF (MNEWT .GT. 0) GO TO 20 CALL DCOPY (N, B, 1, X, 1) RETURN 20 DO 25 I = 1,N X(I) = 0.0D0 25 CONTINUE RETURN 30 CONTINUE C Apply inverse of left preconditioner to vector b. -------------------- IER = 0 IF (JPRE .EQ. 0 .OR. JPRE .EQ. 2) GO TO 55 CALL PSOL (NEQ, TN, Y, SAVF, WK, HL0, WP, IWP, B, 1, IER) NPSL = 1 IF (IER .NE. 0) GO TO 300 C Calculate norm of scaled vector V(*,1) and normalize it. ------------- DO 50 I = 1,N V(I,1) = B(I)*WGHT(I) 50 CONTINUE BNRM = DNRM2(N, V, 1) DELTA = DELTA*(BNRM/BNRM0) 55 TEM = 1.0D0/BNRM CALL DSCAL (N, TEM, V(1,1), 1) C Zero out the HES array. ---------------------------------------------- DO 65 J = 1,MAXL DO 60 I = 1,MAXL HES(I,J) = 0.0D0 60 CONTINUE 65 CONTINUE C----------------------------------------------------------------------- C Main loop on LL = l to compute the vectors V(*,2) to V(*,MAXL). C The running product PROD is needed for the convergence test. C----------------------------------------------------------------------- PROD = 1.0D0 DO 90 LL = 1,MAXL LIOM = LL C----------------------------------------------------------------------- C Call routine DATV to compute VNEW = Abar*v(l), where Abar is C the matrix A with scaling and inverse preconditioner factors applied. C Call routine DORTHOG to orthogonalize the new vector vnew = V(*,l+1). C Call routine DHEFA to update the factors of HES. C----------------------------------------------------------------------- CALL DATV (NEQ, Y, SAVF, V(1,LL), WGHT, X, F, PSOL, V(1,LL+1), 1 WK, WP, IWP, HL0, JPRE, IER, NPSL, rpar,ipar) IF (IER .NE. 0) GO TO 300 CALL DORTHOG (V(1,LL+1), V, HES, N, LL, MAXL, KMP, SNORMW) CALL DHEFA (HES, MAXL, LL, IPVT, INFO, LL) LM1 = LL - 1 IF (LL .GT. 1 .AND. IPVT(LM1) .EQ. LM1) PROD = PROD*HES(LL,LM1) IF (INFO .NE. LL) GO TO 70 C----------------------------------------------------------------------- C The last pivot in HES was found to be zero. C If vnew = 0 or l = MAXL, take an error return with IFLAG = 2. C otherwise, continue the iteration without a convergence test. C----------------------------------------------------------------------- IF (SNORMW .EQ. 0.0D0) GO TO 120 IF (LL .EQ. MAXL) GO TO 120 GO TO 80 C----------------------------------------------------------------------- C Update RHO, the estimate of the norm of the residual b - A*x(l). C test for convergence. If passed, compute approximation x(l). C If failed and l .lt. MAXL, then continue iterating. C----------------------------------------------------------------------- 70 CONTINUE RHO = BNRM*SNORMW*ABS(PROD/HES(LL,LL)) IF (RHO .LE. DELTA) GO TO 200 IF (LL .EQ. MAXL) GO TO 100 C If l .lt. MAXL, store HES(l+1,l) and normalize the vector v(*,l+1). 80 CONTINUE HES(LL+1,LL) = SNORMW TEM = 1.0D0/SNORMW CALL DSCAL (N, TEM, V(1,LL+1), 1) 90 CONTINUE C----------------------------------------------------------------------- C l has reached MAXL without passing the convergence test: C If RHO is not too large, compute a solution anyway and return with C IFLAG = 1. Otherwise return with IFLAG = 2. C----------------------------------------------------------------------- 100 CONTINUE IF (RHO .LE. 1.0D0) GO TO 150 IF (RHO .LE. BNRM .AND. MNEWT .EQ. 0) GO TO 150 120 CONTINUE IFLAG = 2 RETURN 150 IFLAG = 1 C----------------------------------------------------------------------- C Compute the approximation x(l) to the solution. C Since the vector X was used as work space, and the initial guess C of the Newton correction is zero, X must be reset to zero. C----------------------------------------------------------------------- 200 CONTINUE LL = LIOM DO 210 K = 1,LL B(K) = 0.0D0 210 CONTINUE B(1) = BNRM CALL DHESL (HES, MAXL, LL, IPVT, B) DO 220 K = 1,N X(K) = 0.0D0 220 CONTINUE DO 230 I = 1,LL CALL DAXPY (N, B(I), V(1,I), 1, X, 1) 230 CONTINUE DO 240 I = 1,N X(I) = X(I)/WGHT(I) 240 CONTINUE IF (JPRE .LE. 1) RETURN CALL PSOL (NEQ, TN, Y, SAVF, WK, HL0, WP, IWP, X, 2, IER) NPSL = NPSL + 1 IF (IER .NE. 0) GO TO 300 RETURN C----------------------------------------------------------------------- C This block handles error returns forced by routine PSOL. C----------------------------------------------------------------------- 300 CONTINUE IF (IER .LT. 0) IFLAG = -1 IF (IER .GT. 0) IFLAG = 3 RETURN C----------------------- End of Subroutine DSPIOM ---------------------- END *DECK DATV SUBROUTINE DATV (NEQ, Y, SAVF, V, WGHT, FTEM, F, PSOL, Z, VTEM, 1 WP, IWP, HL0, JPRE, IER, NPSL,rpar,ipar) EXTERNAL F, PSOL INTEGER NEQ, IWP, JPRE, IER, NPSL ,ipar(*) DOUBLE PRECISION Y, SAVF, V, WGHT, FTEM, Z, VTEM, WP, HL0,rpar(*) DIMENSION NEQ(*), Y(*), SAVF(*), V(*), WGHT(*), FTEM(*), Z(*), 1 VTEM(*), WP(*), IWP(*) INTEGER IOWND, IOWNS, 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU DOUBLE PRECISION ROWNS, 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND COMMON /DLS001/ ROWNS(209), 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 2 IOWND(6), IOWNS(6), 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU C----------------------------------------------------------------------- C This routine computes the product C C (D-inverse)*(P1-inverse)*(I - hl0*df/dy)*(P2-inverse)*(D*v), C C where D is a diagonal scaling matrix, and P1 and P2 are the C left and right preconditioning matrices, respectively. C v is assumed to have WRMS norm equal to 1. C The product is stored in z. This is computed by a C difference quotient, a call to F, and two calls to PSOL. C----------------------------------------------------------------------- C C On entry C C NEQ = problem size, passed to F and PSOL (NEQ(1) = N). C C Y = array containing current dependent variable vector. C C SAVF = array containing current value of f(t,y). C C V = real array of length N (can be the same array as Z). C C WGHT = array of length N containing scale factors. C 1/WGHT(i) are the diagonal elements of the matrix D. C C FTEM = work array of length N. C C VTEM = work array of length N used to store the C unscaled version of V. C C WP = real work array used by preconditioner PSOL. C C IWP = integer work array used by preconditioner PSOL. C C HL0 = current value of (step size h) * (coefficient l0). C C JPRE = preconditioner type flag. C C C On return C C Z = array of length N containing desired scaled C matrix-vector product. C C IER = error flag from PSOL. C C NPSL = the number of calls to PSOL. C C In addition, this routine uses the Common variables TN, N, NFE. C----------------------------------------------------------------------- INTEGER I DOUBLE PRECISION FAC, RNORM, DNRM2, TEMPN C C Set VTEM = D * V. DO 10 I = 1,N VTEM(I) = V(I)/WGHT(I) 10 CONTINUE IER = 0 IF (JPRE .GE. 2) GO TO 30 C C JPRE = 0 or 1. Save Y in Z and increment Y by VTEM. CALL DCOPY (N, Y, 1, Z, 1) DO 20 I = 1,N Y(I) = Z(I) + VTEM(I) 20 CONTINUE FAC = HL0 GO TO 60 C C JPRE = 2 or 3. Apply inverse of right preconditioner to VTEM. 30 CONTINUE CALL PSOL (NEQ, TN, Y, SAVF, FTEM, HL0, WP, IWP, VTEM, 2, IER) NPSL = NPSL + 1 IF (IER .NE. 0) RETURN C Calculate L-2 norm of (D-inverse) * VTEM. DO 40 I = 1,N Z(I) = VTEM(I)*WGHT(I) 40 CONTINUE TEMPN = DNRM2 (N, Z, 1) RNORM = 1.0D0/TEMPN C Save Y in Z and increment Y by VTEM/norm. CALL DCOPY (N, Y, 1, Z, 1) DO 50 I = 1,N Y(I) = Z(I) + VTEM(I)*RNORM 50 CONTINUE FAC = HL0*TEMPN C C For all JPRE, call F with incremented Y argument, and restore Y. 60 CONTINUE CKS CALL F (NEQ, TN, Y, FTEM, rpar, ipar) NFE = NFE + 1 CALL DCOPY (N, Z, 1, Y, 1) C Set Z = (identity - hl0*Jacobian) * VTEM, using difference quotient. DO 70 I = 1,N Z(I) = FTEM(I) - SAVF(I) 70 CONTINUE DO 80 I = 1,N Z(I) = VTEM(I) - FAC*Z(I) 80 CONTINUE C Apply inverse of left preconditioner to Z, if nontrivial. IF (JPRE .EQ. 0 .OR. JPRE .EQ. 2) GO TO 85 CALL PSOL (NEQ, TN, Y, SAVF, FTEM, HL0, WP, IWP, Z, 1, IER) NPSL = NPSL + 1 IF (IER .NE. 0) RETURN 85 CONTINUE C Apply D-inverse to Z and return. DO 90 I = 1,N Z(I) = Z(I)*WGHT(I) 90 CONTINUE RETURN C----------------------- End of Subroutine DATV ------------------------ END *DECK DORTHOG SUBROUTINE DORTHOG (VNEW, V, HES, N, LL, LDHES, KMP, SNORMW) INTEGER N, LL, LDHES, KMP DOUBLE PRECISION VNEW, V, HES, SNORMW DIMENSION VNEW(*), V(N,*), HES(LDHES,*) C----------------------------------------------------------------------- C This routine orthogonalizes the vector VNEW against the previous C KMP vectors in the V array. It uses a modified Gram-Schmidt C orthogonalization procedure with conditional reorthogonalization. C This is the version of 28 may 1986. C----------------------------------------------------------------------- C C On entry C C VNEW = the vector of length N containing a scaled product C of the Jacobian and the vector V(*,LL). C C V = the N x l array containing the previous LL C orthogonal vectors v(*,1) to v(*,LL). C C HES = an LL x LL upper Hessenberg matrix containing, C in HES(i,k), k.lt.LL, scaled inner products of C A*V(*,k) and V(*,i). C C LDHES = the leading dimension of the HES array. C C N = the order of the matrix A, and the length of VNEW. C C LL = the current order of the matrix HES. C C KMP = the number of previous vectors the new vector VNEW C must be made orthogonal to (KMP .le. MAXL). C C C On return C C VNEW = the new vector orthogonal to V(*,i0) to V(*,LL), C where i0 = MAX(1, LL-KMP+1). C C HES = upper Hessenberg matrix with column LL filled in with C scaled inner products of A*V(*,LL) and V(*,i). C C SNORMW = L-2 norm of VNEW. C C----------------------------------------------------------------------- INTEGER I, I0 DOUBLE PRECISION ARG, DDOT, DNRM2, SUMDSQ, TEM, VNRM C C Get norm of unaltered VNEW for later use. ---------------------------- VNRM = DNRM2 (N, VNEW, 1) C----------------------------------------------------------------------- C Do modified Gram-Schmidt on VNEW = A*v(LL). C Scaled inner products give new column of HES. C Projections of earlier vectors are subtracted from VNEW. C----------------------------------------------------------------------- I0 = MAX(1,LL-KMP+1) DO 10 I = I0,LL HES(I,LL) = DDOT (N, V(1,I), 1, VNEW, 1) TEM = -HES(I,LL) CALL DAXPY (N, TEM, V(1,I), 1, VNEW, 1) 10 CONTINUE C----------------------------------------------------------------------- C Compute SNORMW = norm of VNEW. C If VNEW is small compared to its input value (in norm), then C reorthogonalize VNEW to V(*,1) through V(*,LL). C Correct if relative correction exceeds 1000*(unit roundoff). C finally, correct SNORMW using the dot products involved. C----------------------------------------------------------------------- SNORMW = DNRM2 (N, VNEW, 1) IF (VNRM + 0.001D0*SNORMW .NE. VNRM) RETURN SUMDSQ = 0.0D0 DO 30 I = I0,LL TEM = -DDOT (N, V(1,I), 1, VNEW, 1) IF (HES(I,LL) + 0.001D0*TEM .EQ. HES(I,LL)) GO TO 30 HES(I,LL) = HES(I,LL) - TEM CALL DAXPY (N, TEM, V(1,I), 1, VNEW, 1) SUMDSQ = SUMDSQ + TEM**2 30 CONTINUE IF (SUMDSQ .EQ. 0.0D0) RETURN ARG = MAX(0.0D0,SNORMW**2 - SUMDSQ) SNORMW = SQRT(ARG) C RETURN C----------------------- End of Subroutine DORTHOG --------------------- END *DECK DSPIGMR SUBROUTINE DSPIGMR (NEQ, TN, Y, SAVF, B, WGHT, N, MAXL, MAXLP1, 1 KMP, DELTA, HL0, JPRE, MNEWT, F, PSOL, NPSL, X, V, HES, Q, 2 LGMR, WP, IWP, WK, DL, IFLAG,rpar,ipar) EXTERNAL F, PSOL integer ipar(*) double precision rpar(*) INTEGER NEQ,N,MAXL,MAXLP1,KMP,JPRE,MNEWT,NPSL,LGMR,IWP,IFLAG DOUBLE PRECISION TN,Y,SAVF,B,WGHT,DELTA,HL0,X,V,HES,Q,WP,WK,DL DIMENSION NEQ(*), Y(*), SAVF(*), B(*), WGHT(*), X(*), V(N,*), 1 HES(MAXLP1,*), Q(*), WP(*), IWP(*), WK(*), DL(*) C----------------------------------------------------------------------- C This routine solves the linear system A * x = b using a scaled C preconditioned version of the Generalized Minimal Residual method. C An initial guess of x = 0 is assumed. C----------------------------------------------------------------------- C C On entry C C NEQ = problem size, passed to F and PSOL (NEQ(1) = N). C C TN = current value of t. C C Y = array containing current dependent variable vector. C C SAVF = array containing current value of f(t,y). C C B = the right hand side of the system A*x = b. C B is also used as work space when computing C the final approximation. C (B is the same as V(*,MAXL+1) in the call to DSPIGMR.) C C WGHT = the vector of length N containing the nonzero C elements of the diagonal scaling matrix. C C N = the order of the matrix A, and the lengths C of the vectors WGHT, B and X. C C MAXL = the maximum allowable order of the matrix HES. C C MAXLP1 = MAXL + 1, used for dynamic dimensioning of HES. C C KMP = the number of previous vectors the new vector VNEW C must be made orthogonal to. KMP .le. MAXL. C C DELTA = tolerance on residuals b - A*x in weighted RMS-norm. C C HL0 = current value of (step size h) * (coefficient l0). C C JPRE = preconditioner type flag. C C MNEWT = Newton iteration counter (.ge. 0). C C WK = real work array used by routine DATV and PSOL. C C DL = real work array used for calculation of the residual C norm RHO when the method is incomplete (KMP .lt. MAXL). C Not needed or referenced in complete case (KMP = MAXL). C C WP = real work array used by preconditioner PSOL. C C IWP = integer work array used by preconditioner PSOL. C C On return C C X = the final computed approximation to the solution C of the system A*x = b. C C LGMR = the number of iterations performed and C the current order of the upper Hessenberg C matrix HES. C C NPSL = the number of calls to PSOL. C C V = the N by (LGMR+1) array containing the LGMR C orthogonal vectors V(*,1) to V(*,LGMR). C C HES = the upper triangular factor of the QR decomposition C of the (LGMR+1) by lgmr upper Hessenberg matrix whose C entries are the scaled inner-products of A*V(*,i) C and V(*,k). C C Q = real array of length 2*MAXL containing the components C of the Givens rotations used in the QR decomposition C of HES. It is loaded in DHEQR and used in DHELS. C C IFLAG = integer error flag: C 0 means convergence in LGMR iterations, LGMR .le. MAXL. C 1 means the convergence test did not pass in MAXL C iterations, but the residual norm is .lt. 1, C or .lt. norm(b) if MNEWT = 0, and so x is computed. C 2 means the convergence test did not pass in MAXL C iterations, residual .gt. 1, and X is undefined. C 3 means there was a recoverable error in PSOL C caused by the preconditioner being out of date. C -1 means there was a nonrecoverable error in PSOL. C C----------------------------------------------------------------------- INTEGER I, IER, INFO, IP1, I2, J, K, LL, LLP1 DOUBLE PRECISION BNRM,BNRM0,C,DLNRM,PROD,RHO,S,SNORMW,DNRM2,TEM C IFLAG = 0 LGMR = 0 NPSL = 0 C----------------------------------------------------------------------- C The initial residual is the vector b. Apply scaling to b, and test C for an immediate return with X = 0 or X = b. C----------------------------------------------------------------------- DO 10 I = 1,N V(I,1) = B(I)*WGHT(I) 10 CONTINUE BNRM0 = DNRM2 (N, V, 1) BNRM = BNRM0 IF (BNRM0 .GT. DELTA) GO TO 30 IF (MNEWT .GT. 0) GO TO 20 CALL DCOPY (N, B, 1, X, 1) RETURN 20 DO 25 I = 1,N X(I) = 0.0D0 25 CONTINUE RETURN 30 CONTINUE C Apply inverse of left preconditioner to vector b. -------------------- IER = 0 IF (JPRE .EQ. 0 .OR. JPRE .EQ. 2) GO TO 55 CALL PSOL (NEQ, TN, Y, SAVF, WK, HL0, WP, IWP, B, 1, IER) NPSL = 1 IF (IER .NE. 0) GO TO 300 C Calculate norm of scaled vector V(*,1) and normalize it. ------------- DO 50 I = 1,N V(I,1) = B(I)*WGHT(I) 50 CONTINUE BNRM = DNRM2 (N, V, 1) DELTA = DELTA*(BNRM/BNRM0) 55 TEM = 1.0D0/BNRM CALL DSCAL (N, TEM, V(1,1), 1) C Zero out the HES array. ---------------------------------------------- DO 65 J = 1,MAXL DO 60 I = 1,MAXLP1 HES(I,J) = 0.0D0 60 CONTINUE 65 CONTINUE C----------------------------------------------------------------------- C Main loop to compute the vectors V(*,2) to V(*,MAXL). C The running product PROD is needed for the convergence test. C----------------------------------------------------------------------- PROD = 1.0D0 DO 90 LL = 1,MAXL LGMR = LL C----------------------------------------------------------------------- C Call routine DATV to compute VNEW = Abar*v(ll), where Abar is C the matrix A with scaling and inverse preconditioner factors applied. C Call routine DORTHOG to orthogonalize the new vector VNEW = V(*,LL+1). C Call routine DHEQR to update the factors of HES. C----------------------------------------------------------------------- CALL DATV (NEQ, Y, SAVF, V(1,LL), WGHT, X, F, PSOL, V(1,LL+1), 1 WK, WP, IWP, HL0, JPRE, IER, NPSL,rpar,ipar) IF (IER .NE. 0) GO TO 300 CALL DORTHOG (V(1,LL+1), V, HES, N, LL, MAXLP1, KMP, SNORMW) HES(LL+1,LL) = SNORMW CALL DHEQR (HES, MAXLP1, LL, Q, INFO, LL) IF (INFO .EQ. LL) GO TO 120 C----------------------------------------------------------------------- C Update RHO, the estimate of the norm of the residual b - A*xl. C If KMP .lt. MAXL, then the vectors V(*,1),...,V(*,LL+1) are not C necessarily orthogonal for LL .gt. KMP. The vector DL must then C be computed, and its norm used in the calculation of RHO. C----------------------------------------------------------------------- PROD = PROD*Q(2*LL) RHO = ABS(PROD*BNRM) IF ((LL.GT.KMP) .AND. (KMP.LT.MAXL)) THEN IF (LL .EQ. KMP+1) THEN CALL DCOPY (N, V(1,1), 1, DL, 1) DO 75 I = 1,KMP IP1 = I + 1 I2 = I*2 S = Q(I2) C = Q(I2-1) DO 70 K = 1,N DL(K) = S*DL(K) + C*V(K,IP1) 70 CONTINUE 75 CONTINUE ENDIF S = Q(2*LL) C = Q(2*LL-1)/SNORMW LLP1 = LL + 1 DO 80 K = 1,N DL(K) = S*DL(K) + C*V(K,LLP1) 80 CONTINUE DLNRM = DNRM2 (N, DL, 1) RHO = RHO*DLNRM ENDIF C----------------------------------------------------------------------- C Test for convergence. If passed, compute approximation xl. C if failed and LL .lt. MAXL, then continue iterating. C----------------------------------------------------------------------- IF (RHO .LE. DELTA) GO TO 200 IF (LL .EQ. MAXL) GO TO 100 C----------------------------------------------------------------------- C Rescale so that the norm of V(1,LL+1) is one. C----------------------------------------------------------------------- TEM = 1.0D0/SNORMW CALL DSCAL (N, TEM, V(1,LL+1), 1) 90 CONTINUE 100 CONTINUE IF (RHO .LE. 1.0D0) GO TO 150 IF (RHO .LE. BNRM .AND. MNEWT .EQ. 0) GO TO 150 120 CONTINUE IFLAG = 2 RETURN 150 IFLAG = 1 C----------------------------------------------------------------------- C Compute the approximation xl to the solution. C Since the vector X was used as work space, and the initial guess C of the Newton correction is zero, X must be reset to zero. C----------------------------------------------------------------------- 200 CONTINUE LL = LGMR LLP1 = LL + 1 DO 210 K = 1,LLP1 B(K) = 0.0D0 210 CONTINUE B(1) = BNRM CALL DHELS (HES, MAXLP1, LL, Q, B) DO 220 K = 1,N X(K) = 0.0D0 220 CONTINUE DO 230 I = 1,LL CALL DAXPY (N, B(I), V(1,I), 1, X, 1) 230 CONTINUE DO 240 I = 1,N X(I) = X(I)/WGHT(I) 240 CONTINUE IF (JPRE .LE. 1) RETURN CALL PSOL (NEQ, TN, Y, SAVF, WK, HL0, WP, IWP, X, 2, IER) NPSL = NPSL + 1 IF (IER .NE. 0) GO TO 300 RETURN C----------------------------------------------------------------------- C This block handles error returns forced by routine PSOL. C----------------------------------------------------------------------- 300 CONTINUE IF (IER .LT. 0) IFLAG = -1 IF (IER .GT. 0) IFLAG = 3 C RETURN C----------------------- End of Subroutine DSPIGMR --------------------- END *DECK DPCG SUBROUTINE DPCG (NEQ, TN, Y, SAVF, R, WGHT, N, MAXL, DELTA, HL0, 1 JPRE, MNEWT, F, PSOL, NPSL, X, P, W, Z, LPCG, WP, IWP, WK, IFLAG, 2 rpar,ipar) EXTERNAL F, PSOL INTEGER NEQ, N, MAXL, JPRE, MNEWT, NPSL, LPCG, IWP, IFLAG,ipar(*) DOUBLE PRECISION TN,Y,SAVF,R,WGHT,DELTA,HL0,X,P,W,Z,WP,WK,rpar(*) DIMENSION NEQ(*), Y(*), SAVF(*), R(*), WGHT(*), X(*), P(*), W(*), 1 Z(*), WP(*), IWP(*), WK(*) C----------------------------------------------------------------------- C This routine computes the solution to the system A*x = b using a C preconditioned version of the Conjugate Gradient algorithm. C It is assumed here that the matrix A and the preconditioner C matrix M are symmetric positive definite or nearly so. C----------------------------------------------------------------------- C C On entry C C NEQ = problem size, passed to F and PSOL (NEQ(1) = N). C C TN = current value of t. C C Y = array containing current dependent variable vector. C C SAVF = array containing current value of f(t,y). C C R = the right hand side of the system A*x = b. C C WGHT = array of length N containing scale factors. C 1/WGHT(i) are the diagonal elements of the diagonal C scaling matrix D. C C N = the order of the matrix A, and the lengths C of the vectors Y, SAVF, R, WGHT, P, W, Z, WK, and X. C C MAXL = the maximum allowable number of iterates. C C DELTA = tolerance on residuals b - A*x in weighted RMS-norm. C C HL0 = current value of (step size h) * (coefficient l0). C C JPRE = preconditioner type flag. C C MNEWT = Newton iteration counter (.ge. 0). C C WK = real work array used by routine DATP. C C WP = real work array used by preconditioner PSOL. C C IWP = integer work array used by preconditioner PSOL. C C On return C C X = the final computed approximation to the solution C of the system A*x = b. C C LPCG = the number of iterations performed, and current C order of the upper Hessenberg matrix HES. C C NPSL = the number of calls to PSOL. C C IFLAG = integer error flag: C 0 means convergence in LPCG iterations, LPCG .le. MAXL. C 1 means the convergence test did not pass in MAXL C iterations, but the residual norm is .lt. 1, C or .lt. norm(b) if MNEWT = 0, and so X is computed. C 2 means the convergence test did not pass in MAXL C iterations, residual .gt. 1, and X is undefined. C 3 means there was a recoverable error in PSOL C caused by the preconditioner being out of date. C 4 means there was a zero denominator in the algorithm. C The system matrix or preconditioner matrix is not C sufficiently close to being symmetric pos. definite. C -1 means there was a nonrecoverable error in PSOL. C C----------------------------------------------------------------------- INTEGER I, IER DOUBLE PRECISION ALPHA,BETA,BNRM,PTW,RNRM,DDOT,DVNORM,ZTR,ZTR0 C IFLAG = 0 NPSL = 0 LPCG = 0 DO 10 I = 1,N X(I) = 0.0D0 10 CONTINUE BNRM = DVNORM (N, R, WGHT) C Test for immediate return with X = 0 or X = b. ----------------------- IF (BNRM .GT. DELTA) GO TO 20 IF (MNEWT .GT. 0) RETURN CALL DCOPY (N, R, 1, X, 1) RETURN C 20 ZTR = 0.0D0 C Loop point for PCG iterations. --------------------------------------- 30 CONTINUE LPCG = LPCG + 1 CALL DCOPY (N, R, 1, Z, 1) IER = 0 IF (JPRE .EQ. 0) GO TO 40 CALL PSOL (NEQ, TN, Y, SAVF, WK, HL0, WP, IWP, Z, 3, IER) NPSL = NPSL + 1 IF (IER .NE. 0) GO TO 100 40 CONTINUE ZTR0 = ZTR ZTR = DDOT (N, Z, 1, R, 1) IF (LPCG .NE. 1) GO TO 50 CALL DCOPY (N, Z, 1, P, 1) GO TO 70 50 CONTINUE IF (ZTR0 .EQ. 0.0D0) GO TO 200 BETA = ZTR/ZTR0 DO 60 I = 1,N P(I) = Z(I) + BETA*P(I) 60 CONTINUE 70 CONTINUE C----------------------------------------------------------------------- C Call DATP to compute A*p and return the answer in W. C----------------------------------------------------------------------- CALL DATP (NEQ, Y, SAVF, P, WGHT, HL0, WK, F, W, rpar,ipar) C PTW = DDOT (N, P, 1, W, 1) IF (PTW .EQ. 0.0D0) GO TO 200 ALPHA = ZTR/PTW CALL DAXPY (N, ALPHA, P, 1, X, 1) ALPHA = -ALPHA CALL DAXPY (N, ALPHA, W, 1, R, 1) RNRM = DVNORM (N, R, WGHT) IF (RNRM .LE. DELTA) RETURN IF (LPCG .LT. MAXL) GO TO 30 IFLAG = 2 IF (RNRM .LE. 1.0D0) IFLAG = 1 IF (RNRM .LE. BNRM .AND. MNEWT .EQ. 0) IFLAG = 1 RETURN C----------------------------------------------------------------------- C This block handles error returns from PSOL. C----------------------------------------------------------------------- 100 CONTINUE IF (IER .LT. 0) IFLAG = -1 IF (IER .GT. 0) IFLAG = 3 RETURN C----------------------------------------------------------------------- C This block handles division by zero errors. C----------------------------------------------------------------------- 200 CONTINUE IFLAG = 4 RETURN C----------------------- End of Subroutine DPCG ------------------------ END *DECK DPCGS SUBROUTINE DPCGS (NEQ, TN, Y, SAVF, R, WGHT, N, MAXL, DELTA, HL0, 1 JPRE, MNEWT, F, PSOL, NPSL, X, P, W, Z, LPCG, WP, IWP, WK, IFLAG, 2 rpar,ipar) EXTERNAL F, PSOL INTEGER NEQ, N, MAXL, JPRE, MNEWT, NPSL, LPCG, IWP, IFLAG,ipar(*) DOUBLE PRECISION TN,Y,SAVF,R,WGHT,DELTA,HL0,X,P,W,Z,WP,WK,rpar(*) DIMENSION NEQ(*), Y(*), SAVF(*), R(*), WGHT(*), X(*), P(*), W(*), 1 Z(*), WP(*), IWP(*), WK(*) C----------------------------------------------------------------------- C This routine computes the solution to the system A*x = b using a C scaled preconditioned version of the Conjugate Gradient algorithm. C It is assumed here that the scaled matrix D**-1 * A * D and the C scaled preconditioner D**-1 * M * D are close to being C symmetric positive definite. C----------------------------------------------------------------------- C C On entry C C NEQ = problem size, passed to F and PSOL (NEQ(1) = N). C C TN = current value of t. C C Y = array containing current dependent variable vector. C C SAVF = array containing current value of f(t,y). C C R = the right hand side of the system A*x = b. C C WGHT = array of length N containing scale factors. C 1/WGHT(i) are the diagonal elements of the diagonal C scaling matrix D. C C N = the order of the matrix A, and the lengths C of the vectors Y, SAVF, R, WGHT, P, W, Z, WK, and X. C C MAXL = the maximum allowable number of iterates. C C DELTA = tolerance on residuals b - A*x in weighted RMS-norm. C C HL0 = current value of (step size h) * (coefficient l0). C C JPRE = preconditioner type flag. C C MNEWT = Newton iteration counter (.ge. 0). C C WK = real work array used by routine DATP. C C WP = real work array used by preconditioner PSOL. C C IWP = integer work array used by preconditioner PSOL. C C On return C C X = the final computed approximation to the solution C of the system A*x = b. C C LPCG = the number of iterations performed, and current C order of the upper Hessenberg matrix HES. C C NPSL = the number of calls to PSOL. C C IFLAG = integer error flag: C 0 means convergence in LPCG iterations, LPCG .le. MAXL. C 1 means the convergence test did not pass in MAXL C iterations, but the residual norm is .lt. 1, C or .lt. norm(b) if MNEWT = 0, and so X is computed. C 2 means the convergence test did not pass in MAXL C iterations, residual .gt. 1, and X is undefined. C 3 means there was a recoverable error in PSOL C caused by the preconditioner being out of date. C 4 means there was a zero denominator in the algorithm. C the scaled matrix or scaled preconditioner is not C sufficiently close to being symmetric pos. definite. C -1 means there was a nonrecoverable error in PSOL. C C----------------------------------------------------------------------- INTEGER I, IER DOUBLE PRECISION ALPHA, BETA, BNRM, PTW, RNRM, DVNORM, ZTR, ZTR0 C IFLAG = 0 NPSL = 0 LPCG = 0 DO 10 I = 1,N X(I) = 0.0D0 10 CONTINUE BNRM = DVNORM (N, R, WGHT) C Test for immediate return with X = 0 or X = b. ----------------------- IF (BNRM .GT. DELTA) GO TO 20 IF (MNEWT .GT. 0) RETURN CALL DCOPY (N, R, 1, X, 1) RETURN C 20 ZTR = 0.0D0 C Loop point for PCG iterations. --------------------------------------- 30 CONTINUE LPCG = LPCG + 1 CALL DCOPY (N, R, 1, Z, 1) IER = 0 IF (JPRE .EQ. 0) GO TO 40 CALL PSOL (NEQ, TN, Y, SAVF, WK, HL0, WP, IWP, Z, 3, IER) NPSL = NPSL + 1 IF (IER .NE. 0) GO TO 100 40 CONTINUE ZTR0 = ZTR ZTR = 0.0D0 DO 45 I = 1,N ZTR = ZTR + Z(I)*R(I)*WGHT(I)**2 45 CONTINUE IF (LPCG .NE. 1) GO TO 50 CALL DCOPY (N, Z, 1, P, 1) GO TO 70 50 CONTINUE IF (ZTR0 .EQ. 0.0D0) GO TO 200 BETA = ZTR/ZTR0 DO 60 I = 1,N P(I) = Z(I) + BETA*P(I) 60 CONTINUE 70 CONTINUE C----------------------------------------------------------------------- C Call DATP to compute A*p and return the answer in W. C----------------------------------------------------------------------- CALL DATP (NEQ, Y, SAVF, P, WGHT, HL0, WK, F, W, rpar,ipar) C PTW = 0.0D0 DO 80 I = 1,N PTW = PTW + P(I)*W(I)*WGHT(I)**2 80 CONTINUE IF (PTW .EQ. 0.0D0) GO TO 200 ALPHA = ZTR/PTW CALL DAXPY (N, ALPHA, P, 1, X, 1) ALPHA = -ALPHA CALL DAXPY (N, ALPHA, W, 1, R, 1) RNRM = DVNORM (N, R, WGHT) IF (RNRM .LE. DELTA) RETURN IF (LPCG .LT. MAXL) GO TO 30 IFLAG = 2 IF (RNRM .LE. 1.0D0) IFLAG = 1 IF (RNRM .LE. BNRM .AND. MNEWT .EQ. 0) IFLAG = 1 RETURN C----------------------------------------------------------------------- C This block handles error returns from PSOL. C----------------------------------------------------------------------- 100 CONTINUE IF (IER .LT. 0) IFLAG = -1 IF (IER .GT. 0) IFLAG = 3 RETURN C----------------------------------------------------------------------- C This block handles division by zero errors. C----------------------------------------------------------------------- 200 CONTINUE IFLAG = 4 RETURN C----------------------- End of Subroutine DPCGS ----------------------- END *DECK DATP SUBROUTINE DATP (NEQ, Y, SAVF, P, WGHT, HL0, WK, F, W,rpar,ipar) EXTERNAL F INTEGER NEQ, ipar(*) DOUBLE PRECISION Y, SAVF, P, WGHT, HL0, WK, W, rpar(*) DIMENSION NEQ(*), Y(*), SAVF(*), P(*), WGHT(*), WK(*), W(*) INTEGER IOWND, IOWNS, 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU DOUBLE PRECISION ROWNS, 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND COMMON /DLS001/ ROWNS(209), 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 2 IOWND(6), IOWNS(6), 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU C----------------------------------------------------------------------- C This routine computes the product C C w = (I - hl0*df/dy)*p C C This is computed by a call to F and a difference quotient. C----------------------------------------------------------------------- C C On entry C C NEQ = problem size, passed to F and PSOL (NEQ(1) = N). C C Y = array containing current dependent variable vector. C C SAVF = array containing current value of f(t,y). C C P = real array of length N. C C WGHT = array of length N containing scale factors. C 1/WGHT(i) are the diagonal elements of the matrix D. C C WK = work array of length N. C C On return C C C W = array of length N containing desired C matrix-vector product. C C In addition, this routine uses the Common variables TN, N, NFE. C----------------------------------------------------------------------- INTEGER I DOUBLE PRECISION FAC, PNRM, RPNRM, DVNORM C PNRM = DVNORM (N, P, WGHT) RPNRM = 1.0D0/PNRM CALL DCOPY (N, Y, 1, W, 1) DO 20 I = 1,N Y(I) = W(I) + P(I)*RPNRM 20 CONTINUE CKS CALL F (NEQ, TN, Y, WK, rpar, ipar) NFE = NFE + 1 CALL DCOPY (N, W, 1, Y, 1) FAC = HL0*PNRM DO 40 I = 1,N W(I) = P(I) - FAC*(WK(I) - SAVF(I)) 40 CONTINUE RETURN C----------------------- End of Subroutine DATP ------------------------ END *DECK DUSOL SUBROUTINE DUSOL (NEQ, TN, Y, SAVF, B, WGHT, N, DELTA, HL0, MNEWT, 1 PSOL, NPSL, X, WP, IWP, WK, IFLAG) EXTERNAL PSOL INTEGER NEQ, N, MNEWT, NPSL, IWP, IFLAG DOUBLE PRECISION TN, Y, SAVF, B, WGHT, DELTA, HL0, X, WP, WK DIMENSION NEQ(*), Y(*), SAVF(*), B(*), WGHT(*), X(*), 1 WP(*), IWP(*), WK(*) C----------------------------------------------------------------------- C This routine solves the linear system A * x = b using only a call C to the user-supplied routine PSOL (no Krylov iteration). C If the norm of the right-hand side vector b is smaller than DELTA, C the vector X returned is X = b (if MNEWT = 0) or X = 0 otherwise. C PSOL is called with an LR argument of 0. C----------------------------------------------------------------------- C C On entry C C NEQ = problem size, passed to F and PSOL (NEQ(1) = N). C C TN = current value of t. C C Y = array containing current dependent variable vector. C C SAVF = array containing current value of f(t,y). C C B = the right hand side of the system A*x = b. C C WGHT = the vector of length N containing the nonzero C elements of the diagonal scaling matrix. C C N = the order of the matrix A, and the lengths C of the vectors WGHT, B and X. C C DELTA = tolerance on residuals b - A*x in weighted RMS-norm. C C HL0 = current value of (step size h) * (coefficient l0). C C MNEWT = Newton iteration counter (.ge. 0). C C WK = real work array used by PSOL. C C WP = real work array used by preconditioner PSOL. C C IWP = integer work array used by preconditioner PSOL. C C On return C C X = the final computed approximation to the solution C of the system A*x = b. C C NPSL = the number of calls to PSOL. C C IFLAG = integer error flag: C 0 means no trouble occurred. C 3 means there was a recoverable error in PSOL C caused by the preconditioner being out of date. C -1 means there was a nonrecoverable error in PSOL. C C----------------------------------------------------------------------- INTEGER I, IER DOUBLE PRECISION BNRM, DVNORM C IFLAG = 0 NPSL = 0 C----------------------------------------------------------------------- C Test for an immediate return with X = 0 or X = b. C----------------------------------------------------------------------- BNRM = DVNORM (N, B, WGHT) IF (BNRM .GT. DELTA) GO TO 30 IF (MNEWT .GT. 0) GO TO 10 CALL DCOPY (N, B, 1, X, 1) RETURN 10 DO 20 I = 1,N X(I) = 0.0D0 20 CONTINUE RETURN C Make call to PSOL and copy result from B to X. ----------------------- 30 IER = 0 CALL PSOL (NEQ, TN, Y, SAVF, WK, HL0, WP, IWP, B, 0, IER) NPSL = 1 IF (IER .NE. 0) GO TO 100 CALL DCOPY (N, B, 1, X, 1) RETURN C----------------------------------------------------------------------- C This block handles error returns forced by routine PSOL. C----------------------------------------------------------------------- 100 CONTINUE IF (IER .LT. 0) IFLAG = -1 IF (IER .GT. 0) IFLAG = 3 RETURN C----------------------- End of Subroutine DUSOL ----------------------- END *DECK DSRCPK *DECK DHEFA SUBROUTINE DHEFA (A, LDA, N, IPVT, INFO, JOB) INTEGER LDA, N, IPVT(*), INFO, JOB DOUBLE PRECISION A(LDA,*) C----------------------------------------------------------------------- C This routine is a modification of the LINPACK routine DGEFA and C performs an LU decomposition of an upper Hessenberg matrix A. C There are two options available: C C (1) performing a fresh factorization C (2) updating the LU factors by adding a row and a C column to the matrix A. C----------------------------------------------------------------------- C DHEFA factors an upper Hessenberg matrix by elimination. C C On entry C C A DOUBLE PRECISION(LDA, N) C the matrix to be factored. C C LDA INTEGER C the leading dimension of the array A . C C N INTEGER C the order of the matrix A . C C JOB INTEGER C JOB = 1 means that a fresh factorization of the C matrix A is desired. C JOB .ge. 2 means that the current factorization of A C will be updated by the addition of a row C and a column. C C On return C C A an upper triangular matrix and the multipliers C which were used to obtain it. C The factorization can be written A = L*U where C L is a product of permutation and unit lower C triangular matrices and U is upper triangular. C C IPVT INTEGER(N) C an integer vector of pivot indices. C C INFO INTEGER C = 0 normal value. C = k if U(k,k) .eq. 0.0 . This is not an error C condition for this subroutine, but it does C indicate that DHESL will divide by zero if called. C C Modification of LINPACK, by Peter Brown, LLNL. C Written 7/20/83. This version dated 6/20/01. C C BLAS called: DAXPY, IDAMAX C----------------------------------------------------------------------- INTEGER IDAMAX, J, K, KM1, KP1, L, NM1 DOUBLE PRECISION T C IF (JOB .GT. 1) GO TO 80 C C A new facorization is desired. This is essentially the LINPACK C code with the exception that we know there is only one nonzero C element below the main diagonal. C C Gaussian elimination with partial pivoting C INFO = 0 NM1 = N - 1 IF (NM1 .LT. 1) GO TO 70 DO 60 K = 1, NM1 KP1 = K + 1 C C Find L = pivot index C L = IDAMAX (2, A(K,K), 1) + K - 1 IPVT(K) = L C C Zero pivot implies this column already triangularized C IF (A(L,K) .EQ. 0.0D0) GO TO 40 C C Interchange if necessary C IF (L .EQ. K) GO TO 10 T = A(L,K) A(L,K) = A(K,K) A(K,K) = T 10 CONTINUE C C Compute multipliers C T = -1.0D0/A(K,K) A(K+1,K) = A(K+1,K)*T C C Row elimination with column indexing C DO 30 J = KP1, N T = A(L,J) IF (L .EQ. K) GO TO 20 A(L,J) = A(K,J) A(K,J) = T 20 CONTINUE CALL DAXPY (N-K, T, A(K+1,K), 1, A(K+1,J), 1) 30 CONTINUE GO TO 50 40 CONTINUE INFO = K 50 CONTINUE 60 CONTINUE 70 CONTINUE IPVT(N) = N IF (A(N,N) .EQ. 0.0D0) INFO = N RETURN C C The old factorization of A will be updated. A row and a column C has been added to the matrix A. C N-1 is now the old order of the matrix. C 80 CONTINUE NM1 = N - 1 C C Perform row interchanges on the elements of the new column, and C perform elimination operations on the elements using the multipliers. C IF (NM1 .LE. 1) GO TO 105 DO 100 K = 2,NM1 KM1 = K - 1 L = IPVT(KM1) T = A(L,N) IF (L .EQ. KM1) GO TO 90 A(L,N) = A(KM1,N) A(KM1,N) = T 90 CONTINUE A(K,N) = A(K,N) + A(K,KM1)*T 100 CONTINUE 105 CONTINUE C C Complete update of factorization by decomposing last 2x2 block. C INFO = 0 C C Find L = pivot index C L = IDAMAX (2, A(NM1,NM1), 1) + NM1 - 1 IPVT(NM1) = L C C Zero pivot implies this column already triangularized C IF (A(L,NM1) .EQ. 0.0D0) GO TO 140 C C Interchange if necessary C IF (L .EQ. NM1) GO TO 110 T = A(L,NM1) A(L,NM1) = A(NM1,NM1) A(NM1,NM1) = T 110 CONTINUE C C Compute multipliers C T = -1.0D0/A(NM1,NM1) A(N,NM1) = A(N,NM1)*T C C Row elimination with column indexing C T = A(L,N) IF (L .EQ. NM1) GO TO 120 A(L,N) = A(NM1,N) A(NM1,N) = T 120 CONTINUE A(N,N) = A(N,N) + T*A(N,NM1) GO TO 150 140 CONTINUE INFO = NM1 150 CONTINUE IPVT(N) = N IF (A(N,N) .EQ. 0.0D0) INFO = N RETURN C----------------------- End of Subroutine DHEFA ----------------------- END *DECK DHESL SUBROUTINE DHESL (A, LDA, N, IPVT, B) INTEGER LDA, N, IPVT(*) DOUBLE PRECISION A(LDA,*), B(*) C----------------------------------------------------------------------- C This is essentially the LINPACK routine DGESL except for changes C due to the fact that A is an upper Hessenberg matrix. C----------------------------------------------------------------------- C DHESL solves the real system A * x = b C using the factors computed by DHEFA. C C On entry C C A DOUBLE PRECISION(LDA, N) C the output from DHEFA. C C LDA INTEGER C the leading dimension of the array A . C C N INTEGER C the order of the matrix A . C C IPVT INTEGER(N) C the pivot vector from DHEFA. C C B DOUBLE PRECISION(N) C the right hand side vector. C C On return C C B the solution vector x . C C Modification of LINPACK, by Peter Brown, LLNL. C Written 7/20/83. This version dated 6/20/01. C C BLAS called: DAXPY C----------------------------------------------------------------------- INTEGER K, KB, L, NM1 DOUBLE PRECISION T C NM1 = N - 1 C C Solve A * x = b C First solve L*y = b C IF (NM1 .LT. 1) GO TO 30 DO 20 K = 1, NM1 L = IPVT(K) T = B(L) IF (L .EQ. K) GO TO 10 B(L) = B(K) B(K) = T 10 CONTINUE B(K+1) = B(K+1) + T*A(K+1,K) 20 CONTINUE 30 CONTINUE C C Now solve U*x = y C DO 40 KB = 1, N K = N + 1 - KB B(K) = B(K)/A(K,K) T = -B(K) CALL DAXPY (K-1, T, A(1,K), 1, B(1), 1) 40 CONTINUE RETURN C----------------------- End of Subroutine DHESL ----------------------- END *DECK DHEQR SUBROUTINE DHEQR (A, LDA, N, Q, INFO, IJOB) INTEGER LDA, N, INFO, IJOB DOUBLE PRECISION A(LDA,*), Q(*) C----------------------------------------------------------------------- C This routine performs a QR decomposition of an upper C Hessenberg matrix A. There are two options available: C C (1) performing a fresh decomposition C (2) updating the QR factors by adding a row and a C column to the matrix A. C----------------------------------------------------------------------- C DHEQR decomposes an upper Hessenberg matrix by using Givens C rotations. C C On entry C C A DOUBLE PRECISION(LDA, N) C the matrix to be decomposed. C C LDA INTEGER C the leading dimension of the array A . C C N INTEGER C A is an (N+1) by N Hessenberg matrix. C C IJOB INTEGER C = 1 means that a fresh decomposition of the C matrix A is desired. C .ge. 2 means that the current decomposition of A C will be updated by the addition of a row C and a column. C On return C C A the upper triangular matrix R. C The factorization can be written Q*A = R, where C Q is a product of Givens rotations and R is upper C triangular. C C Q DOUBLE PRECISION(2*N) C the factors c and s of each Givens rotation used C in decomposing A. C C INFO INTEGER C = 0 normal value. C = k if A(k,k) .eq. 0.0 . This is not an error C condition for this subroutine, but it does C indicate that DHELS will divide by zero C if called. C C Modification of LINPACK, by Peter Brown, LLNL. C Written 1/13/86. This version dated 6/20/01. C----------------------------------------------------------------------- INTEGER I, IQ, J, K, KM1, KP1, NM1 DOUBLE PRECISION C, S, T, T1, T2 C IF (IJOB .GT. 1) GO TO 70 C C A new facorization is desired. C C QR decomposition without pivoting C INFO = 0 DO 60 K = 1, N KM1 = K - 1 KP1 = K + 1 C C Compute kth column of R. C First, multiply the kth column of A by the previous C k-1 Givens rotations. C IF (KM1 .LT. 1) GO TO 20 DO 10 J = 1, KM1 I = 2*(J-1) + 1 T1 = A(J,K) T2 = A(J+1,K) C = Q(I) S = Q(I+1) A(J,K) = C*T1 - S*T2 A(J+1,K) = S*T1 + C*T2 10 CONTINUE C C Compute Givens components c and s C 20 CONTINUE IQ = 2*KM1 + 1 T1 = A(K,K) T2 = A(KP1,K) IF (T2 .NE. 0.0D0) GO TO 30 C = 1.0D0 S = 0.0D0 GO TO 50 30 CONTINUE IF (ABS(T2) .LT. ABS(T1)) GO TO 40 T = T1/T2 S = -1.0D0/SQRT(1.0D0+T*T) C = -S*T GO TO 50 40 CONTINUE T = T2/T1 C = 1.0D0/SQRT(1.0D0+T*T) S = -C*T 50 CONTINUE Q(IQ) = C Q(IQ+1) = S A(K,K) = C*T1 - S*T2 IF (A(K,K) .EQ. 0.0D0) INFO = K 60 CONTINUE RETURN C C The old factorization of A will be updated. A row and a column C has been added to the matrix A. C N by N-1 is now the old size of the matrix. C 70 CONTINUE NM1 = N - 1 C C Multiply the new column by the N previous Givens rotations. C DO 100 K = 1,NM1 I = 2*(K-1) + 1 T1 = A(K,N) T2 = A(K+1,N) C = Q(I) S = Q(I+1) A(K,N) = C*T1 - S*T2 A(K+1,N) = S*T1 + C*T2 100 CONTINUE C C Complete update of decomposition by forming last Givens rotation, C and multiplying it times the column vector (A(N,N), A(N+1,N)). C INFO = 0 T1 = A(N,N) T2 = A(N+1,N) IF (T2 .NE. 0.0D0) GO TO 110 C = 1.0D0 S = 0.0D0 GO TO 130 110 CONTINUE IF (ABS(T2) .LT. ABS(T1)) GO TO 120 T = T1/T2 S = -1.0D0/SQRT(1.0D0+T*T) C = -S*T GO TO 130 120 CONTINUE T = T2/T1 C = 1.0D0/SQRT(1.0D0+T*T) S = -C*T 130 CONTINUE IQ = 2*N - 1 Q(IQ) = C Q(IQ+1) = S A(N,N) = C*T1 - S*T2 IF (A(N,N) .EQ. 0.0D0) INFO = N RETURN C----------------------- End of Subroutine DHEQR ----------------------- END *DECK DHELS SUBROUTINE DHELS (A, LDA, N, Q, B) INTEGER LDA, N DOUBLE PRECISION A(LDA,*), B(*), Q(*) C----------------------------------------------------------------------- C This is part of the LINPACK routine DGESL with changes C due to the fact that A is an upper Hessenberg matrix. C----------------------------------------------------------------------- C DHELS solves the least squares problem C C min (b-A*x, b-A*x) C C using the factors computed by DHEQR. C C On entry C C A DOUBLE PRECISION(LDA, N) C the output from DHEQR which contains the upper C triangular factor R in the QR decomposition of A. C C LDA INTEGER C the leading dimension of the array A . C C N INTEGER C A is originally an (N+1) by N matrix. C C Q DOUBLE PRECISION(2*N) C The coefficients of the N givens rotations C used in the QR factorization of A. C C B DOUBLE PRECISION(N+1) C the right hand side vector. C C On return C C B the solution vector x . C C Modification of LINPACK, by Peter Brown, LLNL. C Written 1/13/86. This version dated 6/20/01. C C BLAS called: DAXPY C----------------------------------------------------------------------- INTEGER IQ, K, KB, KP1 DOUBLE PRECISION C, S, T, T1, T2 C C Minimize (b-A*x, b-A*x) C First form Q*b. C DO 20 K = 1, N KP1 = K + 1 IQ = 2*(K-1) + 1 C = Q(IQ) S = Q(IQ+1) T1 = B(K) T2 = B(KP1) B(K) = C*T1 - S*T2 B(KP1) = S*T1 + C*T2 20 CONTINUE C C Now solve R*x = Q*b. C DO 40 KB = 1, N K = N + 1 - KB B(K) = B(K)/A(K,K) T = -B(K) CALL DAXPY (K-1, T, A(1,K), 1, B(1), 1) 40 CONTINUE RETURN C----------------------- End of Subroutine DHELS ----------------------- END *DECK DLHIN SUBROUTINE DLHIN (NEQ, N, T0, Y0, YDOT, F, TOUT, UROUND, 1 EWT, ITOL, ATOL, Y, TEMP, H0, NITER, IER, rpar,ipar) EXTERNAL F DOUBLE PRECISION T0, Y0, YDOT, TOUT, UROUND, EWT, ATOL, Y, 1 TEMP, H0 INTEGER NEQ, N, ITOL, NITER, IER integer ipar(*) double precision rpar(*) DIMENSION NEQ(*), Y0(*), YDOT(*), EWT(*), ATOL(*), Y(*), TEMP(*) C----------------------------------------------------------------------- C Call sequence input -- NEQ, N, T0, Y0, YDOT, F, TOUT, UROUND, C EWT, ITOL, ATOL, Y, TEMP C Call sequence output -- H0, NITER, IER C Common block variables accessed -- None C C Subroutines called by DLHIN: F, DCOPY C Function routines called by DLHIN: DVNORM C----------------------------------------------------------------------- C This routine computes the step size, H0, to be attempted on the C first step, when the user has not supplied a value for this. C C First we check that TOUT - T0 differs significantly from zero. Then C an iteration is done to approximate the initial second derivative C and this is used to define H from WRMS-norm(H**2 * yddot / 2) = 1. C A bias factor of 1/2 is applied to the resulting h. C The sign of H0 is inferred from the initial values of TOUT and T0. C C Communication with DLHIN is done with the following variables: C C NEQ = NEQ array of solver, passed to F. C N = size of ODE system, input. C T0 = initial value of independent variable, input. C Y0 = vector of initial conditions, input. C YDOT = vector of initial first derivatives, input. C F = name of subroutine for right-hand side f(t,y), input. C TOUT = first output value of independent variable C UROUND = machine unit roundoff C EWT, ITOL, ATOL = error weights and tolerance parameters C as described in the driver routine, input. C Y, TEMP = work arrays of length N. C H0 = step size to be attempted, output. C NITER = number of iterations (and of f evaluations) to compute H0, C output. C IER = the error flag, returned with the value C IER = 0 if no trouble occurred, or C IER = -1 if TOUT and t0 are considered too close to proceed. C----------------------------------------------------------------------- C C Type declarations for local variables -------------------------------- C DOUBLE PRECISION AFI, ATOLI, DELYI, HALF, HG, HLB, HNEW, HRAT, 1 HUB, HUN, PT1, T1, TDIST, TROUND, TWO, DVNORM, YDDNRM INTEGER I, ITER C----------------------------------------------------------------------- C The following Fortran-77 declaration is to cause the values of the C listed (local) variables to be saved between calls to this integrator. C----------------------------------------------------------------------- SAVE HALF, HUN, PT1, TWO DATA HALF /0.5D0/, HUN /100.0D0/, PT1 /0.1D0/, TWO /2.0D0/ C NITER = 0 TDIST = ABS(TOUT - T0) TROUND = UROUND*MAX(ABS(T0),ABS(TOUT)) IF (TDIST .LT. TWO*TROUND) GO TO 100 C C Set a lower bound on H based on the roundoff level in T0 and TOUT. --- HLB = HUN*TROUND C Set an upper bound on H based on TOUT-T0 and the initial Y and YDOT. - HUB = PT1*TDIST ATOLI = ATOL(1) DO 10 I = 1,N IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) DELYI = PT1*ABS(Y0(I)) + ATOLI AFI = ABS(YDOT(I)) IF (AFI*HUB .GT. DELYI) HUB = DELYI/AFI 10 CONTINUE C C Set initial guess for H as geometric mean of upper and lower bounds. - ITER = 0 HG = SQRT(HLB*HUB) C If the bounds have crossed, exit with the mean value. ---------------- IF (HUB .LT. HLB) THEN H0 = HG GO TO 90 ENDIF C C Looping point for iteration. ----------------------------------------- 50 CONTINUE C Estimate the second derivative as a difference quotient in f. -------- T1 = T0 + HG DO 60 I = 1,N Y(I) = Y0(I) + HG*YDOT(I) 60 CONTINUE CKS CALL F (NEQ, T1, Y, TEMP, rpar, ipar) DO 70 I = 1,N TEMP(I) = (TEMP(I) - YDOT(I))/HG 70 CONTINUE YDDNRM = DVNORM (N, TEMP, EWT) C Get the corresponding new value of H. -------------------------------- IF (YDDNRM*HUB*HUB .GT. TWO) THEN HNEW = SQRT(TWO/YDDNRM) ELSE HNEW = SQRT(HG*HUB) ENDIF ITER = ITER + 1 C----------------------------------------------------------------------- C Test the stopping conditions. C Stop if the new and previous H values differ by a factor of .lt. 2. C Stop if four iterations have been done. Also, stop with previous H C if hnew/hg .gt. 2 after first iteration, as this probably means that C the second derivative value is bad because of cancellation error. C----------------------------------------------------------------------- IF (ITER .GE. 4) GO TO 80 HRAT = HNEW/HG IF ( (HRAT .GT. HALF) .AND. (HRAT .LT. TWO) ) GO TO 80 IF ( (ITER .GE. 2) .AND. (HNEW .GT. TWO*HG) ) THEN HNEW = HG GO TO 80 ENDIF HG = HNEW GO TO 50 C C Iteration done. Apply bounds, bias factor, and sign. ---------------- 80 H0 = HNEW*HALF IF (H0 .LT. HLB) H0 = HLB IF (H0 .GT. HUB) H0 = HUB 90 H0 = SIGN(H0, TOUT - T0) C Restore Y array from Y0, then exit. ---------------------------------- CALL DCOPY (N, Y0, 1, Y, 1) NITER = ITER IER = 0 RETURN C Error return for TOUT - T0 too small. -------------------------------- 100 IER = -1 RETURN C----------------------- End of Subroutine DLHIN ----------------------- END deSolve/src/R_init_deSolve.c0000754000175100001440000001334313131751003015531 0ustar hornikusers#ifndef R_R_H # include #endif #ifndef R_EXT_DYNLOAD_H_ # include #endif #include "deSolve.h" #include #include // for NULL /* register native routines ------------------------------------------------ */ /* ToDo: - consider replacing SEXP with REALSXP, INTSXP, STRSXP (character), VEXSXP (lists) etc. - unlock */ /* .C calls */ extern void unlock_solver(); /* Examples (manually added) */ extern void initccl4(void (* odeparms)(int *, double *)); extern void eventfun(int *n, double *t, double *y); extern void derivsccl4(int *neq, double *t, double *y, double *ydot, double *out, int *ip); extern void initparms(void (* daspkparms)(int *, double *)); extern void initforcs(void (* daspkforcs)(int *, double *)); extern void chemres (double *t, double *y, double *ydot, double *cj, double *delta, int *ires, double *out, int *ip); extern void scocpar(void (* odeparms)(int *, double *)); extern void scocforc(void (* odeforcs)(int *, double *)); extern void scocder (int *neq, double *t, double *y, double *ydot, double *out, int *ip); extern void iniaqua(void (* odeparms)(int *, double *)); extern void initaqforc(void (* odeforc)(int *, double *)); extern void aquaphy (int *neq, double *t, double *y, double *ydot, double *out, int *ip); extern void aquaphyforc (int *neq, double *t, double *y, double *ydot, double *out, int *ip); /* .Call calls */ extern SEXP call_daspk(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP call_DLL(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP call_euler(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP call_iteration(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP call_lsoda(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP call_radau(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP call_rk4(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP call_rkAuto(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP call_rkFixed(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP call_rkImplicit(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP call_zvode(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP getLagDeriv(SEXP, SEXP); extern SEXP getLagValue(SEXP, SEXP); extern SEXP getTimestep(); static const R_CMethodDef CEntries[] = { {"unlock_solver", (DL_FUNC) &unlock_solver, 0}, {"initccl4", (DL_FUNC) &initccl4, 1}, {"initparms", (DL_FUNC) &initparms, 1}, {"initforcs", (DL_FUNC) &initforcs, 1}, {"eventfun", (DL_FUNC) &eventfun, 3}, {"derivsccl4", (DL_FUNC) &derivsccl4, 6}, {"chemres", (DL_FUNC) &chemres, 8}, {"scocpar", (DL_FUNC) &scocpar, 1}, {"scocforc", (DL_FUNC) &scocforc, 1}, {"scocder", (DL_FUNC) &scocder, 6}, {"iniaqua", (DL_FUNC) &iniaqua, 1}, {"initaqforc", (DL_FUNC) &initaqforc, 1}, {"aquaphy", (DL_FUNC) &aquaphy, 6}, {"aquaphyforc", (DL_FUNC) &aquaphy, 6}, {NULL, NULL, 0} }; static const R_CallMethodDef CallEntries[] = { {"call_daspk", (DL_FUNC) &call_daspk, 28}, {"call_DLL", (DL_FUNC) &call_DLL, 11}, {"call_euler", (DL_FUNC) &call_euler, 11}, {"call_iteration", (DL_FUNC) &call_iteration, 12}, {"call_lsoda", (DL_FUNC) &call_lsoda, 28}, {"call_radau", (DL_FUNC) &call_radau, 26}, {"call_rk4", (DL_FUNC) &call_rk4, 11}, {"call_rkAuto", (DL_FUNC) &call_rkAuto, 21}, {"call_rkFixed", (DL_FUNC) &call_rkFixed, 17}, {"call_rkImplicit", (DL_FUNC) &call_rkImplicit, 17}, {"call_zvode", (DL_FUNC) &call_zvode, 21}, {"getLagDeriv", (DL_FUNC) &getLagDeriv, 2}, {"getLagValue", (DL_FUNC) &getLagValue, 2}, {"getTimestep", (DL_FUNC) &getTimestep, 0}, {NULL, NULL, 0} }; /* C callable functions ---------------------------------------------------- */ SEXP get_deSolve_gparms(void); void lagvalue(double T, int* nr, int N, double* ytau); void lagderiv(double T, int* nr, int N, double* ytau); double glob_timesteps[] = {0, 0}; /* Initialization ---------------------------------------------------------- */ void R_init_deSolve(DllInfo *dll) { // thpe 2017-03-22, register entry points R_registerRoutines(dll, CEntries, CallEntries, NULL, NULL); // the following two lines protect against accidentially finding entry points R_useDynamicSymbols(dll, FALSE); // disable dynamic searching //R_forceSymbols(dll, TRUE); // entry points as R objects, not as strings /* thpe: register C callable to support compiled dede functions The direct way would be: R_RegisterCCallable("deSolve", "get_deSolve_gparms", (DL_FUNC) get_deSolve_gparms); while the following macro (taken from package Matrix) makes this more compact. */ #define RREGDEF(name) R_RegisterCCallable("deSolve", #name, (DL_FUNC) name) RREGDEF(get_deSolve_gparms); RREGDEF(lagvalue); RREGDEF(lagderiv); /* initialize global variables */ timesteps = glob_timesteps; } deSolve/src/call_iteration.c0000754000175100001440000001545313131751003015621 0ustar hornikusers/*==========================================================================*/ /* Fixed Step time stepping routine - NO Integration */ /*==========================================================================*/ #include "rk_util.h" #include "externalptr.h" SEXP call_iteration(SEXP Xstart, SEXP Times, SEXP Nsteps, SEXP Func, SEXP Initfunc, SEXP Parms, SEXP Nout, SEXP Rho, SEXP Verbose, SEXP Rpar, SEXP Ipar, SEXP Flist) { /* Initialization */ long int old_N_Protect = save_N_Protected(); double *tt = NULL, *xs = NULL; double *ytmp, *out; SEXP R_y0, R_yout, R_t = NULL, R_y = NULL; SEXP Val, R_fcall; double *y0, *yout, *yy; double t, dt; int i = 0, j = 0, it = 0, nt = 0, nst = 0, neq = 0; int isForcing; C_deriv_func_type *cderivs = NULL; /*------------------------------------------------------------------------*/ /* Processing of Arguments */ /*------------------------------------------------------------------------*/ int nsteps = INTEGER(Nsteps)[0]; PROTECT(Times = AS_NUMERIC(Times)); incr_N_Protect(); tt = NUMERIC_POINTER(Times); nt = length(Times); PROTECT(Xstart = AS_NUMERIC(Xstart)); incr_N_Protect(); xs = NUMERIC_POINTER(Xstart); neq = length(Xstart); ytmp = (double *) R_alloc(neq, sizeof(double)); int nout = INTEGER(Nout)[0]; /* n of global outputs if func is in a DLL */ int verbose = INTEGER(Verbose)[0]; /*------------------------------------------------------------------------*/ /* timesteps (e.g. for advection computation in ReacTran) */ /*------------------------------------------------------------------------*/ for (i = 0; i < 2; i++) timesteps[i] = (tt[1] - tt[0])/nsteps; /*------------------------------------------------------------------------*/ /* DLL, ipar, rpar (for compatibility with lsoda) */ /*------------------------------------------------------------------------*/ int isDll = FALSE; int lrpar= 0, lipar = 0; int *ipar = NULL; if (inherits(Func, "NativeSymbol")) { /* function is a dll */ isDll = TRUE; if (nout > 0) isOut = TRUE; lrpar = nout + LENGTH(Rpar); /* length of rpar; LENGTH(Rpar) is always >0 */ lipar = 3 + LENGTH(Ipar); /* length of ipar */ cderivs = (C_deriv_func_type *) R_ExternalPtrAddrFn_(Func); } else { /* function is not a dll */ isDll = FALSE; isOut = FALSE; lipar = 3; lrpar = nout; PROTECT(R_y = allocVector(REALSXP, neq)); incr_N_Protect(); } out = (double *) R_alloc(lrpar, sizeof(double)); ipar = (int *) R_alloc(lipar, sizeof(int)); ipar[0] = nout; /* first 3 elements of ipar are special */ ipar[1] = lrpar; ipar[2] = lipar; if (isDll == 1) { /* other elements of ipar are set in R-function via argument *ipar* */ for (j = 0; j < LENGTH(Ipar); j++) ipar[j+3] = INTEGER(Ipar)[j]; /* rpar is passed via "out"; first nout elements of out are reserved for output variables; other elements are set via argument rpar */ for (j = 0; j < nout; j++) out[j] = 0.0; for (j = 0; j < LENGTH(Rpar); j++) out[nout+j] = REAL(Rpar)[j]; } /*------------------------------------------------------------------------*/ /* Allocation of Workspace */ /*------------------------------------------------------------------------*/ PROTECT(R_y0 = allocVector(REALSXP, neq)); incr_N_Protect(); y0 = REAL(R_y0); /* matrix for holding the outputs */ PROTECT(R_yout = allocMatrix(REALSXP, nt, neq + nout + 1)); incr_N_Protect(); yout = REAL(R_yout); /* attribute that stores state information, similar to lsoda */ SEXP R_istate; int *istate; PROTECT(R_istate = allocVector(INTSXP, 22)); incr_N_Protect(); istate = INTEGER(R_istate); istate[0] = 0; /* assume succesful return */ for (i = 0; i < 22; i++) istate[i] = 0; /*------------------------------------------------------------------------*/ /* Initialization of Parameters (for DLL functions) */ /*------------------------------------------------------------------------*/ initParms(Initfunc, Parms); isForcing = initForcings(Flist); /*------------------------------------------------------------------------*/ /* Initialization of Loop */ /*------------------------------------------------------------------------*/ yout[0] = tt[0]; /* initial time */ for (i = 0; i < neq; i++) { y0[i] = xs[i]; yout[(i + 1) * nt] = y0[i]; } /*------------------------------------------------------------------------*/ /* Main Loop */ /*------------------------------------------------------------------------*/ t = tt[0]; for (it = 0; it < nt; it++) { if (it < nt - 1) dt = (tt[it + 1] - t)/nsteps; else dt = 0; /* dt after final time is undefined*/ timesteps[0] = timesteps[1]; timesteps[1] = dt; if (verbose) Rprintf("Time steps = %d / %d time = %e\n", it + 1, nt, t); if (it == (nt - 1)) nsteps = 1; /* to make sure last step is saved */ for (nst = 0; nst < nsteps; nst++) { if (nst == 0) { yout[it] = t; for (i = 0; i < neq; i++) yout[it + nt * (1 + i)] = y0[i]; } if (isDll) { if (isForcing) updatedeforc(&t); cderivs(&neq, &t, y0, ytmp, out, ipar); for (i = 0; i < neq; i++) y0[i] = ytmp[i]; } else { yy = REAL(R_y); PROTECT(R_t = ScalarReal(t)); incr_N_Protect(); for (i = 0; i < neq; i++) yy[i] = y0[i]; PROTECT(R_fcall = lang4(Func, R_t, R_y, Parms)); incr_N_Protect(); PROTECT(Val = eval(R_fcall, Rho)); incr_N_Protect(); for (i = 0; i < neq; i++) y0[i] = REAL(VECTOR_ELT(Val, 0))[i]; /* extract outputs from second and following list elements */ if (nst == (nsteps - 1)) { int elt = 1, ii = 0, l; for (i = 0; i < nout; i++) { l = LENGTH(VECTOR_ELT(Val, elt)); if (ii == l) { ii = 0; elt++; } out[i] = REAL(VECTOR_ELT(Val, elt))[ii]; ii++; } } my_unprotect(3); } /* isDLL*/ t = t + dt; if (nst == 0) for (i = 0; i < nout; i++) yout[it + nt * (1 + neq + i)] = out[i]; } /* nsteps*/ } /* end of main loop */ /* attach essential internal information (codes are compatible to lsoda) */ setIstate(R_yout, R_istate, istate, it, 1, 0, 1, 0); /* reset timesteps pointer to saved state, release R resources */ timesteps[0] = 0; timesteps[1] = 0; restore_N_Protected(old_N_Protect); return(R_yout); } deSolve/src/rk_util.c0000754000175100001440000002516313131751003014300 0ustar hornikusers/*==========================================================================*/ /* Runge-Kutta Solvers, (C) Th. Petzoldt, License: GPL >=2 */ /* Definitions and Utilities needed by Runge-Kutta Solvers */ /*==========================================================================*/ /* Load headers needed by the R interface */ #include #include /* for dgemm */ #include #include "deSolve.h" #ifdef HAVE_LONG_DOUBLE # define LDOUBLE long double #else # define LDOUBLE double #endif #include "externalptr.h" /*============================================================================*/ /* DLL specific functions */ /*============================================================================*/ void R_test_call(DllInfo *info) { /* Register routines, allocate resources. */ Rprintf("test_call DLL loaded\n"); } void R_unload_test_call(DllInfo *info) { /* Release resources. */ Rprintf("test_call DLL unloaded\n"); } /*============================================================================*/ /* Functions for processing complex R arguments */ /*============================================================================*/ /* -------- getvar from environment ------------------------------------------*/ SEXP getvar(SEXP name, SEXP Rho) { SEXP ans; if(!isString(name) || length(name) != 1) error("name is not a single string"); if(!isEnvironment(Rho)) error("Rho should be an environment"); ans = findVar(install(CHAR(STRING_ELT(name, 0))), Rho); return(ans); } SEXP getInputs(SEXP symbol, SEXP Rho) { if(!isEnvironment(Rho)) error("Rho should be an environment"); return(getvar(symbol, Rho)); } /*============================================================================*/ /* Arithmetic utilities */ /*============================================================================*/ /*----------------------------------------------------------------------------*/ /* Matrix Multiplication using the BLAS routine */ /* a reduced version without NA checking, this is ensured otherwise */ /*----------------------------------------------------------------------------*/ void blas_matprod1(double *x, int nrx, int ncx, double *y, int nry, int ncy, double *z) { const char *transa = "N", *transb = "N"; int i; double one = 1.0, zero = 0.0; if (nrx > 0 && ncx > 0 && nry > 0 && ncy > 0) { F77_CALL(dgemm)(transa, transb, &nrx, &ncy, &ncx, &one, x, &nrx, y, &nry, &zero, z, &nrx); } else /* zero-extent operations should return zeroes */ for(i = 0; i < nrx*ncy; i++) z[i] = 0; } /* -- Simple Matrix Multiplication without BLAS ------------------------------ */ void matprod(int m, int n, int o, double* a, double* b, double* c) { int i, j, k; for (i = 0; i < m; i++) { for (j = 0; j < o; j++) { c[i + m * j] = 0; for (k = 0; k < n; k++) { c[i + m * j] += a[i + m * k] * b[k + n * j]; } } } } double maxdiff(double *x, double *y, int n) { double d = 0.0; for (int i = 0; i < n; i++) d = fmax(d, fabs(x[i] - y[i])); return(d); } double maxerr(double *y0, double *y1, double *y2, double *Atol, double *Rtol, int n) { double serr = 0, scal, delta; for (int i = 0; i < n; i++) { /* y2 is used to estimate next y-value */ scal = Atol[i] + fmax(fabs(y0[i]), fabs(y2[i])) * Rtol[i]; delta = fabs(y2[i] - y1[i]); if (scal > 0) serr += pow(delta/scal, 2.0); } return(sqrt(serr/n)); /* Euclidean norm */ } /*==========================================================================*/ /* CALL TO THE MODEL FUNCTION */ /*==========================================================================*/ void derivs(SEXP Func, double t, double* y, SEXP Parms, SEXP Rho, double *ydot, double *yout, int j, int neq, int *ipar, int isDll, int isForcing) { SEXP Val, rVal, R_fcall; SEXP R_t; SEXP R_y; int i = 0; int nout = ipar[0]; double *yy; double ytmp[neq]; if (isDll) { /*------------------------------------------------------------------------*/ /* Function is a DLL function */ /*------------------------------------------------------------------------*/ C_deriv_func_type *cderivs; if (isForcing) updatedeforc(&t); cderivs = (C_deriv_func_type *) R_ExternalPtrAddrFn_(Func); cderivs(&neq, &t, y, ytmp, yout, ipar); if (j >= 0) for (i = 0; i < neq; i++) ydot[i + neq * j] = ytmp[i]; } else { /*------------------------------------------------------------------------*/ /* Function is an R function */ /*------------------------------------------------------------------------*/ PROTECT(R_t = ScalarReal(t)); incr_N_Protect(); PROTECT(R_y = allocVector(REALSXP, neq)); incr_N_Protect(); yy = REAL(R_y); for (i=0; i< neq; i++) yy[i] = y[i]; PROTECT(R_fcall = lang4(Func, R_t, R_y, Parms)); incr_N_Protect(); PROTECT(Val = eval(R_fcall, Rho)); incr_N_Protect(); /* extract the states from first list element of "Val" */ if (j >= 0) for (i = 0; i < neq; i++) ydot[i + neq * j] = REAL(VECTOR_ELT(Val, 0))[i]; /* extract outputs from second and following list elements */ /* this is essentially an unlist for non-nested numeric lists */ if (j < 0) { int elt = 1, ii = 0, l; for (i = 0; i < nout; i++) { l = LENGTH(VECTOR_ELT(Val, elt)); if (ii == l) { ii = 0; elt++; } //yout[i] = REAL(VECTOR_ELT(Val, elt))[ii]; // thpe 2012-08-04: make sure the return value is double and not int PROTECT(rVal = coerceVector(VECTOR_ELT(Val, elt), REALSXP)); yout[i] = REAL(rVal)[ii]; UNPROTECT(1); ii++; } } my_unprotect(4); } } /*============================================================================*/ /* Interpolation functions */ /*============================================================================*/ /*----------------------------------------------------------------------------*/ /* "dense output" */ /* is a specific polynomial interpolation that uses intermediate rk steps */ /*----------------------------------------------------------------------------*/ void denspar(double *FF, double *y0, double *y1, double dt, double *d, int neq, int stage, double *r) { double ydiff, bspl; int i, j; for (i = 0; i < neq; i++) { r[i] = y0[i]; ydiff = y1[i] - y0[i]; r[i + neq] = ydiff; bspl = dt * FF[i] - ydiff; r[i + 2 * neq] = bspl; r[i + 3 * neq] = ydiff - dt * FF[i + (stage - 1) * neq] - bspl; r[i + 4 * neq] = 0; for (j = 0; j < stage; j++) r[i + 4 * neq] = r[i + 4 * neq] + d[j] * FF[i + j * neq]; r[i + 4 * neq] = r[i + 4 * neq] * dt; } } void densout(double *r, double t0, double t, double dt, double* res, int neq) { double s = (t - t0) / dt; double s1 = 1.0 - s; for (int i = 0; i < neq; i++) res[i] = r[i] + s * (r[i + neq] + s1 * (r[i + 2 * neq] + s * (r[i + 3 * neq] + s1 * (r[i + 4 * neq])))); } /*----------------------------------------------------------------------------*/ /* dense output for the Cash-Karp method - does not work (yet) */ /*----------------------------------------------------------------------------*/ void densoutck(double t0, double t, double dt, double* y0, double* FF, double* dy, double* res, int neq) { double s, s2, s3, s4, b1, b3, b4, b5, b6, b7; s = (t - t0) / dt; s2 = s * s; s3 = s2 * s; s4 = s3 * s; b3 = 500./161. * s2 - 20000./4347.* s3 + 2750./1449.* s4; b4 = 125./132. * s2 - 625./594. * s3 + 125./396. * s4; b5 = 15./28. * s2 - 15./14. * s3 + 15./28. * s4; b6 = -6144./1771. * s2 + 2048./253. * s3 - 7680./1771.* s4; b7 = 3./2. * s2 - 4. * s3 + 5./2. * s4; b1 = s-b3-b4-b5-b6-b7; for (int i = 0; i < neq; i++) res[i] = y0[i] + b1 * dt * FF[i + 0 * neq] + b3 * dt * FF[i + 2 * neq] + b4 * dt * FF[i + 3 * neq] + b5 * dt * FF[i + 4 * neq] + b6 * dt * FF[i + 5 * neq] + b7 * dt * dy[i]; } /*----------------------------------------------------------------------------*/ /* Polynomial interpolation */ /* ksig: number of signals */ /* n: number of knots per signal */ /* x[0 .. n-1]: vector of x values */ /* y[0 .. n-1, 0 .. ksig] array of y values */ /*----------------------------------------------------------------------------*/ void neville(double *xx, double *y, double tnew, double *ynew, int n, int ksig) { int i, j, k; double x[n]; double yy[n * ksig]; /* temporary workspace */ double tscal = xx[n-1] - xx[0]; double t = tnew / tscal; for (i = 0; i < n; i++) x[i] = xx[i] / tscal; for (i = 0; i < n * ksig; i++) yy[i] = y[i]; for (k = 0; k < ksig; k++) { for (j = 1; j < n; j++) for (i = n - 1; i >= j; i--) { yy[i + k * n] = ((t - x[i - j]) * yy[i + k * n] - (t - x[i]) * yy[i - 1 + k * n]) / (x[i] - x[i - j]); } ynew[k] = yy[n - 1 + k * n]; } } /*============================================================================*/ /* Specific utility functions */ /*============================================================================*/ void shiftBuffer (double *x, int n, int k) { /* n = rows, k = columns */ for (int i = 0; i < (n - 1); i++) for (int j = 0; j < k; j++) x[i + j * n] = x[i + 1 + j * n]; } void setIstate(SEXP R_yout, SEXP R_istate, int *istate, int it_tot, int stage, int fsal, int qerr, int nrej) { /* karline: nsteps + 1 for "initial condition evaluation" */ /* note that indices are 1 smaller in C than in R */ istate[11] = it_tot; /* number of steps */ istate[12] = it_tot * (stage - fsal) + 1; /* number of function evaluations */ if (fsal) istate[12] = istate[12] + nrej + 1; /* one more ftion eval if rejected*/ istate[13] = nrej; /* number of rejected steps */ istate[14] = qerr; /* order of the method */ setAttrib(R_yout, install("istate"), R_istate); } deSolve/src/rk_implicit.c0000754000175100001440000002047613131751003015137 0ustar hornikusers/*==========================================================================*/ /* Implicit RK Solver with fixed step size */ /*==========================================================================*/ #include "rk_util.h" void F77_NAME(dgefa)(double*, int*, int*, int*, int*); void F77_NAME(dgesl)(double*, int*, int*, int*, double*, int*); /* void lu_solve(double, int, int, double); void kfunc(int, int, double, double, double, double, double, double, double, SEXP, SEXP, SEXP, double, double, double, int, int, int); void dkfunc(int, int, double, double, double, double, double, double, double, SEXP, SEXP, SEXP, double, double, double, double, int, int, int, double); */ /* lower upper decomposition - no error checking */ void lu_solve(double *alfa, int n, int *index, double *bet) { int info; F77_CALL(dgefa)(alfa, &n, &n, index, &info); if (info != 0) error("error during factorisation of matrix (dgefa), singular matrix"); F77_CALL(dgesl)(alfa, &n, &n, index, bet, &info); if (info != 0) error("error during backsubstitution"); } /* function that returns -k + dt*derivs(t+c[i]*dt, y+sum(a[i,)*k this is the function whose roots should be found in the implicit method */ void kfunc(int stage, int neq, double t, double dt, double *FF, double *Fj, double *A, double *cc, double *y0 , SEXP Func, SEXP Parms, SEXP Rho, double *tmp, double *tmp2, double *out, int *ipar, int isDll, int isForcing){ int i, j, k; /****** Prepare Coefficients from Butcher table ******/ for (j = 0; j < stage; j++) { for (i = 0; i < neq; i++) Fj[i] = 0.; for (k =0; k < stage; k++) { /* implicit part */ for(i = 0; i < neq; i++) Fj[i] = Fj[i] + A[j + stage * k] * FF[i + neq * k] * dt; } for (int i = 0; i < neq; i++) { tmp[i] = Fj[i] + y0[i]; } /****** Compute Derivatives ******/ /* pass option to avoid unnecessary copying in derivs note:tmp2 rather than FF */ derivs(Func, t + dt * cc[j], tmp, Parms, Rho, tmp2, out, j, neq, ipar, isDll, isForcing); } for (i = 0; i< neq*stage;i++) tmp[i] = FF[i] - tmp2[i]; /* tmp should be = 0 at root */ } /* function that returns the Jacobian of kfunc; df[i,j] should contain: dkfunc_i/dFFj CHECK */ void dkfunc(int stage, int neq, double t, double dt, double *FF, double *Fj, double *A, double *cc, double *y0, SEXP Func, SEXP Parms, SEXP Rho, double *tmp, double *tmp2, double *tmp3, double *out, int *ipar, int isDll, int isForcing, double *df){ int i, j, nroot; double d1, d2; nroot = neq*stage; /* function reference value in tmp2 */ kfunc(stage, neq, t, dt, FF, Fj, A, cc, y0, Func, Parms, Rho, tmp2, tmp3, out, ipar, isDll, isForcing); for (i = 0; i < nroot; i++) { d1 = FF[i]; /* copy */ d2 = fmax(1e-8, FF[i] * 1e-8); /* perturb */ FF[i] = FF[i] + d2; kfunc(stage, neq, t, dt, FF, Fj, A, cc, y0, Func, Parms, Rho, tmp, tmp3, out, ipar, isDll, isForcing); for (j = 0; j < nroot; j++) df[nroot * i + j] = (tmp[j] - tmp2[j])/d2; //df[j,i] j,i=1:nroot FF[i] = d1; /* restore */ } } /* ks: check if tmp3 necessary ... */ void rk_implicit( double * alfa, /* neq*stage * neq*stage */ int *index, /* neq*stage */ /* integers */ int fsal, int neq, int stage, int isDll, int isForcing, int verbose, int nknots, int interpolate, int maxsteps, int nt, /* int pointers */ int* _iknots, int* _it, int* _it_ext, int* _it_tot, int* istate, int* ipar, /* double */ double t, double tmax, double hini, /* double pointers */ double* _dt, /* arrays */ double* tt, double* y0, double* y1, double* dy1, double* f, double* y, double* Fj, double* tmp, double* tmp2, double* tmp3, double* FF, double* rr, double* A, double* out, double* bb1, double* cc, double* yknots, double* yout, /* SEXPs */ SEXP Func, SEXP Parms, SEXP Rho ) { int i = 0, one = 1; int iknots = *_iknots, it = *_it, it_ext = *_it_ext, it_tot = *_it_tot; double t_ext; double dt = *_dt; int iter, maxit = 100; double errf, errx; int nroot = neq * stage; /*------------------------------------------------------------------------*/ /* Main Loop */ /*------------------------------------------------------------------------*/ do { /* select time step (possibly irregular) */ if (hini > 0.0) dt = fmin(hini, tmax - t); /* adjust dt for step-by-step-mode */ else dt = tt[it] - tt[it-1]; timesteps[0] = timesteps[1]; timesteps[1] = dt; /* Newton-Raphson steps */ for (iter = 0; iter < maxit; iter++) { /* function value and Jacobian*/ kfunc(stage, neq, t, dt, FF, Fj, A, cc, y0, Func, Parms, Rho, tmp, tmp2, out, ipar, isDll, isForcing); it_tot++; /* count total number of time steps */ errf = 0.; for ( i = 0; i < nroot; i++) errf = errf + fabs(tmp[i]); if (errf < 1e-8) break; dkfunc(stage, neq, t, dt, FF, Fj, A, cc, y0, Func, Parms, Rho, tmp, tmp2, tmp3, out, ipar, isDll, isForcing, alfa); it_tot = it_tot + nroot + 1; lu_solve (alfa, nroot, index, tmp); errx = 0; for (i = 0; i < nroot; i++) { errx = errx + fabs(tmp[i]); FF[i] = FF[i] - tmp[i]; } // Rprintf("iter %i errf %g errx %g\n",iter, errf, errx); if (errx < 1e-8) break; } /*====================================================================*/ /* Estimation of new values */ /*====================================================================*/ /* use BLAS with reduced error checking */ blas_matprod1(FF, neq, stage, bb1, stage, one, dy1); for (i = 0; i < neq; i++) { y1[i] = y0[i] + dt * dy1[i]; } /*====================================================================*/ /* Interpolation and Data Storage */ /*====================================================================*/ if (interpolate) { /*------------------------------------------------------------------*/ /* "Neville-Aitken-Interpolation"; */ /* the fixed step integrators have no dense output */ /*------------------------------------------------------------------*/ /* (1) collect number "nknots" of knots in advanve */ yknots[iknots] = t + dt; /* time in first column */ for (i = 0; i < neq; i++) yknots[iknots + nknots * (1 + i)] = y1[i]; if (iknots < (nknots - 1)) { iknots++; } else { /* (2) do polynomial interpolation */ t_ext = tt[it_ext]; while (t_ext <= t + dt) { neville(yknots, &yknots[nknots], t_ext, tmp, nknots, neq); /* (3) store outputs */ if (it_ext < nt) { yout[it_ext] = t_ext; for (i = 0; i < neq; i++) yout[it_ext + nt * (1 + i)] = tmp[i]; } if(it_ext < nt-1) t_ext = tt[++it_ext]; else break; } shiftBuffer(yknots, nknots, neq + 1); } } else { /*--------------------------------------------------------------------*/ /* No interpolation mode(for step to step integration); */ /* results are stored after the call */ /*--------------------------------------------------------------------*/ } /*--------------------------------------------------------------------*/ /* next time step */ /*--------------------------------------------------------------------*/ t = t + dt; it++; for (i = 0; i < neq; i++) y0[i] = y1[i]; if (it_ext > nt) { Rprintf("error in RK solver rk_implicit.c: output buffer overflow\n"); break; } if (it_tot > maxsteps) { istate[0] = -1; warning("Number of time steps %i exceeded maxsteps at t = %g\n", it, t); break; } /* tolerance to avoid rounding errors */ } while (t < (tmax - 100.0 * DBL_EPSILON * dt)); /* end of rk main loop */ /* return reference values */ *_iknots = iknots; *_it = it; *_it_ext = it_ext; *_it_tot = it_tot; } deSolve/src/dsparsk.f0000754000175100001440000010117013131751003014272 0ustar hornikusersc----------------------------------------------------------------------c c S P A R S K I T c c----------------------------------------------------------------------c c BASIC LINEAR ALGEBRA FOR SPARSE MATRICES. BLASSM MODULE c c----------------------------------------------------------------------c c aplb : computes C = A+B c c aplb1 : computes C = A+B [Sorted version: A, B, C sorted] c c aplsb : computes C = A + s B c c diamua : Computes C = Diag * A c c amudia : Computes C = A* Diag c c aplsca : Computes A:= A + s I (s = scalar) c c----------------------------------------------------------------------c subroutine diamua (nrow,job, a, ja, ia, diag, b, jb, ib) real(kind=8) a(*), b(*), diag(nrow), scal integer ja(*),jb(*), ia(nrow+1),ib(nrow+1) c----------------------------------------------------------------------- c performs the matrix by matrix product B = Diag * A (in place) c----------------------------------------------------------------------- c on entry: c --------- c nrow = integer. The row dimension of A c c job = integer. job indicator. Job=0 means get array b only c job = 1 means get b, and the integer arrays ib, jb. c c a, c ja, c ia = Matrix A in compressed sparse row format. c c diag = diagonal matrix stored as a vector dig(1:n) c c on return: c---------- c c b, c jb, c ib = resulting matrix B in compressed sparse row sparse format. c c Notes: c------- c 1) The column dimension of A is not needed. c 2) algorithm in place (B can take the place of A). c in this case use job=0. c----------------------------------------------------------------- do 1 ii=1,nrow c c normalize each row c k1 = ia(ii) k2 = ia(ii+1)-1 scal = diag(ii) do 2 k=k1, k2 b(k) = a(k)*scal 2 continue 1 continue c if (job .eq. 0) return c do 3 ii=1, nrow+1 ib(ii) = ia(ii) 3 continue do 31 k=ia(1), ia(nrow+1) -1 jb(k) = ja(k) 31 continue return c----------end-of-diamua------------------------------------------------ c----------------------------------------------------------------------- end c----------------------------------------------------------------------c c S P A R S K I T c c----------------------------------------------------------------------c c BASIC MATRIX-VECTOR OPERATIONS - MATVEC MODULE c c----------------------------------------------------------------------c c amux : A times a vector. Compressed Sparse Row (CSR) format. c c----------------------------------------------------------------------c c----------------------------------------------------------------------c c S P A R S K I T c c----------------------------------------------------------------------c C INPUT-OUTPUT MODULE c c----------------------------------------------------------------------c c prtmt : prints matrices in the Boeing/Harwell format. c c----------------------------------------------------------------------c c----------------------------------------------------------------------c c S P A R S K I T c c----------------------------------------------------------------------c c FORMAT CONVERSION MODULE c c----------------------------------------------------------------------c c csrdns : converts a row-stored sparse matrix into the dense format. c c coocsr : converts coordinate to to csr format c c coicsr : in-place conversion of coordinate to csr format c c csrcoo : converts compressed sparse row to coordinate. c c csrcsc : converts compressed sparse row format to compressed sparse c c column format (transposition) c c csrcsc2 : rectangular version of csrcsc c c csrdia : converts a compressed sparse row format into a diagonal c c format. c c csrbnd : converts a compressed sparse row format into a banded c c format (linpack style). c c----------------------------------------------------------------------c subroutine csrcsc (n,job,ipos,a,ja,ia,ao,jao,iao) integer ia(n+1),iao(n+1),ja(*),jao(*) real(kind=8) a(*),ao(*) c----------------------------------------------------------------------- c Compressed Sparse Row to Compressed Sparse Column c c (transposition operation) Not in place. c----------------------------------------------------------------------- c -- not in place -- c this subroutine transposes a matrix stored in a, ja, ia format. c --------------- c on entry: c---------- c n = dimension of A. c job = integer to indicate whether to fill the values (job.eq.1) of the c matrix ao or only the pattern., i.e.,ia, and ja (job .ne.1) c c ipos = starting position in ao, jao of the transposed matrix. c the iao array takes this into account (thus iao(1) is set to ipos.) c Note: this may be useful if one needs to append the data structure c of the transpose to that of A. In this case use for example c call csrcsc (n,1,ia(n+1),a,ja,ia,a,ja,ia(n+2)) c for any other normal usage, enter ipos=1. c a = real array of length nnz (nnz=number of nonzero elements in input c matrix) containing the nonzero elements. c ja = integer array of length nnz containing the column positions c of the corresponding elements in a. c ia = integer of size n+1. ia(k) contains the position in a, ja of c the beginning of the k-th row. c c on return: c ---------- c output arguments: c ao = real array of size nzz containing the "a" part of the transpose c jao = integer array of size nnz containing the column indices. c iao = integer array of size n+1 containing the "ia" index array of c the transpose. c c----------------------------------------------------------------------- call csrcsc2 (n,n,job,ipos,a,ja,ia,ao,jao,iao) end subroutine csrcsc2 (n,n2,job,ipos,a,ja,ia,ao,jao,iao) integer ia(n+1),iao(n2+1),ja(*),jao(*) real(kind=8) a(*),ao(*) c----------------------------------------------------------------------- c Compressed Sparse Row to Compressed Sparse Column c c (transposition operation) Not in place. c----------------------------------------------------------------------- c Rectangular version. n is number of rows of CSR matrix, c n2 (input) is number of columns of CSC matrix. c----------------------------------------------------------------------- c -- not in place -- c this subroutine transposes a matrix stored in a, ja, ia format. c --------------- c on entry: c---------- c n = number of rows of CSR matrix. c n2 = number of columns of CSC matrix. c job = integer to indicate whether to fill the values (job.eq.1) of the c matrix ao or only the pattern., i.e.,ia, and ja (job .ne.1) c c ipos = starting position in ao, jao of the transposed matrix. c the iao array takes this into account (thus iao(1) is set to ipos.) c Note: this may be useful if one needs to append the data structure c of the transpose to that of A. In this case use for example c call csrcsc2 (n,n,1,ia(n+1),a,ja,ia,a,ja,ia(n+2)) c for any other normal usage, enter ipos=1. c a = real array of length nnz (nnz=number of nonzero elements in input c matrix) containing the nonzero elements. c ja = integer array of length nnz containing the column positions c of the corresponding elements in a. c ia = integer of size n+1. ia(k) contains the position in a, ja of c the beginning of the k-th row. c c on return: c ---------- c output arguments: c ao = real array of size nzz containing the "a" part of the transpose c jao = integer array of size nnz containing the column indices. c iao = integer array of size n+1 containing the "ia" index array of c the transpose. c c----------------------------------------------------------------------- c----------------- compute lengths of rows of transp(A) ---------------- do 1 i=1,n2+1 iao(i) = 0 1 continue do 3 i=1, n do 2 k=ia(i), ia(i+1)-1 j = ja(k)+1 iao(j) = iao(j)+1 2 continue 3 continue c---------- compute pointers from lengths ------------------------------ iao(1) = ipos do 4 i=1,n2 iao(i+1) = iao(i) + iao(i+1) 4 continue c--------------- now do the actual copying ----------------------------- do 6 i=1,n do 62 k=ia(i),ia(i+1)-1 j = ja(k) next = iao(j) if (job .eq. 1) ao(next) = a(k) jao(next) = i iao(j) = next+1 62 continue 6 continue c-------------------------- reshift iao and leave ---------------------- do 7 i=n2,1,-1 iao(i+1) = iao(i) 7 continue iao(1) = ipos c--------------- end of csrcsc2 ---------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------c c S P A R S K I T c c----------------------------------------------------------------------c c UNARY SUBROUTINES MODULE c c----------------------------------------------------------------------c c rperm : permutes the rows of a matrix (B = P A) c c cperm : permutes the columns of a matrix (B = A Q) c c dperm : permutes both the rows and columns of a matrix (B = P A Q ) c c dvperm : permutes a real vector (in-place) c c ivperm : permutes an integer vector (in-place) c c diapos : returns the positions of the diagonal elements in A. c c getbwd : returns the bandwidth information on a matrix. c c infdia : obtains information on the diagonals of A. c c rnrms : computes the norms of the rows of A c c roscal : scales the rows of a matrix by their norms. c c----------------------------------------------------------------------c subroutine rperm (nrow,a,ja,ia,ao,jao,iao,perm,job) integer nrow,ja(*),ia(nrow+1),jao(*),iao(nrow+1),perm(nrow),job real(kind=8) a(*),ao(*) c----------------------------------------------------------------------- c this subroutine permutes the rows of a matrix in CSR format. c rperm computes B = P A where P is a permutation matrix. c the permutation P is defined through the array perm: for each j, c perm(j) represents the destination row number of row number j. c Youcef Saad -- recoded Jan 28, 1991. c----------------------------------------------------------------------- c on entry: c---------- c n = dimension of the matrix c a, ja, ia = input matrix in csr format c perm = integer array of length nrow containing the permutation arrays c for the rows: perm(i) is the destination of row i in the c permuted matrix. c ---> a(i,j) in the original matrix becomes a(perm(i),j) c in the output matrix. c c job = integer indicating the work to be done: c job = 1 permute a, ja, ia into ao, jao, iao c (including the copying of real values ao and c the array iao). c job .ne. 1 : ignore real values. c (in which case arrays a and ao are not needed nor c used). c c------------ c on return: c------------ c ao, jao, iao = input matrix in a, ja, ia format c note : c if (job.ne.1) then the arrays a and ao are not used. c----------------------------------------------------------------------c c Y. Saad, May 2, 1990 c c----------------------------------------------------------------------c logical values values = (job .eq. 1) c c determine pointers for output matix. c do 50 j=1,nrow i = perm(j) iao(i+1) = ia(j+1) - ia(j) 50 continue c c get pointers from lengths c iao(1) = 1 do 51 j=1,nrow iao(j+1)=iao(j+1)+iao(j) 51 continue c c copying c do 100 ii=1,nrow c c old row = ii -- new row = iperm(ii) -- ko = new pointer c ko = iao(perm(ii)) do 60 k=ia(ii), ia(ii+1)-1 jao(ko) = ja(k) if (values) ao(ko) = a(k) ko = ko+1 60 continue 100 continue c return c---------end-of-rperm ------------------------------------------------- c----------------------------------------------------------------------- end subroutine cperm (nrow,a,ja,ia,ao,jao,iao,perm,job) integer nrow,ja(*),ia(nrow+1),jao(*),iao(nrow+1),perm(*), job real(kind=8) a(*), ao(*) c----------------------------------------------------------------------- c this subroutine permutes the columns of a matrix a, ja, ia. c the result is written in the output matrix ao, jao, iao. c cperm computes B = A P, where P is a permutation matrix c that maps column j into column perm(j), i.e., on return c a(i,j) becomes a(i,perm(j)) in new matrix c Y. Saad, May 2, 1990 / modified Jan. 28, 1991. c----------------------------------------------------------------------- c on entry: c---------- c nrow = row dimension of the matrix c c a, ja, ia = input matrix in csr format. c c perm = integer array of length ncol (number of columns of A c containing the permutation array the columns: c a(i,j) in the original matrix becomes a(i,perm(j)) c in the output matrix. c c job = integer indicating the work to be done: c job = 1 permute a, ja, ia into ao, jao, iao c (including the copying of real values ao and c the array iao). c job .ne. 1 : ignore real values ao and ignore iao. c c------------ c on return: c------------ c ao, jao, iao = input matrix in a, ja, ia format (array ao not needed) c c Notes: c------- c 1. if job=1 then ao, iao are not used. c 2. This routine is in place: ja, jao can be the same. c 3. If the matrix is initially sorted (by increasing column number) c then ao,jao,iao may not be on return. c c----------------------------------------------------------------------c c local parameters: integer k, i, nnz c nnz = ia(nrow+1)-1 do 100 k=1,nnz jao(k) = perm(ja(k)) 100 continue c c done with ja array. return if no need to touch values. c if (job .ne. 1) return c c else get new pointers -- and copy values too. c do 1 i=1, nrow+1 iao(i) = ia(i) 1 continue c do 2 k=1, nnz ao(k) = a(k) 2 continue c return c---------end-of-cperm-------------------------------------------------- c----------------------------------------------------------------------- end subroutine diapos (n,ja,ia,idiag) integer ia(n+1), ja(*), idiag(n) c----------------------------------------------------------------------- c this subroutine returns the positions of the diagonal elements of a c sparse matrix a, ja, ia, in the array idiag. c----------------------------------------------------------------------- c on entry: c---------- c c n = integer. row dimension of the matrix a. c a,ja, c ia = matrix stored compressed sparse row format. a array skipped. c c on return: c----------- c idiag = integer array of length n. The i-th entry of idiag c points to the diagonal element a(i,i) in the arrays c a, ja. (i.e., a(idiag(i)) = element A(i,i) of matrix A) c if no diagonal element is found the entry is set to 0. c----------------------------------------------------------------------c c Y. Saad, March, 1990 c----------------------------------------------------------------------c do 1 i=1, n idiag(i) = 0 1 continue c c sweep through data structure. c do 6 i=1,n do 51 k= ia(i),ia(i+1) -1 if (ja(k) .eq. i) idiag(i) = k 51 continue 6 continue c----------- -end-of-diapos--------------------------------------------- c----------------------------------------------------------------------- return end subroutine getbwd(n,a,ja,ia,ml,mu) c----------------------------------------------------------------------- c gets the bandwidth of lower part and upper part of A. c does not assume that A is sorted. c----------------------------------------------------------------------- c on entry: c---------- c n = integer = the row dimension of the matrix c a, ja, c ia = matrix in compressed sparse row format. c c on return: c----------- c ml = integer. The bandwidth of the strict lower part of A c mu = integer. The bandwidth of the strict upper part of A c c Notes: c ===== ml and mu are allowed to be negative or return. This may be c useful since it will tell us whether a band is confined c in the strict upper/lower triangular part. c indeed the definitions of ml and mu are c c ml = max ( (i-j) s.t. a(i,j) .ne. 0 ) c mu = max ( (j-i) s.t. a(i,j) .ne. 0 ) c----------------------------------------------------------------------c c Y. Saad, Sep. 21 1989 c c----------------------------------------------------------------------c real(kind=8) a(*) integer ja(*),ia(n+1),ml,mu,ldist,i,k ml = - n mu = - n do 3 i=1,n do 31 k=ia(i),ia(i+1)-1 ldist = i-ja(k) ml = max(ml,ldist) mu = max(mu,-ldist) 31 continue 3 continue return c---------------end-of-getbwd ------------------------------------------ c----------------------------------------------------------------------- end subroutine infdia (n,ja,ia,ind,idiag) integer ia(*), ind(*), ja(*) c----------------------------------------------------------------------- c obtains information on the diagonals of A. c----------------------------------------------------------------------- c this subroutine finds the lengths of each of the 2*n-1 diagonals of A c it also outputs the number of nonzero diagonals found. c----------------------------------------------------------------------- c on entry: c---------- c n = dimension of the matrix a. c c a, ..... not needed here. c ja, c ia = matrix stored in csr format c c on return: c----------- c c idiag = integer. number of nonzero diagonals found. c c ind = integer array of length at least 2*n-1. The k-th entry in c ind contains the number of nonzero elements in the diagonal c number k, the numbering beeing from the lowermost diagonal c (bottom-left). In other words ind(k) = length of diagonal c whose offset wrt the main diagonal is = - n + k. c----------------------------------------------------------------------c c Y. Saad, Sep. 21 1989 c c----------------------------------------------------------------------c n2= n+n-1 do 1 i=1,n2 ind(i) = 0 1 continue do 3 i=1, n do 2 k=ia(i),ia(i+1)-1 j = ja(k) ind(n+j-i) = ind(n+j-i) +1 2 continue 3 continue c count the nonzero ones. idiag = 0 do 41 k=1, n2 if (ind(k) .ne. 0) idiag = idiag+1 41 continue return c done c------end-of-infdia --------------------------------------------------- c----------------------------------------------------------------------- end subroutine rnrms (nrow, nrm, a, ja, ia, diag) real(kind=8) a(*), diag(nrow), scal integer ja(*), ia(nrow+1) c----------------------------------------------------------------------- c gets the norms of each row of A. (choice of three norms) c----------------------------------------------------------------------- c on entry: c --------- c nrow = integer. The row dimension of A c c nrm = integer. norm indicator. nrm = 1, means 1-norm, nrm =2 c means the 2-nrm, nrm = 0 means max norm c c a, c ja, c ia = Matrix A in compressed sparse row format. c c on return: c---------- c c diag = real vector of length nrow containing the norms c c----------------------------------------------------------------- do 1 ii=1,nrow c c compute the norm if each element. c scal = 0.0d0 k1 = ia(ii) k2 = ia(ii+1)-1 if (nrm .eq. 0) then do 2 k=k1, k2 scal = max(scal,abs(a(k) ) ) 2 continue elseif (nrm .eq. 1) then do 3 k=k1, k2 scal = scal + abs(a(k) ) 3 continue else do 4 k=k1, k2 scal = scal+a(k)**2 4 continue endif if (nrm .eq. 2) scal = sqrt(scal) diag(ii) = scal 1 continue return c----------------------------------------------------------------------- c-------------end-of-rnrms---------------------------------------------- end c----------------------------------------------------------------------c c S P A R S K I T c c----------------------------------------------------------------------c c ITERATIVE SOLVERS MODULE c c----------------------------------------------------------------------c c ILUT : Incomplete LU factorization with dual truncation strategy c c ILUTP : ILUT with column pivoting c c LUSOL : forward followed by backward triangular solve (Precond.) c c QSPLIT : quick split routine used by ilut to sort out the k largest c c elements in absolute value c c----------------------------------------------------------------------c subroutine qsplit(a,ind,n,ncut) real(kind=8) a(n) integer ind(n), n, ncut c----------------------------------------------------------------------- c does a quick-sort split of a real array. c on input a(1:n). is a real array c on output a(1:n) is permuted such that its elements satisfy: c c abs(a(i)) .ge. abs(a(ncut)) for i .lt. ncut and c abs(a(i)) .le. abs(a(ncut)) for i .gt. ncut c c ind(1:n) is an integer array which permuted in the same way as a(*). c----------------------------------------------------------------------- real(kind=8) tmp, abskey integer itmp, first, last c----- first = 1 last = n if (ncut .lt. first .or. ncut .gt. last) return c c outer loop -- while mid .ne. ncut do c 1 mid = first abskey = abs(a(mid)) do 2 j=first+1, last if (abs(a(j)) .gt. abskey) then mid = mid+1 c interchange tmp = a(mid) itmp = ind(mid) a(mid) = a(j) ind(mid) = ind(j) a(j) = tmp ind(j) = itmp endif 2 continue c c interchange c tmp = a(mid) a(mid) = a(first) a(first) = tmp c itmp = ind(mid) ind(mid) = ind(first) ind(first) = itmp c c test for while loop c if (mid .eq. ncut) return if (mid .gt. ncut) then last = mid-1 else first = mid+1 endif goto 1 c----------------end-of-qsplit------------------------------------------ c----------------------------------------------------------------------- end c----------------------------------------------------------------------c c S P A R S K I T c c----------------------------------------------------------------------c c REORDERING ROUTINES -- LEVEL SET BASED ROUTINES c c----------------------------------------------------------------------c c dblstr : doubled stripe partitioner c BFS : Breadth-First search traversal algorithm c add_lvst : routine to add a level -- used by BFS c stripes : finds the level set structure c perphn : finds a pseudo-peripheral node and performs a BFS from it. c rversp : routine to reverse a given permutation (e.g., for RCMK) c maskdeg : integer function to compute the `masked' of a node c----------------------------------------------------------------------- subroutine BFS(n,ja,ia,nfirst,iperm,mask,maskval,riord,levels, * nlev) implicit none integer n,ja(*),ia(*),nfirst,iperm(n),mask(n),riord(*),levels(*), * nlev,maskval c----------------------------------------------------------------------- c finds the level-structure (breadth-first-search or CMK) ordering for a c given sparse matrix. Uses add_lvst. Allows an set of nodes to be c the initial level (instead of just one node). c-------------------------parameters------------------------------------ c on entry: c--------- c n = number of nodes in the graph c ja, ia = pattern of matrix in CSR format (the ja,ia arrays of csr data c structure) c nfirst = number of nodes in the first level that is input in riord c iperm = integer array indicating in which order to traverse the graph c in order to generate all connected components. c if iperm(1) .eq. 0 on entry then BFS will traverse the nodes c in the order 1,2,...,n. c c riord = (also an ouput argument). On entry riord contains the labels c of the nfirst nodes that constitute the first level. c c mask = array used to indicate whether or not a node should be c condidered in the graph. see maskval. c mask is also used as a marker of visited nodes. c c maskval= consider node i only when: mask(i) .eq. maskval c maskval must be .gt. 0. c thus, to consider all nodes, take mask(1:n) = 1. c maskval=1 (for example) c c on return c --------- c mask = on return mask is restored to its initial state. c riord = `reverse permutation array'. Contains the labels of the nodes c constituting all the levels found, from the first level to c the last. c levels = pointer array for the level structure. If lev is a level c number, and k1=levels(lev),k2=levels(lev+1)-1, then c all the nodes of level number lev are: c riord(k1),riord(k1+1),...,riord(k2) c nlev = number of levels found c----------------------------------------------------------------------- c integer j, ii, nod, istart, iend logical permut permut = (iperm(1) .ne. 0) c c start pointer structure to levels c nlev = 0 c c previous end c istart = 0 ii = 0 c c current end c iend = nfirst c c intialize masks to zero -- except nodes of first level -- c do 12 j=1, nfirst mask(riord(j)) = 0 12 continue c----------------------------------------------------------------------- continue c 1 nlev = nlev+1 levels(nlev) = istart + 1 call add_lvst (istart,iend,nlev,riord,ja,ia,mask,maskval) if (istart .lt. iend) goto 1 2 ii = ii+1 if (ii .le. n) then nod = ii if (permut) nod = iperm(nod) if (mask(nod) .eq. maskval) then c c start a new level c istart = iend iend = iend+1 riord(iend) = nod mask(nod) = 0 goto 1 else goto 2 endif endif c----------------------------------------------------------------------- levels(nlev+1) = iend+1 do j=1, iend mask(riord(j)) = maskval enddo c----------------------------------------------------------------------- return end subroutine add_lvst(istart,iend,nlev,riord,ja,ia,mask,maskval) integer nlev, nod, riord(*), ja(*), ia(*), mask(*) c------------------------------------------------------------- c adds one level set to the previous sets.. c span all nodes of previous mask c------------------------------------------------------------- nod = iend do 25 ir = istart+1,iend i = riord(ir) do 24 k=ia(i),ia(i+1)-1 j = ja(k) if (mask(j) .eq. maskval) then nod = nod+1 mask(j) = 0 riord(nod) = j endif 24 continue 25 continue istart = iend iend = nod return end subroutine stripes (nlev,riord,levels,ip,map,mapptr,ndom) implicit none integer nlev,riord(*),levels(nlev+1),ip,map(*), * mapptr(*), ndom c----------------------------------------------------------------------- c this is a post processor to BFS. stripes uses the output of BFS to c find a decomposition of the adjacency graph by stripes. It fills c the stripes level by level until a number of nodes .gt. ip is c is reached. c---------------------------parameters----------------------------------- c on entry: c -------- c nlev = number of levels as found by BFS c riord = reverse permutation array produced by BFS -- c levels = pointer array for the level structure as computed by BFS. If c lev is a level number, and k1=levels(lev),k2=levels(lev+1)-1, c then all the nodes of level number lev are: c riord(k1),riord(k1+1),...,riord(k2) c ip = number of desired partitions (subdomains) of about equal size. c c on return c --------- c ndom = number of subgraphs (subdomains) found c map = node per processor list. The nodes are listed contiguously c from proc 1 to nproc = mpx*mpy. c mapptr = pointer array for array map. list for proc. i starts at c mapptr(i) and ends at mapptr(i+1)-1 in array map. c----------------------------------------------------------------------- c local variables. c integer ib,ktr,ilev,k,nsiz,psiz ndom = 1 ib = 1 c to add: if (ip .le. 1) then ... nsiz = levels(nlev+1) - levels(1) psiz = (nsiz-ib)/max(1,(ip - ndom + 1)) + 1 mapptr(ndom) = ib ktr = 0 do 10 ilev = 1, nlev c c add all nodes of this level to domain c do 3 k=levels(ilev), levels(ilev+1)-1 map(ib) = riord(k) ib = ib+1 ktr = ktr + 1 if (ktr .ge. psiz .or. k .ge. nsiz) then ndom = ndom + 1 mapptr(ndom) = ib psiz = (nsiz-ib)/max(1,(ip - ndom + 1)) + 1 ktr = 0 endif c 3 continue 10 continue ndom = ndom-1 return end integer function maskdeg (ja,ia,nod,mask,maskval) implicit none integer ja(*),ia(*),nod,mask(*),maskval c----------------------------------------------------------------------- integer deg, k deg = 0 do k =ia(nod),ia(nod+1)-1 if (mask(ja(k)) .eq. maskval) deg = deg+1 enddo maskdeg = deg return end subroutine perphn(n,ja,ia,init,mask,maskval,nlev,riord,levels) implicit none integer n,ja(*),ia(*),init,mask(*),maskval, * nlev,riord(*),levels(*) c----------------------------------------------------------------------- c finds a peripheral node and does a BFS search from it. c----------------------------------------------------------------------- c see routine dblstr for description of parameters c input: c------- c ja, ia = list pointer array for the adjacency graph c mask = array used for masking nodes -- see maskval c maskval = value to be checked against for determing whether or c not a node is masked. If mask(k) .ne. maskval then c node k is not considered. c init = init node in the pseudo-peripheral node algorithm. c c output: c------- c init = actual pseudo-peripherial node found. c nlev = number of levels in the final BFS traversal. c riord = c levels = c----------------------------------------------------------------------- integer j,nlevp,deg,nfirst,mindeg,nod,maskdeg integer iperm(1) nlevp = 0 1 continue riord(1) = init nfirst = 1 iperm(1) = 0 c call BFS(n,ja,ia,nfirst,iperm,mask,maskval,riord,levels,nlev) if (nlev .gt. nlevp) then mindeg = n+1 do j=levels(nlev),levels(nlev+1)-1 nod = riord(j) deg = maskdeg(ja,ia,nod,mask,maskval) if (deg .lt. mindeg) then init = nod mindeg = deg endif enddo nlevp = nlev goto 1 endif return end c----------------------------------------------------------------------c c Non-SPARSKIT utility routine c----------------------------------------------------------------------c deSolve/src/dlsoder.f0000754000175100001440000020323313131751003014262 0ustar hornikusers*DECK DLSODER C DLSODER was created by merging DLSODE with DLSODAR - Karline Soetaert SUBROUTINE DLSODER (F, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, ITASK, 1 ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JAC, MF, 2 G, NG, JROOT, rpar, ipar) IMPLICIT NONE EXTERNAL F, JAC, G CKS: added rpar, ipar, and G INTEGER ipar(*) DOUBLE PRECISION rpar(*) INTEGER NEQ, ITOL, ITASK, ISTATE, IOPT, LRW, IWORK, LIW, MF INTEGER NG, JROOT DOUBLE PRECISION Y, T, TOUT, RTOL, ATOL, RWORK DIMENSION NEQ(*), Y(*), RTOL(*), ATOL(*), RWORK(LRW), IWORK(LIW), 1 JROOT(NG) C----------------------------------------------------------------------- C***BEGIN PROLOGUE DLSODER C***PURPOSE Livermore Solver for Ordinary Differential Equations. C DLSODER solves the initial-value problem for stiff or C nonstiff systems of first-order ODE's, C dy/dt = f(t,y), or, in component form, C dy(i)/dt = f(i) = f(i,t,y(1),y(2),...,y(N)), i=1,...,N. C and with Root-finding. C***CATEGORY I1A C***TYPE DOUBLE PRECISION (SLSODE-S, DLSODE-D) C***KEYWORDS ORDINARY DIFFERENTIAL EQUATIONS, INITIAL VALUE PROBLEM, C STIFF, NONSTIFF C***AUTHOR Hindmarsh, Alan C., (LLNL) C Center for Applied Scientific Computing, L-561 C Lawrence Livermore National Laboratory C Livermore, CA 94551. C Root function added by Karline Soetaert C***DESCRIPTION - see DLSODE and DLSODAR C Note: length of RWORK array = 20 + NYH*(MAXORD + 1) + 3*NEQ + LWM + 3*NG. C C----------------------------------------------------------------------- C Declare externals. EXTERNAL DPREPJ, DSOLSY DOUBLE PRECISION DUMACH, DVNORM C C Declare all other variables. INTEGER INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, IOWNS, 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU C KS: added next line INTEGER LG0, LG1, LGX, IOWNR3, IRFND, ITASKC, NGC, NGE INTEGER I, I1, I2, IFLAG, IMXER, KGO, LF0, 1 LENIW, LENRW, LENWM, ML, MORD, MU, MXHNL0, MXSTP0 INTEGER IRFP, IRT, LENYH, LYHNEW DOUBLE PRECISION ROWNS, 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND DOUBLE PRECISION ROWNR3, T0, TLAST, TOUTC DOUBLE PRECISION ATOLI, AYI, BIG, EWTI, H0, HMAX, HMX, RH, RTOLI, 1 TCRIT, TDIST, TNEXT, TOL, TOLSF, TP, SIZE, SUM, W0 DIMENSION MORD(2) LOGICAL IHIT CHARACTER(LEN=80) MSG SAVE MORD, MXSTP0, MXHNL0 C----------------------------------------------------------------------- C The following internal Common block contains C (a) variables which are local to any subroutine but whose values must C be preserved between calls to the routine ("own" variables), and C (b) variables which are communicated between subroutines. C The block DLS001 is declared in subroutines DLSODER, DINTDY, DSTODE, C DPREPJ, and DSOLSY. C The block DLSR01 is declared in subroutines DLSODAR, DRCHEK, DROOTS. C Groups of variables are replaced by dummy arrays in the Common C declarations in routines where those variables are not used. C----------------------------------------------------------------------- COMMON /DLS001/ ROWNS(209), 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 2 INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, IOWNS(6), 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU C karline: added next common block COMMON /DLSR01/ ROWNR3(2), T0, TLAST, TOUTC, 1 LG0, LG1, LGX, IOWNR3(2), IRFND, ITASKC, NGC, NGE C DATA MORD(1),MORD(2)/12,5/, MXSTP0/500/, MXHNL0/10/ C----------------------------------------------------------------------- C Block A. C This code block is executed on every call. C It tests ISTATE and ITASK for legality and branches appropriately. C If ISTATE .GT. 1 but the flag INIT shows that initialization has C not yet been done, an error return occurs. C If ISTATE = 1 and TOUT = T, return immediately. C----------------------------------------------------------------------- C C***FIRST EXECUTABLE STATEMENT DLSODER IF (ISTATE .LT. 1 .OR. ISTATE .GT. 3) GO TO 601 IF (ITASK .LT. 1 .OR. ITASK .GT. 5) GO TO 602 C Karline: added nest sentence ITASKC = ITASK IF (ISTATE .EQ. 1) GO TO 10 IF (INIT .EQ. 0) GO TO 603 IF (ISTATE .EQ. 2) GO TO 200 GO TO 20 10 INIT = 0 IF (TOUT .EQ. T) RETURN C----------------------------------------------------------------------- C Block B. C The next code block is executed for the initial call (ISTATE = 1), C or for a continuation call with parameter changes (ISTATE = 3). C It contains checking of all inputs and various initializations. C C First check legality of the non-optional inputs NEQ, ITOL, IOPT, C MF, ML, MU, and NG.. C----------------------------------------------------------------------- 20 IF (NEQ(1) .LE. 0) GO TO 604 IF (ISTATE .EQ. 1) GO TO 25 IF (NEQ(1) .GT. N) GO TO 605 25 N = NEQ(1) IF (ITOL .LT. 1 .OR. ITOL .GT. 4) GO TO 606 IF (IOPT .LT. 0 .OR. IOPT .GT. 1) GO TO 607 METH = MF/10 MITER = MF - 10*METH IF (METH .LT. 1 .OR. METH .GT. 2) GO TO 608 IF (MITER .LT. 0 .OR. MITER .GT. 5) GO TO 608 IF (MITER .LE. 3) GO TO 30 ML = IWORK(1) MU = IWORK(2) IF (ML .LT. 0 .OR. ML .GE. N) GO TO 609 IF (MU .LT. 0 .OR. MU .GE. N) GO TO 610 30 CONTINUE C karline: added next four lines IF (NG .LT. 0) GO TO 630 IF (ISTATE .EQ. 1) GO TO 35 IF (IRFND .EQ. 0 .AND. NG .NE. NGC) GO TO 631 35 NGC = NG C Next process and check the optional inputs. -------------------------- IF (IOPT .EQ. 1) GO TO 40 MAXORD = MORD(METH) MXSTEP = MXSTP0 MXHNIL = MXHNL0 IF (ISTATE .EQ. 1) H0 = 0.0D0 HMXI = 0.0D0 HMIN = 0.0D0 GO TO 60 40 MAXORD = IWORK(5) IF (MAXORD .LT. 0) GO TO 611 IF (MAXORD .EQ. 0) MAXORD = 100 MAXORD = MIN(MAXORD,MORD(METH)) MXSTEP = IWORK(6) IF (MXSTEP .LT. 0) GO TO 612 IF (MXSTEP .EQ. 0) MXSTEP = MXSTP0 MXHNIL = IWORK(7) IF (MXHNIL .LT. 0) GO TO 613 IF (MXHNIL .EQ. 0) MXHNIL = MXHNL0 IF (ISTATE .NE. 1) GO TO 50 H0 = RWORK(5) IF ((TOUT - T)*H0 .LT. 0.0D0) GO TO 614 50 HMAX = RWORK(6) IF (HMAX .LT. 0.0D0) GO TO 615 HMXI = 0.0D0 IF (HMAX .GT. 0.0D0) HMXI = 1.0D0/HMAX HMIN = RWORK(7) IF (HMIN .LT. 0.0D0) GO TO 616 C----------------------------------------------------------------------- C Set work array pointers and check lengths LRW and LIW. C Pointers to segments of RWORK and IWORK are named by prefixing L to C the name of the segment. E.g., the segment YH starts at RWORK(LYH). C Segments of RWORK (in order) are denoted G0, G1, GX, YH, WM, C EWT, SAVF, ACOR. C----------------------------------------------------------------------- CKS: init changes 60 LYH = 21 60 IF (ISTATE .EQ. 1) NYH = N LG0 = 21 LG1 = LG0 + NG LGX = LG1 + NG LYHNEW = LGX + NG IF (ISTATE .EQ. 1) LYH = LYHNEW IF (LYHNEW .EQ. LYH) GO TO 62 C If ISTATE = 3 and NG was changed, shift YH to its new location. ------ LENYH = L*NYH IF (LRW .LT. LYHNEW-1+LENYH) GO TO 62 I1 = 1 IF (LYHNEW .GT. LYH) I1 = -1 CALL DCOPY (LENYH, RWORK(LYH), I1, RWORK(LYHNEW), I1) LYH = LYHNEW 62 CONTINUE CKS end of changes LWM = LYH + (MAXORD + 1)*NYH IF (MITER .EQ. 0) LENWM = 0 IF (MITER .EQ. 1 .OR. MITER .EQ. 2) LENWM = N*N + 2 IF (MITER .EQ. 3) LENWM = N + 2 IF (MITER .GE. 4) LENWM = (2*ML + MU + 1)*N + 2 LEWT = LWM + LENWM LSAVF = LEWT + N LACOR = LSAVF + N LENRW = LACOR + N - 1 IWORK(17) = LENRW LIWM = 1 LENIW = 20 + N IF (MITER .EQ. 0 .OR. MITER .EQ. 3) LENIW = 20 IWORK(18) = LENIW IF (LENRW .GT. LRW) GO TO 617 IF (LENIW .GT. LIW) GO TO 618 C Check RTOL and ATOL for legality. ------------------------------------ RTOLI = RTOL(1) ATOLI = ATOL(1) DO 70 I = 1,N IF (ITOL .GE. 3) RTOLI = RTOL(I) IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) IF (RTOLI .LT. 0.0D0) GO TO 619 IF (ATOLI .LT. 0.0D0) GO TO 620 70 CONTINUE IF (ISTATE .EQ. 1) GO TO 100 C If ISTATE = 3, set flag to signal parameter changes to DSTODE. ------- JSTART = -1 IF (NQ .LE. MAXORD) GO TO 90 C MAXORD was reduced below NQ. Copy YH(*,MAXORD+2) into SAVF. --------- DO 80 I = 1,N RWORK(I+LSAVF-1) = RWORK(I+LWM-1) 80 CONTINUE C Reload WM(1) = RWORK(LWM), since LWM may have changed. --------------- 90 IF (MITER .GT. 0) RWORK(LWM) = SQRT(UROUND) IF (N .EQ. NYH) GO TO 200 C NEQ was reduced. Zero part of YH to avoid undefined references. ----- I1 = LYH + L*NYH I2 = LYH + (MAXORD + 1)*NYH - 1 IF (I1 .GT. I2) GO TO 200 DO 95 I = I1,I2 RWORK(I) = 0.0D0 95 CONTINUE GO TO 200 C----------------------------------------------------------------------- C Block C. C The next block is for the initial call only (ISTATE = 1). C It contains all remaining initializations, the initial call to F, C and the calculation of the initial step size. C The error weights in EWT are inverted after being loaded. C----------------------------------------------------------------------- 100 UROUND = DUMACH() TN = T IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 110 TCRIT = RWORK(1) IF ((TCRIT - TOUT)*(TOUT - T) .LT. 0.0D0) GO TO 625 IF (H0 .NE. 0.0D0 .AND. (T + H0 - TCRIT)*H0 .GT. 0.0D0) 1 H0 = TCRIT - T 110 JSTART = 0 IF (MITER .GT. 0) RWORK(LWM) = SQRT(UROUND) NHNIL = 0 NST = 0 NJE = 0 NSLAST = 0 HU = 0.0D0 NQU = 0 CCMAX = 0.3D0 MAXCOR = 3 MSBP = 20 MXNCF = 10 C Initial call to F. (LF0 points to YH(*,2).) ------------------------- LF0 = LYH + NYH CALL F (NEQ, T, Y, RWORK(LF0), rpar, ipar) NFE = 1 C Load the initial value vector in YH. --------------------------------- DO 115 I = 1,N RWORK(I+LYH-1) = Y(I) 115 CONTINUE C Load and invert the EWT array. (H is temporarily set to 1.0.) ------- NQ = 1 H = 1.0D0 CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) DO 120 I = 1,N IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 621 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 120 CONTINUE C----------------------------------------------------------------------- C The coding below computes the step size, H0, to be attempted on the C first step, unless the user has supplied a value for this. C First check that TOUT - T differs significantly from zero. C A scalar tolerance quantity TOL is computed, as MAX(RTOL(I)) C if this is positive, or MAX(ATOL(I)/ABS(Y(I))) otherwise, adjusted C so as to be between 100*UROUND and 1.0E-3. C Then the computed value H0 is given by.. C NEQ C H0**2 = TOL / ( w0**-2 + (1/NEQ) * SUM ( f(i)/ywt(i) )**2 ) C 1 C where w0 = MAX ( ABS(T), ABS(TOUT) ), C f(i) = i-th component of initial value of f, C ywt(i) = EWT(i)/TOL (a weight for y(i)). C The sign of H0 is inferred from the initial values of TOUT and T. C----------------------------------------------------------------------- IF (H0 .NE. 0.0D0) GO TO 180 TDIST = ABS(TOUT - T) W0 = MAX(ABS(T),ABS(TOUT)) IF (TDIST .LT. 2.0D0*UROUND*W0) GO TO 622 TOL = RTOL(1) IF (ITOL .LE. 2) GO TO 140 DO 130 I = 1,N TOL = MAX(TOL,RTOL(I)) 130 CONTINUE 140 IF (TOL .GT. 0.0D0) GO TO 160 ATOLI = ATOL(1) DO 150 I = 1,N IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) AYI = ABS(Y(I)) IF (AYI .NE. 0.0D0) TOL = MAX(TOL,ATOLI/AYI) 150 CONTINUE 160 TOL = MAX(TOL,100.0D0*UROUND) TOL = MIN(TOL,0.001D0) SUM = DVNORM (N, RWORK(LF0), RWORK(LEWT)) SUM = 1.0D0/(TOL*W0*W0) + TOL*SUM**2 H0 = 1.0D0/SQRT(SUM) H0 = MIN(H0,TDIST) H0 = SIGN(H0,TOUT-T) C Adjust H0 if necessary to meet HMAX bound. --------------------------- 180 RH = ABS(H0)*HMXI IF (RH .GT. 1.0D0) H0 = H0/RH C Load H with H0 and scale YH(*,2) by H0. ------------------------------ H = H0 DO 190 I = 1,N RWORK(I+LF0-1) = H0*RWORK(I+LF0-1) 190 CONTINUE CKS: start changes GO TO 270 C C Check for a zero of g at T. ------------------------------------------ IRFND = 0 TOUTC = TOUT IF (NGC .EQ. 0) GO TO 270 CALL DRCHEK (1, G, NEQ, Y, RWORK(LYH), NYH, 1 RWORK(LG0), RWORK(LG1), RWORK(LGX), JROOT, IRT, rpar, ipar) IF (IRT .EQ. 0) GO TO 270 GO TO 632 CKS: end changes C----------------------------------------------------------------------- C Block D. C The next code block is for continuation calls only (ISTATE = 2 or 3) C and is to check stop conditions before taking a step. C First, DRCHEK is called to check for a root within the last step C taken, other than the last root found there, if any. C If ITASK = 2 or 5, and y(TN) has not yet been returned to the user C because of an intervening root, return through Block G. C----------------------------------------------------------------------- 200 NSLAST = NST C karline: added from here IRFP = IRFND IF (NGC .EQ. 0) GO TO 205 IF (ITASK .EQ. 1 .OR. ITASK .EQ. 4) TOUTC = TOUT CALL DRCHEK (2, G, NEQ, Y, RWORK(LYH), NYH, 1 RWORK(LG0), RWORK(LG1), RWORK(LGX), JROOT, IRT, rpar, ipar) IF (IRT .NE. 1) GO TO 205 IRFND = 1 ISTATE = 3 T = T0 GO TO 425 205 CONTINUE IRFND = 0 IF (IRFP .EQ. 1 .AND. TLAST .NE. TN .AND. ITASK .EQ. 2) GO TO 400 C karline: till here IF (ITASK .EQ. 1) THEN GOTO 210 ELSE IF (ITASK .EQ. 2) THEN GOTO 250 ELSE IF (ITASK .EQ. 3) THEN GOTO 220 ELSE IF (ITASK .EQ. 4) THEN GOTO 230 ELSE IF (ITASK .EQ. 5) THEN GOTO 240 ENDIF C GO TO (210, 250, 220, 230, 240), ITASK 210 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) IF (IFLAG .NE. 0) GO TO 627 T = TOUT GO TO 420 220 TP = TN - HU*(1.0D0 + 100.0D0*UROUND) IF ((TP - TOUT)*H .GT. 0.0D0) GO TO 623 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 GO TO 400 230 TCRIT = RWORK(1) IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 IF ((TCRIT - TOUT)*H .LT. 0.0D0) GO TO 625 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 245 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) IF (IFLAG .NE. 0) GO TO 627 T = TOUT GO TO 420 240 TCRIT = RWORK(1) IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 245 HMX = ABS(TN) + ABS(H) IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX C this in lsoda, not in lsode... IF (IHIT) T = TCRIT + karline added next line IF (IRFP .EQ. 1 .AND. TLAST .NE. TN .AND. ITASK .EQ. 5) GO TO 400 IF (IHIT) GO TO 400 TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) IF (ISTATE .EQ. 2) JSTART = -2 C----------------------------------------------------------------------- C Block E. C The next block is normally executed for all calls and contains C the call to the one-step core integrator DSTODE. C C This is a looping point for the integration steps. C C First check for too many steps being taken, update EWT (if not at C start of problem), check for too much accuracy being requested, and C check for H below the roundoff level in T. C----------------------------------------------------------------------- 250 CONTINUE IF ((NST-NSLAST) .GE. MXSTEP) GO TO 500 CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) DO 260 I = 1,N IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 510 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 260 CONTINUE 270 TOLSF = UROUND*DVNORM (N, RWORK(LYH), RWORK(LEWT)) IF (TOLSF .LE. 1.0D0) GO TO 280 TOLSF = TOLSF*2.0D0 IF (NST .EQ. 0) GO TO 626 GO TO 520 280 IF ((TN + H) .NE. TN) GO TO 290 NHNIL = NHNIL + 1 IF (NHNIL .GT. MXHNIL) GO TO 290 MSG = 'DLSODER- Warning..internal T (=R1) and H (=R2) are' CALL XERRWD (MSG, 50, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' such that in the machine, T + H = T on the next step ' CALL XERRWD (MSG, 60, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' (H = step size). Solver will continue anyway' CALL XERRWD (MSG, 50, 101, 0, 0, 0, 0, 2, TN, H) IF (NHNIL .LT. MXHNIL) GO TO 290 MSG = 'DLSODER- Above warning has been issued I1 times. ' CALL XERRWD (MSG, 50, 102, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' It will not be issued again for this problem' CALL XERRWD (MSG, 50, 102, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0) 290 CONTINUE C----------------------------------------------------------------------- C CALL DSTODE(NEQ,Y,YH,NYH,YH,EWT,SAVF,ACOR,WM,IWM,F,JAC,DPREPJ,DSOLSY) C----------------------------------------------------------------------- CALL DSTODE (NEQ, Y, RWORK(LYH), NYH, RWORK(LYH), RWORK(LEWT), 1 RWORK(LSAVF), RWORK(LACOR), RWORK(LWM), IWORK(LIWM), 2 F, JAC, DPREPJ, DSOLSY, rpar,ipar) KGO = 1 - KFLAG IF (KGO .EQ. 1) THEN GOTO 300 ELSE IF (KGO .EQ. 2) THEN GOTO 530 ELSE IF (KGO .EQ. 3) THEN GOTO 540 ENDIF C GO TO (300, 530, 540), KGO C----------------------------------------------------------------------- C Block F. C The following block handles the case of a successful return from the C core integrator (KFLAG = 0). Test for stop conditions. C Then call DRCHEK to check for a root within the last step. C Then, if no root was found, check for stop conditions. C----------------------------------------------------------------------- 300 INIT = 1 Ckarline: changed this IF (NGC .EQ. 0) GO TO 315 CALL DRCHEK (3, G, NEQ, Y, RWORK(LYH), NYH, 1 RWORK(LG0), RWORK(LG1), RWORK(LGX), JROOT, IRT, rpar, ipar) IF (IRT .NE. 1) GO TO 315 IRFND = 1 ISTATE = 3 T = T0 GO TO 425 315 CONTINUE C karline: end of changes IF (ITASK .EQ. 1) THEN GOTO 320 ELSE IF (ITASK .EQ. 2) THEN GOTO 400 ELSE IF (ITASK .EQ. 3) THEN GOTO 330 ELSE IF (ITASK .EQ. 4) THEN GOTO 340 ELSE IF (ITASK .EQ. 5) THEN GOTO 350 ENDIF C GO TO (320, 400, 330, 340, 350), ITASK C ITASK = 1. If TOUT has been reached, interpolate. ------------------- 320 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) T = TOUT GO TO 420 C ITASK = 3. Jump to exit if TOUT was reached. ------------------------ 330 IF ((TN - TOUT)*H .GE. 0.0D0) GO TO 400 GO TO 250 C ITASK = 4. See if TOUT or TCRIT was reached. Adjust H if necessary. 340 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 345 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) T = TOUT GO TO 420 345 HMX = ABS(TN) + ABS(H) IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX IF (IHIT) GO TO 400 TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) JSTART = -2 GO TO 250 C ITASK = 5. See if TCRIT was reached and jump to exit. --------------- 350 HMX = ABS(TN) + ABS(H) IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX C----------------------------------------------------------------------- C Block G. C The following block handles all successful returns from DLSODER. C If ITASK .NE. 1, Y is loaded from YH and T is set accordingly. C ISTATE is set to 2, and the optional outputs are loaded into the C work arrays before returning. C----------------------------------------------------------------------- 400 DO 410 I = 1,N Y(I) = RWORK(I+LYH-1) 410 CONTINUE T = TN IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 420 IF (IHIT) T = TCRIT 420 ISTATE = 2 425 CONTINUE RWORK(11) = HU RWORK(12) = H RWORK(13) = TN IWORK(11) = NST IWORK(12) = NFE IWORK(13) = NJE IWORK(14) = NQU IWORK(15) = NQ C karline: added next two lines IWORK(10) = NGE TLAST = T RETURN C----------------------------------------------------------------------- C Block H. C The following block handles all unsuccessful returns other than C those for illegal input. First the error message routine is called. C If there was an error test or convergence test failure, IMXER is set. C Then Y is loaded from YH and T is set to TN. The optional outputs C are loaded into the work arrays before returning. C----------------------------------------------------------------------- C The maximum number of steps was taken before reaching TOUT. ---------- 500 MSG = 'DLSODER- At current T (=R1), MXSTEP (=I1) steps ' CALL XERRWD (MSG, 50, 201, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' taken on this call before reaching TOUT ' CALL XERRWD (MSG, 50, 201, 0, 1, MXSTEP, 0, 1, TN, 0.0D0) ISTATE = -1 GO TO 580 C EWT(I) .LE. 0.0 for some I (not at start of problem). ---------------- 510 EWTI = RWORK(LEWT+I-1) MSG = 'DLSODER- At T (=R1), EWT(I1) has become R2 .LE. 0.' CALL XERRWD (MSG, 50, 202, 0, 1, I, 0, 2, TN, EWTI) ISTATE = -6 GO TO 580 C Too much accuracy requested for machine precision. ------------------- 520 MSG = 'DLSODER- At T (=R1), too much accuracy requested ' CALL XERRWD (MSG, 50, 203, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' for precision of machine.. see TOLSF (=R2) ' CALL XERRWD (MSG, 50, 203, 0, 0, 0, 0, 2, TN, TOLSF) RWORK(14) = TOLSF ISTATE = -2 GO TO 580 C KFLAG = -1. Error test failed repeatedly or with ABS(H) = HMIN. ----- 530 MSG = 'DLSODER- At T(=R1) and step size H(=R2), the error' CALL XERRWD (MSG, 50, 204, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' test failed repeatedly or with ABS(H) = HMIN' CALL XERRWD (MSG, 50, 204, 0, 0, 0, 0, 2, TN, H) ISTATE = -4 GO TO 560 C KFLAG = -2. Convergence failed repeatedly or with ABS(H) = HMIN. ---- 540 MSG = 'DLSODER- At T (=R1) and step size H (=R2), the ' CALL XERRWD (MSG, 50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' corrector convergence failed repeatedly ' CALL XERRWD (MSG, 50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' or with ABS(H) = HMIN ' CALL XERRWD (MSG, 30, 205, 0, 0, 0, 0, 2, TN, H) ISTATE = -5 C Compute IMXER if relevant. ------------------------------------------- 560 BIG = 0.0D0 IMXER = 1 DO 570 I = 1,N SIZE = ABS(RWORK(I+LACOR-1)*RWORK(I+LEWT-1)) IF (BIG .GE. SIZE) GO TO 570 BIG = SIZE IMXER = I 570 CONTINUE IWORK(16) = IMXER C Set Y vector, T, and optional outputs. ------------------------------- 580 DO 590 I = 1,N Y(I) = RWORK(I+LYH-1) 590 CONTINUE T = TN RWORK(11) = HU RWORK(12) = H RWORK(13) = TN IWORK(11) = NST IWORK(12) = NFE IWORK(13) = NJE IWORK(14) = NQU IWORK(15) = NQ C Karline: added next two lines IWORK(10) = NGE TLAST = T RETURN C----------------------------------------------------------------------- C Block I. C The following block handles all error returns due to illegal input C (ISTATE = -3), as detected before calling the core integrator. C First the error message routine is called. If the illegal input C is a negative ISTATE, the run is aborted (apparent infinite loop). C----------------------------------------------------------------------- 601 MSG = 'DLSODER- ISTATE (=I1) illegal ' CALL XERRWD (MSG, 30, 1, 0, 1, ISTATE, 0, 0, 0.0D0, 0.0D0) IF (ISTATE .LT. 0) GO TO 800 GO TO 700 602 MSG = 'DLSODER- ITASK (=I1) illegal ' CALL XERRWD (MSG, 30, 2, 0, 1, ITASK, 0, 0, 0.0D0, 0.0D0) GO TO 700 603 MSG = 'DLSODER- ISTATE .GT. 1 but DLSODER not initialized ' CALL XERRWD (MSG, 50, 3, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) GO TO 700 604 MSG = 'DLSODER- NEQ (=I1) .LT. 1 ' CALL XERRWD (MSG, 30, 4, 0, 1, NEQ(1), 0, 0, 0.0D0, 0.0D0) GO TO 700 605 MSG = 'DLSODER- ISTATE = 3 and NEQ increased (I1 to I2) ' CALL XERRWD (MSG, 50, 5, 0, 2, N, NEQ(1), 0, 0.0D0, 0.0D0) GO TO 700 606 MSG = 'DLSODER- ITOL (=I1) illegal ' CALL XERRWD (MSG, 30, 6, 0, 1, ITOL, 0, 0, 0.0D0, 0.0D0) GO TO 700 607 MSG = 'DLSODER- IOPT (=I1) illegal ' CALL XERRWD (MSG, 30, 7, 0, 1, IOPT, 0, 0, 0.0D0, 0.0D0) GO TO 700 608 MSG = 'DLSODER- MF (=I1) illegal ' CALL XERRWD (MSG, 30, 8, 0, 1, MF, 0, 0, 0.0D0, 0.0D0) GO TO 700 609 MSG = 'DLSODER- ML (=I1) illegal.. .LT.0 or .GE.NEQ (=I2)' CALL XERRWD (MSG, 50, 9, 0, 2, ML, NEQ(1), 0, 0.0D0, 0.0D0) GO TO 700 610 MSG = 'DLSODER- MU (=I1) illegal.. .LT.0 or .GE.NEQ (=I2)' CALL XERRWD (MSG, 50, 10, 0, 2, MU, NEQ(1), 0, 0.0D0, 0.0D0) GO TO 700 611 MSG = 'DLSODER- MAXORD (=I1) .LT. 0 ' CALL XERRWD (MSG, 30, 11, 0, 1, MAXORD, 0, 0, 0.0D0, 0.0D0) GO TO 700 612 MSG = 'DLSODER- MXSTEP (=I1) .LT. 0 ' CALL XERRWD (MSG, 30, 12, 0, 1, MXSTEP, 0, 0, 0.0D0, 0.0D0) GO TO 700 613 MSG = 'DLSODER- MXHNIL (=I1) .LT. 0 ' CALL XERRWD (MSG, 30, 13, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0) GO TO 700 614 MSG = 'DLSODER- TOUT (=R1) behind T (=R2) ' CALL XERRWD (MSG, 40, 14, 0, 0, 0, 0, 2, TOUT, T) MSG = ' Integration direction is given by H0 (=R1) ' CALL XERRWD (MSG, 50, 14, 0, 0, 0, 0, 1, H0, 0.0D0) GO TO 700 615 MSG = 'DLSODER- HMAX (=R1) .LT. 0.0 ' CALL XERRWD (MSG, 30, 15, 0, 0, 0, 0, 1, HMAX, 0.0D0) GO TO 700 616 MSG = 'DLSODER- HMIN (=R1) .LT. 0.0 ' CALL XERRWD (MSG, 30, 16, 0, 0, 0, 0, 1, HMIN, 0.0D0) GO TO 700 617 CONTINUE MSG='DLSODER- RWORK length needed, LENRW (=I1), exceeds LRW (=I2)' CALL XERRWD (MSG, 60, 17, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) GO TO 700 618 CONTINUE MSG='DLSODER- IWORK length needed, LENIW (=I1), exceeds LIW (=I2)' CALL XERRWD (MSG, 60, 18, 0, 2, LENIW, LIW, 0, 0.0D0, 0.0D0) GO TO 700 619 MSG = 'DLSODER- RTOL(I1) is R1 .LT. 0.0 ' CALL XERRWD (MSG, 40, 19, 0, 1, I, 0, 1, RTOLI, 0.0D0) GO TO 700 620 MSG = 'DLSODER- ATOL(I1) is R1 .LT. 0.0 ' CALL XERRWD (MSG, 40, 20, 0, 1, I, 0, 1, ATOLI, 0.0D0) GO TO 700 621 EWTI = RWORK(LEWT+I-1) MSG = 'DLSODER- EWT(I1) is R1 .LE. 0.0 ' CALL XERRWD (MSG, 40, 21, 0, 1, I, 0, 1, EWTI, 0.0D0) GO TO 700 622 CONTINUE MSG='DLSODER- TOUT (=R1) too close to T(=R2) to start integration' CALL XERRWD (MSG, 60, 22, 0, 0, 0, 0, 2, TOUT, T) GO TO 700 623 CONTINUE MSG='DLSODER- ITASK = I1 and TOUT (=R1) behind TCUR - HU (= R2) ' CALL XERRWD (MSG, 60, 23, 0, 1, ITASK, 0, 2, TOUT, TP) GO TO 700 624 CONTINUE MSG='DLSODER- ITASK = 4 OR 5 and TCRIT (=R1) behind TCUR (=R2) ' CALL XERRWD (MSG, 60, 24, 0, 0, 0, 0, 2, TCRIT, TN) GO TO 700 625 CONTINUE MSG='DLSODER- ITASK = 4 or 5 and TCRIT (=R1) behind TOUT (=R2) ' CALL XERRWD (MSG, 60, 25, 0, 0, 0, 0, 2, TCRIT, TOUT) GO TO 700 626 MSG = 'DLSODER- At start of problem, too much accuracy ' CALL XERRWD (MSG, 50, 26, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' requested for precision of machine.. See TOLSF (=R1) ' CALL XERRWD (MSG, 60, 26, 0, 0, 0, 0, 1, TOLSF, 0.0D0) RWORK(14) = TOLSF GO TO 700 627 MSG = 'DLSODER- Trouble in DINTDY. ITASK = I1, TOUT = R1' CALL XERRWD (MSG, 50, 27, 0, 1, ITASK, 0, 1, TOUT, 0.0D0) C Karline: added next error messages 630 MSG = 'DLSODER- NG (=I1) .lt. 0 ' CALL XERRWD (MSG, 30, 30, 0, 1, NG, 0, 0, 0.0D0, 0.0D0) GO TO 700 631 MSG = 'DLSODER- NG changed (from I1 to I2) illegally, ' CALL XERRWD (MSG, 50, 31, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' i.e. not immediately after a root was found.' CALL XERRWD (MSG, 50, 31, 0, 2, NGC, NG, 0, 0.0D0, 0.0D0) GO TO 700 632 MSG = 'DLSODER- One or more components of g has a root ' CALL XERRWD (MSG, 50, 32, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' too near to the initial point. ' CALL XERRWD (MSG, 40, 32, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) C C 700 ISTATE = -3 RETURN C 800 MSG = 'DLSODER- Run aborted.. apparent infinite loop ' CALL XERRWD (MSG, 50, 303, 2, 0, 0, 0, 0, 0.0D0, 0.0D0) RETURN C----------------------- END OF SUBROUTINE DLSODER ---------------------- END *DECK DLSODESR C DLSODESR was created by merging DLSODES with DLSODAR - Karline Soetaert SUBROUTINE DLSODESR (F, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, ITASK, 1 ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JAC, MF, 2 G, NG, JROOT, rpar, ipar) IMPLICIT NONE EXTERNAL F, JAC, G CKS: added rpar, ipar, and G INTEGER ipar(*) DOUBLE PRECISION rpar(*) INTEGER NEQ, ITOL, ITASK, ISTATE, IOPT, LRW, IWORK, LIW, MF INTEGER NG, JROOT DOUBLE PRECISION Y, T, TOUT, RTOL, ATOL, RWORK DIMENSION NEQ(*), Y(*), RTOL(*), ATOL(*), RWORK(LRW), IWORK(LIW), & JROOT(NG) C----------------------------------------------------------------------- C DLSODES solves the initial value problem for stiff or nonstiff C systems of first order ODEs, C dy/dt = f(t,y) , or, in component form, C dy(i)/dt = f(i) = f(i,t,y(1),y(2),...,y(NEQ)) (i = 1,...,NEQ). C DLSODES is a variant of the DLSODE package, and is intended for C problems in which the Jacobian matrix df/dy has an arbitrary C sparse structure (when the problem is stiff). C C Authors: Alan C. Hindmarsh C Center for Applied Scientific Computing, L-561 C Lawrence Livermore National Laboratory C Livermore, CA 94551 C and C Andrew H. Sherman C J. S. Nolen and Associates C Houston, TX 77084 C C Root function added by Karline Soetaert C C***DESCRIPTION - see DLSODES C Note: length of RWORK array = 20 + NYH*(MAXORD + 1) + 3*NEQ + LWM + 3*NG. C----------------------------------------------------------------------- EXTERNAL DPRJS, DSOLSS DOUBLE PRECISION DUMACH, DVNORM INTEGER INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, IOWNS, 1 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 2 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 3 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU INTEGER IPLOST, IESP, ISTATC, IYS, IBA, IBIAN, IBJAN, IBJGP, 1 IPIAN, IPJAN, IPJGP, IPIGP, IPR, IPC, IPIC, IPISP, IPRSP, IPA, 2 LENYH, LENYHM, LENWK, LREQ, LRAT, LREST, LWMIN, MOSS, MSBJ, 3 NSLJ, NGP, NLU, NNZ, NSP, NZL, NZU C KS: added next lines INTEGER LG0, LG1, LGX, IOWNR3, IRFND, ITASKC, NGC, NGE INTEGER IRFP, IRT, LYHNEW DOUBLE PRECISION ROWNR3, T0, TLAST, TOUTC INTEGER I, I1, I2, IFLAG, IMAX, IMUL, IMXER, IPFLAG, IPGO, IREM, 1 J, KGO, LENRAT, LENYHT, LENIW, LENRW, LF0, LIA, LJA, 2 LRTEM, LWTEM, LYHD, LYHN, MF1, MORD, MXHNL0, MXSTP0, NCOLM DOUBLE PRECISION ROWNS, 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND DOUBLE PRECISION CON0, CONMIN, CCMXJ, PSMALL, RBIG, SETH DOUBLE PRECISION ATOLI, AYI, BIG, EWTI, H0, HMAX, HMX, RH, RTOLI, 1 TCRIT, TDIST, TNEXT, TOL, TOLSF, TP, SIZE, SUM, W0 DIMENSION MORD(2) LOGICAL IHIT CHARACTER(LEN=60) MSG SAVE LENRAT, MORD, MXSTP0, MXHNL0 C----------------------------------------------------------------------- C The following two internal Common blocks contain C (a) variables which are local to any subroutine but whose values must C be preserved between calls to the routine ("own" variables), and C (b) variables which are communicated between subroutines. C The block DLS001 is declared in subroutines DLSODES, DIPREP, DPREP, C DINTDY, DSTODE, DPRJS, and DSOLSS. C The block DLSS01 is declared in subroutines DLSODES, DIPREP, DPREP, C DPRJS, and DSOLSS. C Groups of variables are replaced by dummy arrays in the Common C declarations in routines where those variables are not used. C----------------------------------------------------------------------- COMMON /DLS001/ ROWNS(209), 1 CCMAX, EL0, H, HMIN, HMXI, HU, RC, TN, UROUND, 2 INIT, MXSTEP, MXHNIL, NHNIL, NSLAST, NYH, IOWNS(6), 3 ICF, IERPJ, IERSL, JCUR, JSTART, KFLAG, L, 4 LYH, LEWT, LACOR, LSAVF, LWM, LIWM, METH, MITER, 5 MAXORD, MAXCOR, MSBP, MXNCF, N, NQ, NST, NFE, NJE, NQU C COMMON /DLSS01/ CON0, CONMIN, CCMXJ, PSMALL, RBIG, SETH, 1 IPLOST, IESP, ISTATC, IYS, IBA, IBIAN, IBJAN, IBJGP, 2 IPIAN, IPJAN, IPJGP, IPIGP, IPR, IPC, IPIC, IPISP, IPRSP, IPA, 3 LENYH, LENYHM, LENWK, LREQ, LRAT, LREST, LWMIN, MOSS, MSBJ, 4 NSLJ, NGP, NLU, NNZ, NSP, NZL, NZU C karline: COMMON /DLSR01/ ROWNR3(2), T0, TLAST, TOUTC, 1 LG0, LG1, LGX, IOWNR3(2), IRFND, ITASKC, NGC, NGE C DATA MORD(1),MORD(2)/12,5/, MXSTP0/500/, MXHNL0/10/ C----------------------------------------------------------------------- C In the Data statement below, set LENRAT equal to the ratio of C the wordlength for a real number to that for an integer. Usually, C LENRAT = 1 for single precision and 2 for double precision. If the C true ratio is not an integer, use the next smaller integer (.ge. 1). C----------------------------------------------------------------------- DATA LENRAT/2/ C----------------------------------------------------------------------- C Block A. C This code block is executed on every call. C It tests ISTATE and ITASK for legality and branches appropriately. C If ISTATE .gt. 1 but the flag INIT shows that initialization has C not yet been done, an error return occurs. C If ISTATE = 1 and TOUT = T, return immediately. C----------------------------------------------------------------------- IF (ISTATE .LT. 1 .OR. ISTATE .GT. 3) GO TO 601 IF (ITASK .LT. 1 .OR. ITASK .GT. 5) GO TO 602 C Karline: added nest sentence ITASKC = ITASK IF (ISTATE .EQ. 1) GO TO 10 IF (INIT .EQ. 0) GO TO 603 IF (ISTATE .EQ. 2) GO TO 200 GO TO 20 10 INIT = 0 IF (TOUT .EQ. T) RETURN C----------------------------------------------------------------------- C Block B. C The next code block is executed for the initial call (ISTATE = 1), C or for a continuation call with parameter changes (ISTATE = 3). C It contains checking of all inputs and various initializations. C If ISTATE = 1, the final setting of work space pointers, the matrix C preprocessing, and other initializations are done in Block C. C C First check legality of the non-optional inputs NEQ, ITOL, IOPT, C MF, ML, MU, and NG. C----------------------------------------------------------------------- 20 IF (NEQ(1) .LE. 0) GO TO 604 IF (ISTATE .EQ. 1) GO TO 25 IF (NEQ(1) .GT. N) GO TO 605 25 N = NEQ(1) IF (ITOL .LT. 1 .OR. ITOL .GT. 4) GO TO 606 IF (IOPT .LT. 0 .OR. IOPT .GT. 1) GO TO 607 MOSS = MF/100 MF1 = MF - 100*MOSS METH = MF1/10 MITER = MF1 - 10*METH IF (MOSS .LT. 0 .OR. MOSS .GT. 2) GO TO 608 IF (METH .LT. 1 .OR. METH .GT. 2) GO TO 608 IF (MITER .LT. 0 .OR. MITER .GT. 3) GO TO 608 IF (MITER .EQ. 0 .OR. MITER .EQ. 3) MOSS = 0 C Karline: start add IF (NG .LT. 0) GO TO 680 IF (ISTATE .EQ. 1) GO TO 35 IF (IRFND .EQ. 0 .AND. NG .NE. NGC) GO TO 681 35 NGC = NG C Karline: end added C Next process and check the optional inputs. -------------------------- IF (IOPT .EQ. 1) GO TO 40 MAXORD = MORD(METH) MXSTEP = MXSTP0 MXHNIL = MXHNL0 IF (ISTATE .EQ. 1) H0 = 0.0D0 HMXI = 0.0D0 HMIN = 0.0D0 SETH = 0.0D0 GO TO 60 40 MAXORD = IWORK(5) IF (MAXORD .LT. 0) GO TO 611 IF (MAXORD .EQ. 0) MAXORD = 100 MAXORD = MIN(MAXORD,MORD(METH)) MXSTEP = IWORK(6) IF (MXSTEP .LT. 0) GO TO 612 IF (MXSTEP .EQ. 0) MXSTEP = MXSTP0 MXHNIL = IWORK(7) IF (MXHNIL .LT. 0) GO TO 613 IF (MXHNIL .EQ. 0) MXHNIL = MXHNL0 IF (ISTATE .NE. 1) GO TO 50 H0 = RWORK(5) IF ((TOUT - T)*H0 .LT. 0.0D0) GO TO 614 50 HMAX = RWORK(6) IF (HMAX .LT. 0.0D0) GO TO 615 HMXI = 0.0D0 IF (HMAX .GT. 0.0D0) HMXI = 1.0D0/HMAX HMIN = RWORK(7) IF (HMIN .LT. 0.0D0) GO TO 616 SETH = RWORK(8) IF (SETH .LT. 0.0D0) GO TO 609 C Check RTOL and ATOL for legality. ------------------------------------ 60 RTOLI = RTOL(1) ATOLI = ATOL(1) DO 65 I = 1,N IF (ITOL .GE. 3) RTOLI = RTOL(I) IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) IF (RTOLI .LT. 0.0D0) GO TO 619 IF (ATOLI .LT. 0.0D0) GO TO 620 65 CONTINUE C----------------------------------------------------------------------- C Compute required work array lengths, as far as possible, and test C these against LRW and LIW. Then set tentative pointers for work C arrays. Pointers to RWORK/IWORK segments are named by prefixing L to C the name of the segment. E.g., the segment YH starts at RWORK(LYH). C Segments of RWORK (in order) are denoted G0, G1, GX, WM, YH, SAVF, EWT, ACOR. C If MITER = 1 or 2, the required length of the matrix work space WM C is not yet known, and so a crude minimum value is used for the C initial tests of LRW and LIW, and YH is temporarily stored as far C to the right in RWORK as possible, to leave the maximum amount C of space for WM for matrix preprocessing. Thus if MITER = 1 or 2 C and MOSS .ne. 2, some of the segments of RWORK are temporarily C omitted, as they are not needed in the preprocessing. These C omitted segments are: ACOR if ISTATE = 1, EWT and ACOR if ISTATE = 3 C and MOSS = 1, and SAVF, EWT, and ACOR if ISTATE = 3 and MOSS = 0. C----------------------------------------------------------------------- LRAT = LENRAT IF (ISTATE .EQ. 1) NYH = N LWMIN = 0 IF (MITER .EQ. 1) LWMIN = 4*N + 10*N/LRAT IF (MITER .EQ. 2) LWMIN = 4*N + 11*N/LRAT IF (MITER .EQ. 3) LWMIN = N + 2 LENYH = (MAXORD+1)*NYH LREST = LENYH + 3*N LENRW = 20 + LWMIN + LREST IWORK(17) = LENRW LENIW = 30 IF (MOSS .EQ. 0 .AND. MITER .NE. 0 .AND. MITER .NE. 3) 1 LENIW = LENIW + N + 1 IWORK(18) = LENIW IF (LENRW .GT. LRW) GO TO 617 IF (LENIW .GT. LIW) GO TO 618 LIA = 31 IF (MOSS .EQ. 0 .AND. MITER .NE. 0 .AND. MITER .NE. 3) 1 LENIW = LENIW + IWORK(LIA+N) - 1 IWORK(18) = LENIW IF (LENIW .GT. LIW) GO TO 618 LJA = LIA + N + 1 LIA = MIN(LIA,LIW) LJA = MIN(LJA,LIW) C LWM = 21 C Karline: start changes IF (ISTATE .EQ. 1) NYH = N LG0 = 21 LG1 = LG0 + NG LGX = LG1 + NG LYHNEW = LGX + NG IF (ISTATE .EQ. 1) LYH = LYHNEW IF (LYHNEW .EQ. LYH) GO TO 67 C If ISTATE = 3 and NG was changed, shift YH to its new location. ------ LENYH = L*NYH IF (LRW .LT. LYHNEW-1+LENYH) GO TO 67 I1 = 1 IF (LYHNEW .GT. LYH) I1 = -1 CALL DCOPY (LENYH, RWORK(LYH), I1, RWORK(LYHNEW), I1) LYH = LYHNEW 67 CONTINUE CKS end of changes LWM = LYHNEW IF (ISTATE .EQ. 1) NQ = 1 NCOLM = MIN(NQ+1,MAXORD+2) LENYHM = NCOLM*NYH LENYHT = LENYH IF (MITER .EQ. 1 .OR. MITER .EQ. 2) LENYHT = LENYHM IMUL = 2 IF (ISTATE .EQ. 3) IMUL = MOSS IF (MOSS .EQ. 2) IMUL = 3 LRTEM = LENYHT + IMUL*N LWTEM = LWMIN C IF (MITER .EQ. 1 .OR. MITER .EQ. 2) LWTEM = LRW - 20 - LRTEM IF (MITER .EQ. 1 .OR. MITER .EQ. 2) LWTEM = LRW -(LWM-1)-LRTEM LENWK = LWTEM LYHN = LWM + LWTEM LSAVF = LYHN + LENYHT LEWT = LSAVF + N LACOR = LEWT + N ISTATC = ISTATE IF (ISTATE .EQ. 1) GO TO 100 C----------------------------------------------------------------------- C ISTATE = 3. Move YH to its new location. C Note that only the part of YH needed for the next step, namely C MIN(NQ+1,MAXORD+2) columns, is actually moved. C A temporary error weight array EWT is loaded if MOSS = 2. C Sparse matrix processing is done in DIPREP/DPREP if MITER = 1 or 2. C If MAXORD was reduced below NQ, then the pointers are finally set C so that SAVF is identical to YH(*,MAXORD+2). C----------------------------------------------------------------------- LYHD = LYH - LYHN IMAX = LYHN - 1 + LENYHM C Move YH. Move right if LYHD < 0; move left if LYHD > 0. ------------- IF (LYHD .LT. 0) THEN DO 72 I = LYHN,IMAX J = IMAX + LYHN - I RWORK(J) = RWORK(J+LYHD) 72 CONTINUE ENDIF IF (LYHD .GT. 0) THEN DO 76 I = LYHN,IMAX RWORK(I) = RWORK(I+LYHD) 76 CONTINUE ENDIF LYH = LYHN IWORK(22) = LYH IF (MITER .EQ. 0 .OR. MITER .EQ. 3) GO TO 92 IF (MOSS .NE. 2) GO TO 85 C Temporarily load EWT if MITER = 1 or 2 and MOSS = 2. ----------------- CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) DO 82 I = 1,N IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 621 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 82 CONTINUE 85 CONTINUE C DIPREP and DPREP do sparse matrix preprocessing if MITER = 1 or 2. --- LSAVF = MIN(LSAVF,LRW) LEWT = MIN(LEWT,LRW) LACOR = MIN(LACOR,LRW) CKS CALL DIPREP (NEQ, Y, RWORK, IWORK(LIA),IWORK(LJA), IPFLAG, F, JAC, & rpar, ipar ) LENRW = LWM - 1 + LENWK + LREST IWORK(17) = LENRW IF (IPFLAG .NE. -1) IWORK(23) = IPIAN IF (IPFLAG .NE. -1) IWORK(24) = IPJAN IPGO = -IPFLAG + 1 IF (IPGO .EQ. 1) THEN GOTO 90 ELSE IF (IPGO .EQ. 2) THEN GOTO 628 ELSE IF (IPGO .EQ. 3) THEN GOTO 629 ELSE IF (IPGO .EQ. 4) THEN GOTO 630 ELSE IF (IPGO .EQ. 5) THEN GOTO 631 ELSE IF (IPGO .EQ. 6) THEN GOTO 632 ELSE IF (IPGO .EQ. 7) THEN GOTO 633 ENDIF C GO TO (90, 628, 629, 630, 631, 632, 633), IPGO 90 IWORK(22) = LYH IF (LENRW .GT. LRW) GO TO 617 C Set flag to signal parameter changes to DSTODE. ---------------------- 92 JSTART = -1 IF (N .EQ. NYH) GO TO 200 C NEQ was reduced. Zero part of YH to avoid undefined references. ----- I1 = LYH + L*NYH I2 = LYH + (MAXORD + 1)*NYH - 1 IF (I1 .GT. I2) GO TO 200 DO 95 I = I1,I2 RWORK(I) = 0.0D0 95 CONTINUE GO TO 200 C----------------------------------------------------------------------- C Block C. C The next block is for the initial call only (ISTATE = 1). C It contains all remaining initializations, the initial call to F, C the sparse matrix preprocessing (MITER = 1 or 2), and the C calculation of the initial step size. C The error weights in EWT are inverted after being loaded. C----------------------------------------------------------------------- 100 CONTINUE LYH = LYHN IWORK(22) = LYH TN = T NST = 0 H = 1.0D0 NNZ = 0 NGP = 0 NZL = 0 NZU = 0 C Load the initial value vector in YH. --------------------------------- DO 105 I = 1,N RWORK(I+LYH-1) = Y(I) 105 CONTINUE C Initial call to F. (LF0 points to YH(*,2).) ------------------------- LF0 = LYH + NYH CALL F (NEQ, T, Y, RWORK(LF0), rpar, ipar) NFE = 1 C Load and invert the EWT array. (H is temporarily set to 1.0.) ------- CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) DO 110 I = 1,N IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 621 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 110 CONTINUE IF (MITER .EQ. 0 .OR. MITER .EQ. 3) GO TO 120 C DIPREP and DPREP do sparse matrix preprocessing if MITER = 1 or 2. --- LACOR = MIN(LACOR,LRW) CALL DIPREP (NEQ, Y, RWORK, IWORK(LIA),IWORK(LJA), IPFLAG, F, JAC, & rpar, ipar) LENRW = LWM - 1 + LENWK + LREST IWORK(17) = LENRW IF (IPFLAG .NE. -1) IWORK(23) = IPIAN IF (IPFLAG .NE. -1) IWORK(24) = IPJAN IPGO = -IPFLAG + 1 IF (IPGO .EQ. 1) THEN GOTO 115 ELSE IF (IPGO .EQ. 2) THEN GOTO 628 ELSE IF (IPGO .EQ. 3) THEN GOTO 629 ELSE IF (IPGO .EQ. 4) THEN GOTO 630 ELSE IF (IPGO .EQ. 5) THEN GOTO 631 ELSE IF (IPGO .EQ. 6) THEN GOTO 632 ELSE IF (IPGO .EQ. 7) THEN GOTO 633 ENDIF C GO TO (115, 628, 629, 630, 631, 632, 633), IPGO 115 IWORK(22) = LYH IF (LENRW .GT. LRW) GO TO 617 C Check TCRIT for legality (ITASK = 4 or 5). --------------------------- 120 CONTINUE IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 125 TCRIT = RWORK(1) IF ((TCRIT - TOUT)*(TOUT - T) .LT. 0.0D0) GO TO 625 IF (H0 .NE. 0.0D0 .AND. (T + H0 - TCRIT)*H0 .GT. 0.0D0) 1 H0 = TCRIT - T C Initialize all remaining parameters. --------------------------------- 125 UROUND = DUMACH() JSTART = 0 IF (MITER .NE. 0) RWORK(LWM) = SQRT(UROUND) MSBJ = 50 NSLJ = 0 CCMXJ = 0.2D0 PSMALL = 1000.0D0*UROUND RBIG = 0.01D0/PSMALL NHNIL = 0 NJE = 0 NLU = 0 NSLAST = 0 HU = 0.0D0 NQU = 0 CCMAX = 0.3D0 MAXCOR = 3 MSBP = 20 MXNCF = 10 C----------------------------------------------------------------------- C The coding below computes the step size, H0, to be attempted on the C first step, unless the user has supplied a value for this. C First check that TOUT - T differs significantly from zero. C A scalar tolerance quantity TOL is computed, as MAX(RTOL(i)) C if this is positive, or MAX(ATOL(i)/ABS(Y(i))) otherwise, adjusted C so as to be between 100*UROUND and 1.0E-3. C Then the computed value H0 is given by.. C NEQ C H0**2 = TOL / ( w0**-2 + (1/NEQ) * Sum ( f(i)/ywt(i) )**2 ) C 1 C where w0 = MAX ( ABS(T), ABS(TOUT) ), C f(i) = i-th component of initial value of f, C ywt(i) = EWT(i)/TOL (a weight for y(i)). C The sign of H0 is inferred from the initial values of TOUT and T. C ABS(H0) is made .le. ABS(TOUT-T) in any case. C----------------------------------------------------------------------- LF0 = LYH + NYH IF (H0 .NE. 0.0D0) GO TO 180 TDIST = ABS(TOUT - T) W0 = MAX(ABS(T),ABS(TOUT)) IF (TDIST .LT. 2.0D0*UROUND*W0) GO TO 622 TOL = RTOL(1) IF (ITOL .LE. 2) GO TO 140 DO 130 I = 1,N TOL = MAX(TOL,RTOL(I)) 130 CONTINUE 140 IF (TOL .GT. 0.0D0) GO TO 160 ATOLI = ATOL(1) DO 150 I = 1,N IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) AYI = ABS(Y(I)) IF (AYI .NE. 0.0D0) TOL = MAX(TOL,ATOLI/AYI) 150 CONTINUE 160 TOL = MAX(TOL,100.0D0*UROUND) TOL = MIN(TOL,0.001D0) SUM = DVNORM (N, RWORK(LF0), RWORK(LEWT)) SUM = 1.0D0/(TOL*W0*W0) + TOL*SUM**2 H0 = 1.0D0/SQRT(SUM) H0 = MIN(H0,TDIST) H0 = SIGN(H0,TOUT-T) C Adjust H0 if necessary to meet HMAX bound. --------------------------- 180 RH = ABS(H0)*HMXI IF (RH .GT. 1.0D0) H0 = H0/RH C Load H with H0 and scale YH(*,2) by H0. ------------------------------ H = H0 DO 190 I = 1,N RWORK(I+LF0-1) = H0*RWORK(I+LF0-1) 190 CONTINUE CKS: start changes GO TO 270 C C Check for a zero of g at T. ------------------------------------------ IRFND = 0 TOUTC = TOUT IF (NGC .EQ. 0) GO TO 270 CALL DRCHEK (1, G, NEQ, Y, RWORK(LYH), NYH, 1 RWORK(LG0), RWORK(LG1), RWORK(LGX), JROOT, IRT, rpar, ipar) IF (IRT .EQ. 0) GO TO 270 GO TO 682 CKS: end changes C----------------------------------------------------------------------- C Block D. C The next code block is for continuation calls only (ISTATE = 2 or 3) C and is to check stop conditions before taking a step. C First, DRCHEK is called to check for a root within the last step C taken, other than the last root found there, if any. C If ITASK = 2 or 5, and y(TN) has not yet been returned to the user C because of an intervening root, return through Block G. C----------------------------------------------------------------------- 200 NSLAST = NST C karline: added from here IRFP = IRFND IF (NGC .EQ. 0) GO TO 205 IF (ITASK .EQ. 1 .OR. ITASK .EQ. 4) TOUTC = TOUT CALL DRCHEK (2, G, NEQ, Y, RWORK(LYH), NYH, 1 RWORK(LG0), RWORK(LG1), RWORK(LGX), JROOT, IRT, rpar, ipar) IF (IRT .NE. 1) GO TO 205 IRFND = 1 ISTATE = 3 T = T0 GO TO 425 205 CONTINUE IRFND = 0 IF (IRFP .EQ. 1 .AND. TLAST .NE. TN .AND. ITASK .EQ. 2) GO TO 400 C karline: till here IF (ITASK .EQ. 1) THEN GOTO 210 ELSE IF (ITASK .EQ. 2) THEN GOTO 250 ELSE IF (ITASK .EQ. 3) THEN GOTO 220 ELSE IF (ITASK .EQ. 4) THEN GOTO 230 ELSE IF (ITASK .EQ. 5) THEN GOTO 240 ENDIF C GO TO (210, 250, 220, 230, 240), ITASK 210 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) IF (IFLAG .NE. 0) GO TO 627 T = TOUT GO TO 420 220 TP = TN - HU*(1.0D0 + 100.0D0*UROUND) IF ((TP - TOUT)*H .GT. 0.0D0) GO TO 623 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 GO TO 400 230 TCRIT = RWORK(1) IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 IF ((TCRIT - TOUT)*H .LT. 0.0D0) GO TO 625 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 245 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) IF (IFLAG .NE. 0) GO TO 627 T = TOUT GO TO 420 240 TCRIT = RWORK(1) IF ((TN - TCRIT)*H .GT. 0.0D0) GO TO 624 245 HMX = ABS(TN) + ABS(H) IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX C karline:added next line IF (IRFP .EQ. 1 .AND. TLAST .NE. TN .AND. ITASK .EQ. 5) GO TO 400 IF (IHIT) GO TO 400 TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) IF (ISTATE .EQ. 2) JSTART = -2 C----------------------------------------------------------------------- C Block E. C The next block is normally executed for all calls and contains C the call to the one-step core integrator DSTODE. C C This is a looping point for the integration steps. C C First check for too many steps being taken, update EWT (if not at C start of problem), check for too much accuracy being requested, and C check for H below the roundoff level in T. C----------------------------------------------------------------------- 250 CONTINUE IF ((NST-NSLAST) .GE. MXSTEP) GO TO 500 CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) DO 260 I = 1,N IF (RWORK(I+LEWT-1) .LE. 0.0D0) GO TO 510 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 260 CONTINUE 270 TOLSF = UROUND*DVNORM (N, RWORK(LYH), RWORK(LEWT)) IF (TOLSF .LE. 1.0D0) GO TO 280 TOLSF = TOLSF*2.0D0 IF (NST .EQ. 0) GO TO 626 GO TO 520 280 IF ((TN + H) .NE. TN) GO TO 290 NHNIL = NHNIL + 1 IF (NHNIL .GT. MXHNIL) GO TO 290 MSG = 'DLSODES- Warning..Internal T (=R1) and H (=R2) are' CALL XERRWD (MSG, 50, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' such that in the machine, T + H = T on the next step ' CALL XERRWD (MSG, 60, 101, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' (H = step size). Solver will continue anyway.' CALL XERRWD (MSG, 50, 101, 0, 0, 0, 0, 2, TN, H) IF (NHNIL .LT. MXHNIL) GO TO 290 MSG = 'DLSODES- Above warning has been issued I1 times. ' CALL XERRWD (MSG, 50, 102, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' It will not be issued again for this problem.' CALL XERRWD (MSG, 50, 102, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0) 290 CONTINUE C----------------------------------------------------------------------- C CALL DSTODE(NEQ,Y,YH,NYH,YH,EWT,SAVF,ACOR,WM,WM,F,JAC,DPRJS,DSOLSS) C----------------------------------------------------------------------- CALL DSTODE (NEQ, Y, RWORK(LYH), NYH, RWORK(LYH), RWORK(LEWT), 1 RWORK(LSAVF), RWORK(LACOR), RWORK(LWM), RWORK(LWM), 2 F, JAC, DPRJS, DSOLSS, rpar,ipar) KGO = 1 - KFLAG IF (KGO .EQ. 1) THEN GOTO 300 ELSE IF (KGO .EQ. 2) THEN GOTO 530 ELSE IF (KGO .EQ. 3) THEN GOTO 540 ELSE IF (KGO .EQ. 4) THEN GOTO 550 ENDIF C GO TO (300, 530, 540, 550), KGO C----------------------------------------------------------------------- C Block F. C The following block handles the case of a successful return from the C core integrator (KFLAG = 0). Test for stop conditions. C Then call DRCHEK to check for a root within the last step. C Then, if no root was found, check for stop conditions. C----------------------------------------------------------------------- 300 INIT = 1 Ckarline: changed this IF (NGC .EQ. 0) GO TO 305 CALL DRCHEK (3, G, NEQ, Y, RWORK(LYH), NYH, 1 RWORK(LG0), RWORK(LG1), RWORK(LGX), JROOT, IRT, rpar, ipar) IF (IRT .NE. 1) GO TO 305 IRFND = 1 ISTATE = 3 T = T0 GO TO 425 305 CONTINUE IF (ITASK .EQ. 1) THEN GOTO 310 ELSE IF (ITASK .EQ. 2) THEN GOTO 400 ELSE IF (ITASK .EQ. 3) THEN GOTO 330 ELSE IF (ITASK .EQ. 4) THEN GOTO 340 ELSE IF (ITASK .EQ. 5) THEN GOTO 350 ENDIF C GO TO (310, 400, 330, 340, 350), ITASK C ITASK = 1. if TOUT has been reached, interpolate. ------------------- 310 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 250 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) T = TOUT GO TO 420 C ITASK = 3. Jump to exit if TOUT was reached. ------------------------ 330 IF ((TN - TOUT)*H .GE. 0.0D0) GO TO 400 GO TO 250 C ITASK = 4. See if TOUT or TCRIT was reached. Adjust H if necessary. 340 IF ((TN - TOUT)*H .LT. 0.0D0) GO TO 345 CALL DINTDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) T = TOUT GO TO 420 345 HMX = ABS(TN) + ABS(H) IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX IF (IHIT) GO TO 400 TNEXT = TN + H*(1.0D0 + 4.0D0*UROUND) IF ((TNEXT - TCRIT)*H .LE. 0.0D0) GO TO 250 H = (TCRIT - TN)*(1.0D0 - 4.0D0*UROUND) JSTART = -2 GO TO 250 C ITASK = 5. See if TCRIT was reached and jump to exit. --------------- 350 HMX = ABS(TN) + ABS(H) IHIT = ABS(TN - TCRIT) .LE. 100.0D0*UROUND*HMX C----------------------------------------------------------------------- C Block G. C The following block handles all successful returns from DLSODES. C If ITASK .ne. 1, Y is loaded from YH and T is set accordingly. C ISTATE is set to 2, and the optional outputs are loaded into the C work arrays before returning. C----------------------------------------------------------------------- 400 DO 410 I = 1,N Y(I) = RWORK(I+LYH-1) 410 CONTINUE T = TN IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 420 IF (IHIT) T = TCRIT 420 ISTATE = 2 425 CONTINUE RWORK(11) = HU RWORK(12) = H RWORK(13) = TN IWORK(11) = NST IWORK(12) = NFE IWORK(13) = NJE IWORK(14) = NQU IWORK(15) = NQ IWORK(19) = NNZ IWORK(20) = NGP IWORK(21) = NLU IWORK(25) = NZL IWORK(26) = NZU C karline: added next two lines IWORK(10) = NGE TLAST = T RETURN C----------------------------------------------------------------------- C Block H. C The following block handles all unsuccessful returns other than C those for illegal input. First the error message routine is called. C If there was an error test or convergence test failure, IMXER is set. C Then Y is loaded from YH and T is set to TN. C The optional outputs are loaded into the work arrays before returning. C----------------------------------------------------------------------- C The maximum number of steps was taken before reaching TOUT. ---------- 500 MSG = 'DLSODES- At current T (=R1), MXSTEP (=I1) steps ' CALL XERRWD (MSG, 50, 201, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' taken on this call before reaching TOUT ' CALL XERRWD (MSG, 50, 201, 0, 1, MXSTEP, 0, 1, TN, 0.0D0) ISTATE = -1 GO TO 580 C EWT(i) .le. 0.0 for some i (not at start of problem). ---------------- 510 EWTI = RWORK(LEWT+I-1) MSG = 'DLSODES- At T (=R1), EWT(I1) has become R2 .le. 0.' CALL XERRWD (MSG, 50, 202, 0, 1, I, 0, 2, TN, EWTI) ISTATE = -6 GO TO 580 C Too much accuracy requested for machine precision. ------------------- 520 MSG = 'DLSODES- At T (=R1), too much accuracy requested ' CALL XERRWD (MSG, 50, 203, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' for precision of machine.. See TOLSF (=R2) ' CALL XERRWD (MSG, 50, 203, 0, 0, 0, 0, 2, TN, TOLSF) RWORK(14) = TOLSF ISTATE = -2 GO TO 580 C KFLAG = -1. Error test failed repeatedly or with ABS(H) = HMIN. ----- 530 MSG = 'DLSODES- At T(=R1) and step size H(=R2), the error' CALL XERRWD (MSG, 50, 204, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' test failed repeatedly or with ABS(H) = HMIN' CALL XERRWD (MSG, 50, 204, 0, 0, 0, 0, 2, TN, H) ISTATE = -4 GO TO 560 C KFLAG = -2. Convergence failed repeatedly or with ABS(H) = HMIN. ---- 540 MSG = 'DLSODES- At T (=R1) and step size H (=R2), the ' CALL XERRWD (MSG, 50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' corrector convergence failed repeatedly ' CALL XERRWD (MSG, 50, 205, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' or with ABS(H) = HMIN ' CALL XERRWD (MSG, 30, 205, 0, 0, 0, 0, 2, TN, H) ISTATE = -5 GO TO 560 C KFLAG = -3. Fatal error flag returned by DPRJS or DSOLSS (CDRV). ---- 550 MSG = 'DLSODES- At T (=R1) and step size H (=R2), a fatal' CALL XERRWD (MSG, 50, 207, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' error flag was returned by CDRV (by way of ' CALL XERRWD (MSG, 50, 207, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' Subroutine DPRJS or DSOLSS) ' CALL XERRWD (MSG, 40, 207, 0, 0, 0, 0, 2, TN, H) ISTATE = -7 GO TO 580 C Compute IMXER if relevant. ------------------------------------------- 560 BIG = 0.0D0 IMXER = 1 DO 570 I = 1,N SIZE = ABS(RWORK(I+LACOR-1)*RWORK(I+LEWT-1)) IF (BIG .GE. SIZE) GO TO 570 BIG = SIZE IMXER = I 570 CONTINUE IWORK(16) = IMXER C Set Y vector, T, and optional outputs. ------------------------------- 580 DO 590 I = 1,N Y(I) = RWORK(I+LYH-1) 590 CONTINUE T = TN RWORK(11) = HU RWORK(12) = H RWORK(13) = TN IWORK(11) = NST IWORK(12) = NFE IWORK(13) = NJE IWORK(14) = NQU IWORK(15) = NQ IWORK(19) = NNZ IWORK(20) = NGP IWORK(21) = NLU IWORK(25) = NZL IWORK(26) = NZU C karline: added next two lines IWORK(10) = NGE TLAST = T RETURN C----------------------------------------------------------------------- C Block I. C The following block handles all error returns due to illegal input C (ISTATE = -3), as detected before calling the core integrator. C First the error message routine is called. If the illegal input C is a negative ISTATE, the run is aborted (apparent infinite loop). C----------------------------------------------------------------------- 601 MSG = 'DLSODES- ISTATE (=I1) illegal.' CALL XERRWD (MSG, 30, 1, 0, 1, ISTATE, 0, 0, 0.0D0, 0.0D0) IF (ISTATE .LT. 0) GO TO 800 GO TO 700 602 MSG = 'DLSODES- ITASK (=I1) illegal. ' CALL XERRWD (MSG, 30, 2, 0, 1, ITASK, 0, 0, 0.0D0, 0.0D0) GO TO 700 603 MSG = 'DLSODES- ISTATE.gt.1 but DLSODES not initialized. ' CALL XERRWD (MSG, 50, 3, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) GO TO 700 604 MSG = 'DLSODES- NEQ (=I1) .lt. 1 ' CALL XERRWD (MSG, 30, 4, 0, 1, NEQ(1), 0, 0, 0.0D0, 0.0D0) GO TO 700 605 MSG = 'DLSODES- ISTATE = 3 and NEQ increased (I1 to I2). ' CALL XERRWD (MSG, 50, 5, 0, 2, N, NEQ(1), 0, 0.0D0, 0.0D0) GO TO 700 606 MSG = 'DLSODES- ITOL (=I1) illegal. ' CALL XERRWD (MSG, 30, 6, 0, 1, ITOL, 0, 0, 0.0D0, 0.0D0) GO TO 700 607 MSG = 'DLSODES- IOPT (=I1) illegal. ' CALL XERRWD (MSG, 30, 7, 0, 1, IOPT, 0, 0, 0.0D0, 0.0D0) GO TO 700 608 MSG = 'DLSODES- MF (=I1) illegal. ' CALL XERRWD (MSG, 30, 8, 0, 1, MF, 0, 0, 0.0D0, 0.0D0) GO TO 700 609 MSG = 'DLSODES- SETH (=R1) .lt. 0.0 ' CALL XERRWD (MSG, 30, 9, 0, 0, 0, 0, 1, SETH, 0.0D0) GO TO 700 611 MSG = 'DLSODES- MAXORD (=I1) .lt. 0 ' CALL XERRWD (MSG, 30, 11, 0, 1, MAXORD, 0, 0, 0.0D0, 0.0D0) GO TO 700 612 MSG = 'DLSODES- MXSTEP (=I1) .lt. 0 ' CALL XERRWD (MSG, 30, 12, 0, 1, MXSTEP, 0, 0, 0.0D0, 0.0D0) GO TO 700 613 MSG = 'DLSODES- MXHNIL (=I1) .lt. 0 ' CALL XERRWD (MSG, 30, 13, 0, 1, MXHNIL, 0, 0, 0.0D0, 0.0D0) GO TO 700 614 MSG = 'DLSODES- TOUT (=R1) behind T (=R2) ' CALL XERRWD (MSG, 40, 14, 0, 0, 0, 0, 2, TOUT, T) MSG = ' Integration direction is given by H0 (=R1) ' CALL XERRWD (MSG, 50, 14, 0, 0, 0, 0, 1, H0, 0.0D0) GO TO 700 615 MSG = 'DLSODES- HMAX (=R1) .lt. 0.0 ' CALL XERRWD (MSG, 30, 15, 0, 0, 0, 0, 1, HMAX, 0.0D0) GO TO 700 616 MSG = 'DLSODES- HMIN (=R1) .lt. 0.0 ' CALL XERRWD (MSG, 30, 16, 0, 0, 0, 0, 1, HMIN, 0.0D0) GO TO 700 617 MSG = 'DLSODES- RWORK length is insufficient to proceed. ' CALL XERRWD (MSG, 50, 17, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' Length needed is .ge. LENRW (=I1), exceeds LRW (=I2)' CALL XERRWD (MSG, 60, 17, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) GO TO 700 618 MSG = 'DLSODES- IWORK length is insufficient to proceed. ' CALL XERRWD (MSG, 50, 18, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' Length needed is .ge. LENIW (=I1), exceeds LIW (=I2)' CALL XERRWD (MSG, 60, 18, 0, 2, LENIW, LIW, 0, 0.0D0, 0.0D0) GO TO 700 619 MSG = 'DLSODES- RTOL(I1) is R1 .lt. 0.0 ' CALL XERRWD (MSG, 40, 19, 0, 1, I, 0, 1, RTOLI, 0.0D0) GO TO 700 620 MSG = 'DLSODES- ATOL(I1) is R1 .lt. 0.0 ' CALL XERRWD (MSG, 40, 20, 0, 1, I, 0, 1, ATOLI, 0.0D0) GO TO 700 621 EWTI = RWORK(LEWT+I-1) MSG = 'DLSODES- EWT(I1) is R1 .le. 0.0 ' CALL XERRWD (MSG, 40, 21, 0, 1, I, 0, 1, EWTI, 0.0D0) GO TO 700 622 MSG='DLSODES- TOUT(=R1) too close to T(=R2) to start integration.' CALL XERRWD (MSG, 60, 22, 0, 0, 0, 0, 2, TOUT, T) GO TO 700 623 MSG='DLSODES- ITASK = I1 and TOUT (=R1) behind TCUR - HU (= R2) ' CALL XERRWD (MSG, 60, 23, 0, 1, ITASK, 0, 2, TOUT, TP) GO TO 700 624 MSG='DLSODES- ITASK = 4 or 5 and TCRIT (=R1) behind TCUR (=R2) ' CALL XERRWD (MSG, 60, 24, 0, 0, 0, 0, 2, TCRIT, TN) GO TO 700 625 MSG='DLSODES- ITASK = 4 or 5 and TCRIT (=R1) behind TOUT (=R2) ' CALL XERRWD (MSG, 60, 25, 0, 0, 0, 0, 2, TCRIT, TOUT) GO TO 700 626 MSG = 'DLSODES- At start of problem, too much accuracy ' CALL XERRWD (MSG, 50, 26, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' requested for precision of machine.. See TOLSF (=R1) ' CALL XERRWD (MSG, 60, 26, 0, 0, 0, 0, 1, TOLSF, 0.0D0) RWORK(14) = TOLSF GO TO 700 627 MSG = 'DLSODES- Trouble in DINTDY. ITASK = I1, TOUT = R1' CALL XERRWD (MSG, 50, 27, 0, 1, ITASK, 0, 1, TOUT, 0.0D0) GO TO 700 628 MSG='DLSODES- RWORK length insufficient (for Subroutine DPREP). ' CALL XERRWD (MSG, 60, 28, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' Length needed is .ge. LENRW (=I1), exceeds LRW (=I2)' CALL XERRWD (MSG, 60, 28, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) GO TO 700 629 MSG='DLSODES- RWORK length insufficient (for Subroutine JGROUP). ' CALL XERRWD (MSG, 60, 29, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' Length needed is .ge. LENRW (=I1), exceeds LRW (=I2)' CALL XERRWD (MSG, 60, 29, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) GO TO 700 630 MSG='DLSODES- RWORK length insufficient (for Subroutine ODRV). ' CALL XERRWD (MSG, 60, 30, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' Length needed is .ge. LENRW (=I1), exceeds LRW (=I2)' CALL XERRWD (MSG, 60, 30, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) GO TO 700 631 MSG='DLSODES- Error from ODRV in Yale Sparse Matrix Package. ' CALL XERRWD (MSG, 60, 31, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) IMUL = (IYS - 1)/N IREM = IYS - IMUL*N MSG=' At T (=R1), ODRV returned error flag = I1*NEQ + I2. ' CALL XERRWD (MSG, 60, 31, 0, 2, IMUL, IREM, 1, TN, 0.0D0) GO TO 700 632 MSG='DLSODES- RWORK length insufficient (for Subroutine CDRV). ' CALL XERRWD (MSG, 60, 32, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG=' Length needed is .ge. LENRW (=I1), exceeds LRW (=I2)' CALL XERRWD (MSG, 60, 32, 0, 2, LENRW, LRW, 0, 0.0D0, 0.0D0) GO TO 700 633 MSG='DLSODES- Error from CDRV in Yale Sparse Matrix Package. ' CALL XERRWD (MSG, 60, 33, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) IMUL = (IYS - 1)/N IREM = IYS - IMUL*N MSG=' At T (=R1), CDRV returned error flag = I1*NEQ + I2. ' CALL XERRWD (MSG, 60, 33, 0, 2, IMUL, IREM, 1, TN, 0.0D0) IF (IMUL .EQ. 2) THEN MSG=' Duplicate entry in sparsity structure descriptors. ' CALL XERRWD (MSG, 60, 33, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) ENDIF IF (IMUL .EQ. 3 .OR. IMUL .EQ. 6) THEN MSG=' Insufficient storage for NSFC (called by CDRV). ' CALL XERRWD (MSG, 60, 33, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) ENDIF C Karline: added next error messages 680 MSG = 'DLSODES- NG (=I1) .lt. 0 ' CALL XERRWD (MSG, 30, 30, 0, 1, NG, 0, 0, 0.0D0, 0.0D0) GO TO 700 681 MSG = 'DLSODES- NG changed (from I1 to I2) illegally, ' CALL XERRWD (MSG, 50, 31, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' i.e. not immediately after a root was found.' CALL XERRWD (MSG, 50, 31, 0, 2, NGC, NG, 0, 0.0D0, 0.0D0) GO TO 700 682 MSG = 'DLSODES- One or more components of g has a root ' CALL XERRWD (MSG, 50, 32, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) MSG = ' too near to the initial point. ' CALL XERRWD (MSG, 40, 32, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) C C 700 ISTATE = -3 RETURN C 800 MSG = 'DLSODES- Run aborted.. apparent infinite loop. ' CALL XERRWD (MSG, 50, 303, 2, 0, 0, 0, 0, 0.0D0, 0.0D0) RETURN C----------------------- End of Subroutine DLSODES --------------------- END deSolve/src/twoDmap.c0000754000175100001440000001323613131751003014240 0ustar hornikusers/* --------------------------------------------------------------------* SPARSITY of 2-D and 3-D reaction-transport problems with mapping the states that are present have a value > 0 in vector 'ipres' ipres contains the actual number of state variable, after applying the mask , e.g. ipres(20) = 10 means that the element 20 in the original 2D matrix is the 10th element, after applying the mask -------------------------------------------------------------------- */ #include #include #include #include #include "deSolve.h" void sparsity2Dmap (SEXP Type, int* iwork, int neq, int liw) { int nspec, nx, ny, bndx, bndy, Nt, ij, isp, i, j, k, l, m; int totN, *ipres, Mnew; nspec = INTEGER(Type)[1]; /* number components*/ nx = INTEGER(Type)[2]; /* dimension x*/ ny = INTEGER(Type)[3]; /* dimension y*/ bndx = INTEGER(Type)[4]; /* cyclic boundary x*/ bndy = INTEGER(Type)[5]; /* cyclic boundary y*/ totN = INTEGER(Type)[7]; /* Total state variables in original 2D matrix*/ ipres = (int *) R_alloc(totN, sizeof(int)); for (j=0; j < totN; j++) ipres[j] = INTEGER(Type)[j+8]; Nt = nx*ny; ij = 31 + neq; iwork[30] = 1; m = 1; for( i = 0; i < nspec; i++) { isp = i*Nt; for( j = 0; j < nx; j++) { for( k = 0; k < ny; k++) { if (ij > liw-8-nspec) error("not enough memory allocated in iwork - increase liw %i ",liw); Mnew = ipres[m-1]; if (Mnew > 0) { interactmap (&ij, liw, iwork, ipres, m); if (k < ny-1) interactmap (&ij, liw, iwork, ipres, m+1); if (j < nx-1) interactmap (&ij, liw, iwork, ipres, m+ny); if (j > 0) interactmap (&ij, liw, iwork, ipres, m-ny); if (k > 0) interactmap (&ij, liw, iwork, ipres, m-1); if (bndx == 1) { if (j == 0) interactmap (&ij, liw, iwork, ipres, isp+(nx-1)*ny+k+1); if (j == nx-1) interactmap (&ij, liw, iwork, ipres, isp+k+1); } if (bndy == 1) { if (k == 0) interactmap (&ij, liw, iwork, ipres, isp+(j+1)*ny); if (k == ny-1) interactmap (&ij, liw, iwork, ipres, isp + j*ny +1); } for(l = 0; l < nspec; l++) if (l != i) interactmap (&ij, liw, iwork, ipres, l*Nt+j*ny+k+1); iwork[30+Mnew] = ij-30-neq; } m = m+1; } } } } void interactmap (int *ij, int nnz, int *iwork, int *ipres, int ival) { /* check if not yet present for current state */ if (ipres[ival-1] > 0) { if (*ij > nnz) error ("not enough memory allocated in iwork - increase liw %i ", nnz); iwork[(*ij)++] = ipres[ival-1]; } } /*==================================================*/ /* an element in C-array A(I,J,K), i=0,dim(1)-1 etc... is positioned at j*dim(2)*dim(3) + k*dim(3) + l + 1 in FORTRAN VECTOR! includes check on validity dimens and boundary are reversed ... */ void sparsity3Dmap (SEXP Type, int* iwork, int neq, int liw) { int nspec, nx, ny, nz, bndx, bndy, bndz, Nt, ij, isp, i, j, k, l, m, ll; int totN, *ipres, Mnew; nspec = INTEGER(Type)[1]; nx = INTEGER(Type)[2]; ny = INTEGER(Type)[3]; nz = INTEGER(Type)[4]; bndx = INTEGER(Type)[5]; bndy = INTEGER(Type)[6]; bndz = INTEGER(Type)[7]; totN = INTEGER(Type)[9]; /* Total state variables in original 3D matrix*/ ipres = (int *) R_alloc(totN, sizeof(int)); for (j=0; j < totN; j++) {ipres[j] = INTEGER(Type)[j+10]; } Nt = nx*ny*nz; ij = 31+neq; iwork[30] = 1; m = 1; for( i = 0; i < nspec; i++) { isp = i*Nt; for( j = 0; j < nx; j++) { for( k = 0; k < ny; k++) { for( ll = 0; ll < nz; ll++) { if (ij > liw-6-nspec) error ("not enough memory allocated in iwork - increase liw %i ", liw); Mnew = ipres[m-1]; if (Mnew > 0) { interactmap (&ij, liw, iwork, ipres, m); if (ll < nz-1) interactmap (&ij, liw, iwork, ipres, m+1); else if (bndz == 1) interactmap (&ij, liw, iwork, ipres, isp + j*ny*nz + k*nz + 1); if (k < ny-1) interactmap (&ij, liw, iwork, ipres, m+nz); else if (bndy == 1) interactmap (&ij, liw, iwork, ipres, isp + j*ny*nz + ll + 1); if (j < nx-1) interactmap (&ij, liw, iwork, ipres, m+ny*nz); else if (bndx == 1) interactmap (&ij, liw, iwork, ipres, isp + k*nz + ll + 1); if (j > 0) interactmap (&ij, liw, iwork, ipres, m-ny*nz); else if (bndx == 1) interactmap (&ij, liw, iwork, ipres, isp+(nx-1)*ny*nz+k*nz+ll+1); if (k > 0) interactmap (&ij, liw, iwork, ipres, m-nz); else if (bndy == 1) interactmap (&ij, liw, iwork, ipres, isp + j*ny*nz+(ny-1)*nz+ll+1); if (ll > 0) interactmap (&ij, liw, iwork, ipres, m-1); else if (bndz == 1) interactmap (&ij, liw, iwork, ipres, isp + j*ny*nz+k*nz+nz); for(l = 0; l < nspec; l++) if (l != i) interactmap (&ij, liw, iwork, ipres, l*Nt+j*ny*nz+k*nz+ll+1); iwork[30+Mnew] = ij-30-neq; } m = m+1; } } } } } deSolve/src/call_rkAuto.c0000754000175100001440000002711613131751003015067 0ustar hornikusers/*==========================================================================*/ /* Runge-Kutta Solvers, (C) Th. Petzoldt, License: GPL >=2 */ /* General RK Solver for methods with adaptive step size */ /*==========================================================================*/ #include "rk_util.h" SEXP call_rkAuto(SEXP Xstart, SEXP Times, SEXP Func, SEXP Initfunc, SEXP Parms, SEXP eventfunc, SEXP elist, SEXP Nout, SEXP Rho, SEXP Rtol, SEXP Atol, SEXP Tcrit, SEXP Verbose, SEXP Hmin, SEXP Hmax, SEXP Hini, SEXP Rpar, SEXP Ipar, SEXP Method, SEXP Maxsteps, SEXP Flist) { /** Initialization **/ long int old_N_Protect = save_N_Protected(); double *tt = NULL, *xs = NULL; double *y, *f, *Fj, *tmp, *FF, *rr; SEXP R_yout; double *y0, *y1, *y2, *dy1, *dy2, *out, *yout; double errold = 0.0, t, dt, tmax; SEXP R_FSAL, Alpha, Beta; int fsal = FALSE; /* assume no FSAL */ /* Use polynomial interpolation if not disabled by the method or when events come in to play (stop-and-go mode). Methods with dense output interpolate by default, all others do not. */ int interpolate = TRUE; int i = 0, j = 0, it = 0, it_tot = 0, it_ext = 0, nt = 0, neq = 0, it_rej = 0; int isForcing, isEvent; /*------------------------------------------------------------------------*/ /* Processing of Arguments */ /*------------------------------------------------------------------------*/ int lAtol = LENGTH(Atol); double *atol = (double*) R_alloc((int) lAtol, sizeof(double)); int lRtol = LENGTH(Rtol); double *rtol = (double*) R_alloc((int) lRtol, sizeof(double)); for (j = 0; j < lRtol; j++) rtol[j] = REAL(Rtol)[j]; for (j = 0; j < lAtol; j++) atol[j] = REAL(Atol)[j]; double tcrit = REAL(Tcrit)[0]; double hmin = REAL(Hmin)[0]; double hmax = REAL(Hmax)[0]; double hini = REAL(Hini)[0]; int maxsteps = INTEGER(Maxsteps)[0]; int nout = INTEGER(Nout)[0]; /* number of global outputs is func is in a DLL */ int verbose = INTEGER(Verbose)[0]; int stage = (int)REAL(getListElement(Method, "stage"))[0]; SEXP R_A, R_B1, R_B2, R_C, R_D, R_densetype; double *A, *bb1, *bb2 = NULL, *cc = NULL, *dd = NULL; PROTECT(R_A = getListElement(Method, "A")); incr_N_Protect(); A = REAL(R_A); PROTECT(R_B1 = getListElement(Method, "b1")); incr_N_Protect(); bb1 = REAL(R_B1); PROTECT(R_B2 = getListElement(Method, "b2")); incr_N_Protect(); if (length(R_B2)) bb2 = REAL(R_B2); PROTECT(R_C = getListElement(Method, "c")); incr_N_Protect(); if (length(R_C)) cc = REAL(R_C); PROTECT(R_D = getListElement(Method, "d")); incr_N_Protect(); if (length(R_D)) dd = REAL(R_D); /* dense output Cash-Karp: densetype = 2 */ int densetype = 0; PROTECT(R_densetype = getListElement(Method, "densetype")); incr_N_Protect(); if (length(R_densetype)) densetype = INTEGER(R_densetype)[0]; double qerr = REAL(getListElement(Method, "Qerr"))[0]; double beta = 0; /* 0.4/qerr; */ PROTECT(Beta = getListElement(Method, "beta")); incr_N_Protect(); if (length(Beta)) beta = REAL(Beta)[0]; double alpha = 1/qerr - 0.75 * beta; PROTECT(Alpha = getListElement(Method, "alpha")); incr_N_Protect(); if (length(Alpha)) alpha = REAL(Alpha)[0]; PROTECT(R_FSAL = getListElement(Method, "FSAL")); incr_N_Protect(); if (length(R_FSAL)) fsal = INTEGER(R_FSAL)[0]; PROTECT(Times = AS_NUMERIC(Times)); incr_N_Protect(); tt = NUMERIC_POINTER(Times); nt = length(Times); PROTECT(Xstart = AS_NUMERIC(Xstart)); incr_N_Protect(); xs = NUMERIC_POINTER(Xstart); neq = length(Xstart); /*------------------------------------------------------------------------*/ /* timesteps (for advection computation in ReacTran) */ /*------------------------------------------------------------------------*/ for (i = 0; i < 2; i++) timesteps[i] = 0; /*------------------------------------------------------------------------*/ /* DLL, ipar, rpar (for compatibility with lsoda) */ /*------------------------------------------------------------------------*/ int isDll = FALSE; int lrpar= 0, lipar = 0; int *ipar = NULL; /* code adapted from lsoda to improve compatibility */ if (inherits(Func, "NativeSymbol")) { /* function is a dll */ isDll = TRUE; if (nout > 0) isOut = TRUE; //ntot = neq + nout; /* length of yout */ lrpar = nout + LENGTH(Rpar); /* length of rpar; LENGTH(Rpar) is always >0 */ lipar = 3 + LENGTH(Ipar); /* length of ipar */ } else { /* function is not a dll */ isDll = FALSE; isOut = FALSE; //ntot = neq; lipar = 3; /* in lsoda = 1 */ lrpar = nout; /* in lsoda = 1 */ } out = (double*) R_alloc(lrpar, sizeof(double)); ipar = (int *) R_alloc(lipar, sizeof(int)); /* first 3 elements of ipar are special */ ipar[0] = nout; ipar[1] = lrpar; ipar[2] = lipar; if (isDll == 1) { /* other elements of ipar are set in R-function lsodx via argument "ipar" */ for (j = 0; j < LENGTH(Ipar); j++) ipar[j+3] = INTEGER(Ipar)[j]; /* out: first nout elements of out are reserved for output variables other elements are set via argument "rpar" */ for (j = 0; j < nout; j++) out[j] = 0.0; for (j = 0; j < LENGTH(Rpar); j++) out[nout+j] = REAL(Rpar)[j]; } /*------------------------------------------------------------------------*/ /* Allocation of Workspace */ /*------------------------------------------------------------------------*/ y0 = (double*) R_alloc(neq, sizeof(double)); y1 = (double*) R_alloc(neq, sizeof(double)); y2 = (double*) R_alloc(neq, sizeof(double)); dy1 = (double*) R_alloc(neq, sizeof(double)); dy2 = (double*) R_alloc(neq, sizeof(double)); f = (double*) R_alloc(neq, sizeof(double)); y = (double*) R_alloc(neq, sizeof(double)); Fj = (double*) R_alloc(neq, sizeof(double)); tmp = (double*) R_alloc(neq, sizeof(double)); FF = (double*) R_alloc(neq * stage, sizeof(double)); rr = (double*) R_alloc(neq * 5, sizeof(double)); /* matrix for polynomial interpolation */ SEXP R_nknots; int nknots = 6; /* 6 = 5th order polynomials by default*/ int iknots = 0; /* counter for knots buffer */ double *yknots; PROTECT(R_nknots = getListElement(Method, "nknots")); incr_N_Protect(); if (length(R_nknots)) nknots = INTEGER(R_nknots)[0] + 1; if (nknots < 2) {nknots = 1; interpolate = FALSE;} if (densetype > 0) interpolate = TRUE; yknots = (double*) R_alloc((neq + 1) * (nknots + 1), sizeof(double)); /* matrix for holding states and global outputs */ PROTECT(R_yout = allocMatrix(REALSXP, nt, neq + nout + 1)); incr_N_Protect(); yout = REAL(R_yout); /* initialize outputs with NA first */ for (i = 0; i < nt * (neq + nout + 1); i++) yout[i] = NA_REAL; /* attribute that stores state information, similar to lsoda */ SEXP R_istate; int *istate; PROTECT(R_istate = allocVector(INTSXP, 22)); incr_N_Protect(); istate = INTEGER(R_istate); istate[0] = 0; /* assume succesful return */ for (i = 0; i < 22; i++) istate[i] = 0; /*------------------------------------------------------------------------*/ /* Initialization of Parameters (for DLL functions) */ /*------------------------------------------------------------------------*/ PROTECT(Y = allocVector(REALSXP,(neq))); incr_N_Protect(); initParms(Initfunc, Parms); isForcing = initForcings(Flist); isEvent = initEvents(elist, eventfunc, 0); if (isEvent) interpolate = FALSE; /*------------------------------------------------------------------------*/ /* Initialization of Integration Loop */ /*------------------------------------------------------------------------*/ yout[0] = tt[0]; /* initial time */ yknots[0] = tt[0]; /* for polynomial interpolation */ for (i = 0; i < neq; i++) { y0[i] = xs[i]; /* initial values */ yout[(i + 1) * nt] = y0[i]; /* output array */ yknots[iknots + nknots * (i + 1)] = xs[i]; /* for polynomials */ } iknots++; t = tt[0]; tmax = fmax(tt[nt - 1], tcrit); dt = fmin(hmax, hini); hmax = fmin(hmax, tmax - t); /* Initialize work arrays (to be on the safe side, remove this later) */ for (i = 0; i < neq; i++) { y1[i] = 0; y2[i] = 0; Fj[i] = 0; for (j= 0; j < stage; j++) { FF[i + j * neq] = 0; } } /*------------------------------------------------------------------------*/ /* Main Loop */ /*------------------------------------------------------------------------*/ it = 1; /* step counter; zero element is initial state */ it_ext = 0; /* counter for external time step (dense output) */ it_tot = 0; /* total number of time steps */ it_rej = 0; if (interpolate) { /* integrate over the whole time step and interpolate internally */ rk_auto( fsal, neq, stage, isDll, isForcing, verbose, nknots, interpolate, densetype, maxsteps, nt, &iknots, &it, &it_ext, &it_tot, &it_rej, istate, ipar, t, tmax, hmin, hmax, alpha, beta, &dt, &errold, tt, y0, y1, y2, dy1, dy2, f, y, Fj, tmp, FF, rr, A, out, bb1, bb2, cc, dd, atol, rtol, yknots, yout, Func, Parms, Rho ); } else { /* integrate separately between external time steps; do not interpolate */ for (int j = 0; j < nt - 1; j++) { t = tt[j]; tmax = fmin(tt[j + 1], tcrit); dt = tmax - t; if (isEvent) { updateevent(&t, y0, istate); } if (verbose) Rprintf("\n %d th time interval = %g ... %g", j, t, tmax); rk_auto( fsal, neq, stage, isDll, isForcing, verbose, nknots, interpolate, densetype, maxsteps, nt, &iknots, &it, &it_ext, &it_tot, &it_rej, istate, ipar, t, tmax, hmin, hmax, alpha, beta, &dt, &errold, tt, y0, y1, y2, dy1, dy2, f, y, Fj, tmp, FF, rr, A, out, bb1, bb2, cc, dd, atol, rtol, yknots, yout, Func, Parms, Rho ); /* in this mode, internal interpolation is skipped, so we can simply store the results at the end of each call */ yout[j + 1] = tmax; for (i = 0; i < neq; i++) yout[j + 1 + nt * (1 + i)] = y2[i]; } } /*====================================================================*/ /* call derivs again to get global outputs */ /* j = -1 suppresses unnecessary internal copying */ /*====================================================================*/ if (nout > 0) { for (int j = 0; j < nt; j++) { t = yout[j]; for (i = 0; i < neq; i++) tmp[i] = yout[j + nt * (1 + i)]; derivs(Func, t, tmp, Parms, Rho, FF, out, -1, neq, ipar, isDll, isForcing); for (i = 0; i < nout; i++) { yout[j + nt * (1 + neq + i)] = out[i]; } } } /* attach diagnostic information (codes are compatible to lsoda) */ setIstate(R_yout, R_istate, istate, it_tot, stage, fsal, qerr, it_rej); if (densetype == 2) istate[12] = it_tot * stage + 2; /* number of function evaluations */ /* verbose printing in debugging mode*/ if (verbose) Rprintf("\nNumber of time steps it = %d, it_ext = %d, it_tot = %d it_rej %d\n", it, it_ext, it_tot, it_rej); /* release R resources */ timesteps[0] = 0; timesteps[1] = 0; restore_N_Protected(old_N_Protect); return(R_yout); } deSolve/src/ex_CCL4model.c0000754000175100001440000000775013131751003015033 0ustar hornikusers/* c the CCl4 inhalation model -------- ex_ccl4model.c -> ex_ccl4model.dll ------ compile in R with: system("gcc -shared -o ex_ccl4model.dll ex_ccl4model.c") or with system("R CMD SHLIB ex_ccl4model.c") */ #include static double parms[21]; #define BW parms[0] #define QP parms[1] #define QC parms[2] #define VFC parms[3] #define VLC parms[4] #define VMC parms[5] #define QFC parms[6] #define QLC parms[7] #define QMC parms[8] #define PLA parms[9] #define PFA parms[10] #define PMA parms[11] #define PTA parms[12] #define PB parms[13] #define MW parms[14] #define VMAX parms[15] #define KM parms[16] #define CONC parms[17] #define KL parms[18] #define RATS parms[19] #define VCHC parms[20] double V[5], P[4], AI0, VTC, Q[4]; #define DOSE out[0] #define MASS out[1] #define CP out[2] /* c======================================================================= c======================================================================= c Model initialisation c======================================================================= c======================================================================= c======================================================================= 2c Initialise primary parameter common block c======================================================================= */ void initccl4(void (* odeparms)(int *, double *)) { void derived(); int N=21; odeparms(&N, parms); derived(); } /*======================================================================= In this "event", state variable 1 is increased with 1. DOES NOT WORK... ======================================================================= */ void eventfun(int *n, double *t, double *y) { y[0] = y[0] + 1; } /*======================================================================= c Calculate derived parameters from primary parameters c======================================================================= */ void derived () { // Fraction viscera (kg/(kg BW)) VTC = 0.91 - (VLC+VFC+VMC); // Net chamber volume V[0] = VCHC - RATS*BW; V[1] = VMC*BW; V[2] = VTC*BW; V[3] = VFC*BW; V[4] = VLC*BW; // Initial amt. in chamber (mg) AI0 = CONC*V[0]*MW/24450.; P[0] = PMA/PB; P[1] = PTA/PB; P[2] = PFA/PB; P[3] = PLA/PB; Q[2] = QFC*QC; Q[3] = QLC*QC; Q[0] = QMC*QC; Q[1] = QC - (Q[0]+Q[3]+Q[2]); } /*======================================================================= c The dynamic model c======================================================================= */ void derivsccl4 (int *neq, double *t, double *y, double *ydot, double *out, int *ip) { double vconc[5], tconc[5], CA, CX, RAM; int i; if (ip[0] < 3) error("nout should be at least 3"); /*c y = AI, AAM, AT, AF, AL CLT, AM where clt = the area under the concentration-time curve in the liver AM = total amount metabolised concentrations */ for (i =0; i<5; i++) { tconc[i] = y[i]/V[i]; } /* vconc(1) is conc in mixed venous blood */ vconc[0] = 0.0; for (i = 1; i<5; i++){ vconc[i] = tconc[i]/P[i-1]; vconc[0] = vconc[0] + vconc[i]*Q[i-1]/QC ; } /* CA is conc in arterial blood */ CA = (QC * vconc[0] + QP * tconc[0])/ (QC + QP/PB); /* Exhaled chemical */ CX = CA/PB; /* metabolisation rate */ RAM = VMAX*vconc[4]/(KM + vconc[4]); /* the rate of change */ ydot[0] = RATS*QP*(CX - tconc[0]) - KL*y[0]; for ( i = 1; i<5; i++) ydot[i] = Q[i-1]*(CA-vconc[i]); ydot[4] = ydot[4] - RAM; ydot[5] = tconc[4]; ydot[6] = RAM; /* the mass balance (MASS=AAM+AT+AF+AL+AM), should be constant */ DOSE = AI0 - y[0]; MASS = (y[1]+y[2]+y[3]+y[4]+y[6])*RATS; CP = tconc[0]*24450.0/MW; } deSolve/src/call_lsoda.c0000754000175100001440000006034313131751003014723 0ustar hornikusers#include #include #include "deSolve.h" #include "externalptr.h" /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Ordinary differential equation solvers lsoda, lsode, lsodes, lsodar, and vode. The C-wrappers that provide the interface between FORTRAN codes and R-code are: C_deriv_func: interface with R-code "func", passes derivatives C_deriv_out : interface with R-code "func", passes derivatives + output variables C_jac_func : interface with R-code "jacfunc", passes jacobian (except lsodes) C_jac_vec : interface with R-code "jacvec", passes jacobian (only lsodes) C_deriv_func_forc provides the interface between the function specified in a DLL and the integrator, in case there are forcing functions. Two integrators can locate the root of a function: lsodar and lsode (the latter by merging part of the FORTRAN codes lsodar and lsode, by KS). C_root_func provides the interface between the R root function and the FORTRAN code. changes since 1.4 karline: version 1.5: added forcing functions in DLL karline: version 1.6: added events karline: version 1.7: 1. added root finding in lsode -> lsoder (fortran code) 2. added time lags -> delay differential equations 3. output variables now in C-code -> lsodeSr (fortran code) improving names karline: version 1.9.1: root finding in lsodes version 1.10.4: 2D with mapping - still in testing phase, undocumented karline: version 1.13-1: combining compiled code function with R code event +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ /* definition of the calls to the FORTRAN functions - in file opkdmain.f and in file dvode.f**/ void F77_NAME(dlsoda)(void (*)(int *, double *, double *, double *, double *, int *), int *, double *, double *, double *, int *, double *, double *, int *, int *, int *, double *,int *,int *, int *, void (*)(int *, double *, double *, int *, int *, double *, int *, double *, int *), int *, double *, int *); void F77_NAME(dlsode)(void (*)(int *, double *, double *, double *, double *, int *), int *, double *, double *, double *, int *, double *, double *, int *, int *, int *, double *,int *,int *, int *, void (*)(int *, double *, double *, int *, int *, double *, int *, double *, int *), int *, double *, int *); void F77_NAME(dlsoder)(void (*)(int *, double *, double *, double *, double *, int *), int *, double *, double *, double *, int *, double *, double *, int *, int *, int *, double *,int *,int *, int *, void (*)(int *, double *, double *, int *, int *, double *, int *, double *, int *), int *, void (*)(int *, double *, double *, int *, double *), /* rootfunc */ int *, int *, double *, int *); void F77_NAME(dlsodes)(void (*)(int *, double *, double *, double *, double *, int *), int *, double *, double *, double *, int *, double *, double *, int *, int *, int *, double *, int *, int *, int *, double *, /* extra 'double'; is integer in fortran */ void (*)(int *, double *, double *, int *, int *, int *, double *, double *, int *), /* jacvec */ int *, double *, int *); void F77_NAME(dlsodesr)(void (*)(int *, double *, double *, double *, double *, int *), int *, double *, double *, double *, int *, double *, double *, int *, int *, int *, double *, int *, int *, int *, double *, /* extra 'double'; is integer in fortran */ void (*)(int *, double *, double *, int *, int *, int *, double *, double *, int *), /* jacvec */ int *, void (*)(int *, double *, double *, int *, double *), /* rootfunc */ int *, int *, double *, int *); void F77_NAME(dlsodar)(void (*)(int *, double *, double *, double *, double *, int *), int *, double *, double *, double *, int *, double *, double *, int *, int *, int *, double *,int *,int *, int *, void (*)(int *, double *, double *, int *, int *, double *, int *, double *, int *), int *, void (*)(int *, double *, double *, int *, double *), /* rootfunc */ int *, int *, double *, int *); void F77_NAME(dvode)(void (*)(int *, double *, double *, double *, double *, int *), int *, double *, double *, double *, int *, double *, double *, int *, int *, int *, double *,int *,int *, int *, void (*)(int *, double *, double *, int *, int *, double *, int *, double*, int*), int *, double *, int *); /* wrapper above the derivate function that first estimates the values of the forcing functions */ static void C_deriv_func_forc (int *neq, double *t, double *y, double *ydot, double *yout, int *iout) { updatedeforc(t); DLL_deriv_func(neq, t, y, ydot, yout, iout); } /* interface between FORTRAN function call and R function Fortran code calls C_deriv_func(N, t, y, ydot, yout, iout) R code called as R_deriv_func(time, y) and returns ydot Note: passing of parameter values and "..." is done in R-function lsodx*/ static void C_deriv_func (int *neq, double *t, double *y, double *ydot, double *yout, int *iout) { int i; SEXP R_fcall, ans, Time; for (i = 0; i < *neq; i++) REAL(Y)[i] = y[i]; PROTECT(Time = ScalarReal(*t)); incr_N_Protect(); PROTECT(R_fcall = lang3(R_deriv_func,Time,Y)); incr_N_Protect(); PROTECT(ans = eval(R_fcall, R_envir)); incr_N_Protect(); for (i = 0; i < *neq; i++) ydot[i] = REAL(ans)[i]; my_unprotect(3); } /* deriv output function */ static void C_deriv_out (int *nOut, double *t, double *y, double *ydot, double *yout) { int i; SEXP R_fcall, Time, ans; for (i = 0; i < n_eq; i++) REAL(Y)[i] = y[i]; PROTECT(Time = ScalarReal(*t)); incr_N_Protect(); PROTECT(R_fcall = lang3(R_deriv_func,Time, Y)); incr_N_Protect(); PROTECT(ans = eval(R_fcall, R_envir)); incr_N_Protect(); for (i = 0; i < n_eq; i++) ydot[i] = REAL (ans)[i] ; for (i = 0; i < *nOut; i++) yout[i] = REAL(ans)[i + n_eq]; my_unprotect(3); } /* only if lsodar, lsoder, lsodesr: interface between FORTRAN call to root and corresponding R function */ static void C_root_func (int *neq, double *t, double *y, int *ng, double *gout) { int i; SEXP R_fcall, Time, ans; for (i = 0; i < *neq; i++) REAL(Y)[i] = y[i]; PROTECT(Time = ScalarReal(*t)); incr_N_Protect(); PROTECT(R_fcall = lang3(R_root_func,Time,Y)); incr_N_Protect(); PROTECT(ans = eval(R_fcall, R_envir)); incr_N_Protect(); for (i = 0; i < *ng; i++) gout[i] = REAL(ans)[i]; my_unprotect(3); } /* interface between FORTRAN call to jacobian and R function */ static void C_jac_func (int *neq, double *t, double *y, int *ml, int *mu, double *pd, int *nrowpd, double *yout, int *iout) { int i; SEXP R_fcall, Time, ans; for (i = 0; i < *neq; i++) REAL(Y)[i] = y[i]; PROTECT(Time = ScalarReal(*t)); incr_N_Protect(); PROTECT(R_fcall = lang3(R_jac_func,Time,Y)); incr_N_Protect(); PROTECT(ans = eval(R_fcall, R_envir)); incr_N_Protect(); for (i = 0; i < *neq * *nrowpd; i++) pd[i] = REAL(ans)[i]; my_unprotect(3); } /* only if lsodes: interface between FORTRAN call to jacvec and corresponding R function */ static void C_jac_vec (int *neq, double *t, double *y, int *j, int *ian, int *jan, double *pdj, double *yout, int *iout) { int i; SEXP R_fcall, ans, Time, J; PROTECT(J = NEW_INTEGER(1)); incr_N_Protect(); INTEGER(J)[0] = *j; for (i = 0; i < *neq; i++) REAL(Y)[i] = y[i]; PROTECT(Time = ScalarReal(*t)); incr_N_Protect(); PROTECT(R_fcall = lang4(R_jac_vec,Time,Y,J)); incr_N_Protect(); PROTECT(ans = eval(R_fcall, R_envir)); incr_N_Protect(); for (i = 0; i < *neq ; i++) pdj[i] = REAL(ans)[i]; my_unprotect(4); } /* give name to data types */ typedef void C_root_func_type (int *, double *, double *,int *, double *); typedef void C_jac_func_type (int *, double *, double *, int *, int *, double *, int *, double *, int *); typedef void C_jac_vec_type (int *, double *, double *, int *, int *, int *, double *, double *, int *); /* MAIN C-FUNCTION, CALLED FROM R-code */ SEXP call_lsoda(SEXP y, SEXP times, SEXP derivfunc, SEXP parms, SEXP rtol, SEXP atol, SEXP rho, SEXP tcrit, SEXP jacfunc, SEXP initfunc, SEXP eventfunc, SEXP verbose, SEXP iTask, SEXP rWork, SEXP iWork, SEXP jT, SEXP nOut, SEXP lRw, SEXP lIw, SEXP Solver, SEXP rootfunc, SEXP nRoot, SEXP Rpar, SEXP Ipar, SEXP Type, SEXP flist, SEXP elist, SEXP elag) { /******************************************************************************/ /****** DECLARATION SECTION ******/ /******************************************************************************/ int i, j, k, nt, repcount, latol, lrtol, lrw, liw; int maxit, solver, isForcing, isEvent, islag; double *xytmp, tin, tout, *Atol, *Rtol, *dy=NULL, ss, pt; int itol, itask, istate, iopt, jt, mflag, is, iterm; int nroot, *jroot=NULL, isDll, type; int *iwork, it, ntot, nout, iroot, *evals =NULL; double *rwork; SEXP TROOT, NROOT, VROOT; /* IROOT is in deSolve.h*/ /* pointers to functions passed to FORTRAN */ C_deriv_func_type *deriv_func; C_jac_func_type *jac_func=NULL; C_jac_vec_type *jac_vec=NULL; C_root_func_type *root_func=NULL; /******************************************************************************/ /****** STATEMENTS ******/ /******************************************************************************/ lock_solver(); /* prevent nested call of solvers that have global variables */ /* #### initialisation #### */ long int old_N_Protect = save_N_Protected(); jt = INTEGER(jT)[0]; /* method flag */ n_eq = LENGTH(y); /* number of equations */ nt = LENGTH(times); maxit = 10; /* number of iterations */ mflag = INTEGER(verbose)[0]; nroot = INTEGER(nRoot)[0]; /* number of roots (lsodar, lsode, lsodes) */ solver = INTEGER(Solver)[0]; /* 1=lsoda,2=lsode,3=lsodeS,4=lsodar,5=vode, 6=lsoder, 7 = lsodeSr */ /* is function a dll ?*/ if (inherits(derivfunc, "NativeSymbol")) { isDll = 1; } else { isDll = 0; } /* initialise output ... */ initOutC(isDll, &nout, &ntot, n_eq, nOut, Rpar, Ipar); /* copies of variables that will be changed in the FORTRAN subroutine */ xytmp = (double *) R_alloc(n_eq, sizeof(double)); for (j = 0; j < n_eq; j++) xytmp[j] = REAL(y)[j]; latol = LENGTH(atol); Atol = (double *) R_alloc((int) latol, sizeof(double)); lrtol = LENGTH(rtol); Rtol = (double *) R_alloc((int) lrtol, sizeof(double)); liw = INTEGER (lIw)[0]; iwork = (int *) R_alloc(liw, sizeof(int)); for (j=0; j 0 || islag == 1) { dy = (double *) R_alloc(n_eq, sizeof(double)); for (j = 0; j < n_eq; j++) dy[j] = 0.; } R_envir = rho; if (isDll) { /* DLL address passed to FORTRAN */ deriv_func = (C_deriv_func_type *) R_ExternalPtrAddrFn_(derivfunc); /* no need to communicate with R - but output variables set here */ /* here overruling deriv_func if forcing */ if (isForcing) { DLL_deriv_func = deriv_func; deriv_func = (C_deriv_func_type *) C_deriv_func_forc; } } else { /* interface function between FORTRAN and C/R passed to FORTRAN */ deriv_func = (C_deriv_func_type *) C_deriv_func; /* needed to communicate with R */ R_deriv_func = derivfunc; } R_envir = rho; /* karline: this to allow merging compiled and R-code (e.g. events)*/ if (!isNull(jacfunc) && solver != 3 && solver != 7) { /* lsodes uses jac_vec */ if (isDll) jac_func = (C_jac_func_type *) R_ExternalPtrAddrFn_(jacfunc); else { R_jac_func = jacfunc; jac_func = C_jac_func; } } else if (!isNull(jacfunc) && (solver == 3 || solver == 7)) { /*lsodes*/ if (isDll) jac_vec = (C_jac_vec_type *) R_ExternalPtrAddrFn_(jacfunc); else { R_jac_vec = jacfunc; jac_vec = C_jac_vec; } } if ((solver == 4 || solver == 6 || solver == 7) && nroot > 0) /* lsodar, lsoder, lsodeSr */ { jroot = (int *) R_alloc(nroot, sizeof(int)); for (j=0; j 1 && lrtol == 1 ) itol = 2; if (latol == 1 && lrtol > 1 ) itol = 3; if (latol > 1 && lrtol > 1 ) itol = 4; for (j = 0; j < lrtol; j++) Rtol[j] = REAL(rtol)[j]; for (j = 0; j < latol; j++) Atol[j] = REAL(atol)[j]; itask = INTEGER(iTask)[0]; if (isEvent) itask = 4; if (islag) itask = 5; /* one step and return */ if (isEvent && islag) itask = 5; istate = 1; iopt = 0; ss = 0.; is = 0 ; for (i = 5; i < 8 ; i++) ss = ss+rwork[i]; for (i = 5; i < 10; i++) is = is+iwork[i]; if (ss >0 || is > 0) iopt = 1; /* non-standard input */ /* #### initial time step #### */ tin = REAL(times)[0]; REAL(YOUT)[0] = tin; for (j = 0; j < n_eq; j++) REAL(YOUT)[j+1] = REAL(y)[j]; if (islag == 1) { if (isDll == 1) /* function in DLL and output */ // + thpe deriv_func (&n_eq, &tin, xytmp, dy, out, ipar); // + thpe else // + thpe C_deriv_func (&n_eq, &tin, xytmp, dy, out, ipar); updatehistini(tin, xytmp, dy, rwork, iwork); } if (nout>0) { tin = REAL(times)[0]; if (isDll == 1) /* function in DLL and output */ deriv_func (&n_eq, &tin, xytmp, dy, out, ipar) ; else C_deriv_out(&nout,&tin,xytmp,dy,out); for (j = 0; j < nout; j++) REAL(YOUT)[j + n_eq + 1] = out[j]; } iroot = 0; /* #### main time loop #### */ for (it = 0; it < nt-1; it++) { tin = REAL(times)[it]; tout = REAL(times)[it+1]; if (isEvent) { updateevent(&tin, xytmp, &istate); // check tEvent > tout to account for root events if ((iEvent < nEvent)&&(tEvent > tout)) { rwork[0] = tEvent; } else { rwork[0] = REAL(times)[nt-1]; } } repcount = 0; do { if (islag) rwork[0] = tout; /* error control */ if (istate == -2) { for (j = 0; j < lrtol; j++) Rtol[j] *= 10.0; for (j = 0; j < latol; j++) Atol[j] *= 10.0; warning("Excessive precision requested. `rtol' and `atol' have been scaled upwards by the factor %g\n",10.0); istate = 3; } if (solver == 1) { F77_CALL(dlsoda) (deriv_func, &n_eq, xytmp, &tin, &tout, &itol, Rtol, Atol, &itask, &istate, &iopt, rwork, &lrw, iwork, &liw, jac_func, &jt, out, ipar); } else if (solver == 2) { F77_CALL(dlsode) (deriv_func, &n_eq, xytmp, &tin, &tout, &itol, Rtol, Atol, &itask, &istate, &iopt, rwork, &lrw, iwork, &liw, jac_func, &jt, out, ipar); } else if (solver == 3) { F77_CALL(dlsodes) (deriv_func, &n_eq, xytmp, &tin, &tout, &itol, Rtol, Atol, &itask, &istate, &iopt, rwork, &lrw, iwork, &liw, rwork, jac_vec, &jt, out, ipar); /*rwork: iwk in fortran*/ } else if (solver == 4) { F77_CALL(dlsodar) (deriv_func, &n_eq, xytmp, &tin, &tout, &itol, Rtol, Atol, &itask, &istate, &iopt, rwork, &lrw, iwork, &liw, jac_func, &jt, root_func, &nroot, jroot, out, ipar); } else if (solver == 5) { F77_CALL(dvode) (deriv_func, &n_eq, xytmp, &tin, &tout, &itol, Rtol, Atol, &itask, &istate, &iopt, rwork, &lrw, iwork, &liw, jac_func, &jt, out, ipar); } else if (solver == 6) { F77_CALL(dlsoder) (deriv_func, &n_eq, xytmp, &tin, &tout, &itol, Rtol, Atol, &itask, &istate, &iopt, rwork, &lrw, iwork, &liw, jac_func, &jt, root_func, &nroot, jroot, out, ipar); } else if (solver == 7) { F77_CALL(dlsodesr) (deriv_func, &n_eq, xytmp, &tin, &tout, &itol, Rtol, Atol, &itask, &istate, &iopt, rwork, &lrw, iwork, &liw, rwork, jac_vec, &jt, root_func, &nroot, jroot, /*rwork: iwk in fortran*/ out, ipar); lyh = iwork[21]; } /* in case size of timesteps is called for */ timesteps [0] = rwork[10]; timesteps [1] = rwork[11]; if (istate == -1) { warning("an excessive amount of work (> maxsteps ) was done, but integration was not successful - increase maxsteps"); } else if (istate == 3 && (solver == 4 || solver == 6 || solver == 7)){ /* root found - take into account if an EVENT */ if (isEvent && rootevent) { pt = tEvent; tEvent = tin; /* function evaluations set to 0 again . */ for (j=0; j<3; j++) evals[j] = evals[j] + iwork[10+j]; if (iroot < Rootsave) { troot[iroot] = tin; for (j = 0; j < nroot; j++) if (jroot[j] == 1) nrroot[iroot] = j+1; for (j = 0; j < n_eq; j++) valroot[iroot*n_eq+j] = xytmp[j]; } iroot ++; iterm = 0; /* check if simulation should be terminated */ for (j = 0; j < nroot; j++) if (jroot[j] == 1 && termroot[j] == 1) iterm = 1; if (iterm == 0) { updateevent(&tin, xytmp, &istate); tEvent = pt; istate = 1; repcount = 0; if (mflag ==1) Rprintf("root found at time %g\n",tin); } else { istate = - 30; repcount = 50; if (mflag ==1) Rprintf("TERMINAL root found at time %g\n",tin); } } else{ istate = -20; repcount = 50; } } else if (istate == -2) { warning("Excessive precision requested. scale up `rtol' and `atol' e.g by the factor %g\n",10.0); } else if (istate == -4) { warning("repeated error test failures on a step, but integration was successful - singularity ?"); } else if (istate == -5) { warning("repeated convergence test failures on a step, but integration was successful - inaccurate Jacobian matrix?"); } else if (istate == -6) { warning("Error term became zero for some i: pure relative error control (ATOL(i)=0.0) for a variable which is now vanished"); } if (islag == 1) { if (isDll == 1) /* function in DLL and output */ // + thpe deriv_func (&n_eq, &tin, xytmp, dy, out, ipar); // + thpe else // + thpe C_deriv_func (&n_eq, &tin, xytmp, dy, out, ipar); updatehist(tin, xytmp, dy, rwork, iwork); repcount = 0; } repcount ++; } while (tin < tout && istate >= 0 && repcount < maxit); if (istate == -3) { error("illegal input detected before taking any integration steps - see written message"); unprotect_all(); } else { REAL(YOUT)[(it+1)*(ntot+1)] = tin; for (j = 0; j < n_eq; j++) REAL(YOUT)[(it+1)*(ntot + 1) + j + 1] = xytmp[j]; if (nout>0) { if (isDll == 1) /* function in DLL and output */ deriv_func (&n_eq, &tin, xytmp, dy, out, ipar) ; else C_deriv_out(&nout,&tin,xytmp,dy,out); for (j = 0; j < nout; j++) REAL(YOUT)[(it+1)*(ntot + 1) + j + n_eq + 1] = out[j]; } } /* #### an error occurred #### */ if (istate < 0 || tin < tout) { if (istate > -20) returnearly (1, it, ntot); else returnearly (0, it, ntot); /* stop because a root was found */ break; } } /* end main time loop */ /* #### returning output #### */ if (isEvent && rootevent && iroot > 0) for (j=0; j<3; j++) iwork[10+j] = evals[j]; // thpe-test: reduce ilen from 23 to 21 terminate(istate, iwork, 21, 0, rwork, 5,10); /* istate, iwork, rwork */ if (istate <= -20) INTEGER(ISTATE)[0] = 3; if (istate == -20 && nroot > 0) { PROTECT(IROOT = allocVector(INTSXP, nroot));incr_N_Protect(); for (k = 0;k 0) { /* root + events */ PROTECT(NROOT = allocVector(INTSXP, 1));incr_N_Protect(); INTEGER(NROOT)[0] = iroot; if (iroot > Rootsave) iroot = Rootsave; PROTECT(TROOT = allocVector(REALSXP, iroot)); incr_N_Protect(); for (k = 0; k < iroot; k++) REAL(TROOT)[k] = troot[k]; PROTECT(VROOT = allocVector(REALSXP, iroot*n_eq)); incr_N_Protect(); for (k = 0; k < iroot*n_eq; k++) REAL(VROOT)[k] = valroot[k]; PROTECT(IROOT = allocVector(INTSXP, iroot)); incr_N_Protect(); for (k = 0; k < iroot; k++) INTEGER(IROOT)[k] = nrroot[k]; if (istate > 0 ) { setAttrib(YOUT, install("troot"), TROOT); setAttrib(YOUT, install("nroot"), NROOT); setAttrib(YOUT, install("valroot"), VROOT); setAttrib(YOUT, install("indroot"), IROOT); } else { setAttrib(YOUT2, install("troot"), TROOT); setAttrib(YOUT2, install("nroot"), NROOT); setAttrib(YOUT2, install("valroot"), VROOT); setAttrib(YOUT2, install("indroot"), IROOT); } } /* #### termination #### */ restore_N_Protected(old_N_Protect); unlock_solver(); if (istate > 0) return(YOUT); else return(YOUT2); } deSolve/src/rk_fixed.c0000754000175100001440000001233313131751003014415 0ustar hornikusers/*==========================================================================*/ /* Runge-Kutta Solvers, (C) Th. Petzoldt, License: GPL >=2 */ /* General RK Solver for methods with adaptive step size */ /* -- main loop == core function -- */ /*==========================================================================*/ #include "rk_util.h" void rk_fixed( /* integers */ int fsal, int neq, int stage, int isDll, int isForcing, int verbose, int nknots, int interpolate, int maxsteps, int nt, /* int pointers */ int* _iknots, int* _it, int* _it_ext, int* _it_tot, int* istate, int* ipar, /* double */ double t, double tmax, double hini, /* double pointers */ double* _dt, /* arrays */ double* tt, double* y0, double* y1, double* dy1, double* f, double* y, double* Fj, double* tmp, double* FF, double* rr, double* A, double* out, double* bb1, double* cc, double* yknots, double* yout, /* SEXPs */ SEXP Func, SEXP Parms, SEXP Rho ) { int i = 0, j = 0, one = 1; int iknots = *_iknots, it = *_it, it_ext = *_it_ext, it_tot = *_it_tot; double t_ext; double dt = *_dt; /*------------------------------------------------------------------------*/ /* Main Loop */ /*------------------------------------------------------------------------*/ //Rprintf("1: dt, hini = %g , %g\n", dt, hini); do { /* select time step (possibly irregular) */ if (fabs(hini) < (DBL_EPSILON * 100.0)) dt = tt[it] - tt[it-1]; else dt = fmin(fabs(hini), fabs(tmax - t)) * sign(hini); //Rprintf("dt, hini = %g , %g\n", dt, hini); timesteps[0] = timesteps[1]; timesteps[1] = dt; /****** Prepare Coefficients from Butcher table ******/ /* NOTE: the fixed-step solver needs coefficients as vector, not matrix! */ for (j = 0; j < stage; j++) { if (j == 0) for(i = 0; i < neq; i++) Fj[i] = 0; else for(i = 0; i < neq; i++) Fj[i] = A[j] * FF[i + neq * (j - 1)] * dt; for (int i = 0; i < neq; i++) { tmp[i] = Fj[i] + y0[i]; } /****** Compute Derivatives ******/ derivs(Func, t + dt * cc[j], tmp, Parms, Rho, FF, out, j, neq, ipar, isDll, isForcing); } /*====================================================================*/ /* Estimation of new values */ /*====================================================================*/ /* use BLAS with reduced error checking */ blas_matprod1(FF, neq, stage, bb1, stage, one, dy1); it_tot++; /* count total number of time steps */ for (i = 0; i < neq; i++) { y1[i] = y0[i] + dt * dy1[i]; } /*====================================================================*/ /* Interpolation and Data Storage */ /*====================================================================*/ if (interpolate) { /*------------------------------------------------------------------*/ /* "Neville-Aitken-Interpolation"; */ /* the fixed step integrators have no dense output */ /*------------------------------------------------------------------*/ /* (1) collect number "nknots" of knots in advance */ yknots[iknots] = t + dt; /* time in first column */ for (i = 0; i < neq; i++) yknots[iknots + nknots * (1 + i)] = y1[i]; if (iknots < (nknots - 1)) { iknots++; } else { /* (2) do polynomial interpolation */ t_ext = tt[it_ext]; while (t_ext <= t + dt) { neville(yknots, &yknots[nknots], t_ext, tmp, nknots, neq); /* (3) store outputs */ if (it_ext < nt) { yout[it_ext] = t_ext; for (i = 0; i < neq; i++) yout[it_ext + nt * (1 + i)] = tmp[i]; } if(it_ext < nt-1) t_ext = tt[++it_ext]; else break; } shiftBuffer(yknots, nknots, neq + 1); } } else { /*--------------------------------------------------------------------*/ /* No interpolation mode(for step to step integration); */ /* results are stored after the call */ /*--------------------------------------------------------------------*/ } /*--------------------------------------------------------------------*/ /* next time step */ /*--------------------------------------------------------------------*/ t = t + dt; it++; for (i = 0; i < neq; i++) y0[i] = y1[i]; if (it_ext > nt) { Rprintf("error in RK solver rk_fixed.c: output buffer overflow\n"); break; } if (it_tot > maxsteps) { istate[0] = -1; warning("Number of time steps %i exceeded maxsteps at t = %g\n", it, t); break; } /* tolerance to avoid rounding errors */ } while (fabs(t - tmax) > 100.0 * DBL_EPSILON); /* end of rk main loop */ /* return reference values */ *_iknots = iknots; *_it = it; *_it_ext = it_ext; *_it_tot = it_tot; } deSolve/src/forcings.c0000754000175100001440000002301113131751003014427 0ustar hornikusers/* deals with forcing functions and events; Karline Soetaert */ #include "deSolve.h" #include "externalptr.h" /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Forcing functions (compiled code) from deSolve version 1.5 Events (R- and compiled code) from deSolve version 1.6 **FORCING FUNCTIONS**, or external variables need to be interpolated at each time step. This is done in this part of C-code. "initForcings" creates forcing function vectors passed from an R-list "initforcings" puts a pointer to the vector that contains the forcing functions in the DLL. This is done by calling "Initdeforc"; here the C-globals are initialised . Each time-step, before entering the compiled code, the forcing function variables are interpolated to the current time (function ("updateforc"). **EVENTS** occur when the value of state variables change abruptly. This cannot be easily handled in the integrators, where state variables change via the derivatives only. Events are either specified in a data.frame, or via an event function, specified in R-code or in compiled code. For events, specified in R-code, function "C_event_func" provides the C-interface. "initEvents" creates initialises the events, based on information passed from an R-list. Each time-step, it is tested whether an event occurs ("updateevent") version 1.11: certain roots associated to eventa can terminate simulation +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ int finit = 0; /*=========================================================================== ----- Check for presence of forcing functions ----- function "initForcings" checks if forcing functions are present and if so, create the vectors that contain the times (Tvec), the forcing values (Fvec) the start position of each forcing function variable (Ivec), and the interpolation method (fmethod). =========================================================================== */ int initForcings(SEXP flist) { SEXP Tvec, Fvec, Ivec, initforc; int i, j, isForcing = 0; init_func_type *initforcings; initforc = getListElement(flist, "ModelForc"); if (!isNull(initforc)) { Tvec = getListElement(flist, "tmat"); Fvec = getListElement(flist, "fmat"); Ivec = getListElement(flist, "imat"); nforc = LENGTH(Ivec)-2; /* nforc, fvec, ivec = globals */ i = LENGTH(Fvec); fvec = (double *) R_alloc((int) i, sizeof(double)); for (j = 0; j < i; j++) fvec[j] = REAL(Fvec)[j]; tvec = (double *) R_alloc((int) i, sizeof(double)); for (j = 0; j < i; j++) tvec[j] = REAL(Tvec)[j]; i = LENGTH (Ivec)-1; /* last element: the interpolation method...*/ ivec = (int *) R_alloc(i, sizeof(int)); for (j = 0; j < i; j++) ivec[j] = INTEGER(Ivec)[j]; fmethod = INTEGER(Ivec)[i]; initforcings = (init_func_type *) R_ExternalPtrAddrFn_(initforc); initforcings(Initdeforc); isForcing = 1; } return(isForcing); } /*=========================================================================== ----- INITIALISATION called from compiled code ----- 1. Check the length of forcing functions in solver call and code in DLL 2. Initialise the forcing function vectors 3. set pointer to DLL; FORTRAN common block or C globals / =========================================================================== */ void Initdeforc(int *N, double *forc) { int i, ii; if ((*N) != nforc) { warning("Number of forcings passed to solver, %i; number in DLL, %i\n",nforc, *N); PROBLEM "Confusion over the length of forc" ERROR; } /* for each forcing function: index to current position of data, current value, interpolation factor, current forcing time, next forcing time,.. */ finit = 1; findex = (int *) R_alloc(nforc, sizeof(int)); intpol = (double *) R_alloc(nforc, sizeof(double)); maxindex = (int *) R_alloc(nforc, sizeof(int)); /* Input is in three vectors: tvec, fvec: time and value; ivec : index to each forcing in tvec and fvec */ for (i = 0; i tvec[ii+1]){ if (ii+2 > maxindex[i]) { /* this probably redundant...*/ zerograd=1; break; } ii = ii+1; } while (*time < tvec[ii]){ /* test here for ii < 1 ?...*/ ii = ii-1; } if (ii != findex[i]) { findex[i] = ii; if ((zerograd == 0) & (fmethod == 1)) { /* fmethod 1=linear */ intpol[i] = (fvec[ii+1]-fvec[ii])/(tvec[ii+1]-tvec[ii]); } else { intpol[i] = 0; } } forcings[i]=fvec[ii]+intpol[i]*(*time-tvec[ii]); } } /* ============================================================================ events: time, svar number, value, and method; in a list ==========================================================================*/ typedef void event_func_type(int*, double*, double*); event_func_type *event_func; static void C_event_func (int *n, double *t, double *y) { int i; SEXP R_fcall, Time, ans; for (i = 0; i < *n; i++) REAL(Y)[i] = y[i]; PROTECT(Time = ScalarReal(*t)); incr_N_Protect(); PROTECT(R_fcall = lang3(R_event_func,Time,Y)); incr_N_Protect(); PROTECT(ans = eval(R_fcall, R_envir)); incr_N_Protect(); for (i = 0; i < *n; i++) y[i] = REAL(ans)[i]; my_unprotect(3); } int initEvents(SEXP elist, SEXP eventfunc, int nroot) { SEXP Time, SVar, Value, Method, Type, Root, maxRoot, Terminateroot; int i, j, isEvent = 0; Time = getListElement(elist, "Time"); Root = getListElement(elist, "Root"); if (!isNull(Root)) { /* event combined with root - allocate memory to save time of root*/ rootevent = INTEGER(Root)[0]; maxRoot = getListElement(elist, "Rootsave"); if (!isNull(maxRoot)) Rootsave = INTEGER(maxRoot)[0]; else Rootsave = 0; if (Rootsave > 0) { nrroot = (int *)R_alloc( (int)Rootsave, sizeof(int) ); for (i = 0; i < Rootsave; i++) nrroot[i] = 0; troot = (double *)R_alloc( (int)Rootsave, sizeof(double) ); for (i = 0; i < Rootsave; i++) troot[i] = 0.; valroot = (double *)R_alloc( (int)Rootsave*n_eq, sizeof(double) ); for (i = 0; i < Rootsave*n_eq; i++) valroot[i] = 0.; } /* to allow certain roots to stop simulation */ termroot = (int *)R_alloc( nroot, sizeof(int) ); for (i = 0; i < nroot; i++) termroot[i] = 0; Terminateroot = getListElement(elist, "Terminalroot"); for (i = 0; i < LENGTH(Terminateroot); i++) { j = INTEGER(Terminateroot)[i]-1; if (j > -1 && j < nroot) termroot[j] = 1; } } else rootevent = 0; if (!isNull(Time)) { isEvent = 1; Type = getListElement(elist,"Type"); typeevent = INTEGER(Type)[0]; i = LENGTH(Time); timeevent = (double *) R_alloc((int) i+1, sizeof(double)); for (j = 0; j < i; j++) timeevent[j] = REAL(Time)[j]; /* cap the event timer with an event that can't possibly be reached */ //timeevent[i] = timeevent[0] - 1; // J. Stott timeevent[i] = DOUBLE_XMIN; // thpe if (typeevent == 1) { /* specified in a data.frame */ SVar = getListElement(elist,"SVar"); Value = getListElement(elist,"Value"); Method = getListElement(elist,"Method"); valueevent = (double *) R_alloc((int) i, sizeof(double)); for (j = 0; j < i; j++) valueevent[j] = REAL(Value)[j]; svarevent = (int *) R_alloc(i, sizeof(int)); for (j = 0; j < i; j++) svarevent[j] = INTEGER(SVar)[j]-1; methodevent = (int *) R_alloc(i, sizeof(int)); for (j = 0; j < i; j++) methodevent[j] = INTEGER(Method)[j]; } else { /* a function: either R (typeevent=2) or compiled code (3)... */ if (typeevent == 3) { event_func = (event_func_type *) R_ExternalPtrAddrFn_(eventfunc); } else { event_func = C_event_func; R_event_func = eventfunc; } } tEvent = timeevent[0]; iEvent = 0; nEvent = i; } return(isEvent); } void updateevent(double *t, double *y, int *istate) { int svar, method; double value; if (tEvent == *t) { if (typeevent == 1) { /* specified in a data.frame */ do { svar = svarevent[iEvent]; method = methodevent[iEvent]; value = valueevent[iEvent]; if (method == 1) y[svar] = value; else if (method == 2) y[svar] = y[svar] + value; else if (method == 3) y[svar] = y[svar] * value; tEvent = timeevent[++iEvent]; } while (tEvent == *t); } else { /* a root event or specific times */ event_func(&n_eq, t, y); if (!rootevent) tEvent = timeevent[++iEvent]; /* karline: this was toggled off - why?*/ } *istate = 1; } } deSolve/src/call_rk4.c0000754000175100001440000001701013131751003014312 0ustar hornikusers/*==========================================================================*/ /* Runge-Kutta Solvers, (C) Th. Petzoldt, License: GPL >=2 */ /* rk4 Fixed Step Integrator */ /* (special version with less overhead than the general solution) */ /*==========================================================================*/ #include "rk_util.h" SEXP call_rk4(SEXP Xstart, SEXP Times, SEXP Func, SEXP Initfunc, SEXP Parms, SEXP Nout, SEXP Rho, SEXP Verbose, SEXP Rpar, SEXP Ipar, SEXP Flist) { /* Initialization */ long int old_N_Protect = save_N_Protected(); double *tt = NULL, *xs = NULL; double *tmp, *FF, *out; SEXP R_y, R_f, R_f1, R_f2, R_f3, R_f4; double *y, *f, *f1, *f2, *f3, *f4; SEXP R_y0, R_yout; double *y0, *yout; double t, dt; int i = 0, j=0, it=0, nt = 0, neq=0; int isForcing; /*------------------------------------------------------------------------*/ /* Processing of Arguments */ /*------------------------------------------------------------------------*/ PROTECT(Times = AS_NUMERIC(Times)); incr_N_Protect(); tt = NUMERIC_POINTER(Times); nt = length(Times); PROTECT(Xstart = AS_NUMERIC(Xstart)); incr_N_Protect(); xs = NUMERIC_POINTER(Xstart); neq = length(Xstart); tmp = (double *) R_alloc(neq, sizeof(double)); FF = (double *) R_alloc(neq, sizeof(double)); int nout = INTEGER(Nout)[0]; /* n of global outputs if func is in a DLL */ int verbose = INTEGER(Verbose)[0]; /*------------------------------------------------------------------------*/ /* timesteps (for advection computation in ReacTran) */ /*------------------------------------------------------------------------*/ for (i = 0; i < 2; i++) timesteps[i] = 0; /*------------------------------------------------------------------------*/ /* DLL, ipar, rpar (for compatibility with lsoda) */ /*------------------------------------------------------------------------*/ int isDll = FALSE; //int ntot = 0; int lrpar= 0, lipar = 0; int *ipar = NULL; if (inherits(Func, "NativeSymbol")) { /* function is a dll */ isDll = TRUE; if (nout > 0) isOut = TRUE; //ntot = neq + nout; /* length of yout */ lrpar = nout + LENGTH(Rpar); /* length of rpar; LENGTH(Rpar) is always >0 */ lipar = 3 + LENGTH(Ipar); /* length of ipar */ } else { /* function is not a dll */ isDll = FALSE; isOut = FALSE; //ntot = neq; lipar = 3; /* in lsoda = 1; */ lrpar = nout; /* in lsoda = 1; */ } out = (double *) R_alloc(lrpar, sizeof(double)); ipar = (int *) R_alloc(lipar, sizeof(int)); ipar[0] = nout; /* first 3 elements of ipar are special */ ipar[1] = lrpar; ipar[2] = lipar; if (isDll == 1) { /* other elements of ipar are set in R-function lsodx via argument *ipar* */ for (j = 0; j < LENGTH(Ipar); j++) ipar[j+3] = INTEGER(Ipar)[j]; /* out: first nout elements of out are reserved for output variables other elements are set via argument *rpar* */ for (j = 0; j < nout; j++) out[j] = 0.0; for (j = 0; j < LENGTH(Rpar); j++) out[nout+j] = REAL(Rpar)[j]; } /*------------------------------------------------------------------------*/ /* Allocation of Workspace */ /*------------------------------------------------------------------------*/ PROTECT(R_y0 = allocVector(REALSXP, neq)); incr_N_Protect(); PROTECT(R_f = allocVector(REALSXP, neq)); incr_N_Protect(); PROTECT(R_y = allocVector(REALSXP, neq)); incr_N_Protect(); PROTECT(R_f1 = allocVector(REALSXP, neq)); incr_N_Protect(); PROTECT(R_f2 = allocVector(REALSXP, neq)); incr_N_Protect(); PROTECT(R_f3 = allocVector(REALSXP, neq)); incr_N_Protect(); PROTECT(R_f4 = allocVector(REALSXP, neq)); incr_N_Protect(); y0 = REAL(R_y0); f = REAL(R_f); y = REAL(R_y); f1 = REAL(R_f1); f2 = REAL(R_f2); f3 = REAL(R_f3); f4 = REAL(R_f4); /* matrix for holding the outputs */ PROTECT(R_yout = allocMatrix(REALSXP, nt, neq + nout + 1)); incr_N_Protect(); yout = REAL(R_yout); /* attribute that stores state information, similar to lsoda */ SEXP R_istate; int *istate; PROTECT(R_istate = allocVector(INTSXP, 22)); incr_N_Protect(); istate = INTEGER(R_istate); istate[0] = 0; /* assume succesful return */ for (i = 0; i < 22; i++) istate[i] = 0; /*------------------------------------------------------------------------*/ /* Initialization of Parameters (for DLL functions) */ /*------------------------------------------------------------------------*/ initParms(Initfunc, Parms); isForcing = initForcings(Flist); /*------------------------------------------------------------------------*/ /* Initialization of Integration Loop */ /*------------------------------------------------------------------------*/ yout[0] = tt[0]; /* initial time */ for (i = 0; i < neq; i++) { y0[i] = xs[i]; yout[(i + 1) * nt] = y0[i]; } /*------------------------------------------------------------------------*/ /* Main Loop */ /*------------------------------------------------------------------------*/ for (it = 0; it < nt - 1; it++) { t = tt[it]; dt = tt[it + 1] - t; timesteps[0] = timesteps[1]; timesteps[1] = dt; if (verbose) Rprintf("Time steps = %d / %d time = %e\n", it + 1, nt, t); derivs(Func, t, y0, Parms, Rho, f1, out, 0, neq, ipar, isDll, isForcing); for (i = 0; i < neq; i++) { f1[i] = dt * f1[i]; f[i] = y0[i] + 0.5 * f1[i]; } derivs(Func, t + 0.5*dt, f, Parms, Rho, f2, out, 0, neq, ipar, isDll, isForcing); for (i = 0; i < neq; i++) { f2[i] = dt * f2[i]; f[i] = y0[i] + 0.5 * f2[i]; } derivs(Func, t + 0.5*dt, f, Parms, Rho, f3, out, 0, neq, ipar, isDll, isForcing); for (i = 0; i < neq; i++) { f3[i] = dt * f3[i]; f[i] = y0[i] + f3[i]; } derivs(Func, t + dt, f, Parms, Rho, f4, out, 0, neq, ipar, isDll, isForcing); for (i = 0; i < neq; i++) { f4[i] = dt * f4[i]; } /* Final computation of y */ for (i = 0; i < neq; i++) { f[i] = (f1[i] + 2.0 * f2[i] + 2.0 * f3[i] + f4[i]) / 6.0; y[i] = y0[i] + f[i]; y0[i] = y[i]; /* next time step */ } /* Store outputs */ if (it < nt) { yout[it + 1] = t + dt; for (i = 0; i < neq; i++) yout[it + 1 + nt * (1 + i)] = y[i]; } } /* end of rk main loop */ /*------------------------------------------------------------------------*/ /* call derivs again to get global outputs */ /* "-1" in derivs suppresses unnecessary copying */ /*------------------------------------------------------------------------*/ for (int j = 0; j < nt; j++) { t = yout[j]; for (i = 0; i < neq; i++) tmp[i] = yout[j + nt * (1 + i)]; derivs(Func, t, tmp, Parms, Rho, FF, out, -1, neq, ipar, isDll, isForcing); for (i = 0; i < nout; i++) { yout[j + nt * (1 + neq + i)] = out[i]; } } /* Attach diagnostic information (codes are compatible to lsoda) */ setIstate(R_yout, R_istate, istate, it, 4, 0, 4, 0); /* release R resources */ timesteps[0] = 0; timesteps[1] = 0; restore_N_Protected(old_N_Protect); return(R_yout); } deSolve/src/DLLutil.c0000754000175100001440000000353213131751003014134 0ustar hornikusers/* Functions to test compiled code implementation of ODE and DAE */ #include #include #include "deSolve.h" #include "externalptr.h" SEXP call_DLL(SEXP y, SEXP dY, SEXP time, SEXP func, SEXP initfunc, SEXP parms, SEXP nOut, SEXP Rpar, SEXP Ipar, SEXP Type, SEXP flist) { SEXP yout; double *ytmp, *dy, tin, *delta, cj; int ny, j, type, ires, isDll, isForcing, nout=0, ntot=0; C_deriv_func_type *derivs; C_res_func_type *res; //init_N_Protect(); long int old_N_Protect = save_N_Protected(); ny = LENGTH(y); type = INTEGER(Type)[0]; /* function is a dll ?*/ if (inherits(func, "NativeSymbol")) { isDll = 1; } else { isDll = 0; } /* initialise output, parameters, forcings ... */ initOutR(isDll, &nout, &ntot, ny, nOut, Rpar, Ipar); initParms(initfunc, parms); isForcing = initForcings(flist); PROTECT(yout = allocVector(REALSXP,ntot)) ; incr_N_Protect(); tin = REAL(time)[0]; ytmp = (double *) R_alloc(ny, sizeof(double)); for (j = 0; j < ny; j++) ytmp[j] = REAL(y)[j]; dy = (double *) R_alloc(ny, sizeof(double)); for (j = 0; j < ny; j++) dy[j] = REAL(dY)[j]; if(isForcing == 1) updatedeforc(&tin); if (type == 1) { derivs = (C_deriv_func_type *) R_ExternalPtrAddrFn_(func); derivs (&ny, &tin, ytmp, dy, out, ipar) ; for (j = 0; j < ny; j++) REAL(yout)[j] = dy[j]; } else { res = (C_res_func_type *) R_ExternalPtrAddrFn_(func); delta = (double *) R_alloc(ny, sizeof(double)); for (j = 0; j < ny; j++) delta[j] = 0.; res (&tin, ytmp, dy, &cj, delta, &ires, out, ipar) ; for (j = 0; j < ny; j++) REAL(yout)[j] = delta[j]; } if (nout > 0) { for (j = 0; j < nout; j++) REAL(yout)[j + ny] = out[j]; } //unprotect_all(); restore_N_Protected(old_N_Protect); return(yout); } deSolve/src/daux.f0000754000175100001440000000121213131751003013560 0ustar hornikusers DOUBLE PRECISION FUNCTION D1MACH (IDUM) INTEGER IDUM C----------------------------------------------------------------------- C THIS ROUTINE COMPUTES THE UNIT ROUNDOFF OF THE MACHINE IN DOUBLE C PRECISION. THIS IS DEFINED AS THE SMALLEST POSITIVE MACHINE NUMBER C U SUCH THAT 1.0D0 + U .NE. 1.0D0 (IN DOUBLE PRECISION). C----------------------------------------------------------------------- DOUBLE PRECISION U, COMP U = 1.0D0 10 U = U*0.5D0 COMP = 1.0D0 + U IF (COMP .NE. 1.0D0) GO TO 10 D1MACH = U*2.0D0 RETURN C----------------------- END OF FUNCTION D1MACH ------------------------ END deSolve/src/ddaspk.f0000754000175100001440000073332213131751003014103 0ustar hornikusersC Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C karline: changed INFO, to also pass the index of the variables C error scaling ~ index of variables SUBROUTINE DDASPK (RES, NEQ, T, Y, YPRIME, TOUT, INFO, RTOL, ATOL, * IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR, JAC, PSOL) C C***BEGIN PROLOGUE DDASPK C***DATE WRITTEN 890101 (YYMMDD) C***REVISION DATE 910624 C***REVISION DATE 920929 (CJ in RES call, RES counter fix.) C***REVISION DATE 921215 (Warnings on poor iteration performance) C***REVISION DATE 921216 (NRMAX as optional input) C***REVISION DATE 930315 (Name change: DDINI to DDINIT) C***REVISION DATE 940822 (Replaced initial condition calculation) C***REVISION DATE 941101 (Added linesearch in I.C. calculations) C***REVISION DATE 941220 (Misc. corrections throughout) C***REVISION DATE 950125 (Added DINVWT routine) C***REVISION DATE 950714 (Misc. corrections throughout) C***REVISION DATE 950802 (Default NRMAX = 5, based on tests.) C***REVISION DATE 950808 (Optional error test added.) C***REVISION DATE 950814 (Added I.C. constraints and INFO(14)) C***REVISION DATE 950828 (Various minor corrections.) C***REVISION DATE 951006 (Corrected WT scaling in DFNRMK.) C***REVISION DATE 960129 (Corrected RL bug in DLINSD, DLINSK.) C***REVISION DATE 960301 (Added NONNEG to SAVE statement.) C***CATEGORY NO. I1A2 C***KEYWORDS DIFFERENTIAL/ALGEBRAIC, BACKWARD DIFFERENTIATION FORMULAS, C IMPLICIT DIFFERENTIAL SYSTEMS, KRYLOV ITERATION C***AUTHORS Linda R. Petzold, Peter N. Brown, Alan C. Hindmarsh, and C Clement W. Ulrich C Center for Computational Sciences & Engineering, L-316 C Lawrence Livermore National Laboratory C P.O. Box 808, C Livermore, CA 94551 C***PURPOSE This code solves a system of differential/algebraic C equations of the form C G(t,y,y') = 0 , C using a combination of Backward Differentiation Formula C (BDF) methods and a choice of two linear system solution C methods: direct (dense or band) or Krylov (iterative). C This version is in double precision. C----------------------------------------------------------------------- C***DESCRIPTION C C *Usage: C C IMPLICIT DOUBLE PRECISION(A-H,O-Z) C INTEGER NEQ, INFO(N), IDID, LRW, LIW, IWORK(LIW), IPAR(*) C DOUBLE PRECISION T, Y(*), YPRIME(*), TOUT, RTOL(*), ATOL(*), C RWORK(LRW), RPAR(*) C EXTERNAL RES, JAC, PSOL C C CALL DDASPK (RES, NEQ, T, Y, YPRIME, TOUT, INFO, RTOL, ATOL, C * IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR, JAC, PSOL) C C Quantities which may be altered by the code are: C T, Y(*), YPRIME(*), INFO(1), RTOL, ATOL, IDID, RWORK(*), IWORK(*) C C C *Arguments: C C RES:EXT This is the name of a subroutine which you C provide to define the residual function G(t,y,y') C of the differential/algebraic system. C C NEQ:IN This is the number of equations in the system. C C T:INOUT This is the current value of the independent C variable. C C Y(*):INOUT This array contains the solution components at T. C C YPRIME(*):INOUT This array contains the derivatives of the solution C components at T. C C TOUT:IN This is a point at which a solution is desired. C C INFO(N):IN This is an integer array used to communicate details C of how the solution is to be carried out, such as C tolerance type, matrix structure, step size and C order limits, and choice of nonlinear system method. C N must be at least 20. C C RTOL,ATOL:INOUT These quantities represent absolute and relative C error tolerances (on local error) which you provide C to indicate how accurately you wish the solution to C be computed. You may choose them to be both scalars C or else both arrays of length NEQ. C C IDID:OUT This integer scalar is an indicator reporting what C the code did. You must monitor this variable to C decide what action to take next. C C RWORK:WORK A real work array of length LRW which provides the C code with needed storage space. C C LRW:IN The length of RWORK. C C IWORK:WORK An integer work array of length LIW which provides C the code with needed storage space. C C LIW:IN The length of IWORK. C C RPAR,IPAR:IN These are real and integer parameter arrays which C you can use for communication between your calling C program and the RES, JAC, and PSOL subroutines. C C JAC:EXT This is the name of a subroutine which you may C provide (optionally) for calculating Jacobian C (partial derivative) data involved in solving linear C systems within DDASPK. C C PSOL:EXT This is the name of a subroutine which you must C provide for solving linear systems if you selected C a Krylov method. The purpose of PSOL is to solve C linear systems involving a left preconditioner P. C C *Overview C C The DDASPK solver uses the backward differentiation formulas of C orders one through five to solve a system of the form G(t,y,y') = 0 C for y = Y and y' = YPRIME. Values for Y and YPRIME at the initial C time must be given as input. These values should be consistent, C that is, if T, Y, YPRIME are the given initial values, they should C satisfy G(T,Y,YPRIME) = 0. However, if consistent values are not C known, in many cases you can have DDASPK solve for them -- see INFO(11). C (This and other options are described in more detail below.) C C Normally, DDASPK solves the system from T to TOUT. It is easy to C continue the solution to get results at additional TOUT. This is C the interval mode of operation. Intermediate results can also be C obtained easily by specifying INFO(3). C C On each step taken by DDASPK, a sequence of nonlinear algebraic C systems arises. These are solved by one of two types of C methods: C * a Newton iteration with a direct method for the linear C systems involved (INFO(12) = 0), or C * a Newton iteration with a preconditioned Krylov iterative C method for the linear systems involved (INFO(12) = 1). C C The direct method choices are dense and band matrix solvers, C with either a user-supplied or an internal difference quotient C Jacobian matrix, as specified by INFO(5) and INFO(6). C In the band case, INFO(6) = 1, you must supply half-bandwidths C in IWORK(1) and IWORK(2). C C The Krylov method is the Generalized Minimum Residual (GMRES) C method, in either complete or incomplete form, and with C scaling and preconditioning. The method is implemented C in an algorithm called SPIGMR. Certain options in the Krylov C method case are specified by INFO(13) and INFO(15). C C If the Krylov method is chosen, you may supply a pair of routines, C JAC and PSOL, to apply preconditioning to the linear system. C If the system is A*x = b, the matrix is A = dG/dY + CJ*dG/dYPRIME C (of order NEQ). This system can then be preconditioned in the form C (P-inverse)*A*x = (P-inverse)*b, with left preconditioner P. C (DDASPK does not allow right preconditioning.) C Then the Krylov method is applied to this altered, but equivalent, C linear system, hopefully with much better performance than without C preconditioning. (In addition, a diagonal scaling matrix based on C the tolerances is also introduced into the altered system.) C C The JAC routine evaluates any data needed for solving systems C with coefficient matrix P, and PSOL carries out that solution. C In any case, in order to improve convergence, you should try to C make P approximate the matrix A as much as possible, while keeping C the system P*x = b reasonably easy and inexpensive to solve for x, C given a vector b. C C C *Description C C------INPUT - WHAT TO DO ON THE FIRST CALL TO DDASPK------------------- C C C The first call of the code is defined to be the start of each new C problem. Read through the descriptions of all the following items, C provide sufficient storage space for designated arrays, set C appropriate variables for the initialization of the problem, and C give information about how you want the problem to be solved. C C C RES -- Provide a subroutine of the form C C SUBROUTINE RES (T, Y, YPRIME, CJ, DELTA, IRES, RPAR, IPAR) C C to define the system of differential/algebraic C equations which is to be solved. For the given values C of T, Y and YPRIME, the subroutine should return C the residual of the differential/algebraic system C DELTA = G(T,Y,YPRIME) C DELTA is a vector of length NEQ which is output from RES. C C Subroutine RES must not alter T, Y, YPRIME, or CJ. C You must declare the name RES in an EXTERNAL C statement in your program that calls DDASPK. C You must dimension Y, YPRIME, and DELTA in RES. C C The input argument CJ can be ignored, or used to rescale C constraint equations in the system (see Ref. 2, p. 145). C Note: In this respect, DDASPK is not downward-compatible C with DDASSL, which does not have the RES argument CJ. C C IRES is an integer flag which is always equal to zero C on input. Subroutine RES should alter IRES only if it C encounters an illegal value of Y or a stop condition. C Set IRES = -1 if an input value is illegal, and DDASPK C will try to solve the problem without getting IRES = -1. C If IRES = -2, DDASPK will return control to the calling C program with IDID = -11. C C RPAR and IPAR are real and integer parameter arrays which C you can use for communication between your calling program C and subroutine RES. They are not altered by DDASPK. If you C do not need RPAR or IPAR, ignore these parameters by treat- C ing them as dummy arguments. If you do choose to use them, C dimension them in your calling program and in RES as arrays C of appropriate length. C C NEQ -- Set it to the number of equations in the system (NEQ .GE. 1). C C T -- Set it to the initial point of the integration. (T must be C a variable.) C C Y(*) -- Set this array to the initial values of the NEQ solution C components at the initial point. You must dimension Y of C length at least NEQ in your calling program. C C YPRIME(*) -- Set this array to the initial values of the NEQ first C derivatives of the solution components at the initial C point. You must dimension YPRIME at least NEQ in your C calling program. C C TOUT - Set it to the first point at which a solution is desired. C You cannot take TOUT = T. Integration either forward in T C (TOUT .GT. T) or backward in T (TOUT .LT. T) is permitted. C C The code advances the solution from T to TOUT using step C sizes which are automatically selected so as to achieve the C desired accuracy. If you wish, the code will return with the C solution and its derivative at intermediate steps (the C intermediate-output mode) so that you can monitor them, C but you still must provide TOUT in accord with the basic C aim of the code. C C The first step taken by the code is a critical one because C it must reflect how fast the solution changes near the C initial point. The code automatically selects an initial C step size which is practically always suitable for the C problem. By using the fact that the code will not step past C TOUT in the first step, you could, if necessary, restrict the C length of the initial step. C C For some problems it may not be permissible to integrate C past a point TSTOP, because a discontinuity occurs there C or the solution or its derivative is not defined beyond C TSTOP. When you have declared a TSTOP point (see INFO(4) C and RWORK(1)), you have told the code not to integrate past C TSTOP. In this case any tout beyond TSTOP is invalid input. C C INFO(*) - Use the INFO array to give the code more details about C how you want your problem solved. This array should be C dimensioned of length 20, though DDASPK uses only the C first 15 entries. You must respond to all of the following C items, which are arranged as questions. The simplest use C of DDASPK corresponds to setting all entries of INFO to 0. C C INFO(1) - This parameter enables the code to initialize itself. C You must set it to indicate the start of every new C problem. C C **** Is this the first call for this problem ... C yes - set INFO(1) = 0 C no - not applicable here. C See below for continuation calls. **** C C INFO(2) - How much accuracy you want of your solution C is specified by the error tolerances RTOL and ATOL. C The simplest use is to take them both to be scalars. C To obtain more flexibility, they can both be arrays. C The code must be told your choice. C C **** Are both error tolerances RTOL, ATOL scalars ... C yes - set INFO(2) = 0 C and input scalars for both RTOL and ATOL C no - set INFO(2) = 1 C and input arrays for both RTOL and ATOL **** C C INFO(3) - The code integrates from T in the direction of TOUT C by steps. If you wish, it will return the computed C solution and derivative at the next intermediate step C (the intermediate-output mode) or TOUT, whichever comes C first. This is a good way to proceed if you want to C see the behavior of the solution. If you must have C solutions at a great many specific TOUT points, this C code will compute them efficiently. C C **** Do you want the solution only at C TOUT (and not at the next intermediate step) ... C yes - set INFO(3) = 0 C no - set INFO(3) = 1 **** C C INFO(4) - To handle solutions at a great many specific C values TOUT efficiently, this code may integrate past C TOUT and interpolate to obtain the result at TOUT. C Sometimes it is not possible to integrate beyond some C point TSTOP because the equation changes there or it is C not defined past TSTOP. Then you must tell the code C this stop condition. C C **** Can the integration be carried out without any C restrictions on the independent variable T ... C yes - set INFO(4) = 0 C no - set INFO(4) = 1 C and define the stopping point TSTOP by C setting RWORK(1) = TSTOP **** C C INFO(5) - used only when INFO(12) = 0 (direct methods). C To solve differential/algebraic systems you may wish C to use a matrix of partial derivatives of the C system of differential equations. If you do not C provide a subroutine to evaluate it analytically (see C description of the item JAC in the call list), it will C be approximated by numerical differencing in this code. C Although it is less trouble for you to have the code C compute partial derivatives by numerical differencing, C the solution will be more reliable if you provide the C derivatives via JAC. Usually numerical differencing is C more costly than evaluating derivatives in JAC, but C sometimes it is not - this depends on your problem. C C **** Do you want the code to evaluate the partial deriv- C atives automatically by numerical differences ... C yes - set INFO(5) = 0 C no - set INFO(5) = 1 C and provide subroutine JAC for evaluating the C matrix of partial derivatives **** C C INFO(6) - used only when INFO(12) = 0 (direct methods). C DDASPK will perform much better if the matrix of C partial derivatives, dG/dY + CJ*dG/dYPRIME (here CJ is C a scalar determined by DDASPK), is banded and the code C is told this. In this case, the storage needed will be C greatly reduced, numerical differencing will be performed C much cheaper, and a number of important algorithms will C execute much faster. The differential equation is said C to have half-bandwidths ML (lower) and MU (upper) if C equation i involves only unknowns Y(j) with C i-ML .le. j .le. i+MU . C For all i=1,2,...,NEQ. Thus, ML and MU are the widths C of the lower and upper parts of the band, respectively, C with the main diagonal being excluded. If you do not C indicate that the equation has a banded matrix of partial C derivatives the code works with a full matrix of NEQ**2 C elements (stored in the conventional way). Computations C with banded matrices cost less time and storage than with C full matrices if 2*ML+MU .lt. NEQ. If you tell the C code that the matrix of partial derivatives has a banded C structure and you want to provide subroutine JAC to C compute the partial derivatives, then you must be careful C to store the elements of the matrix in the special form C indicated in the description of JAC. C C **** Do you want to solve the problem using a full (dense) C matrix (and not a special banded structure) ... C yes - set INFO(6) = 0 C no - set INFO(6) = 1 C and provide the lower (ML) and upper (MU) C bandwidths by setting C IWORK(1)=ML C IWORK(2)=MU **** C C INFO(7) - You can specify a maximum (absolute value of) C stepsize, so that the code will avoid passing over very C large regions. C C **** Do you want the code to decide on its own the maximum C stepsize ... C yes - set INFO(7) = 0 C no - set INFO(7) = 1 C and define HMAX by setting C RWORK(2) = HMAX **** C C INFO(8) - Differential/algebraic problems may occasionally C suffer from severe scaling difficulties on the first C step. If you know a great deal about the scaling of C your problem, you can help to alleviate this problem C by specifying an initial stepsize H0. C C **** Do you want the code to define its own initial C stepsize ... C yes - set INFO(8) = 0 C no - set INFO(8) = 1 C and define H0 by setting C RWORK(3) = H0 **** C C INFO(9) - If storage is a severe problem, you can save some C storage by restricting the maximum method order MAXORD. C The default value is 5. For each order decrease below 5, C the code requires NEQ fewer locations, but it is likely C to be slower. In any case, you must have C 1 .le. MAXORD .le. 5. C **** Do you want the maximum order to default to 5 ... C yes - set INFO(9) = 0 C no - set INFO(9) = 1 C and define MAXORD by setting C IWORK(3) = MAXORD **** C C INFO(10) - If you know that certain components of the C solutions to your equations are always nonnegative C (or nonpositive), it may help to set this C parameter. There are three options that are C available: C 1. To have constraint checking only in the initial C condition calculation. C 2. To enforce nonnegativity in Y during the integration. C 3. To enforce both options 1 and 2. C C When selecting option 2 or 3, it is probably best to try the C code without using this option first, and only use C this option if that does not work very well. C C **** Do you want the code to solve the problem without C invoking any special inequality constraints ... C yes - set INFO(10) = 0 C no - set INFO(10) = 1 to have option 1 enforced C no - set INFO(10) = 2 to have option 2 enforced C no - set INFO(10) = 3 to have option 3 enforced **** C C If you have specified INFO(10) = 1 or 3, then you C will also need to identify how each component of Y C in the initial condition calculation is constrained. C You must set: C IWORK(40+I) = +1 if Y(I) must be .GE. 0, C IWORK(40+I) = +2 if Y(I) must be .GT. 0, C IWORK(40+I) = -1 if Y(I) must be .LE. 0, while C IWORK(40+I) = -2 if Y(I) must be .LT. 0, while C IWORK(40+I) = 0 if Y(I) is not constrained. C C INFO(11) - DDASPK normally requires the initial T, Y, and C YPRIME to be consistent. That is, you must have C G(T,Y,YPRIME) = 0 at the initial T. If you do not know C the initial conditions precisely, in some cases C DDASPK may be able to compute it. C C Denoting the differential variables in Y by Y_d C and the algebraic variables by Y_a, DDASPK can solve C one of two initialization problems: C 1. Given Y_d, calculate Y_a and Y'_d, or C 2. Given Y', calculate Y. C In either case, initial values for the given C components are input, and initial guesses for C the unknown components must also be provided as input. C C **** Are the initial T, Y, YPRIME consistent ... C C yes - set INFO(11) = 0 C no - set INFO(11) = 1 to calculate option 1 above, C or set INFO(11) = 2 to calculate option 2 **** C C If you have specified INFO(11) = 1, then you C will also need to identify which are the C differential and which are the algebraic C components (algebraic components are components C whose derivatives do not appear explicitly C in the function G(T,Y,YPRIME)). You must set: C IWORK(LID+I) = +1 if Y(I) is a differential variable C IWORK(LID+I) = -1 if Y(I) is an algebraic variable, C where LID = 40 if INFO(10) = 0 or 2 and LID = 40+NEQ C if INFO(10) = 1 or 3. C C INFO(12) - Except for the addition of the RES argument CJ, C DDASPK by default is downward-compatible with DDASSL, C which uses only direct (dense or band) methods to solve C the linear systems involved. You must set INFO(12) to C indicate whether you want the direct methods or the C Krylov iterative method. C **** Do you want DDASPK to use standard direct methods C (dense or band) or the Krylov (iterative) method ... C direct methods - set INFO(12) = 0. C Krylov method - set INFO(12) = 1, C and check the settings of INFO(13) and INFO(15). C C INFO(13) - used when INFO(12) = 1 (Krylov methods). C DDASPK uses scalars MAXL, KMP, NRMAX, and EPLI for the C iterative solution of linear systems. INFO(13) allows C you to override the default values of these parameters. C These parameters and their defaults are as follows: C MAXL = maximum number of iterations in the SPIGMR C algorithm (MAXL .le. NEQ). The default is C MAXL = MIN(5,NEQ). C KMP = number of vectors on which orthogonalization is C done in the SPIGMR algorithm. The default is C KMP = MAXL, which corresponds to complete GMRES C iteration, as opposed to the incomplete form. C NRMAX = maximum number of restarts of the SPIGMR C algorithm per nonlinear iteration. The default is C NRMAX = 5. C EPLI = convergence test constant in SPIGMR algorithm. C The default is EPLI = 0.05. C Note that the length of RWORK depends on both MAXL C and KMP. See the definition of LRW below. C **** Are MAXL, KMP, and EPLI to be given their C default values ... C yes - set INFO(13) = 0 C no - set INFO(13) = 1, C and set all of the following: C IWORK(24) = MAXL (1 .le. MAXL .le. NEQ) C IWORK(25) = KMP (1 .le. KMP .le. MAXL) C IWORK(26) = NRMAX (NRMAX .ge. 0) C RWORK(10) = EPLI (0 .lt. EPLI .lt. 1.0) **** C C INFO(14) - used with INFO(11) > 0 (initial condition C calculation is requested). In this case, you may C request control to be returned to the calling program C immediately after the initial condition calculation, C before proceeding to the integration of the system C (e.g. to examine the computed Y and YPRIME). C If this is done, and if the initialization succeeded C (IDID = 4), you should reset INFO(11) to 0 for the C next call, to prevent the solver from repeating the C initialization (and to avoid an infinite loop). C **** Do you want to proceed to the integration after C the initial condition calculation is done ... C yes - set INFO(14) = 0 C no - set INFO(14) = 1 **** C C INFO(15) - used when INFO(12) = 1 (Krylov methods). C When using preconditioning in the Krylov method, C you must supply a subroutine, PSOL, which solves the C associated linear systems using P. C The usage of DDASPK is simpler if PSOL can carry out C the solution without any prior calculation of data. C However, if some partial derivative data is to be C calculated in advance and used repeatedly in PSOL, C then you must supply a JAC routine to do this, C and set INFO(15) to indicate that JAC is to be called C for this purpose. For example, P might be an C approximation to a part of the matrix A which can be C calculated and LU-factored for repeated solutions of C the preconditioner system. The arrays WP and IWP C (described under JAC and PSOL) can be used to C communicate data between JAC and PSOL. C **** Does PSOL operate with no prior preparation ... C yes - set INFO(15) = 0 (no JAC routine) C no - set INFO(15) = 1 C and supply a JAC routine to evaluate and C preprocess any required Jacobian data. **** C C INFO(16) - option to exclude algebraic variables from C the error test. C **** Do you wish to control errors locally on C all the variables... C yes - set INFO(16) = 0 C no - set INFO(16) = 1 C If you have specified INFO(16) = 1, then you C will also need to identify which are the C differential and which are the algebraic C components (algebraic components are components C whose derivatives do not appear explicitly C in the function G(T,Y,YPRIME)). You must set: C IWORK(LID+I) = +1 if Y(I) is a differential C variable, and C IWORK(LID+I) = -1 if Y(I) is an algebraic C variable, C where LID = 40 if INFO(10) = 0 or 2 and C LID = 40 + NEQ if INFO(10) = 1 or 3. C C INFO(17) - used when INFO(11) > 0 (DDASPK is to do an C initial condition calculation). C DDASPK uses several heuristic control quantities in the C initial condition calculation. They have default values, C but can also be set by the user using INFO(17). C These parameters and their defaults are as follows: C MXNIT = maximum number of Newton iterations C per Jacobian or preconditioner evaluation. C The default is: C MXNIT = 5 in the direct case (INFO(12) = 0), and C MXNIT = 15 in the Krylov case (INFO(12) = 1). C MXNJ = maximum number of Jacobian or preconditioner C evaluations. The default is: C MXNJ = 6 in the direct case (INFO(12) = 0), and C MXNJ = 2 in the Krylov case (INFO(12) = 1). C MXNH = maximum number of values of the artificial C stepsize parameter H to be tried if INFO(11) = 1. C The default is MXNH = 5. C NOTE: the maximum number of Newton iterations C allowed in all is MXNIT*MXNJ*MXNH if INFO(11) = 1, C and MXNIT*MXNJ if INFO(11) = 2. C LSOFF = flag to turn off the linesearch algorithm C (LSOFF = 0 means linesearch is on, LSOFF = 1 means C it is turned off). The default is LSOFF = 0. C STPTOL = minimum scaled step in linesearch algorithm. C The default is STPTOL = (unit roundoff)**(2/3). C EPINIT = swing factor in the Newton iteration convergence C test. The test is applied to the residual vector, C premultiplied by the approximate Jacobian (in the C direct case) or the preconditioner (in the Krylov C case). For convergence, the weighted RMS norm of C this vector (scaled by the error weights) must be C less than EPINIT*EPCON, where EPCON = .33 is the C analogous test constant used in the time steps. C The default is EPINIT = .01. C **** Are the initial condition heuristic controls to be C given their default values... C yes - set INFO(17) = 0 C no - set INFO(17) = 1, C and set all of the following: C IWORK(32) = MXNIT (.GT. 0) C IWORK(33) = MXNJ (.GT. 0) C IWORK(34) = MXNH (.GT. 0) C IWORK(35) = LSOFF ( = 0 or 1) C RWORK(14) = STPTOL (.GT. 0.0) C RWORK(15) = EPINIT (.GT. 0.0) **** C C INFO(18) - option to get extra printing in initial condition C calculation. C **** Do you wish to have extra printing... C no - set INFO(18) = 0 C yes - set INFO(18) = 1 for minimal printing, or C set INFO(18) = 2 for full printing. C If you have specified INFO(18) .ge. 1, data C will be printed with the error handler routines. C To print to a non-default unit number L, include C the line CALL XSETUN(L) in your program. **** C C RTOL, ATOL -- You must assign relative (RTOL) and absolute (ATOL) C error tolerances to tell the code how accurately you C want the solution to be computed. They must be defined C as variables because the code may change them. C you have two choices -- C Both RTOL and ATOL are scalars (INFO(2) = 0), or C both RTOL and ATOL are vectors (INFO(2) = 1). C In either case all components must be non-negative. C C The tolerances are used by the code in a local error C test at each step which requires roughly that C abs(local error in Y(i)) .le. EWT(i) , C where EWT(i) = RTOL*abs(Y(i)) + ATOL is an error weight C quantity, for each vector component. C (More specifically, a root-mean-square norm is used to C measure the size of vectors, and the error test uses the C magnitude of the solution at the beginning of the step.) C C The true (global) error is the difference between the C true solution of the initial value problem and the C computed approximation. Practically all present day C codes, including this one, control the local error at C each step and do not even attempt to control the global C error directly. C C Usually, but not always, the true accuracy of C the computed Y is comparable to the error tolerances. C This code will usually, but not always, deliver a more C accurate solution if you reduce the tolerances and C integrate again. By comparing two such solutions you C can get a fairly reliable idea of the true error in the C solution at the larger tolerances. C C Setting ATOL = 0. results in a pure relative error test C on that component. Setting RTOL = 0. results in a pure C absolute error test on that component. A mixed test C with non-zero RTOL and ATOL corresponds roughly to a C relative error test when the solution component is C much bigger than ATOL and to an absolute error test C when the solution component is smaller than the C threshold ATOL. C C The code will not attempt to compute a solution at an C accuracy unreasonable for the machine being used. It C will advise you if you ask for too much accuracy and C inform you as to the maximum accuracy it believes C possible. C C RWORK(*) -- a real work array, which should be dimensioned in your C calling program with a length equal to the value of C LRW (or greater). C C LRW -- Set it to the declared length of the RWORK array. The C minimum length depends on the options you have selected, C given by a base value plus additional storage as described C below. C C If INFO(12) = 0 (standard direct method), the base value is C base = 50 + max(MAXORD+4,7)*NEQ. C The default value is MAXORD = 5 (see INFO(9)). With the C default MAXORD, base = 50 + 9*NEQ. C Additional storage must be added to the base value for C any or all of the following options: C if INFO(6) = 0 (dense matrix), add NEQ**2 C if INFO(6) = 1 (banded matrix), then C if INFO(5) = 0, add (2*ML+MU+1)*NEQ + 2*(NEQ/(ML+MU+1)+1), C if INFO(5) = 1, add (2*ML+MU+1)*NEQ, C if INFO(16) = 1, add NEQ. C C If INFO(12) = 1 (Krylov method), the base value is C base = 50 + (MAXORD+5)*NEQ + (MAXL+3+MIN0(1,MAXL-KMP))*NEQ + C + (MAXL+3)*MAXL + 1 + LENWP. C See PSOL for description of LENWP. The default values are: C MAXORD = 5 (see INFO(9)), MAXL = min(5,NEQ) and KMP = MAXL C (see INFO(13)). C With the default values for MAXORD, MAXL and KMP, C base = 91 + 18*NEQ + LENWP. C Additional storage must be added to the base value for C any or all of the following options: C if INFO(16) = 1, add NEQ. C C C IWORK(*) -- an integer work array, which should be dimensioned in C your calling program with a length equal to the value C of LIW (or greater). C C LIW -- Set it to the declared length of the IWORK array. The C minimum length depends on the options you have selected, C given by a base value plus additional storage as described C below. C C If INFO(12) = 0 (standard direct method), the base value is C base = 40 + NEQ. C IF INFO(10) = 1 or 3, add NEQ to the base value. C If INFO(11) = 1 or INFO(16) =1, add NEQ to the base value. C C If INFO(12) = 1 (Krylov method), the base value is C base = 40 + LENIWP. C See PSOL for description of LENIWP. C IF INFO(10) = 1 or 3, add NEQ to the base value. C If INFO(11) = 1 or INFO(16) = 1, add NEQ to the base value. C C C RPAR, IPAR -- These are arrays of double precision and integer type, C respectively, which are available for you to use C for communication between your program that calls C DDASPK and the RES subroutine (and the JAC and PSOL C subroutines). They are not altered by DDASPK. C If you do not need RPAR or IPAR, ignore these C parameters by treating them as dummy arguments. C If you do choose to use them, dimension them in C your calling program and in RES (and in JAC and PSOL) C as arrays of appropriate length. C C JAC -- This is the name of a routine that you may supply C (optionally) that relates to the Jacobian matrix of the C nonlinear system that the code must solve at each T step. C The role of JAC (and its call sequence) depends on whether C a direct (INFO(12) = 0) or Krylov (INFO(12) = 1) method C is selected. C C **** INFO(12) = 0 (direct methods): C If you are letting the code generate partial derivatives C numerically (INFO(5) = 0), then JAC can be absent C (or perhaps a dummy routine to satisfy the loader). C Otherwise you must supply a JAC routine to compute C the matrix A = dG/dY + CJ*dG/dYPRIME. It must have C the form C C SUBROUTINE JAC (T, Y, YPRIME, PD, CJ, RPAR, IPAR) C C The JAC routine must dimension Y, YPRIME, and PD (and RPAR C and IPAR if used). CJ is a scalar which is input to JAC. C For the given values of T, Y, and YPRIME, the JAC routine C must evaluate the nonzero elements of the matrix A, and C store these values in the array PD. The elements of PD are C set to zero before each call to JAC, so that only nonzero C elements need to be defined. C The way you store the elements into the PD array depends C on the structure of the matrix indicated by INFO(6). C *** INFO(6) = 0 (full or dense matrix) *** C Give PD a first dimension of NEQ. When you evaluate the C nonzero partial derivatives of equation i (i.e. of G(i)) C with respect to component j (of Y and YPRIME), you must C store the element in PD according to C PD(i,j) = dG(i)/dY(j) + CJ*dG(i)/dYPRIME(j). C *** INFO(6) = 1 (banded matrix with half-bandwidths ML, MU C as described under INFO(6)) *** C Give PD a first dimension of 2*ML+MU+1. When you C evaluate the nonzero partial derivatives of equation i C (i.e. of G(i)) with respect to component j (of Y and C YPRIME), you must store the element in PD according to C IROW = i - j + ML + MU + 1 C PD(IROW,j) = dG(i)/dY(j) + CJ*dG(i)/dYPRIME(j). C C **** INFO(12) = 1 (Krylov method): C If you are not calculating Jacobian data in advance for use C in PSOL (INFO(15) = 0), JAC can be absent (or perhaps a C dummy routine to satisfy the loader). Otherwise, you may C supply a JAC routine to compute and preprocess any parts of C of the Jacobian matrix A = dG/dY + CJ*dG/dYPRIME that are C involved in the preconditioner matrix P. C It is to have the form C C SUBROUTINE JAC (RES, IRES, NEQ, T, Y, YPRIME, REWT, SAVR, C WK, H, CJ, WP, IWP, IER, RPAR, IPAR) C C The JAC routine must dimension Y, YPRIME, REWT, SAVR, WK, C and (if used) WP, IWP, RPAR, and IPAR. C The Y, YPRIME, and SAVR arrays contain the current values C of Y, YPRIME, and the residual G, respectively. C The array WK is work space of length NEQ. C H is the step size. CJ is a scalar, input to JAC, that is C normally proportional to 1/H. REWT is an array of C reciprocal error weights, 1/EWT(i), where EWT(i) is C RTOL*abs(Y(i)) + ATOL (unless you supplied routine DDAWTS C instead), for use in JAC if needed. For example, if JAC C computes difference quotient approximations to partial C derivatives, the REWT array may be useful in setting the C increments used. The JAC routine should do any C factorization operations called for, in preparation for C solving linear systems in PSOL. The matrix P should C be an approximation to the Jacobian, C A = dG/dY + CJ*dG/dYPRIME. C C WP and IWP are real and integer work arrays which you may C use for communication between your JAC routine and your C PSOL routine. These may be used to store elements of the C preconditioner P, or related matrix data (such as factored C forms). They are not altered by DDASPK. C If you do not need WP or IWP, ignore these parameters by C treating them as dummy arguments. If you do use them, C dimension them appropriately in your JAC and PSOL routines. C See the PSOL description for instructions on setting C the lengths of WP and IWP. C C On return, JAC should set the error flag IER as follows.. C IER = 0 if JAC was successful, C IER .ne. 0 if JAC was unsuccessful (e.g. if Y or YPRIME C was illegal, or a singular matrix is found). C (If IER .ne. 0, a smaller stepsize will be tried.) C IER = 0 on entry to JAC, so need be reset only on a failure. C If RES is used within JAC, then a nonzero value of IRES will C override any nonzero value of IER (see the RES description). C C Regardless of the method type, subroutine JAC must not C alter T, Y(*), YPRIME(*), H, CJ, or REWT(*). C You must declare the name JAC in an EXTERNAL statement in C your program that calls DDASPK. C C PSOL -- This is the name of a routine you must supply if you have C selected a Krylov method (INFO(12) = 1) with preconditioning. C In the direct case (INFO(12) = 0), PSOL can be absent C (a dummy routine may have to be supplied to satisfy the C loader). Otherwise, you must provide a PSOL routine to C solve linear systems arising from preconditioning. C When supplied with INFO(12) = 1, the PSOL routine is to C have the form C C SUBROUTINE PSOL (NEQ, T, Y, YPRIME, SAVR, WK, CJ, WGHT, C WP, IWP, B, EPLIN, IER, RPAR, IPAR) C C The PSOL routine must solve linear systems of the form C P*x = b where P is the left preconditioner matrix. C C The right-hand side vector b is in the B array on input, and C PSOL must return the solution vector x in B. C The Y, YPRIME, and SAVR arrays contain the current values C of Y, YPRIME, and the residual G, respectively. C C Work space required by JAC and/or PSOL, and space for data to C be communicated from JAC to PSOL is made available in the form C of arrays WP and IWP, which are parts of the RWORK and IWORK C arrays, respectively. The lengths of these real and integer C work spaces WP and IWP must be supplied in LENWP and LENIWP, C respectively, as follows.. C IWORK(27) = LENWP = length of real work space WP C IWORK(28) = LENIWP = length of integer work space IWP. C C WK is a work array of length NEQ for use by PSOL. C CJ is a scalar, input to PSOL, that is normally proportional C to 1/H (H = stepsize). If the old value of CJ C (at the time of the last JAC call) is needed, it must have C been saved by JAC in WP. C C WGHT is an array of weights, to be used if PSOL uses an C iterative method and performs a convergence test. (In terms C of the argument REWT to JAC, WGHT is REWT/sqrt(NEQ).) C If PSOL uses an iterative method, it should use EPLIN C (a heuristic parameter) as the bound on the weighted norm of C the residual for the computed solution. Specifically, the C residual vector R should satisfy C SQRT (SUM ( (R(i)*WGHT(i))**2 ) ) .le. EPLIN C C PSOL must not alter NEQ, T, Y, YPRIME, SAVR, CJ, WGHT, EPLIN. C C On return, PSOL should set the error flag IER as follows.. C IER = 0 if PSOL was successful, C IER .lt. 0 if an unrecoverable error occurred, meaning C control will be passed to the calling routine, C IER .gt. 0 if a recoverable error occurred, meaning that C the step will be retried with the same step size C but with a call to JAC to update necessary data, C unless the Jacobian data is current, in which case C the step will be retried with a smaller step size. C IER = 0 on entry to PSOL so need be reset only on a failure. C C You must declare the name PSOL in an EXTERNAL statement in C your program that calls DDASPK. C C C OPTIONALLY REPLACEABLE SUBROUTINE: C C DDASPK uses a weighted root-mean-square norm to measure the C size of various error vectors. The weights used in this norm C are set in the following subroutine: C C SUBROUTINE DDAWTS (NEQ, IWT, RTOL, ATOL, Y, EWT, RPAR, IPAR) C DIMENSION RTOL(*), ATOL(*), Y(*), EWT(*), RPAR(*), IPAR(*) C C A DDAWTS routine has been included with DDASPK which sets the C weights according to C EWT(I) = RTOL*ABS(Y(I)) + ATOL C in the case of scalar tolerances (IWT = 0) or C EWT(I) = RTOL(I)*ABS(Y(I)) + ATOL(I) C in the case of array tolerances (IWT = 1). (IWT is INFO(2).) C In some special cases, it may be appropriate for you to define C your own error weights by writing a subroutine DDAWTS to be C called instead of the version supplied. However, this should C be attempted only after careful thought and consideration. C If you supply this routine, you may use the tolerances and Y C as appropriate, but do not overwrite these variables. You C may also use RPAR and IPAR to communicate data as appropriate. C ***Note: Aside from the values of the weights, the choice of C norm used in DDASPK (weighted root-mean-square) is not subject C to replacement by the user. In this respect, DDASPK is not C downward-compatible with the original DDASSL solver (in which C the norm routine was optionally user-replaceable). C C C------OUTPUT - AFTER ANY RETURN FROM DDASPK---------------------------- C C The principal aim of the code is to return a computed solution at C T = TOUT, although it is also possible to obtain intermediate C results along the way. To find out whether the code achieved its C goal or if the integration process was interrupted before the task C was completed, you must check the IDID parameter. C C C T -- The output value of T is the point to which the solution C was successfully advanced. C C Y(*) -- contains the computed solution approximation at T. C C YPRIME(*) -- contains the computed derivative approximation at T. C C IDID -- reports what the code did, described as follows: C C *** TASK COMPLETED *** C Reported by positive values of IDID C C IDID = 1 -- a step was successfully taken in the C intermediate-output mode. The code has not C yet reached TOUT. C C IDID = 2 -- the integration to TSTOP was successfully C completed (T = TSTOP) by stepping exactly to TSTOP. C C IDID = 3 -- the integration to TOUT was successfully C completed (T = TOUT) by stepping past TOUT. C Y(*) and YPRIME(*) are obtained by interpolation. C C IDID = 4 -- the initial condition calculation, with C INFO(11) > 0, was successful, and INFO(14) = 1. C No integration steps were taken, and the solution C is not considered to have been started. C C *** TASK INTERRUPTED *** C Reported by negative values of IDID C C IDID = -1 -- a large amount of work has been expended C (about 500 steps). C C IDID = -2 -- the error tolerances are too stringent. C C IDID = -3 -- the local error test cannot be satisfied C because you specified a zero component in ATOL C and the corresponding computed solution component C is zero. Thus, a pure relative error test is C impossible for this component. C C IDID = -5 -- there were repeated failures in the evaluation C or processing of the preconditioner (in JAC). C C IDID = -6 -- DDASPK had repeated error test failures on the C last attempted step. C C IDID = -7 -- the nonlinear system solver in the time integration C could not converge. C C IDID = -8 -- the matrix of partial derivatives appears C to be singular (direct method). C C IDID = -9 -- the nonlinear system solver in the time integration C failed to achieve convergence, and there were repeated C error test failures in this step. C C IDID =-10 -- the nonlinear system solver in the time integration C failed to achieve convergence because IRES was equal C to -1. C C IDID =-11 -- IRES = -2 was encountered and control is C being returned to the calling program. C C IDID =-12 -- DDASPK failed to compute the initial Y, YPRIME. C C IDID =-13 -- unrecoverable error encountered inside user's C PSOL routine, and control is being returned to C the calling program. C C IDID =-14 -- the Krylov linear system solver could not C achieve convergence. C C IDID =-15,..,-32 -- Not applicable for this code. C C *** TASK TERMINATED *** C reported by the value of IDID=-33 C C IDID = -33 -- the code has encountered trouble from which C it cannot recover. A message is printed C explaining the trouble and control is returned C to the calling program. For example, this occurs C when invalid input is detected. C C RTOL, ATOL -- these quantities remain unchanged except when C IDID = -2. In this case, the error tolerances have been C increased by the code to values which are estimated to C be appropriate for continuing the integration. However, C the reported solution at T was obtained using the input C values of RTOL and ATOL. C C RWORK, IWORK -- contain information which is usually of no interest C to the user but necessary for subsequent calls. C However, you may be interested in the performance data C listed below. These quantities are accessed in RWORK C and IWORK but have internal mnemonic names, as follows.. C C RWORK(3)--contains H, the step size h to be attempted C on the next step. C C RWORK(4)--contains TN, the current value of the C independent variable, i.e. the farthest point C integration has reached. This will differ C from T if interpolation has been performed C (IDID = 3). C C RWORK(7)--contains HOLD, the stepsize used on the last C successful step. If INFO(11) = INFO(14) = 1, C this contains the value of H used in the C initial condition calculation. C C IWORK(7)--contains K, the order of the method to be C attempted on the next step. C C IWORK(8)--contains KOLD, the order of the method used C on the last step. C C IWORK(11)--contains NST, the number of steps (in T) C taken so far. C C IWORK(12)--contains NRE, the number of calls to RES C so far. C C IWORK(13)--contains NJE, the number of calls to JAC so C far (Jacobian or preconditioner evaluations). C C IWORK(14)--contains NETF, the total number of error test C failures so far. C C IWORK(15)--contains NCFN, the total number of nonlinear C convergence failures so far (includes counts C of singular iteration matrix or singular C preconditioners). C C IWORK(16)--contains NCFL, the number of convergence C failures of the linear iteration so far. C C IWORK(17)--contains LENIW, the length of IWORK actually C required. This is defined on normal returns C and on an illegal input return for C insufficient storage. C C IWORK(18)--contains LENRW, the length of RWORK actually C required. This is defined on normal returns C and on an illegal input return for C insufficient storage. C C IWORK(19)--contains NNI, the total number of nonlinear C iterations so far (each of which calls a C linear solver). C C IWORK(20)--contains NLI, the total number of linear C (Krylov) iterations so far. C C IWORK(21)--contains NPS, the number of PSOL calls so C far, for preconditioning solve operations or C for solutions with the user-supplied method. C C Note: The various counters in IWORK do not include C counts during a call made with INFO(11) > 0 and C INFO(14) = 1. C C C------INPUT - WHAT TO DO TO CONTINUE THE INTEGRATION ----------------- C (CALLS AFTER THE FIRST) C C This code is organized so that subsequent calls to continue the C integration involve little (if any) additional effort on your C part. You must monitor the IDID parameter in order to determine C what to do next. C C Recalling that the principal task of the code is to integrate C from T to TOUT (the interval mode), usually all you will need C to do is specify a new TOUT upon reaching the current TOUT. C C Do not alter any quantity not specifically permitted below. In C particular do not alter NEQ, T, Y(*), YPRIME(*), RWORK(*), C IWORK(*), or the differential equation in subroutine RES. Any C such alteration constitutes a new problem and must be treated C as such, i.e. you must start afresh. C C You cannot change from array to scalar error control or vice C versa (INFO(2)), but you can change the size of the entries of C RTOL or ATOL. Increasing a tolerance makes the equation easier C to integrate. Decreasing a tolerance will make the equation C harder to integrate and should generally be avoided. C C You can switch from the intermediate-output mode to the C interval mode (INFO(3)) or vice versa at any time. C C If it has been necessary to prevent the integration from going C past a point TSTOP (INFO(4), RWORK(1)), keep in mind that the C code will not integrate to any TOUT beyond the currently C specified TSTOP. Once TSTOP has been reached, you must change C the value of TSTOP or set INFO(4) = 0. You may change INFO(4) C or TSTOP at any time but you must supply the value of TSTOP in C RWORK(1) whenever you set INFO(4) = 1. C C Do not change INFO(5), INFO(6), INFO(12-17) or their associated C IWORK/RWORK locations unless you are going to restart the code. C C *** FOLLOWING A COMPLETED TASK *** C C If.. C IDID = 1, call the code again to continue the integration C another step in the direction of TOUT. C C IDID = 2 or 3, define a new TOUT and call the code again. C TOUT must be different from T. You cannot change C the direction of integration without restarting. C C IDID = 4, reset INFO(11) = 0 and call the code again to begin C the integration. (If you leave INFO(11) > 0 and C INFO(14) = 1, you may generate an infinite loop.) C In this situation, the next call to DASPK is C considered to be the first call for the problem, C in that all initializations are done. C C *** FOLLOWING AN INTERRUPTED TASK *** C C To show the code that you realize the task was interrupted and C that you want to continue, you must take appropriate action and C set INFO(1) = 1. C C If.. C IDID = -1, the code has taken about 500 steps. If you want to C continue, set INFO(1) = 1 and call the code again. C An additional 500 steps will be allowed. C C C IDID = -2, the error tolerances RTOL, ATOL have been increased C to values the code estimates appropriate for C continuing. You may want to change them yourself. C If you are sure you want to continue with relaxed C error tolerances, set INFO(1) = 1 and call the code C again. C C IDID = -3, a solution component is zero and you set the C corresponding component of ATOL to zero. If you C are sure you want to continue, you must first alter C the error criterion to use positive values of ATOL C for those components corresponding to zero solution C components, then set INFO(1) = 1 and call the code C again. C C IDID = -4 --- cannot occur with this code. C C IDID = -5, your JAC routine failed with the Krylov method. Check C for errors in JAC and restart the integration. C C IDID = -6, repeated error test failures occurred on the last C attempted step in DDASPK. A singularity in the C solution may be present. If you are absolutely C certain you want to continue, you should restart C the integration. (Provide initial values of Y and C YPRIME which are consistent.) C C IDID = -7, repeated convergence test failures occurred on the last C attempted step in DDASPK. An inaccurate or ill- C conditioned Jacobian or preconditioner may be the C problem. If you are absolutely certain you want C to continue, you should restart the integration. C C C IDID = -8, the matrix of partial derivatives is singular, with C the use of direct methods. Some of your equations C may be redundant. DDASPK cannot solve the problem C as stated. It is possible that the redundant C equations could be removed, and then DDASPK could C solve the problem. It is also possible that a C solution to your problem either does not exist C or is not unique. C C IDID = -9, DDASPK had multiple convergence test failures, preceded C by multiple error test failures, on the last C attempted step. It is possible that your problem is C ill-posed and cannot be solved using this code. Or, C there may be a discontinuity or a singularity in the C solution. If you are absolutely certain you want to C continue, you should restart the integration. C C IDID = -10, DDASPK had multiple convergence test failures C because IRES was equal to -1. If you are C absolutely certain you want to continue, you C should restart the integration. C C IDID = -11, there was an unrecoverable error (IRES = -2) from RES C inside the nonlinear system solver. Determine the C cause before trying again. C C IDID = -12, DDASPK failed to compute the initial Y and YPRIME C vectors. This could happen because the initial C approximation to Y or YPRIME was not very good, or C because no consistent values of these vectors exist. C The problem could also be caused by an inaccurate or C singular iteration matrix, or a poor preconditioner. C C IDID = -13, there was an unrecoverable error encountered inside C your PSOL routine. Determine the cause before C trying again. C C IDID = -14, the Krylov linear system solver failed to achieve C convergence. This may be due to ill-conditioning C in the iteration matrix, or a singularity in the C preconditioner (if one is being used). C Another possibility is that there is a better C choice of Krylov parameters (see INFO(13)). C Possibly the failure is caused by redundant equations C in the system, or by inconsistent equations. C In that case, reformulate the system to make it C consistent and non-redundant. C C IDID = -15,..,-32 --- Cannot occur with this code. C C *** FOLLOWING A TERMINATED TASK *** C C If IDID = -33, you cannot continue the solution of this problem. C An attempt to do so will result in your run being C terminated. C C --------------------------------------------------------------------- C C***REFERENCES C 1. L. R. Petzold, A Description of DASSL: A Differential/Algebraic C System Solver, in Scientific Computing, R. S. Stepleman et al. C (Eds.), North-Holland, Amsterdam, 1983, pp. 65-68. C 2. K. E. Brenan, S. L. Campbell, and L. R. Petzold, Numerical C Solution of Initial-Value Problems in Differential-Algebraic C Equations, Elsevier, New York, 1989. C 3. P. N. Brown and A. C. Hindmarsh, Reduced Storage Matrix Methods C in Stiff ODE Systems, J. Applied Mathematics and Computation, C 31 (1989), pp. 40-91. C 4. P. N. Brown, A. C. Hindmarsh, and L. R. Petzold, Using Krylov C Methods in the Solution of Large-Scale Differential-Algebraic C Systems, SIAM J. Sci. Comp., 15 (1994), pp. 1467-1488. C 5. P. N. Brown, A. C. Hindmarsh, and L. R. Petzold, Consistent C Initial Condition Calculation for Differential-Algebraic C Systems, LLNL Report UCRL-JC-122175, August 1995; submitted to C SIAM J. Sci. Comp. C C***ROUTINES CALLED C C The following are all the subordinate routines used by DDASPK. C C DDASIC computes consistent initial conditions. C DYYPNW updates Y and YPRIME in linesearch for initial condition C calculation. C DDSTP carries out one step of the integration. C DCNSTR/DCNST0 check the current solution for constraint violations. C DDAWTS sets error weight quantities. C DINVWT tests and inverts the error weights. C DDATRP performs interpolation to get an output solution. C DDWNRM computes the weighted root-mean-square norm of a vector. C D1MACH provides the unit roundoff of the computer. C XERRWD/XSETF/XSETUN/IXSAV is a package to handle error messages. C DDASID nonlinear equation driver to initialize Y and YPRIME using C direct linear system solver methods. Interfaces to Newton C solver (direct case). C DNSID solves the nonlinear system for unknown initial values by C modified Newton iteration and direct linear system methods. C DLINSD carries out linesearch algorithm for initial condition C calculation (direct case). C DFNRMD calculates weighted norm of preconditioned residual in C initial condition calculation (direct case). C DNEDD nonlinear equation driver for direct linear system solver C methods. Interfaces to Newton solver (direct case). C DMATD assembles the iteration matrix (direct case). C DNSD solves the associated nonlinear system by modified C Newton iteration and direct linear system methods. C DSLVD interfaces to linear system solver (direct case). C DDASIK nonlinear equation driver to initialize Y and YPRIME using C Krylov iterative linear system methods. Interfaces to C Newton solver (Krylov case). C DNSIK solves the nonlinear system for unknown initial values by C Newton iteration and Krylov iterative linear system methods. C DLINSK carries out linesearch algorithm for initial condition C calculation (Krylov case). C DFNRMK calculates weighted norm of preconditioned residual in C initial condition calculation (Krylov case). C DNEDK nonlinear equation driver for iterative linear system solver C methods. Interfaces to Newton solver (Krylov case). C DNSK solves the associated nonlinear system by Inexact Newton C iteration and (linear) Krylov iteration. C DSLVK interfaces to linear system solver (Krylov case). C DSPIGM solves a linear system by SPIGMR algorithm. C DATV computes matrix-vector product in Krylov algorithm. C DORTH performs orthogonalization of Krylov basis vectors. C DHEQR performs QR factorization of Hessenberg matrix. C DHELS finds least-squares solution of Hessenberg linear system. C DGEFA, DGESL, DGBFA, DGBSL are LINPACK routines for solving C linear systems (dense or band direct methods). C DAXPY, DCOPY, DDOT, DNRM2, DSCAL are Basic Linear Algebra (BLAS) C routines. C C The routines called directly by DDASPK are: C DCNST0, DDAWTS, DINVWT, D1MACH, DDWNRM, DDASIC, DDATRP, DDSTP, C XERRWD C C***END PROLOGUE DDASPK C C IMPLICIT DOUBLE PRECISION(A-H,O-Z) LOGICAL DONE, LAVL, LCFN, LCFL, LWARN DIMENSION Y(*),YPRIME(*) DIMENSION INFO(25) ! Karline: increased from 20 -> 25 INTEGER NIND(3) ! added DIMENSION RWORK(LRW),IWORK(LIW) DIMENSION RTOL(*),ATOL(*) DIMENSION RPAR(*),IPAR(*) EXTERNAL RES, JAC, PSOL, DDASID, DDASIK, DNEDD, DNEDK C C Set pointers into IWORK. C PARAMETER (LML=1, LMU=2, LMTYPE=4, * LIWM=1, LMXORD=3, LJCALC=5, LPHASE=6, LK=7, LKOLD=8, * LNS=9, LNSTL=10, LNST=11, LNRE=12, LNJE=13, LETF=14, LNCFN=15, * LNCFL=16, LNIW=17, LNRW=18, LNNI=19, LNLI=20, LNPS=21, * LNPD=22, LMITER=23, LMAXL=24, LKMP=25, LNRMAX=26, LLNWP=27, * LLNIWP=28, LLOCWP=29, LLCIWP=30, LKPRIN=31, * LMXNIT=32, LMXNJ=33, LMXNH=34, LLSOFF=35, LICNS=41) C C Set pointers into RWORK. C PARAMETER (LTSTOP=1, LHMAX=2, LH=3, LTN=4, LCJ=5, LCJOLD=6, * LHOLD=7, LS=8, LROUND=9, LEPLI=10, LSQRN=11, LRSQRN=12, * LEPCON=13, LSTOL=14, LEPIN=15, * LALPHA=21, LBETA=27, LGAMMA=33, LPSI=39, LSIGMA=45, LDELTA=51) C SAVE LID, LENID, NONNEG C C C***FIRST EXECUTABLE STATEMENT DDASPK C C C Karline: the index of each variable DO I = 1, 3 NIND(I) = INFO(20+I) ENDDO IF(INFO(1).NE.0) GO TO 100 C C----------------------------------------------------------------------- C This block is executed for the initial call only. C It contains checking of inputs and initializations. C----------------------------------------------------------------------- C C First check INFO array to make sure all elements of INFO C Are within the proper range. (INFO(1) is checked later, because C it must be tested on every call.) ITEMP holds the location C within INFO which may be out of range. C DO 10 I=2,9 ITEMP = I IF (INFO(I) .NE. 0 .AND. INFO(I) .NE. 1) GO TO 701 10 CONTINUE ITEMP = 10 IF(INFO(10).LT.0 .OR. INFO(10).GT.3) GO TO 701 ITEMP = 11 IF(INFO(11).LT.0 .OR. INFO(11).GT.2) GO TO 701 DO 15 I=12,17 ITEMP = I IF (INFO(I) .NE. 0 .AND. INFO(I) .NE. 1) GO TO 701 15 CONTINUE ITEMP = 18 IF(INFO(18).LT.0 .OR. INFO(18).GT.2) GO TO 701 C C Check NEQ to see if it is positive. C IF (NEQ .LE. 0) GO TO 702 C C Check and compute maximum order. C MXORD=5 IF (INFO(9) .NE. 0) THEN MXORD=IWORK(LMXORD) IF (MXORD .LT. 1 .OR. MXORD .GT. 5) GO TO 703 ENDIF IWORK(LMXORD)=MXORD C C Set and/or check inputs for constraint checking (INFO(10) .NE. 0). C Set values for ICNFLG, NONNEG, and pointer LID. C ICNFLG = 0 NONNEG = 0 LID = LICNS IF (INFO(10) .EQ. 0) GO TO 20 IF (INFO(10) .EQ. 1) THEN ICNFLG = 1 NONNEG = 0 LID = LICNS + NEQ ELSEIF (INFO(10) .EQ. 2) THEN ICNFLG = 0 NONNEG = 1 ELSE ICNFLG = 1 NONNEG = 1 LID = LICNS + NEQ ENDIF C 20 CONTINUE C C Set and/or check inputs for Krylov solver (INFO(12) .NE. 0). C If indicated, set default values for MAXL, KMP, NRMAX, and EPLI. C Otherwise, verify inputs required for iterative solver. C IF (INFO(12) .EQ. 0) GO TO 25 C IWORK(LMITER) = INFO(12) IF (INFO(13) .EQ. 0) THEN IWORK(LMAXL) = MIN(5,NEQ) IWORK(LKMP) = IWORK(LMAXL) IWORK(LNRMAX) = 5 RWORK(LEPLI) = 0.05D0 ELSE IF(IWORK(LMAXL) .LT. 1 .OR. IWORK(LMAXL) .GT. NEQ) GO TO 720 IF(IWORK(LKMP) .LT. 1 .OR. IWORK(LKMP) .GT. IWORK(LMAXL)) 1 GO TO 721 IF(IWORK(LNRMAX) .LT. 0) GO TO 722 IF(RWORK(LEPLI).LE.0.0D0 .OR. RWORK(LEPLI).GE.1.0D0)GO TO 723 ENDIF C 25 CONTINUE C C Set and/or check controls for the initial condition calculation C (INFO(11) .GT. 0). If indicated, set default values. C Otherwise, verify inputs required for iterative solver. C IF (INFO(11) .EQ. 0) GO TO 30 IF (INFO(17) .EQ. 0) THEN IWORK(LMXNIT) = 5 IF (INFO(12) .GT. 0) IWORK(LMXNIT) = 15 IWORK(LMXNJ) = 6 IF (INFO(12) .GT. 0) IWORK(LMXNJ) = 2 IWORK(LMXNH) = 5 IWORK(LLSOFF) = 0 RWORK(LEPIN) = 0.01D0 ELSE IF (IWORK(LMXNIT) .LE. 0) GO TO 725 IF (IWORK(LMXNJ) .LE. 0) GO TO 725 IF (IWORK(LMXNH) .LE. 0) GO TO 725 LSOFF = IWORK(LLSOFF) IF (LSOFF .LT. 0 .OR. LSOFF .GT. 1) GO TO 725 IF (RWORK(LEPIN) .LE. 0.0D0) GO TO 725 ENDIF C 30 CONTINUE C C Below is the computation and checking of the work array lengths C LENIW and LENRW, using direct methods (INFO(12) = 0) or C the Krylov methods (INFO(12) = 1). C LENIC = 0 IF (INFO(10) .EQ. 1 .OR. INFO(10) .EQ. 3) LENIC = NEQ LENID = 0 IF (INFO(11) .EQ. 1 .OR. INFO(16) .EQ. 1) LENID = NEQ IF (INFO(12) .EQ. 0) THEN C C Compute MTYPE, etc. Check ML and MU. C NCPHI = MAX(MXORD + 1, 4) IF(INFO(6).EQ.0) THEN LENPD = NEQ**2 LENRW = 50 + (NCPHI+3)*NEQ + LENPD IF(INFO(5).EQ.0) THEN IWORK(LMTYPE)=2 ELSE IWORK(LMTYPE)=1 ENDIF ELSE IF(IWORK(LML).LT.0.OR.IWORK(LML).GE.NEQ)GO TO 717 IF(IWORK(LMU).LT.0.OR.IWORK(LMU).GE.NEQ)GO TO 718 LENPD=(2*IWORK(LML)+IWORK(LMU)+1)*NEQ IF(INFO(5).EQ.0) THEN IWORK(LMTYPE)=5 MBAND=IWORK(LML)+IWORK(LMU)+1 MSAVE=(NEQ/MBAND)+1 LENRW = 50 + (NCPHI+3)*NEQ + LENPD + 2*MSAVE ELSE IWORK(LMTYPE)=4 LENRW = 50 + (NCPHI+3)*NEQ + LENPD ENDIF ENDIF C C Compute LENIW, LENWP, LENIWP. C LENIW = 40 + LENIC + LENID + NEQ LENWP = 0 LENIWP = 0 C ELSE IF (INFO(12) .EQ. 1) THEN MAXL = IWORK(LMAXL) LENWP = IWORK(LLNWP) LENIWP = IWORK(LLNIWP) LENPD = (MAXL+3+MIN0(1,MAXL-IWORK(LKMP)))*NEQ 1 + (MAXL+3)*MAXL + 1 + LENWP LENRW = 50 + (IWORK(LMXORD)+5)*NEQ + LENPD LENIW = 40 + LENIC + LENID + LENIWP C ENDIF IF(INFO(16) .NE. 0) LENRW = LENRW + NEQ C C Check lengths of RWORK and IWORK. C IWORK(LNIW)=LENIW IWORK(LNRW)=LENRW IWORK(LNPD)=LENPD IWORK(LLOCWP) = LENPD-LENWP+1 IF(LRW.LT.LENRW)GO TO 704 IF(LIW.LT.LENIW)GO TO 705 C C Check ICNSTR for legality. C IF (LENIC .GT. 0) THEN DO 40 I = 1,NEQ ICI = IWORK(LICNS-1+I) IF (ICI .LT. -2 .OR. ICI .GT. 2) GO TO 726 40 CONTINUE ENDIF C C Check Y for consistency with constraints. C IF (LENIC .GT. 0) THEN CALL DCNST0(NEQ,Y,IWORK(LICNS),IRET) IF (IRET .NE. 0) GO TO 727 ENDIF C C Check ID for legality. C IF (LENID .GT. 0) THEN DO 50 I = 1,NEQ IDI = IWORK(LID-1+I) IF (IDI .NE. 1 .AND. IDI .NE. -1) GO TO 724 50 CONTINUE ENDIF C C Check to see that TOUT is different from T. C IF(TOUT .EQ. T)GO TO 719 C C Check HMAX. C IF(INFO(7) .NE. 0) THEN HMAX = RWORK(LHMAX) IF (HMAX .LE. 0.0D0) GO TO 710 ENDIF C C Initialize counters and other flags. C IWORK(LNST)=0 IWORK(LNRE)=0 IWORK(LNJE)=0 IWORK(LETF)=0 IWORK(LNCFN)=0 IWORK(LNNI)=0 IWORK(LNLI)=0 IWORK(LNPS)=0 IWORK(LNCFL)=0 IWORK(LKPRIN)=INFO(18) IDID=1 GO TO 200 C C----------------------------------------------------------------------- C This block is for continuation calls only. C Here we check INFO(1), and if the last step was interrupted, C we check whether appropriate action was taken. C----------------------------------------------------------------------- C 100 CONTINUE IF(INFO(1).EQ.1)GO TO 110 ITEMP = 1 IF(INFO(1).NE.-1)GO TO 701 C C If we are here, the last step was interrupted by an error C condition from DDSTP, and appropriate action was not taken. C This is a fatal error. C call rprintf( 1 'daspk-- warning.. the last step terminated with a negative') call rprintfi1( 2 'value of idid and no appropriate action was taken %i' & // char(0),idid) call rexit('- run terminated') RETURN 110 CONTINUE C C----------------------------------------------------------------------- C This block is executed on all calls. C C Counters are saved for later checks of performance. C Then the error tolerance parameters are checked, and the C work array pointers are set. C----------------------------------------------------------------------- C 200 CONTINUE C C Save counters for use later. C IWORK(LNSTL)=IWORK(LNST) NLI0 = IWORK(LNLI) NNI0 = IWORK(LNNI) NCFN0 = IWORK(LNCFN) NCFL0 = IWORK(LNCFL) NWARN = 0 C C Check RTOL and ATOL. C NZFLG = 0 RTOLI = RTOL(1) ATOLI = ATOL(1) DO 210 I=1,NEQ IF (INFO(2) .EQ. 1) RTOLI = RTOL(I) IF (INFO(2) .EQ. 1) ATOLI = ATOL(I) IF (RTOLI .GT. 0.0D0 .OR. ATOLI .GT. 0.0D0) NZFLG = 1 IF (RTOLI .LT. 0.0D0) GO TO 706 IF (ATOLI .LT. 0.0D0) GO TO 707 210 CONTINUE IF (NZFLG .EQ. 0) GO TO 708 C C Set pointers to RWORK and IWORK segments. C For direct methods, SAVR is not used. C IWORK(LLCIWP) = LID + LENID LSAVR = LDELTA IF (INFO(12) .NE. 0) LSAVR = LDELTA + NEQ LE = LSAVR + NEQ LWT = LE + NEQ LVT = LWT IF (INFO(16) .NE. 0) LVT = LWT + NEQ LPHI = LVT + NEQ LWM = LPHI + (IWORK(LMXORD)+1)*NEQ IF (INFO(1) .EQ. 1) GO TO 400 C C----------------------------------------------------------------------- C This block is executed on the initial call only. C Set the initial step size, the error weight vector, and PHI. C Compute unknown initial components of Y and YPRIME, if requested. C----------------------------------------------------------------------- C CONTINUE TN=T IDID=1 C C Set error weight array WT and altered weight array VT. C CALL DDAWTS(NEQ,INFO(2),RTOL,ATOL,Y,RWORK(LWT),RPAR,IPAR) C KARLINE IF(NIND(1) < NEQ)CALL SCALE(NEQ, NIND, RWORK(LWT), 1.d-1) !H not known yet CALL DINVWT(NEQ,RWORK(LWT),IER) IF (IER .NE. 0) GO TO 713 IF (INFO(16) .NE. 0) THEN DO 305 I = 1, NEQ RWORK(LVT+I-1) = MAX(IWORK(LID+I-1),0)*RWORK(LWT+I-1) 305 CONTINUE ENDIF C C Compute unit roundoff and HMIN. C UROUND = D1MACH(4) RWORK(LROUND) = UROUND HMIN = 4.0D0*UROUND*MAX(ABS(T),ABS(TOUT)) C C Set/check STPTOL control for initial condition calculation. C IF (INFO(11) .NE. 0) THEN IF( INFO(17) .EQ. 0) THEN RWORK(LSTOL) = UROUND**.6667D0 ELSE IF (RWORK(LSTOL) .LE. 0.0D0) GO TO 725 ENDIF ENDIF C C Compute EPCON and square root of NEQ and its reciprocal, used C inside iterative solver. C RWORK(LEPCON) = 0.33D0 FLOATN = NEQ RWORK(LSQRN) = SQRT(FLOATN) RWORK(LRSQRN) = 1.D0/RWORK(LSQRN) C C Check initial interval to see that it is long enough. C TDIST = ABS(TOUT - T) IF(TDIST .LT. HMIN) GO TO 714 C C Check H0, if this was input. C IF (INFO(8) .EQ. 0) GO TO 310 H0 = RWORK(LH) IF ((TOUT - T)*H0 .LT. 0.0D0) GO TO 711 IF (H0 .EQ. 0.0D0) GO TO 712 GO TO 320 310 CONTINUE C C Compute initial stepsize, to be used by either C DDSTP or DDASIC, depending on INFO(11). C H0 = 0.001D0*TDIST YPNORM = DDWNRM(NEQ,YPRIME,RWORK(LVT),RPAR,IPAR) IF (YPNORM .GT. 0.5D0/H0) H0 = 0.5D0/YPNORM H0 = SIGN(H0,TOUT-T) C C Adjust H0 if necessary to meet HMAX bound. C 320 IF (INFO(7) .EQ. 0) GO TO 330 RH = ABS(H0)/RWORK(LHMAX) IF (RH .GT. 1.0D0) H0 = H0/RH C C Check against TSTOP, if applicable. C 330 IF (INFO(4) .EQ. 0) GO TO 340 TSTOP = RWORK(LTSTOP) IF ((TSTOP - T)*H0 .LT. 0.0D0) GO TO 715 IF ((T + H0 - TSTOP)*H0 .GT. 0.0D0) H0 = TSTOP - T IF ((TSTOP - TOUT)*H0 .LT. 0.0D0) GO TO 709 C 340 IF (INFO(11) .EQ. 0) GO TO 370 C C Compute unknown components of initial Y and YPRIME, depending C on INFO(11) and INFO(12). INFO(12) represents the nonlinear C solver type (direct/Krylov). Pass the name of the specific C nonlinear solver, depending on INFO(12). The location of the work C arrays SAVR, YIC, YPIC, PWK also differ in the two cases. C NWT = 1 EPCONI = RWORK(LEPIN)*RWORK(LEPCON) 350 IF (INFO(12) .EQ. 0) THEN LYIC = LPHI + 2*NEQ LYPIC = LYIC + NEQ LPWK = LYPIC CALL DDASIC(TN,Y,YPRIME,NEQ,INFO(11),IWORK(LID), * RES,JAC,PSOL,H0,RWORK(LWT),NWT,IDID,RPAR,IPAR, * RWORK(LPHI),RWORK(LSAVR),RWORK(LDELTA),RWORK(LE), * RWORK(LYIC),RWORK(LYPIC),RWORK(LPWK),RWORK(LWM),IWORK(LIWM), * HMIN,RWORK(LROUND),RWORK(LEPLI),RWORK(LSQRN),RWORK(LRSQRN), * EPCONI,RWORK(LSTOL),INFO(15),ICNFLG,IWORK(LICNS),DDASID) ELSE IF (INFO(12) .EQ. 1) THEN LYIC = LWM LYPIC = LYIC + NEQ LPWK = LYPIC + NEQ CALL DDASIC(TN,Y,YPRIME,NEQ,INFO(11),IWORK(LID), * RES,JAC,PSOL,H0,RWORK(LWT),NWT,IDID,RPAR,IPAR, * RWORK(LPHI),RWORK(LSAVR),RWORK(LDELTA),RWORK(LE), * RWORK(LYIC),RWORK(LYPIC),RWORK(LPWK),RWORK(LWM),IWORK(LIWM), * HMIN,RWORK(LROUND),RWORK(LEPLI),RWORK(LSQRN),RWORK(LRSQRN), * EPCONI,RWORK(LSTOL),INFO(15),ICNFLG,IWORK(LICNS),DDASIK) ENDIF C IF (IDID .LT. 0) GO TO 600 C C DDASIC was successful. If this was the first call to DDASIC, C update the WT array (with the current Y) and call it again. C IF (NWT .EQ. 2) GO TO 355 NWT = 2 CALL DDAWTS(NEQ,INFO(2),RTOL,ATOL,Y,RWORK(LWT),RPAR,IPAR) C KARLINE IF(NIND(1) < NEQ) CALL SCALE(NEQ, NIND, RWORK(LWT), H0) CALL DINVWT(NEQ,RWORK(LWT),IER) IF (IER .NE. 0) GO TO 713 GO TO 350 C C If INFO(14) = 1, return now with IDID = 4. C 355 IF (INFO(14) .EQ. 1) THEN IDID = 4 H = H0 IF (INFO(11) .EQ. 1) RWORK(LHOLD) = H0 GO TO 590 ENDIF C C Update the WT and VT arrays one more time, with the new Y. C CALL DDAWTS(NEQ,INFO(2),RTOL,ATOL,Y,RWORK(LWT),RPAR,IPAR) C KARLINE IF(NIND(1) < NEQ) CALL SCALE(NEQ, NIND, RWORK(LWT), H0) CALL DINVWT(NEQ,RWORK(LWT),IER) IF (IER .NE. 0) GO TO 713 IF (INFO(16) .NE. 0) THEN DO 357 I = 1, NEQ RWORK(LVT+I-1) = MAX(IWORK(LID+I-1),0)*RWORK(LWT+I-1) 357 CONTINUE ENDIF C C Reset the initial stepsize to be used by DDSTP. C Use H0, if this was input. Otherwise, recompute H0, C and adjust it if necessary to meet HMAX bound. C IF (INFO(8) .NE. 0) THEN H0 = RWORK(LH) GO TO 360 ENDIF C H0 = 0.001D0*TDIST YPNORM = DDWNRM(NEQ,YPRIME,RWORK(LVT),RPAR,IPAR) IF (YPNORM .GT. 0.5D0/H0) H0 = 0.5D0/YPNORM H0 = SIGN(H0,TOUT-T) C 360 IF (INFO(7) .NE. 0) THEN RH = ABS(H0)/RWORK(LHMAX) IF (RH .GT. 1.0D0) H0 = H0/RH ENDIF C C Check against TSTOP, if applicable. C IF (INFO(4) .NE. 0) THEN TSTOP = RWORK(LTSTOP) IF ((T + H0 - TSTOP)*H0 .GT. 0.0D0) H0 = TSTOP - T ENDIF C C Load H and RWORK(LH) with H0. C 370 H = H0 RWORK(LH) = H C C Load Y and H*YPRIME into PHI(*,1) and PHI(*,2). C ITEMP = LPHI + NEQ DO 380 I = 1,NEQ RWORK(LPHI + I - 1) = Y(I) RWORK(ITEMP + I - 1) = H*YPRIME(I) 380 CONTINUE C GO TO 500 C C----------------------------------------------------------------------- C This block is for continuation calls only. C Its purpose is to check stop conditions before taking a step. C Adjust H if necessary to meet HMAX bound. C----------------------------------------------------------------------- C 400 CONTINUE UROUND=RWORK(LROUND) DONE = .FALSE. TN=RWORK(LTN) H=RWORK(LH) IF(INFO(7) .EQ. 0) GO TO 410 RH = ABS(H)/RWORK(LHMAX) IF(RH .GT. 1.0D0) H = H/RH 410 CONTINUE IF(T .EQ. TOUT) GO TO 719 IF((T - TOUT)*H .GT. 0.0D0) GO TO 711 IF(INFO(4) .EQ. 1) GO TO 430 IF(INFO(3) .EQ. 1) GO TO 420 IF((TN-TOUT)*H.LT.0.0D0)GO TO 490 CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), * RWORK(LPHI),RWORK(LPSI)) T=TOUT IDID = 3 DONE = .TRUE. GO TO 490 420 IF((TN-T)*H .LE. 0.0D0) GO TO 490 IF((TN - TOUT)*H .GT. 0.0D0) GO TO 425 CALL DDATRP(TN,TN,Y,YPRIME,NEQ,IWORK(LKOLD), * RWORK(LPHI),RWORK(LPSI)) T = TN IDID = 1 DONE = .TRUE. GO TO 490 425 CONTINUE CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), * RWORK(LPHI),RWORK(LPSI)) T = TOUT IDID = 3 DONE = .TRUE. GO TO 490 430 IF(INFO(3) .EQ. 1) GO TO 440 TSTOP=RWORK(LTSTOP) IF((TN-TSTOP)*H.GT.0.0D0) GO TO 715 IF((TSTOP-TOUT)*H.LT.0.0D0)GO TO 709 IF((TN-TOUT)*H.LT.0.0D0)GO TO 450 CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), * RWORK(LPHI),RWORK(LPSI)) T=TOUT IDID = 3 DONE = .TRUE. GO TO 490 440 TSTOP = RWORK(LTSTOP) IF((TN-TSTOP)*H .GT. 0.0D0) GO TO 715 IF((TSTOP-TOUT)*H .LT. 0.0D0) GO TO 709 IF((TN-T)*H .LE. 0.0D0) GO TO 450 IF((TN - TOUT)*H .GT. 0.0D0) GO TO 445 CALL DDATRP(TN,TN,Y,YPRIME,NEQ,IWORK(LKOLD), * RWORK(LPHI),RWORK(LPSI)) T = TN IDID = 1 DONE = .TRUE. GO TO 490 445 CONTINUE CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), * RWORK(LPHI),RWORK(LPSI)) T = TOUT IDID = 3 DONE = .TRUE. GO TO 490 450 CONTINUE C C Check whether we are within roundoff of TSTOP. C IF(ABS(TN-TSTOP).GT.100.0D0*UROUND* * (ABS(TN)+ABS(H)))GO TO 460 CALL DDATRP(TN,TSTOP,Y,YPRIME,NEQ,IWORK(LKOLD), * RWORK(LPHI),RWORK(LPSI)) IDID=2 T=TSTOP DONE = .TRUE. GO TO 490 460 TNEXT=TN+H IF((TNEXT-TSTOP)*H.LE.0.0D0)GO TO 490 H=TSTOP-TN RWORK(LH)=H C 490 IF (DONE) GO TO 590 C C----------------------------------------------------------------------- C The next block contains the call to the one-step integrator DDSTP. C This is a looping point for the integration steps. C Check for too many steps. C Check for poor Newton/Krylov performance. C Update WT. Check for too much accuracy requested. C Compute minimum stepsize. C----------------------------------------------------------------------- C 500 CONTINUE C C Check for too many steps. C IF((IWORK(LNST)-IWORK(LNSTL)).LT.500) GO TO 505 IDID=-1 GO TO 527 C C Check for poor Newton/Krylov performance. C 505 IF (INFO(12) .EQ. 0) GO TO 510 NSTD = IWORK(LNST) - IWORK(LNSTL) NNID = IWORK(LNNI) - NNI0 IF (NSTD .LT. 10 .OR. NNID .EQ. 0) GO TO 510 AVLIN = REAL(IWORK(LNLI) - NLI0)/REAL(NNID) RCFN = REAL(IWORK(LNCFN) - NCFN0)/REAL(NSTD) RCFL = REAL(IWORK(LNCFL) - NCFL0)/REAL(NNID) FMAXL = IWORK(LMAXL) LAVL = AVLIN .GT. FMAXL LCFN = RCFN .GT. 0.9D0 LCFL = RCFL .GT. 0.9D0 LWARN = LAVL .OR. LCFN .OR. LCFL IF (.NOT.LWARN) GO TO 510 NWARN = NWARN + 1 IF (NWARN .GT. 10) GO TO 510 IF (LAVL) THEN call rprintf( 1 'daspk-- warning.. Poor iterative algorithm performance' & // char(0)) call rprintfd2( 2 ' at T = R1. Average no. of linear iterations = R2' & // ' %g, %g' // char(0), TN, AVLIN) ENDIF IF (LCFN) THEN call rprintf( 1 'daspk-- warning.. Poor iterative algorithm performance ' & // char(0)) call rprintfd2( 2 ' at T = R1. Nonlinear convergence failure rate = R2' & // '%g, %g' // char(0), TN, RCFN) ENDIF IF (LCFL) THEN call rprintf( 1 'daspk-- warning.. Poor iterative algorithm performance ' & // char(0)) call rprintfd2( 2 ' at T = R1. Linear convergence failure rate = R2 ' & // char(0), TN, RCFL) ENDIF C C Update WT and VT, if this is not the first call. C 510 CALL DDAWTS(NEQ,INFO(2),RTOL,ATOL,RWORK(LPHI),RWORK(LWT), * RPAR,IPAR) IF(NIND(1) < NEQ) CALL SCALE(NEQ, NIND, RWORK(LWT), H) CALL DINVWT(NEQ,RWORK(LWT),IER) IF (IER .NE. 0) THEN IDID = -3 GO TO 527 ENDIF IF (INFO(16) .NE. 0) THEN DO 515 I = 1, NEQ RWORK(LVT+I-1) = MAX(IWORK(LID+I-1),0)*RWORK(LWT+I-1) 515 CONTINUE ENDIF C C Test for too much accuracy requested. C R = DDWNRM(NEQ,RWORK(LPHI),RWORK(LWT),RPAR,IPAR)*100.0D0*UROUND IF (R .LE. 1.0D0) GO TO 525 C C Multiply RTOL and ATOL by R and return. C IF(INFO(2).EQ.1)GO TO 523 RTOL(1)=R*RTOL(1) ATOL(1)=R*ATOL(1) IDID=-2 GO TO 527 523 DO 524 I=1,NEQ RTOL(I)=R*RTOL(I) ATOL(I)=R*ATOL(I) 524 CONTINUE IDID=-2 GO TO 527 525 CONTINUE C C Compute minimum stepsize. C HMIN=4.0D0*UROUND*MAX(ABS(TN),ABS(TOUT)) C C Test H vs. HMAX IF (INFO(7) .NE. 0) THEN RH = ABS(H)/RWORK(LHMAX) IF (RH .GT. 1.0D0) H = H/RH ENDIF C C Call the one-step integrator. C Note that INFO(12) represents the nonlinear solver type. C Pass the required nonlinear solver, depending upon INFO(12). C IF (INFO(12) .EQ. 0) THEN CALL DDSTP(TN,Y,YPRIME,NEQ, * RES,JAC,PSOL,H,RWORK(LWT),RWORK(LVT),INFO(1),IDID,RPAR,IPAR, * RWORK(LPHI),RWORK(LSAVR),RWORK(LDELTA),RWORK(LE), * RWORK(LWM),IWORK(LIWM), * RWORK(LALPHA),RWORK(LBETA),RWORK(LGAMMA), * RWORK(LPSI),RWORK(LSIGMA), * RWORK(LCJ),RWORK(LCJOLD),RWORK(LHOLD),RWORK(LS),HMIN, * RWORK(LROUND), RWORK(LEPLI),RWORK(LSQRN),RWORK(LRSQRN), * RWORK(LEPCON), IWORK(LPHASE),IWORK(LJCALC),INFO(15), * IWORK(LK), IWORK(LKOLD),IWORK(LNS),NONNEG,INFO(12), * DNEDD) ELSE IF (INFO(12) .EQ. 1) THEN CALL DDSTP(TN,Y,YPRIME,NEQ, * RES,JAC,PSOL,H,RWORK(LWT),RWORK(LVT),INFO(1),IDID,RPAR,IPAR, * RWORK(LPHI),RWORK(LSAVR),RWORK(LDELTA),RWORK(LE), * RWORK(LWM),IWORK(LIWM), * RWORK(LALPHA),RWORK(LBETA),RWORK(LGAMMA), * RWORK(LPSI),RWORK(LSIGMA), * RWORK(LCJ),RWORK(LCJOLD),RWORK(LHOLD),RWORK(LS),HMIN, * RWORK(LROUND), RWORK(LEPLI),RWORK(LSQRN),RWORK(LRSQRN), * RWORK(LEPCON), IWORK(LPHASE),IWORK(LJCALC),INFO(15), * IWORK(LK), IWORK(LKOLD),IWORK(LNS),NONNEG,INFO(12), * DNEDK) ENDIF C 527 IF(IDID.LT.0)GO TO 600 C C----------------------------------------------------------------------- C This block handles the case of a successful return from DDSTP C (IDID=1). Test for stop conditions. C----------------------------------------------------------------------- C IF(INFO(4).NE.0)GO TO 540 IF(INFO(3).NE.0)GO TO 530 IF((TN-TOUT)*H.LT.0.0D0)GO TO 500 CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) IDID=3 T=TOUT GO TO 580 530 IF((TN-TOUT)*H.GE.0.0D0)GO TO 535 T=TN IDID=1 GO TO 580 535 CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) IDID=3 T=TOUT GO TO 580 540 IF(INFO(3).NE.0)GO TO 550 IF((TN-TOUT)*H.LT.0.0D0)GO TO 542 CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) T=TOUT IDID=3 GO TO 580 542 IF(ABS(TN-TSTOP).LE.100.0D0*UROUND* * (ABS(TN)+ABS(H)))GO TO 545 TNEXT=TN+H IF((TNEXT-TSTOP)*H.LE.0.0D0)GO TO 500 H=TSTOP-TN GO TO 500 545 CALL DDATRP(TN,TSTOP,Y,YPRIME,NEQ, * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) IDID=2 T=TSTOP GO TO 580 550 IF((TN-TOUT)*H.GE.0.0D0)GO TO 555 IF(ABS(TN-TSTOP).LE.100.0D0*UROUND*(ABS(TN)+ABS(H)))GO TO 552 T=TN IDID=1 GO TO 580 552 CALL DDATRP(TN,TSTOP,Y,YPRIME,NEQ, * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) IDID=2 T=TSTOP GO TO 580 555 CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) T=TOUT IDID=3 580 CONTINUE C C----------------------------------------------------------------------- C All successful returns from DDASPK are made from this block. C----------------------------------------------------------------------- C 590 CONTINUE RWORK(LTN)=TN RWORK(LH)=H RETURN C C----------------------------------------------------------------------- C This block handles all unsuccessful returns other than for C illegal input. C----------------------------------------------------------------------- C 600 CONTINUE ITEMP = -IDID IF (ITEMP .EQ. 1) THEN GOTO 610 ELSE IF (ITEMP .EQ. 2) THEN GOTO 620 ELSE IF (ITEMP .EQ. 3) THEN GOTO 630 ELSE IF (ITEMP .EQ. 4) THEN GOTO 700 ELSE IF (ITEMP .EQ. 5) THEN GOTO 655 ELSE IF (ITEMP .EQ. 6) THEN GOTO 640 ELSE IF (ITEMP .EQ. 7) THEN GOTO 650 ELSE IF (ITEMP .EQ. 8) THEN GOTO 660 ELSE IF (ITEMP .EQ. 9) THEN GOTO 670 ELSE IF (ITEMP .EQ. 10) THEN GOTO 675 ELSE IF (ITEMP .EQ. 11) THEN GOTO 680 ELSE IF (ITEMP .EQ. 12) THEN GOTO 685 ELSE IF (ITEMP .EQ. 13) THEN GOTO 690 ELSE IF (ITEMP .EQ. 14) THEN GOTO 695 ENDIF C GO TO (610,620,630,700,655,640,650,660,670,675, C * 680,685,690,695), ITEMP C C The maximum number of steps was taken before C reaching tout. C! Karline toggled this off, version > 1.10.3 unless lots of printing requested 610 IF(IWORK(LKPRIN) .GE. 2) THEN call rprintf( 1 'daspk-- warning.. At current T (=R1) max number steps' & // char(0)) call rprintfd1( 2 ' on this call before reaching tout %g' // char(0), TN) ENDIF GO TO 700 C C Too much accuracy for machine precision. C 620 call rprintf( 1 'daspk-- warning.. At T(=R1) too much accuracy requested' & // char(0)) call rprintf( 2 ' for precision of machine. rtol and atol were' // char(0)) call rprintfd1( 3 ' increased to appropriate values %g' & // char(0), TN ) GO TO 700 C C WT(I) .LE. 0.0D0 for some I (not at start of problem). C 630 call rprintf( 1 'daspk-- warning.. At T(=R1) some element of WT ' // char(0)) call rprintfd1( 2 ' has become less or equal than 0 %g' // char(0), TN ) GO TO 700 C C Error test failed repeatedly or with H=HMIN. C 640 call rprintf( 1 'daspk-- warning.. At T(=R1) and stepsize H (=R2)' & //char(0)) call rprintfd2( 2 ' error test failed repeatedly or with abs(H)=Hmin' & // ' %g, %g' // char(0), TN, H ) GO TO 700 C C Nonlinear solver failed to converge repeatedly or with H=HMIN. C 650 call rprintf( 1 'daspk-- warning.. At T(=R1) and stepsize H (=R2) the' & // char(0)) call rprintf( 2 ' nonlinear solver failed to converge ' // char(0)) call rprintfd2( 3 ' repeatedly of with abs (H) = HMIN &g, %g' & // char(0), TN, H) GO TO 700 C C The preconditioner had repeated failures. C 655 call rprintf( 1 'daspk-- warning.. At T(=R1) and stepsize H (=R2) the' & // char(0)) call rprintfd2( 2 ' preconditioner had repeated failures %g, %g' & // char(0), TN, H ) GO TO 700 C C The iteration matrix is singular. C 660 call rprintf( 1 'daspk-- warning.. At T(=R1) and stepsize H (=R2) the' & // char(0)) call rprintfd2( 2 ' iteration matrix is singular %g, %g' & // char(0), TN, H) GO TO 700 C C Nonlinear system failure preceded by error test failures. C 670 call rprintf( 1 'daspk-- warning.. At T(=R1) and stepsize H (=R2) the' & // char(0)) call rprintf( 2 ' nonlinear solver could not converge ' // char(0)) call rprintfd2( 3 ' Also the error test failed repeatedly %g, %g' & // char(0), TN, H ) GO TO 700 C C Nonlinear system failure because IRES = -1. C 675 call rprintf( 1 'daspk-- warning.. At T(=R1) and stepsize H (=R2) the' & // char(0)) call rprintf( 2 ' nonlinear system solver could not converge' & // char(0)) call rprintfd2( 3 ' because ires was equal to -1 %g, %g' & // char(0), TN, H) GO TO 700 C C Failure because IRES = -2. C 680 call rprintf( 1 'daspk-- warning.. At T(=R1) and stepsize H (=R2)' // char(0)) call rprintfd2( 2 ' ires was equal to -2 &g, %g' // char(0), TN, H ) GO TO 700 C C Failed to compute initial YPRIME. C 685 call rprintf( 1 'daspk-- warning.. At T(=R1) and stepsize H (=R2) the' & // char(0)) call rprintfd2( 2 ' initial yprime could not be computed %g, %g' & // char(0), TN, H0 ) GO TO 700 C C Failure because IER was negative from PSOL. C 690 call rprintf( 1 'daspk-- warning.. At T(=R1) and stepsize H (=R2)' // char(0)) call rprintfd2( 2 ' IER was negative from psol %g, %g' // char(0), TN, H) GO TO 700 C C Failure because the linear system solver could not converge. C 695 call rprintf( 1 'daspk-- warning.. At T(=R1) and stepsize H (=R2) the' & // char(0)) call rprintfd2( 2 ' linear system solver could not converge %g, %g' & // char(0), TN,H ) GO TO 700 C C 700 CONTINUE INFO(1)=-1 T=TN RWORK(LTN)=TN RWORK(LH)=H RETURN C C----------------------------------------------------------------------- C This block handles all error returns due to illegal input, C as detected before calling DDSTP. C First the error message routine is called. If this happens C twice in succession, execution is terminated. C----------------------------------------------------------------------- C 701 call rprintfi1( 1 'daspk-- element (= %i) of info vector is not valid' & // char(0),ITEMP) GO TO 750 702 call rprintfi1( 1 'daspk-- neq (= %i) < 0' // char(0), NEQ) GO TO 750 703 call rprintfi1( 1 'daspk-- maxord (= %i) not in range' // char(0), MXORD) GO TO 750 704 call rprintfi2( 1 'daspk-- rwork length needed, LENRW(= %i) exceeds LRW(= %i)' & // char(0), LENRW, LRW) GO TO 750 705 call rprintfi2( 1 'daspk-- iwork length needed, LENIW(= %i) exceeds LIW(= %i)' & // char(0), LENIW, LIW) GO TO 750 706 call rprintf( 1 'daspk-- some element of rtol is < 0' // char(0)) GO TO 750 707 call rprintf( 1 'daspk-- some element of atol is < 0' // char(0)) GO TO 750 708 call rprintf( 1 'daspk-- all elements of rtol and atol are 0' // char(0)) GO TO 750 709 call rprintfd2( 1 'daspk-- INFO(4)=1 and TSTOP (= %g) behind TOUT (= %g)' & // char(0),TSTOP,TOUT) GO TO 750 710 call rprintfd1( 1 'daspk-- HMAX (= %g) < 0' // char(0), HMAX) GO TO 750 711 call rprintfd2( 1 'daspk-- TOUT (= %g) behind T (= %g)' // char(0), TOUT, T) GO TO 750 712 call rprintf( 1 'daspk-- INFO(8)=1 and H0=0' // char(0)) GO TO 750 713 call rprintf( 1 'daspk-- some element of WT <= 0 ' // char(0)) GO TO 750 714 call rprintfd2( 1 'daspk-- TOUT (= %g) too close to T (= %g)' & // ' to start integration ' // char(0), TOUT, T) GO TO 750 715 call rprintfd2( 1 'daspk-- INFO(4)=1 and TSTOP (= %g) behind T (= %g)' & // char(0), TSTOP, T) GO TO 750 717 call rprintfi1( 1 'daspk-- ML (= %i) illegal - either < 0 or > neq' & // char(0),IWORK(LML)) GO TO 750 718 call rprintfi1( 1 'daspk-- MU (= %i) illegal - either < 0 or > neq' & // char(0),IWORK(LMU)) GO TO 750 719 call rprintfd2( 1 'daspk-- TOUT (= %g) is equal to T (= %g)' & // char(0),TOUT,T) GO TO 750 720 call rprintfi1( 1 'daspk-- MAXL (= %i) illegal - either < 1 or > neq' & // char(0), IWORK(LMAXL)) GO TO 750 721 call rprintfi1( 1 'daspk-- KMP (= %i) illegal - either < 1 or > MAXL' & // char(0), IWORK(LKMP)) GO TO 750 722 call rprintfi1( 1 'daspk-- NRMAX (= %i) illegal - < 0 ' & // char(0),IWORK(LNRMAX)) GO TO 750 723 call rprintfd1( 1 'daspk-- EPLI (= %g) illegal - either <= 0 or >= 1' & // char(0),RWORK(LEPLI)) GO TO 750 724 call rprintf( 1 'daspk-- illegal IWORK value for INFO(11) not equal to 0' & // char(0)) GO TO 750 725 call rprintf( 1 'daspk-- one of the inputs for INFO(17) = 1 is illegal' & // char(0)) GO TO 750 726 call rprintf( 1 'daspk-- illegal IWORK value for INFO(10) not equal to 0' & // char(0)) GO TO 750 727 call rprintfi1( 1 'daspk-- Y(I) and IWORK(40+I) (I= %i) inconsistent' & // char(0), IRET ) GO TO 750 750 IF(INFO(1).EQ.-1) GO TO 760 INFO(1)=-1 IDID=-33 RETURN 760 call rprintf( 1 'daspk-- repeated occurrences of illegal input' // char(0)) call rprintf( 1 'daspk-- run terminated; apparent infinite loop' // char(0)) RETURN C C------END OF SUBROUTINE DDASPK----------------------------------------- END C Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C SUBROUTINE DDASIC (X, Y, YPRIME, NEQ, ICOPT, ID, RES, JAC, PSOL, * H, WT, NIC, IDID, RPAR, IPAR, PHI, SAVR, DELTA, E, YIC, YPIC, * PWK, WM, IWM, HMIN, UROUND, EPLI, SQRTN, RSQRTN, EPCONI, * STPTOL, JFLG, ICNFLG, ICNSTR, NLSIC) C C***BEGIN PROLOGUE DDASIC C***REFER TO DDASPK C***DATE WRITTEN 940628 (YYMMDD) C***REVISION DATE 941206 (YYMMDD) C***REVISION DATE 950714 (YYMMDD) C C----------------------------------------------------------------------- C***DESCRIPTION C C DDASIC is a driver routine to compute consistent initial values C for Y and YPRIME. There are two different options: C Denoting the differential variables in Y by Y_d, and C the algebraic variables by Y_a, the problem solved is either: C 1. Given Y_d, calculate Y_a and Y_d', or C 2. Given Y', calculate Y. C In either case, initial values for the given components C are input, and initial guesses for the unknown components C must also be provided as input. C C The external routine NLSIC solves the resulting nonlinear system. C C The parameters represent C C X -- Independent variable. C Y -- Solution vector at X. C YPRIME -- Derivative of solution vector. C NEQ -- Number of equations to be integrated. C ICOPT -- Flag indicating initial condition option chosen. C ICOPT = 1 for option 1 above. C ICOPT = 2 for option 2. C ID -- Array of dimension NEQ, which must be initialized C if option 1 is chosen. C ID(i) = +1 if Y_i is a differential variable, C ID(i) = -1 if Y_i is an algebraic variable. C RES -- External user-supplied subroutine to evaluate the C residual. See RES description in DDASPK prologue. C JAC -- External user-supplied routine to update Jacobian C or preconditioner information in the nonlinear solver C (optional). See JAC description in DDASPK prologue. C PSOL -- External user-supplied routine to solve C a linear system using preconditioning. C See PSOL in DDASPK prologue. C H -- Scaling factor in iteration matrix. DDASIC may C reduce H to achieve convergence. C WT -- Vector of weights for error criterion. C NIC -- Input number of initial condition calculation call C (= 1 or 2). C IDID -- Completion code. See IDID in DDASPK prologue. C RPAR,IPAR -- Real and integer parameter arrays that C are used for communication between the C calling program and external user routines. C They are not altered by DNSK C PHI -- Work space for DDASIC of length at least 2*NEQ. C SAVR -- Work vector for DDASIC of length NEQ. C DELTA -- Work vector for DDASIC of length NEQ. C E -- Work vector for DDASIC of length NEQ. C YIC,YPIC -- Work vectors for DDASIC, each of length NEQ. C PWK -- Work vector for DDASIC of length NEQ. C WM,IWM -- Real and integer arrays storing C information required by the linear solver. C EPCONI -- Test constant for Newton iteration convergence. C ICNFLG -- Flag showing whether constraints on Y are to apply. C ICNSTR -- Integer array of length NEQ with constraint types. C C The other parameters are for use internally by DDASIC. C C----------------------------------------------------------------------- C***ROUTINES CALLED C DCOPY, NLSIC C C***END PROLOGUE DDASIC C C IMPLICIT DOUBLE PRECISION(A-H,O-Z) DIMENSION Y(*),YPRIME(*),ID(*),WT(*),PHI(NEQ,*) DIMENSION SAVR(*),DELTA(*),E(*),YIC(*),YPIC(*),PWK(*) DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*), ICNSTR(*) EXTERNAL RES, JAC, PSOL, NLSIC C PARAMETER (LCFN=15) PARAMETER (LMXNH=34) C C The following parameters are data-loaded here: C RHCUT = factor by which H is reduced on retry of Newton solve. C RATEMX = maximum convergence rate for which Newton iteration C is considered converging. C SAVE RHCUT, RATEMX DATA RHCUT/0.1D0/, RATEMX/0.8D0/ C C C----------------------------------------------------------------------- C BLOCK 1. C Initializations. C JSKIP is a flag set to 1 when NIC = 2 and NH = 1, to signal that C the initial call to the JAC routine is to be skipped then. C Save Y and YPRIME in PHI. Initialize IDID, NH, and CJ. C----------------------------------------------------------------------- C MXNH = IWM(LMXNH) IDID = 1 NH = 1 JSKIP = 0 IF (NIC .EQ. 2) JSKIP = 1 CALL DCOPY (NEQ, Y, 1, PHI(1,1), 1) CALL DCOPY (NEQ, YPRIME, 1, PHI(1,2), 1) C IF (ICOPT .EQ. 2) THEN CJ = 0.0D0 ELSE CJ = 1.0D0/H ENDIF C C----------------------------------------------------------------------- C BLOCK 2 C Call the nonlinear system solver to obtain C consistent initial values for Y and YPRIME. C----------------------------------------------------------------------- C 200 CONTINUE CALL NLSIC(X,Y,YPRIME,NEQ,ICOPT,ID,RES,JAC,PSOL,H,WT,JSKIP, * RPAR,IPAR,SAVR,DELTA,E,YIC,YPIC,PWK,WM,IWM,CJ,UROUND, * EPLI,SQRTN,RSQRTN,EPCONI,RATEMX,STPTOL,JFLG,ICNFLG,ICNSTR, * IERNLS) C IF (IERNLS .EQ. 0) RETURN C C----------------------------------------------------------------------- C BLOCK 3 C The nonlinear solver was unsuccessful. Increment NCFN. C Return with IDID = -12 if either C IERNLS = -1: error is considered unrecoverable, C ICOPT = 2: we are doing initialization problem type 2, or C NH = MXNH: the maximum number of H values has been tried. C Otherwise (problem 1 with IERNLS .GE. 1), reduce H and try again. C If IERNLS > 1, restore Y and YPRIME to their original values. C----------------------------------------------------------------------- C IWM(LCFN) = IWM(LCFN) + 1 JSKIP = 0 C IF (IERNLS .EQ. -1) GO TO 350 IF (ICOPT .EQ. 2) GO TO 350 IF (NH .EQ. MXNH) GO TO 350 C NH = NH + 1 H = H*RHCUT CJ = 1.0D0/H C IF (IERNLS .EQ. 1) GO TO 200 C CALL DCOPY (NEQ, PHI(1,1), 1, Y, 1) CALL DCOPY (NEQ, PHI(1,2), 1, YPRIME, 1) GO TO 200 C 350 IDID = -12 RETURN C C------END OF SUBROUTINE DDASIC----------------------------------------- END C Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C SUBROUTINE DYYPNW (NEQ, Y, YPRIME, CJ, RL, P, ICOPT, ID, * YNEW, YPNEW) C C***BEGIN PROLOGUE DYYPNW C***REFER TO DLINSK C***DATE WRITTEN 940830 (YYMMDD) C C C----------------------------------------------------------------------- C***DESCRIPTION C C DYYPNW calculates the new (Y,YPRIME) pair needed in the C linesearch algorithm based on the current lambda value. It is C called by DLINSK and DLINSD. Based on the ICOPT and ID values, C the corresponding entry in Y or YPRIME is updated. C C In addition to the parameters described in the calling programs, C the parameters represent C C P -- Array of length NEQ that contains the current C approximate Newton step. C RL -- Scalar containing the current lambda value. C YNEW -- Array of length NEQ containing the updated Y vector. C YPNEW -- Array of length NEQ containing the updated YPRIME C vector. C----------------------------------------------------------------------- C C***ROUTINES CALLED (NONE) C C***END PROLOGUE DYYPNW C C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION Y(*), YPRIME(*), YNEW(*), YPNEW(*), ID(*), P(*) C IF (ICOPT .EQ. 1) THEN DO 10 I=1,NEQ IF(ID(I) .LT. 0) THEN YNEW(I) = Y(I) - RL*P(I) YPNEW(I) = YPRIME(I) ELSE YNEW(I) = Y(I) YPNEW(I) = YPRIME(I) - RL*CJ*P(I) ENDIF 10 CONTINUE ELSE DO 20 I = 1,NEQ YNEW(I) = Y(I) - RL*P(I) YPNEW(I) = YPRIME(I) 20 CONTINUE ENDIF RETURN C----------------------- END OF SUBROUTINE DYYPNW ---------------------- END C Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C SUBROUTINE DDSTP(X,Y,YPRIME,NEQ,RES,JAC,PSOL,H,WT,VT, * JSTART,IDID,RPAR,IPAR,PHI,SAVR,DELTA,E,WM,IWM, * ALPHA,BETA,GAMMA,PSI,SIGMA,CJ,CJOLD,HOLD,S,HMIN,UROUND, * EPLI,SQRTN,RSQRTN,EPCON,IPHASE,JCALC,JFLG,K,KOLD,NS,NONNEG, * NTYPE,NLS) C C***BEGIN PROLOGUE DDSTP C***REFER TO DDASPK C***DATE WRITTEN 890101 (YYMMDD) C***REVISION DATE 900926 (YYMMDD) C***REVISION DATE 940909 (YYMMDD) (Reset PSI(1), PHI(*,2) at 690) C C C----------------------------------------------------------------------- C***DESCRIPTION C C DDSTP solves a system of differential/algebraic equations of C the form G(X,Y,YPRIME) = 0, for one step (normally from X to X+H). C C The methods used are modified divided difference, fixed leading C coefficient forms of backward differentiation formulas. C The code adjusts the stepsize and order to control the local error C per step. C C C The parameters represent C X -- Independent variable. C Y -- Solution vector at X. C YPRIME -- Derivative of solution vector C after successful step. C NEQ -- Number of equations to be integrated. C RES -- External user-supplied subroutine C to evaluate the residual. See RES description C in DDASPK prologue. C JAC -- External user-supplied routine to update C Jacobian or preconditioner information in the C nonlinear solver. See JAC description in DDASPK C prologue. C PSOL -- External user-supplied routine to solve C a linear system using preconditioning. C (This is optional). See PSOL in DDASPK prologue. C H -- Appropriate step size for next step. C Normally determined by the code. C WT -- Vector of weights for error criterion used in Newton test. C VT -- Masked vector of weights used in error test. C JSTART -- Integer variable set 0 for C first step, 1 otherwise. C IDID -- Completion code returned from the nonlinear solver. C See IDID description in DDASPK prologue. C RPAR,IPAR -- Real and integer parameter arrays that C are used for communication between the C calling program and external user routines. C They are not altered by DNSK C PHI -- Array of divided differences used by C DDSTP. The length is NEQ*(K+1), where C K is the maximum order. C SAVR -- Work vector for DDSTP of length NEQ. C DELTA,E -- Work vectors for DDSTP of length NEQ. C WM,IWM -- Real and integer arrays storing C information required by the linear solver. C C The other parameters are information C which is needed internally by DDSTP to C continue from step to step. C C----------------------------------------------------------------------- C***ROUTINES CALLED C NLS, DDWNRM, DDATRP C C***END PROLOGUE DDSTP C C IMPLICIT DOUBLE PRECISION(A-H,O-Z) DIMENSION Y(*),YPRIME(*),WT(*),VT(*) DIMENSION PHI(NEQ,*),SAVR(*),DELTA(*),E(*) DIMENSION WM(*),IWM(*) DIMENSION PSI(*),ALPHA(*),BETA(*),GAMMA(*),SIGMA(*) DIMENSION RPAR(*),IPAR(*) EXTERNAL RES, JAC, PSOL, NLS C PARAMETER (LMXORD=3) PARAMETER (LNST=11, LETF=14, LCFN=15) C C C----------------------------------------------------------------------- C BLOCK 1. C Initialize. On the first call, set C the order to 1 and initialize C other variables. C----------------------------------------------------------------------- C C Initializations for all calls C XOLD=X NCF=0 NEF=0 IF(JSTART .NE. 0) GO TO 120 C C If this is the first step, perform C other initializations C K=1 KOLD=0 HOLD=0.0D0 PSI(1)=H CJ = 1.D0/H IPHASE = 0 NS=0 120 CONTINUE C C C C C C----------------------------------------------------------------------- C BLOCK 2 C Compute coefficients of formulas for C this step. C----------------------------------------------------------------------- 200 CONTINUE KP1=K+1 KP2=K+2 KM1=K-1 IF(H.NE.HOLD.OR.K .NE. KOLD) NS = 0 NS=MIN0(NS+1,KOLD+2) NSP1=NS+1 IF(KP1 .LT. NS)GO TO 230 C BETA(1)=1.0D0 ALPHA(1)=1.0D0 TEMP1=H GAMMA(1)=0.0D0 SIGMA(1)=1.0D0 DO 210 I=2,KP1 TEMP2=PSI(I-1) PSI(I-1)=TEMP1 BETA(I)=BETA(I-1)*PSI(I-1)/TEMP2 TEMP1=TEMP2+H ALPHA(I)=H/TEMP1 SIGMA(I)=(I-1)*SIGMA(I-1)*ALPHA(I) GAMMA(I)=GAMMA(I-1)+ALPHA(I-1)/H 210 CONTINUE PSI(KP1)=TEMP1 230 CONTINUE C C Compute ALPHAS, ALPHA0 C ALPHAS = 0.0D0 ALPHA0 = 0.0D0 DO 240 I = 1,K ALPHAS = ALPHAS - 1.0D0/I ALPHA0 = ALPHA0 - ALPHA(I) 240 CONTINUE C C Compute leading coefficient CJ C CJLAST = CJ CJ = -ALPHAS/H C C Compute variable stepsize error coefficient CK C CK = ABS(ALPHA(KP1) + ALPHAS - ALPHA0) CK = MAX(CK,ALPHA(KP1)) C C Change PHI to PHI STAR C IF(KP1 .LT. NSP1) GO TO 280 DO 270 J=NSP1,KP1 DO 260 I=1,NEQ PHI(I,J)=BETA(J)*PHI(I,J) 260 CONTINUE 270 CONTINUE 280 CONTINUE C C Update time C X=X+H C C Initialize IDID to 1 C IDID = 1 C C C C C C----------------------------------------------------------------------- C BLOCK 3 C Call the nonlinear system solver to obtain the solution and C derivative. C----------------------------------------------------------------------- C CALL NLS(X,Y,YPRIME,NEQ, * RES,JAC,PSOL,H,WT,JSTART,IDID,RPAR,IPAR,PHI,GAMMA, * SAVR,DELTA,E,WM,IWM,CJ,CJOLD,CJLAST,S, * UROUND,EPLI,SQRTN,RSQRTN,EPCON,JCALC,JFLG,KP1, * NONNEG,NTYPE,IERNLS) C IF(IERNLS .NE. 0)GO TO 600 C C C C C C----------------------------------------------------------------------- C BLOCK 4 C Estimate the errors at orders K,K-1,K-2 C as if constant stepsize was used. Estimate C the local error at order K and test C whether the current step is successful. C----------------------------------------------------------------------- C C Estimate errors at orders K,K-1,K-2 C ENORM = DDWNRM(NEQ,E,VT,RPAR,IPAR) ERK = SIGMA(K+1)*ENORM TERK = (K+1)*ERK EST = ERK KNEW=K IF(K .EQ. 1)GO TO 430 DO 405 I = 1,NEQ DELTA(I) = PHI(I,KP1) + E(I) 405 CONTINUE ERKM1=SIGMA(K)*DDWNRM(NEQ,DELTA,VT,RPAR,IPAR) TERKM1 = K*ERKM1 IF(K .GT. 2)GO TO 410 IF(TERKM1 .LE. 0.5*TERK)GO TO 420 GO TO 430 410 CONTINUE DO 415 I = 1,NEQ DELTA(I) = PHI(I,K) + DELTA(I) 415 CONTINUE ERKM2=SIGMA(K-1)*DDWNRM(NEQ,DELTA,VT,RPAR,IPAR) TERKM2 = (K-1)*ERKM2 IF(MAX(TERKM1,TERKM2).GT.TERK)GO TO 430 C C Lower the order C 420 CONTINUE KNEW=K-1 EST = ERKM1 C C C Calculate the local error for the current step C to see if the step was successful C 430 CONTINUE ERR = CK * ENORM IF(ERR .GT. 1.0D0)GO TO 600 C C C C C C----------------------------------------------------------------------- C BLOCK 5 C The step is successful. Determine C the best order and stepsize for C the next step. Update the differences C for the next step. C----------------------------------------------------------------------- IDID=1 IWM(LNST)=IWM(LNST)+1 KDIFF=K-KOLD KOLD=K HOLD=H C C C Estimate the error at order K+1 unless C already decided to lower order, or C already using maximum order, or C stepsize not constant, or C order raised in previous step C IF(KNEW.EQ.KM1.OR.K.EQ.IWM(LMXORD))IPHASE=1 IF(IPHASE .EQ. 0)GO TO 545 IF(KNEW.EQ.KM1)GO TO 540 IF(K.EQ.IWM(LMXORD)) GO TO 550 IF(KP1.GE.NS.OR.KDIFF.EQ.1)GO TO 550 DO 510 I=1,NEQ DELTA(I)=E(I)-PHI(I,KP2) 510 CONTINUE ERKP1 = (1.0D0/(K+2))*DDWNRM(NEQ,DELTA,VT,RPAR,IPAR) TERKP1 = (K+2)*ERKP1 IF(K.GT.1)GO TO 520 IF(TERKP1.GE.0.5D0*TERK)GO TO 550 GO TO 530 520 IF(TERKM1.LE.MIN(TERK,TERKP1))GO TO 540 IF(TERKP1.GE.TERK.OR.K.EQ.IWM(LMXORD))GO TO 550 C C Raise order C 530 K=KP1 EST = ERKP1 GO TO 550 C C Lower order C 540 K=KM1 EST = ERKM1 GO TO 550 C C If IPHASE = 0, increase order by one and multiply stepsize by C factor two C 545 K = KP1 HNEW = H*2.0D0 H = HNEW GO TO 575 C C C Determine the appropriate stepsize for C the next step. C 550 HNEW=H TEMP2=K+1 R=(2.0D0*EST+0.0001D0)**(-1.0D0/TEMP2) IF(R .LT. 2.0D0) GO TO 555 HNEW = 2.0D0*H GO TO 560 555 IF(R .GT. 1.0D0) GO TO 560 R = MAX(0.5D0,MIN(0.9D0,R)) HNEW = H*R 560 H=HNEW C C C Update differences for next step C 575 CONTINUE IF(KOLD.EQ.IWM(LMXORD))GO TO 585 DO 580 I=1,NEQ PHI(I,KP2)=E(I) 580 CONTINUE 585 CONTINUE DO 590 I=1,NEQ PHI(I,KP1)=PHI(I,KP1)+E(I) 590 CONTINUE DO 596 J1=2,KP1 J=KP1-J1+1 DO 595 I=1,NEQ PHI(I,J)=PHI(I,J)+PHI(I,J+1) 595 CONTINUE 596 CONTINUE JSTART = 1 RETURN C C C C C C----------------------------------------------------------------------- C BLOCK 6 C The step is unsuccessful. Restore X,PSI,PHI C Determine appropriate stepsize for C continuing the integration, or exit with C an error flag if there have been many C failures. C----------------------------------------------------------------------- 600 IPHASE = 1 C C Restore X,PHI,PSI C X=XOLD IF(KP1.LT.NSP1)GO TO 630 DO 620 J=NSP1,KP1 TEMP1=1.0D0/BETA(J) DO 610 I=1,NEQ PHI(I,J)=TEMP1*PHI(I,J) 610 CONTINUE 620 CONTINUE 630 CONTINUE DO 640 I=2,KP1 PSI(I-1)=PSI(I)-H 640 CONTINUE C C C Test whether failure is due to nonlinear solver C or error test C IF(IERNLS .EQ. 0)GO TO 660 IWM(LCFN)=IWM(LCFN)+1 C C C The nonlinear solver failed to converge. C Determine the cause of the failure and take appropriate action. C If IERNLS .LT. 0, then return. Otherwise, reduce the stepsize C and try again, unless too many failures have occurred. C IF (IERNLS .LT. 0) GO TO 675 NCF = NCF + 1 R = 0.25D0 H = H*R IF (NCF .LT. 10 .AND. ABS(H) .GE. HMIN) GO TO 690 IF (IDID .EQ. 1) IDID = -7 IF (NEF .GE. 3) IDID = -9 GO TO 675 C C C The nonlinear solver converged, and the cause C of the failure was the error estimate C exceeding the tolerance. C 660 NEF=NEF+1 IWM(LETF)=IWM(LETF)+1 IF (NEF .GT. 1) GO TO 665 C C On first error test failure, keep current order or lower C order by one. Compute new stepsize based on differences C of the solution. C K = KNEW TEMP2 = K + 1 R = 0.90D0*(2.0D0*EST+0.0001D0)**(-1.0D0/TEMP2) R = MAX(0.25D0,MIN(0.9D0,R)) H = H*R IF (ABS(H) .GE. HMIN) GO TO 690 IDID = -6 GO TO 675 C C On second error test failure, use the current order or C decrease order by one. Reduce the stepsize by a factor of C one quarter. C 665 IF (NEF .GT. 2) GO TO 670 K = KNEW R = 0.25D0 H = R*H IF (ABS(H) .GE. HMIN) GO TO 690 IDID = -6 GO TO 675 C C On third and subsequent error test failures, set the order to C one, and reduce the stepsize by a factor of one quarter. C 670 K = 1 R = 0.25D0 H = R*H IF (ABS(H) .GE. HMIN) GO TO 690 IDID = -6 GO TO 675 C C C C C For all crashes, restore Y to its last value, C interpolate to find YPRIME at last X, and return. C C Before returning, verify that the user has not set C IDID to a nonnegative value. If the user has set IDID C to a nonnegative value, then reset IDID to be -7, indicating C a failure in the nonlinear system solver. C 675 CONTINUE CALL DDATRP(X,X,Y,YPRIME,NEQ,K,PHI,PSI) JSTART = 1 IF (IDID .GE. 0) IDID = -7 RETURN C C C Go back and try this step again. C If this is the first step, reset PSI(1) and rescale PHI(*,2). C 690 IF (KOLD .EQ. 0) THEN PSI(1) = H DO 695 I = 1,NEQ PHI(I,2) = R*PHI(I,2) 695 CONTINUE ENDIF GO TO 200 C C------END OF SUBROUTINE DDSTP------------------------------------------ END C Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C SUBROUTINE DCNSTR (NEQ, Y, YNEW, ICNSTR, TAU, RLX, IRET, IVAR) C C***BEGIN PROLOGUE DCNSTR C***DATE WRITTEN 950808 (YYMMDD) C***REVISION DATE 950814 (YYMMDD) C C C----------------------------------------------------------------------- C***DESCRIPTION C C This subroutine checks for constraint violations in the proposed C new approximate solution YNEW. C If a constraint violation occurs, then a new step length, TAU, C is calculated, and this value is to be given to the linesearch routine C to calculate a new approximate solution YNEW. C C On entry: C C NEQ -- size of the nonlinear system, and the length of arrays C Y, YNEW and ICNSTR. C C Y -- real array containing the current approximate y. C C YNEW -- real array containing the new approximate y. C C ICNSTR -- INTEGER array of length NEQ containing flags indicating C which entries in YNEW are to be constrained. C if ICNSTR(I) = 2, then YNEW(I) must be .GT. 0, C if ICNSTR(I) = 1, then YNEW(I) must be .GE. 0, C if ICNSTR(I) = -1, then YNEW(I) must be .LE. 0, while C if ICNSTR(I) = -2, then YNEW(I) must be .LT. 0, while C if ICNSTR(I) = 0, then YNEW(I) is not constrained. C C RLX -- real scalar restricting update, if ICNSTR(I) = 2 or -2, C to ABS( (YNEW-Y)/Y ) < FAC2*RLX in component I. C C TAU -- the current size of the step length for the linesearch. C C On return C C TAU -- the adjusted size of the step length if a constraint C violation occurred (otherwise, it is unchanged). it is C the step length to give to the linesearch routine. C C IRET -- output flag. C IRET=0 means that YNEW satisfied all constraints. C IRET=1 means that YNEW failed to satisfy all the C constraints, and a new linesearch step C must be computed. C C IVAR -- index of variable causing constraint to be violated. C C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION(A-H,O-Z) DIMENSION Y(NEQ), YNEW(NEQ), ICNSTR(NEQ) SAVE FAC, FAC2, ZERO DATA FAC /0.6D0/, FAC2 /0.9D0/, ZERO/0.0D0/ C----------------------------------------------------------------------- C Check constraints for proposed new step YNEW. If a constraint has C been violated, then calculate a new step length, TAU, to be C used in the linesearch routine. C----------------------------------------------------------------------- IRET = 0 RDYMX = ZERO IVAR = 0 DO 100 I = 1,NEQ C IF (ICNSTR(I) .EQ. 2) THEN RDY = ABS( (YNEW(I)-Y(I))/Y(I) ) IF (RDY .GT. RDYMX) THEN RDYMX = RDY IVAR = I ENDIF IF (YNEW(I) .LE. ZERO) THEN TAU = FAC*TAU IVAR = I IRET = 1 RETURN ENDIF C ELSEIF (ICNSTR(I) .EQ. 1) THEN IF (YNEW(I) .LT. ZERO) THEN TAU = FAC*TAU IVAR = I IRET = 1 RETURN ENDIF C ELSEIF (ICNSTR(I) .EQ. -1) THEN IF (YNEW(I) .GT. ZERO) THEN TAU = FAC*TAU IVAR = I IRET = 1 RETURN ENDIF C ELSEIF (ICNSTR(I) .EQ. -2) THEN RDY = ABS( (YNEW(I)-Y(I))/Y(I) ) IF (RDY .GT. RDYMX) THEN RDYMX = RDY IVAR = I ENDIF IF (YNEW(I) .GE. ZERO) THEN TAU = FAC*TAU IVAR = I IRET = 1 RETURN ENDIF C ENDIF 100 CONTINUE IF(RDYMX .GE. RLX) THEN TAU = FAC2*TAU*RLX/RDYMX IRET = 1 ENDIF C RETURN C----------------------- END OF SUBROUTINE DCNSTR ---------------------- END C Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C SUBROUTINE DCNST0 (NEQ, Y, ICNSTR, IRET) C C***BEGIN PROLOGUE DCNST0 C***DATE WRITTEN 950808 (YYMMDD) C***REVISION DATE 950808 (YYMMDD) C C C----------------------------------------------------------------------- C***DESCRIPTION C C This subroutine checks for constraint violations in the initial C approximate solution u. C C On entry C C NEQ -- size of the nonlinear system, and the length of arrays C Y and ICNSTR. C C Y -- real array containing the initial approximate root. C C ICNSTR -- INTEGER array of length NEQ containing flags indicating C which entries in Y are to be constrained. C if ICNSTR(I) = 2, then Y(I) must be .GT. 0, C if ICNSTR(I) = 1, then Y(I) must be .GE. 0, C if ICNSTR(I) = -1, then Y(I) must be .LE. 0, while C if ICNSTR(I) = -2, then Y(I) must be .LT. 0, while C if ICNSTR(I) = 0, then Y(I) is not constrained. C C On return C C IRET -- output flag. C IRET=0 means that u satisfied all constraints. C IRET.NE.0 means that Y(IRET) failed to satisfy its C constraint. C C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION(A-H,O-Z) DIMENSION Y(NEQ), ICNSTR(NEQ) SAVE ZERO DATA ZERO/0.D0/ C----------------------------------------------------------------------- C Check constraints for initial Y. If a constraint has been violated, C set IRET = I to signal an error return to calling routine. C----------------------------------------------------------------------- IRET = 0 DO 100 I = 1,NEQ IF (ICNSTR(I) .EQ. 2) THEN IF (Y(I) .LE. ZERO) THEN IRET = I RETURN ENDIF ELSEIF (ICNSTR(I) .EQ. 1) THEN IF (Y(I) .LT. ZERO) THEN IRET = I RETURN ENDIF ELSEIF (ICNSTR(I) .EQ. -1) THEN IF (Y(I) .GT. ZERO) THEN IRET = I RETURN ENDIF ELSEIF (ICNSTR(I) .EQ. -2) THEN IF (Y(I) .GE. ZERO) THEN IRET = I RETURN ENDIF ENDIF 100 CONTINUE RETURN C----------------------- END OF SUBROUTINE DCNST0 ---------------------- END C Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C SUBROUTINE DDAWTS(NEQ,IWT,RTOL,ATOL,Y,WT,RPAR,IPAR) C C***BEGIN PROLOGUE DDAWTS C***REFER TO DDASPK C***ROUTINES CALLED (NONE) C***DATE WRITTEN 890101 (YYMMDD) C***REVISION DATE 900926 (YYMMDD) C***END PROLOGUE DDAWTS C----------------------------------------------------------------------- C This subroutine sets the error weight vector, C WT, according to WT(I)=RTOL(I)*ABS(Y(I))+ATOL(I), C I = 1 to NEQ. C RTOL and ATOL are scalars if IWT = 0, C and vectors if IWT = 1. C----------------------------------------------------------------------- C IMPLICIT DOUBLE PRECISION(A-H,O-Z) DIMENSION RTOL(*),ATOL(*),Y(*),WT(*) DIMENSION RPAR(*),IPAR(*) RTOLI=RTOL(1) ATOLI=ATOL(1) DO 20 I=1,NEQ IF (IWT .EQ.0) GO TO 10 RTOLI=RTOL(I) ATOLI=ATOL(I) 10 WT(I)=RTOLI*ABS(Y(I))+ATOLI 20 CONTINUE RETURN C C------END OF SUBROUTINE DDAWTS----------------------------------------- END C Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C SUBROUTINE DINVWT(NEQ,WT,IER) C C***BEGIN PROLOGUE DINVWT C***REFER TO DDASPK C***ROUTINES CALLED (NONE) C***DATE WRITTEN 950125 (YYMMDD) C***END PROLOGUE DINVWT C----------------------------------------------------------------------- C This subroutine checks the error weight vector WT, of length NEQ, C for components that are .le. 0, and if none are found, it C inverts the WT(I) in place. This replaces division operations C with multiplications in all norm evaluations. C IER is returned as 0 if all WT(I) were found positive, C and the first I with WT(I) .le. 0.0 otherwise. C----------------------------------------------------------------------- C IMPLICIT DOUBLE PRECISION(A-H,O-Z) DIMENSION WT(*) C DO 10 I = 1,NEQ IF (WT(I) .LE. 0.0D0) GO TO 30 10 CONTINUE DO 20 I = 1,NEQ WT(I) = 1.0D0/WT(I) 20 CONTINUE IER = 0 RETURN C 30 IER = I RETURN C C------END OF SUBROUTINE DINVWT----------------------------------------- END C Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C SUBROUTINE DDATRP(X,XOUT,YOUT,YPOUT,NEQ,KOLD,PHI,PSI) C C***BEGIN PROLOGUE DDATRP C***REFER TO DDASPK C***ROUTINES CALLED (NONE) C***DATE WRITTEN 890101 (YYMMDD) C***REVISION DATE 900926 (YYMMDD) C***END PROLOGUE DDATRP C C----------------------------------------------------------------------- C The methods in subroutine DDSTP use polynomials C to approximate the solution. DDATRP approximates the C solution and its derivative at time XOUT by evaluating C one of these polynomials, and its derivative, there. C Information defining this polynomial is passed from C DDSTP, so DDATRP cannot be used alone. C C The parameters are C C X The current time in the integration. C XOUT The time at which the solution is desired. C YOUT The interpolated approximation to Y at XOUT. C (This is output.) C YPOUT The interpolated approximation to YPRIME at XOUT. C (This is output.) C NEQ Number of equations. C KOLD Order used on last successful step. C PHI Array of scaled divided differences of Y. C PSI Array of past stepsize history. C----------------------------------------------------------------------- C IMPLICIT DOUBLE PRECISION(A-H,O-Z) DIMENSION YOUT(*),YPOUT(*) DIMENSION PHI(NEQ,*),PSI(*) KOLDP1=KOLD+1 TEMP1=XOUT-X DO 10 I=1,NEQ YOUT(I)=PHI(I,1) YPOUT(I)=0.0D0 10 CONTINUE C=1.0D0 D=0.0D0 GAMMA=TEMP1/PSI(1) DO 30 J=2,KOLDP1 D=D*GAMMA+C/PSI(J-1) C=C*GAMMA GAMMA=(TEMP1+PSI(J-1))/PSI(J) DO 20 I=1,NEQ YOUT(I)=YOUT(I)+C*PHI(I,J) YPOUT(I)=YPOUT(I)+D*PHI(I,J) 20 CONTINUE 30 CONTINUE RETURN C C------END OF SUBROUTINE DDATRP----------------------------------------- END C Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C DOUBLE PRECISION FUNCTION DDWNRM(NEQ,V,RWT,RPAR,IPAR) C C***BEGIN PROLOGUE DDWNRM C***ROUTINES CALLED (NONE) C***DATE WRITTEN 890101 (YYMMDD) C***REVISION DATE 900926 (YYMMDD) C***END PROLOGUE DDWNRM C----------------------------------------------------------------------- C This function routine computes the weighted C root-mean-square norm of the vector of length C NEQ contained in the array V, with reciprocal weights C contained in the array RWT of length NEQ. C DDWNRM=SQRT((1/NEQ)*SUM(V(I)*RWT(I))**2) C----------------------------------------------------------------------- C IMPLICIT DOUBLE PRECISION(A-H,O-Z) DIMENSION V(*),RWT(*) DIMENSION RPAR(*),IPAR(*) DDWNRM = 0.0D0 VMAX = 0.0D0 DO 10 I = 1,NEQ IF(ABS(V(I)*RWT(I)) .GT. VMAX) VMAX = ABS(V(I)*RWT(I)) 10 CONTINUE IF(VMAX .LE. 0.0D0) GO TO 30 SUM = 0.0D0 DO 20 I = 1,NEQ SUM = SUM + ((V(I)*RWT(I))/VMAX)**2 20 CONTINUE DDWNRM = VMAX*SQRT(SUM/NEQ) 30 CONTINUE RETURN C C------END OF FUNCTION DDWNRM------------------------------------------- END C Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C SUBROUTINE DDASID(X,Y,YPRIME,NEQ,ICOPT,ID,RES,JACD,PDUM,H,WT, * JSDUM,RPAR,IPAR,DUMSVR,DELTA,R,YIC,YPIC,DUMPWK,WM,IWM,CJ,UROUND, * DUME,DUMS,DUMR,EPCON,RATEMX,STPTOL,JFDUM, * ICNFLG,ICNSTR,IERNLS) C C***BEGIN PROLOGUE DDASID C***REFER TO DDASPK C***DATE WRITTEN 940701 (YYMMDD) C***REVISION DATE 950808 (YYMMDD) C***REVISION DATE 951110 Removed unreachable block 390. C C C----------------------------------------------------------------------- C***DESCRIPTION C C C DDASID solves a nonlinear system of algebraic equations of the C form G(X,Y,YPRIME) = 0 for the unknown parts of Y and YPRIME in C the initial conditions. C C The method used is a modified Newton scheme. C C The parameters represent C C X -- Independent variable. C Y -- Solution vector. C YPRIME -- Derivative of solution vector. C NEQ -- Number of unknowns. C ICOPT -- Initial condition option chosen (1 or 2). C ID -- Array of dimension NEQ, which must be initialized C if ICOPT = 1. See DDASIC. C RES -- External user-supplied subroutine to evaluate the C residual. See RES description in DDASPK prologue. C JACD -- External user-supplied routine to evaluate the C Jacobian. See JAC description for the case C INFO(12) = 0 in the DDASPK prologue. C PDUM -- Dummy argument. C H -- Scaling factor for this initial condition calc. C WT -- Vector of weights for error criterion. C JSDUM -- Dummy argument. C RPAR,IPAR -- Real and integer arrays used for communication C between the calling program and external user C routines. They are not altered within DASPK. C DUMSVR -- Dummy argument. C DELTA -- Work vector for NLS of length NEQ. C R -- Work vector for NLS of length NEQ. C YIC,YPIC -- Work vectors for NLS, each of length NEQ. C DUMPWK -- Dummy argument. C WM,IWM -- Real and integer arrays storing matrix information C such as the matrix of partial derivatives, C permutation vector, and various other information. C CJ -- Matrix parameter = 1/H (ICOPT = 1) or 0 (ICOPT = 2). C UROUND -- Unit roundoff. C DUME -- Dummy argument. C DUMS -- Dummy argument. C DUMR -- Dummy argument. C EPCON -- Tolerance to test for convergence of the Newton C iteration. C RATEMX -- Maximum convergence rate for which Newton iteration C is considered converging. C JFDUM -- Dummy argument. C STPTOL -- Tolerance used in calculating the minimum lambda C value allowed. C ICNFLG -- Integer scalar. If nonzero, then constraint C violations in the proposed new approximate solution C will be checked for, and the maximum step length C will be adjusted accordingly. C ICNSTR -- Integer array of length NEQ containing flags for C checking constraints. C IERNLS -- Error flag for nonlinear solver. C 0 ==> nonlinear solver converged. C 1,2 ==> recoverable error inside nonlinear solver. C 1 => retry with current Y, YPRIME C 2 => retry with original Y, YPRIME C -1 ==> unrecoverable error in nonlinear solver. C C All variables with "DUM" in their names are dummy variables C which are not used in this routine. C C----------------------------------------------------------------------- C C***ROUTINES CALLED C RES, DMATD, DNSID C C***END PROLOGUE DDASID C C IMPLICIT DOUBLE PRECISION(A-H,O-Z) DIMENSION Y(*),YPRIME(*),ID(*),WT(*),ICNSTR(*) DIMENSION DELTA(*),R(*),YIC(*),YPIC(*) DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*) EXTERNAL RES, JACD C PARAMETER (LNRE=12, LNJE=13, LMXNIT=32, LMXNJ=33) C C C Perform initializations. C MXNIT = IWM(LMXNIT) MXNJ = IWM(LMXNJ) IERNLS = 0 NJ = 0 C C Call RES to initialize DELTA. C IRES = 0 IWM(LNRE) = IWM(LNRE) + 1 CALL RES(X,Y,YPRIME,CJ,DELTA,IRES,RPAR,IPAR) IF (IRES .LT. 0) GO TO 370 C C Looping point for updating the Jacobian. C 300 CONTINUE C C Initialize all error flags to zero. C IERJ = 0 IRES = 0 IERNEW = 0 C C Reevaluate the iteration matrix, J = dG/dY + CJ*dG/dYPRIME, C where G(X,Y,YPRIME) = 0. C NJ = NJ + 1 IWM(LNJE)=IWM(LNJE)+1 CALL DMATD(NEQ,X,Y,YPRIME,DELTA,CJ,H,IERJ,WT,R, * WM,IWM,RES,IRES,UROUND,JACD,RPAR,IPAR) IF (IRES .LT. 0 .OR. IERJ .NE. 0) GO TO 370 C C Call the nonlinear Newton solver for up to MXNIT iterations. C CALL DNSID(X,Y,YPRIME,NEQ,ICOPT,ID,RES,WT,RPAR,IPAR,DELTA,R, * YIC,YPIC,WM,IWM,CJ,EPCON,RATEMX,MXNIT,STPTOL, * ICNFLG,ICNSTR,IERNEW) C IF (IERNEW .EQ. 1 .AND. NJ .LT. MXNJ) THEN C C MXNIT iterations were done, the convergence rate is < 1, C and the number of Jacobian evaluations is less than MXNJ. C Call RES, reevaluate the Jacobian, and try again. C IWM(LNRE)=IWM(LNRE)+1 CALL RES(X,Y,YPRIME,CJ,DELTA,IRES,RPAR,IPAR) IF (IRES .LT. 0) GO TO 370 GO TO 300 ENDIF C IF (IERNEW .NE. 0) GO TO 380 RETURN C C C Unsuccessful exits from nonlinear solver. C Compute IERNLS accordingly. C 370 IERNLS = 2 IF (IRES .LE. -2) IERNLS = -1 RETURN C 380 IERNLS = MIN(IERNEW,2) RETURN C C------END OF SUBROUTINE DDASID----------------------------------------- END C Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C SUBROUTINE DNSID(X,Y,YPRIME,NEQ,ICOPT,ID,RES,WT,RPAR,IPAR, * DELTA,R,YIC,YPIC,WM,IWM,CJ,EPCON,RATEMX,MAXIT,STPTOL, * ICNFLG,ICNSTR,IERNEW) C C***BEGIN PROLOGUE DNSID C***REFER TO DDASPK C***DATE WRITTEN 940701 (YYMMDD) C***REVISION DATE 950713 (YYMMDD) C C C----------------------------------------------------------------------- C***DESCRIPTION C C DNSID solves a nonlinear system of algebraic equations of the C form G(X,Y,YPRIME) = 0 for the unknown parts of Y and YPRIME C in the initial conditions. C C The method used is a modified Newton scheme. C C The parameters represent C C X -- Independent variable. C Y -- Solution vector. C YPRIME -- Derivative of solution vector. C NEQ -- Number of unknowns. C ICOPT -- Initial condition option chosen (1 or 2). C ID -- Array of dimension NEQ, which must be initialized C if ICOPT = 1. See DDASIC. C RES -- External user-supplied subroutine to evaluate the C residual. See RES description in DDASPK prologue. C WT -- Vector of weights for error criterion. C RPAR,IPAR -- Real and integer arrays used for communication C between the calling program and external user C routines. They are not altered within DASPK. C DELTA -- Residual vector on entry, and work vector of C length NEQ for DNSID. C WM,IWM -- Real and integer arrays storing matrix information C such as the matrix of partial derivatives, C permutation vector, and various other information. C CJ -- Matrix parameter = 1/H (ICOPT = 1) or 0 (ICOPT = 2). C R -- Array of length NEQ used as workspace by the C linesearch routine DLINSD. C YIC,YPIC -- Work vectors for DLINSD, each of length NEQ. C EPCON -- Tolerance to test for convergence of the Newton C iteration. C RATEMX -- Maximum convergence rate for which Newton iteration C is considered converging. C MAXIT -- Maximum allowed number of Newton iterations. C STPTOL -- Tolerance used in calculating the minimum lambda C value allowed. C ICNFLG -- Integer scalar. If nonzero, then constraint C violations in the proposed new approximate solution C will be checked for, and the maximum step length C will be adjusted accordingly. C ICNSTR -- Integer array of length NEQ containing flags for C checking constraints. C IERNEW -- Error flag for Newton iteration. C 0 ==> Newton iteration converged. C 1 ==> failed to converge, but RATE .le. RATEMX. C 2 ==> failed to converge, RATE .gt. RATEMX. C 3 ==> other recoverable error (IRES = -1, or C linesearch failed). C -1 ==> unrecoverable error (IRES = -2). C C----------------------------------------------------------------------- C C***ROUTINES CALLED C DSLVD, DDWNRM, DLINSD, DCOPY C C***END PROLOGUE DNSID C C IMPLICIT DOUBLE PRECISION(A-H,O-Z) DIMENSION Y(*),YPRIME(*),WT(*),R(*) DIMENSION ID(*),DELTA(*), YIC(*), YPIC(*) DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*) DIMENSION ICNSTR(*) EXTERNAL RES C PARAMETER (LNNI=19, LLSOFF=35) C C C Initializations. M is the Newton iteration counter. C LSOFF = IWM(LLSOFF) M = 0 RATE = 1.0D0 RLX = 0.4D0 C C Compute a new step vector DELTA by back-substitution. C CALL DSLVD (NEQ, DELTA, WM, IWM) C C Get norm of DELTA. Return now if norm(DELTA) .le. EPCON. C DELNRM = DDWNRM(NEQ,DELTA,WT,RPAR,IPAR) FNRM = DELNRM IF (FNRM .LE. EPCON) RETURN C C Newton iteration loop. C 300 CONTINUE IWM(LNNI) = IWM(LNNI) + 1 C C Call linesearch routine for global strategy and set RATE C OLDFNM = FNRM C CALL DLINSD (NEQ, Y, X, YPRIME, CJ, DELTA, DELNRM, WT, LSOFF, * STPTOL, IRET, RES, IRES, WM, IWM, FNRM, ICOPT, ID, * R, YIC, YPIC, ICNFLG, ICNSTR, RLX, RPAR, IPAR) C RATE = FNRM/OLDFNM C C Check for error condition from linesearch. IF (IRET .NE. 0) GO TO 390 C C Test for convergence of the iteration, and return or loop. C IF (FNRM .LE. EPCON) RETURN C C The iteration has not yet converged. Update M. C Test whether the maximum number of iterations have been tried. C M = M + 1 IF (M .GE. MAXIT) GO TO 380 C C Copy the residual to DELTA and its norm to DELNRM, and loop for C another iteration. C CALL DCOPY (NEQ, R, 1, DELTA, 1) DELNRM = FNRM GO TO 300 C C The maximum number of iterations was done. Set IERNEW and return. C 380 IF (RATE .LE. RATEMX) THEN IERNEW = 1 ELSE IERNEW = 2 ENDIF RETURN C 390 IF (IRES .LE. -2) THEN IERNEW = -1 ELSE IERNEW = 3 ENDIF RETURN C C C------END OF SUBROUTINE DNSID------------------------------------------ END C Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C SUBROUTINE DLINSD (NEQ, Y, T, YPRIME, CJ, P, PNRM, WT, LSOFF, * STPTOL, IRET, RES, IRES, WM, IWM, * FNRM, ICOPT, ID, R, YNEW, YPNEW, ICNFLG, * ICNSTR, RLX, RPAR, IPAR) C C***BEGIN PROLOGUE DLINSD C***REFER TO DNSID C***DATE WRITTEN 941025 (YYMMDD) C***REVISION DATE 941215 (YYMMDD) C***REVISION DATE 960129 Moved line RL = ONE to top block. C C C----------------------------------------------------------------------- C***DESCRIPTION C C DLINSD uses a linesearch algorithm to calculate a new (Y,YPRIME) C pair (YNEW,YPNEW) such that C C f(YNEW,YPNEW) .le. (1 - 2*ALPHA*RL)*f(Y,YPRIME) , C C where 0 < RL <= 1. Here, f(y,y') is defined as C C f(y,y') = (1/2)*norm( (J-inverse)*G(t,y,y') )**2 , C C where norm() is the weighted RMS vector norm, G is the DAE C system residual function, and J is the system iteration matrix C (Jacobian). C C In addition to the parameters defined elsewhere, we have C C P -- Approximate Newton step used in backtracking. C PNRM -- Weighted RMS norm of P. C LSOFF -- Flag showing whether the linesearch algorithm is C to be invoked. 0 means do the linesearch, and C 1 means turn off linesearch. C STPTOL -- Tolerance used in calculating the minimum lambda C value allowed. C ICNFLG -- Integer scalar. If nonzero, then constraint violations C in the proposed new approximate solution will be C checked for, and the maximum step length will be C adjusted accordingly. C ICNSTR -- Integer array of length NEQ containing flags for C checking constraints. C RLX -- Real scalar restricting update size in DCNSTR. C YNEW -- Array of length NEQ used to hold the new Y in C performing the linesearch. C YPNEW -- Array of length NEQ used to hold the new YPRIME in C performing the linesearch. C Y -- Array of length NEQ containing the new Y (i.e.,=YNEW). C YPRIME -- Array of length NEQ containing the new YPRIME C (i.e.,=YPNEW). C FNRM -- Real scalar containing SQRT(2*f(Y,YPRIME)) for the C current (Y,YPRIME) on input and output. C R -- Work array of length NEQ, containing the scaled C residual (J-inverse)*G(t,y,y') on return. C IRET -- Return flag. C IRET=0 means that a satisfactory (Y,YPRIME) was found. C IRET=1 means that the routine failed to find a new C (Y,YPRIME) that was sufficiently distinct from C the current (Y,YPRIME) pair. C IRET=2 means IRES .ne. 0 from RES. C----------------------------------------------------------------------- C C***ROUTINES CALLED C DFNRMD, DYYPNW, DCOPY C C***END PROLOGUE DLINSD C IMPLICIT DOUBLE PRECISION(A-H,O-Z) EXTERNAL RES DIMENSION Y(*), YPRIME(*), WT(*), R(*), ID(*) DIMENSION WM(*), IWM(*) DIMENSION YNEW(*), YPNEW(*), P(*), ICNSTR(*) DIMENSION RPAR(*), IPAR(*) C PARAMETER (LNRE=12, LKPRIN=31) C SAVE ALPHA, ONE, TWO DATA ALPHA/1.0D-4/, ONE/1.0D0/, TWO/2.0D0/ C KPRIN=IWM(LKPRIN) C F1NRM = (FNRM*FNRM)/TWO RATIO = ONE IF (KPRIN .GE. 2) THEN call rprintfd1( 1 'daspk-- in routine dlinsd--PNRM (= %g)' // char(0), PNRM) ENDIF TAU = PNRM IVIO = 0 RL = ONE C----------------------------------------------------------------------- C Check for violations of the constraints, if any are imposed. C If any violations are found, the step vector P is rescaled, and the C constraint check is repeated, until no violations are found. C----------------------------------------------------------------------- IF (ICNFLG .NE. 0) THEN 10 CONTINUE CALL DYYPNW (NEQ,Y,YPRIME,CJ,RL,P,ICOPT,ID,YNEW,YPNEW) CALL DCNSTR (NEQ, Y, YNEW, ICNSTR, TAU, RLX, IRET, IVAR) IF (IRET .EQ. 1) THEN IVIO = 1 RATIO1 = TAU/PNRM RATIO = RATIO*RATIO1 DO 20 I = 1,NEQ P(I) = P(I)*RATIO1 20 CONTINUE PNRM = TAU IF (KPRIN .GE. 2) THEN call rprintfid( 1 'daspk-- constraint violation-PNRM (= %g), index =( %i)' & // char(0), 2 IVAR,PNRM) ENDIF IF (PNRM .LE. STPTOL) THEN IRET = 1 RETURN ENDIF GO TO 10 ENDIF ENDIF C SLPI = (-TWO*F1NRM)*RATIO RLMIN = STPTOL/PNRM IF (LSOFF .EQ. 0 .AND. KPRIN .GE. 2) THEN call rprintfd1( 1 'daspk-- min lambda (= %g)' // char(0), RLMIN) ENDIF C----------------------------------------------------------------------- C Begin iteration to find RL value satisfying alpha-condition. C If RL becomes less than RLMIN, then terminate with IRET = 1. C----------------------------------------------------------------------- 100 CONTINUE CALL DYYPNW (NEQ,Y,YPRIME,CJ,RL,P,ICOPT,ID,YNEW,YPNEW) CALL DFNRMD (NEQ, YNEW, T, YPNEW, R, CJ, WT, RES, IRES, * FNRMP, WM, IWM, RPAR, IPAR) IWM(LNRE) = IWM(LNRE) + 1 IF (IRES .NE. 0) THEN IRET = 2 RETURN ENDIF IF (LSOFF .EQ. 1) GO TO 150 C F1NRMP = FNRMP*FNRMP/TWO IF (KPRIN .GE. 2) THEN call rprintfd1( 1 'daspk-- LAMBDA (= %g)' // char(0), RL) call rprintfd2( 1 'daspk-- NORM(F1) = %g, NORM(F1NEW) = %g' & // char(0), F1NRM, F1NRMP) ENDIF IF (F1NRMP .GT. F1NRM + ALPHA*SLPI*RL) GO TO 200 C----------------------------------------------------------------------- C Alpha-condition is satisfied, or linesearch is turned off. C Copy YNEW,YPNEW to Y,YPRIME and return. C----------------------------------------------------------------------- 150 IRET = 0 CALL DCOPY (NEQ, YNEW, 1, Y, 1) CALL DCOPY (NEQ, YPNEW, 1, YPRIME, 1) FNRM = FNRMP IF (KPRIN .GE. 1) THEN call rprintfd1( 1 'daspk-- leaving routine dlinsd--FNRM (= %g)' & // char(0),FNRM) ENDIF RETURN C----------------------------------------------------------------------- C Alpha-condition not satisfied. Perform backtrack to compute new RL C value. If no satisfactory YNEW,YPNEW can be found sufficiently C distinct from Y,YPRIME, then return IRET = 1. C----------------------------------------------------------------------- 200 CONTINUE IF (RL .LT. RLMIN) THEN IRET = 1 RETURN ENDIF C RL = RL/TWO GO TO 100 C C----------------------- END OF SUBROUTINE DLINSD ---------------------- END C Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C SUBROUTINE DFNRMD (NEQ, Y, T, YPRIME, R, CJ, WT, RES, IRES, * FNORM, WM, IWM, RPAR, IPAR) C C***BEGIN PROLOGUE DFNRMD C***REFER TO DLINSD C***DATE WRITTEN 941025 (YYMMDD) C C C----------------------------------------------------------------------- C***DESCRIPTION C C DFNRMD calculates the scaled preconditioned norm of the nonlinear C function used in the nonlinear iteration for obtaining consistent C initial conditions. Specifically, DFNRMD calculates the weighted C root-mean-square norm of the vector (J-inverse)*G(T,Y,YPRIME), C where J is the Jacobian matrix. C C In addition to the parameters described in the calling program C DLINSD, the parameters represent C C R -- Array of length NEQ that contains C (J-inverse)*G(T,Y,YPRIME) on return. C FNORM -- Scalar containing the weighted norm of R on return. C----------------------------------------------------------------------- C C***ROUTINES CALLED C RES, DSLVD, DDWNRM C C***END PROLOGUE DFNRMD C C IMPLICIT DOUBLE PRECISION (A-H,O-Z) EXTERNAL RES DIMENSION Y(*), YPRIME(*), WT(*), R(*) DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*) C----------------------------------------------------------------------- C Call RES routine. C----------------------------------------------------------------------- IRES = 0 CALL RES(T,Y,YPRIME,CJ,R,IRES,RPAR,IPAR) IF (IRES .LT. 0) RETURN C----------------------------------------------------------------------- C Apply inverse of Jacobian to vector R. C----------------------------------------------------------------------- CALL DSLVD(NEQ,R,WM,IWM) C----------------------------------------------------------------------- C Calculate norm of R. C----------------------------------------------------------------------- FNORM = DDWNRM(NEQ,R,WT,RPAR,IPAR) C RETURN C----------------------- END OF SUBROUTINE DFNRMD ---------------------- END C Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C SUBROUTINE DNEDD(X,Y,YPRIME,NEQ,RES,JACD,PDUM,H,WT, * JSTART,IDID,RPAR,IPAR,PHI,GAMMA,DUMSVR,DELTA,E, * WM,IWM,CJ,CJOLD,CJLAST,S,UROUND,DUME,DUMS,DUMR, * EPCON,JCALC,JFDUM,KP1,NONNEG,NTYPE,IERNLS) C C***BEGIN PROLOGUE DNEDD C***REFER TO DDASPK C***DATE WRITTEN 891219 (YYMMDD) C***REVISION DATE 900926 (YYMMDD) C C C----------------------------------------------------------------------- C***DESCRIPTION C C DNEDD solves a nonlinear system of C algebraic equations of the form C G(X,Y,YPRIME) = 0 for the unknown Y. C C The method used is a modified Newton scheme. C C The parameters represent C C X -- Independent variable. C Y -- Solution vector. C YPRIME -- Derivative of solution vector. C NEQ -- Number of unknowns. C RES -- External user-supplied subroutine C to evaluate the residual. See RES description C in DDASPK prologue. C JACD -- External user-supplied routine to evaluate the C Jacobian. See JAC description for the case C INFO(12) = 0 in the DDASPK prologue. C PDUM -- Dummy argument. C H -- Appropriate step size for next step. C WT -- Vector of weights for error criterion. C JSTART -- Indicates first call to this routine. C If JSTART = 0, then this is the first call, C otherwise it is not. C IDID -- Completion flag, output by DNEDD. C See IDID description in DDASPK prologue. C RPAR,IPAR -- Real and integer arrays used for communication C between the calling program and external user C routines. They are not altered within DASPK. C PHI -- Array of divided differences used by C DNEDD. The length is NEQ*(K+1),where C K is the maximum order. C GAMMA -- Array used to predict Y and YPRIME. The length C is MAXORD+1 where MAXORD is the maximum order. C DUMSVR -- Dummy argument. C DELTA -- Work vector for NLS of length NEQ. C E -- Error accumulation vector for NLS of length NEQ. C WM,IWM -- Real and integer arrays storing C matrix information such as the matrix C of partial derivatives, permutation C vector, and various other information. C CJ -- Parameter always proportional to 1/H. C CJOLD -- Saves the value of CJ as of the last call to DMATD. C Accounts for changes in CJ needed to C decide whether to call DMATD. C CJLAST -- Previous value of CJ. C S -- A scalar determined by the approximate rate C of convergence of the Newton iteration and used C in the convergence test for the Newton iteration. C C If RATE is defined to be an estimate of the C rate of convergence of the Newton iteration, C then S = RATE/(1.D0-RATE). C C The closer RATE is to 0., the faster the Newton C iteration is converging; the closer RATE is to 1., C the slower the Newton iteration is converging. C C On the first Newton iteration with an up-dated C preconditioner S = 100.D0, Thus the initial C RATE of convergence is approximately 1. C C S is preserved from call to call so that the rate C estimate from a previous step can be applied to C the current step. C UROUND -- Unit roundoff. C DUME -- Dummy argument. C DUMS -- Dummy argument. C DUMR -- Dummy argument. C EPCON -- Tolerance to test for convergence of the Newton C iteration. C JCALC -- Flag used to determine when to update C the Jacobian matrix. In general: C C JCALC = -1 ==> Call the DMATD routine to update C the Jacobian matrix. C JCALC = 0 ==> Jacobian matrix is up-to-date. C JCALC = 1 ==> Jacobian matrix is out-dated, C but DMATD will not be called unless C JCALC is set to -1. C JFDUM -- Dummy argument. C KP1 -- The current order(K) + 1; updated across calls. C NONNEG -- Flag to determine nonnegativity constraints. C NTYPE -- Identification code for the NLS routine. C 0 ==> modified Newton; direct solver. C IERNLS -- Error flag for nonlinear solver. C 0 ==> nonlinear solver converged. C 1 ==> recoverable error inside nonlinear solver. C -1 ==> unrecoverable error inside nonlinear solver. C C All variables with "DUM" in their names are dummy variables C which are not used in this routine. C C Following is a list and description of local variables which C may not have an obvious usage. They are listed in roughly the C order they occur in this subroutine. C C The following group of variables are passed as arguments to C the Newton iteration solver. They are explained in greater detail C in DNSD: C TOLNEW, MULDEL, MAXIT, IERNEW C C IERTYP -- Flag which tells whether this subroutine is correct. C 0 ==> correct subroutine. C 1 ==> incorrect subroutine. C C----------------------------------------------------------------------- C***ROUTINES CALLED C DDWNRM, RES, DMATD, DNSD C C***END PROLOGUE DNEDD C C IMPLICIT DOUBLE PRECISION(A-H,O-Z) DIMENSION Y(*),YPRIME(*),WT(*) DIMENSION DELTA(*),E(*) DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*) DIMENSION PHI(NEQ,*),GAMMA(*) EXTERNAL RES, JACD C PARAMETER (LNRE=12, LNJE=13) C SAVE MULDEL, MAXIT, XRATE DATA MULDEL/1/, MAXIT/4/, XRATE/0.25D0/ C C Verify that this is the correct subroutine. C IERTYP = 0 IF (NTYPE .NE. 0) THEN IERTYP = 1 GO TO 380 ENDIF C C If this is the first step, perform initializations. C IF (JSTART .EQ. 0) THEN CJOLD = CJ JCALC = -1 ENDIF C C Perform all other initializations. C IERNLS = 0 C C Decide whether new Jacobian is needed. C TEMP1 = (1.0D0 - XRATE)/(1.0D0 + XRATE) TEMP2 = 1.0D0/TEMP1 IF (CJ/CJOLD .LT. TEMP1 .OR. CJ/CJOLD .GT. TEMP2) JCALC = -1 IF (CJ .NE. CJLAST) S = 100.D0 C C----------------------------------------------------------------------- C Entry point for updating the Jacobian with current C stepsize. C----------------------------------------------------------------------- 300 CONTINUE C C Initialize all error flags to zero. C IERJ = 0 IRES = 0 IERNEW = 0 C C Predict the solution and derivative and compute the tolerance C for the Newton iteration. C DO 310 I=1,NEQ Y(I)=PHI(I,1) YPRIME(I)=0.0D0 310 CONTINUE DO 330 J=2,KP1 DO 320 I=1,NEQ Y(I)=Y(I)+PHI(I,J) YPRIME(I)=YPRIME(I)+GAMMA(J)*PHI(I,J) 320 CONTINUE 330 CONTINUE PNORM = DDWNRM (NEQ,Y,WT,RPAR,IPAR) TOLNEW = 100.D0*UROUND*PNORM C C Call RES to initialize DELTA. C IWM(LNRE)=IWM(LNRE)+1 CALL RES(X,Y,YPRIME,CJ,DELTA,IRES,RPAR,IPAR) IF (IRES .LT. 0) GO TO 380 C C If indicated, reevaluate the iteration matrix C J = dG/dY + CJ*dG/dYPRIME (where G(X,Y,YPRIME)=0). C Set JCALC to 0 as an indicator that this has been done. C IF(JCALC .EQ. -1) THEN IWM(LNJE)=IWM(LNJE)+1 JCALC=0 CALL DMATD(NEQ,X,Y,YPRIME,DELTA,CJ,H,IERJ,WT,E,WM,IWM, * RES,IRES,UROUND,JACD,RPAR,IPAR) CJOLD=CJ S = 100.D0 IF (IRES .LT. 0) GO TO 380 IF(IERJ .NE. 0)GO TO 380 ENDIF C C Call the nonlinear Newton solver. C TEMP1 = 2.0D0/(1.0D0 + CJ/CJOLD) CALL DNSD(X,Y,YPRIME,NEQ,RES,PDUM,WT,RPAR,IPAR,DUMSVR, * DELTA,E,WM,IWM,CJ,DUMS,DUMR,DUME,EPCON,S,TEMP1, * TOLNEW,MULDEL,MAXIT,IRES,IDUM,IERNEW) C IF (IERNEW .GT. 0 .AND. JCALC .NE. 0) THEN C C The Newton iteration had a recoverable failure with an old C iteration matrix. Retry the step with a new iteration matrix. C JCALC = -1 GO TO 300 ENDIF C IF (IERNEW .NE. 0) GO TO 380 C C The Newton iteration has converged. If nonnegativity of C solution is required, set the solution nonnegative, if the C perturbation to do it is small enough. If the change is too C large, then consider the corrector iteration to have failed. C IF(NONNEG .EQ. 0) GO TO 390 DO 377 I = 1,NEQ DELTA(I) = MIN(Y(I),0.0D0) 377 CONTINUE DELNRM = DDWNRM(NEQ,DELTA,WT,RPAR,IPAR) IF(DELNRM .GT. EPCON) GO TO 380 DO 378 I = 1,NEQ E(I) = E(I) - DELTA(I) 378 CONTINUE GO TO 390 C C C Exits from nonlinear solver. C No convergence with current iteration C matrix, or singular iteration matrix. C Compute IERNLS and IDID accordingly. C 380 CONTINUE IF (IRES .LE. -2 .OR. IERTYP .NE. 0) THEN IERNLS = -1 IF (IRES .LE. -2) IDID = -11 IF (IERTYP .NE. 0) IDID = -15 ELSE IERNLS = 1 IF (IRES .LT. 0) IDID = -10 IF (IERJ .NE. 0) IDID = -8 ENDIF C 390 JCALC = 1 RETURN C C------END OF SUBROUTINE DNEDD------------------------------------------ END C Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C SUBROUTINE DNSD(X,Y,YPRIME,NEQ,RES,PDUM,WT,RPAR,IPAR, * DUMSVR,DELTA,E,WM,IWM,CJ,DUMS,DUMR,DUME,EPCON, * S,CONFAC,TOLNEW,MULDEL,MAXIT,IRES,IDUM,IERNEW) C C***BEGIN PROLOGUE DNSD C***REFER TO DDASPK C***DATE WRITTEN 891219 (YYMMDD) C***REVISION DATE 900926 (YYMMDD) C***REVISION DATE 950126 (YYMMDD) C C C----------------------------------------------------------------------- C***DESCRIPTION C C DNSD solves a nonlinear system of C algebraic equations of the form C G(X,Y,YPRIME) = 0 for the unknown Y. C C The method used is a modified Newton scheme. C C The parameters represent C C X -- Independent variable. C Y -- Solution vector. C YPRIME -- Derivative of solution vector. C NEQ -- Number of unknowns. C RES -- External user-supplied subroutine C to evaluate the residual. See RES description C in DDASPK prologue. C PDUM -- Dummy argument. C WT -- Vector of weights for error criterion. C RPAR,IPAR -- Real and integer arrays used for communication C between the calling program and external user C routines. They are not altered within DASPK. C DUMSVR -- Dummy argument. C DELTA -- Work vector for DNSD of length NEQ. C E -- Error accumulation vector for DNSD of length NEQ. C WM,IWM -- Real and integer arrays storing C matrix information such as the matrix C of partial derivatives, permutation C vector, and various other information. C CJ -- Parameter always proportional to 1/H (step size). C DUMS -- Dummy argument. C DUMR -- Dummy argument. C DUME -- Dummy argument. C EPCON -- Tolerance to test for convergence of the Newton C iteration. C S -- Used for error convergence tests. C In the Newton iteration: S = RATE/(1 - RATE), C where RATE is the estimated rate of convergence C of the Newton iteration. C The calling routine passes the initial value C of S to the Newton iteration. C CONFAC -- A residual scale factor to improve convergence. C TOLNEW -- Tolerance on the norm of Newton correction in C alternative Newton convergence test. C MULDEL -- A flag indicating whether or not to multiply C DELTA by CONFAC. C 0 ==> do not scale DELTA by CONFAC. C 1 ==> scale DELTA by CONFAC. C MAXIT -- Maximum allowed number of Newton iterations. C IRES -- Error flag returned from RES. See RES description C in DDASPK prologue. If IRES = -1, then IERNEW C will be set to 1. C If IRES < -1, then IERNEW will be set to -1. C IDUM -- Dummy argument. C IERNEW -- Error flag for Newton iteration. C 0 ==> Newton iteration converged. C 1 ==> recoverable error inside Newton iteration. C -1 ==> unrecoverable error inside Newton iteration. C C All arguments with "DUM" in their names are dummy arguments C which are not used in this routine. C----------------------------------------------------------------------- C C***ROUTINES CALLED C DSLVD, DDWNRM, RES C C***END PROLOGUE DNSD C C IMPLICIT DOUBLE PRECISION(A-H,O-Z) DIMENSION Y(*),YPRIME(*),WT(*),DELTA(*),E(*) DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*) EXTERNAL RES C PARAMETER (LNRE=12, LNNI=19) C C Initialize Newton counter M and accumulation vector E. C M = 0 DO 100 I=1,NEQ E(I)=0.0D0 100 CONTINUE C C Corrector loop. C 300 CONTINUE IWM(LNNI) = IWM(LNNI) + 1 C C If necessary, multiply residual by convergence factor. C IF (MULDEL .EQ. 1) THEN DO 320 I = 1,NEQ DELTA(I) = DELTA(I) * CONFAC 320 CONTINUE ENDIF C C Compute a new iterate (back-substitution). C Store the correction in DELTA. C CALL DSLVD(NEQ,DELTA,WM,IWM) C C Update Y, E, and YPRIME. C DO 340 I=1,NEQ Y(I)=Y(I)-DELTA(I) E(I)=E(I)-DELTA(I) YPRIME(I)=YPRIME(I)-CJ*DELTA(I) 340 CONTINUE C C Test for convergence of the iteration. C DELNRM=DDWNRM(NEQ,DELTA,WT,RPAR,IPAR) IF (DELNRM .LE. TOLNEW) GO TO 370 IF (M .EQ. 0) THEN OLDNRM = DELNRM ELSE RATE = (DELNRM/OLDNRM)**(1.0D0/M) IF (RATE .GT. 0.9D0) GO TO 380 S = RATE/(1.0D0 - RATE) ENDIF IF (S*DELNRM .LE. EPCON) GO TO 370 C C The corrector has not yet converged. C Update M and test whether the C maximum number of iterations have C been tried. C M=M+1 IF(M.GE.MAXIT) GO TO 380 C C Evaluate the residual, C and go back to do another iteration. C IWM(LNRE)=IWM(LNRE)+1 CALL RES(X,Y,YPRIME,CJ,DELTA,IRES,RPAR,IPAR) IF (IRES .LT. 0) GO TO 380 GO TO 300 C C The iteration has converged. C 370 RETURN C C The iteration has not converged. Set IERNEW appropriately. C 380 CONTINUE IF (IRES .LE. -2 ) THEN IERNEW = -1 ELSE IERNEW = 1 ENDIF RETURN C C C------END OF SUBROUTINE DNSD------------------------------------------- END C Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C SUBROUTINE DMATD(NEQ,X,Y,YPRIME,DELTA,CJ,H,IER,EWT,E, * WM,IWM,RES,IRES,UROUND,JACD,RPAR,IPAR) C C***BEGIN PROLOGUE DMATD C***REFER TO DDASPK C***DATE WRITTEN 890101 (YYMMDD) C***REVISION DATE 900926 (YYMMDD) C***REVISION DATE 940701 (YYMMDD) (new LIPVT) C C----------------------------------------------------------------------- C***DESCRIPTION C C This routine computes the iteration matrix C J = dG/dY+CJ*dG/dYPRIME (where G(X,Y,YPRIME)=0). C Here J is computed by: C the user-supplied routine JACD if IWM(MTYPE) is 1 or 4, or C by numerical difference quotients if IWM(MTYPE) is 2 or 5. C C The parameters have the following meanings. C X = Independent variable. C Y = Array containing predicted values. C YPRIME = Array containing predicted derivatives. C DELTA = Residual evaluated at (X,Y,YPRIME). C (Used only if IWM(MTYPE)=2 or 5). C CJ = Scalar parameter defining iteration matrix. C H = Current stepsize in integration. C IER = Variable which is .NE. 0 if iteration matrix C is singular, and 0 otherwise. C EWT = Vector of error weights for computing norms. C E = Work space (temporary) of length NEQ. C WM = Real work space for matrices. On output C it contains the LU decomposition C of the iteration matrix. C IWM = Integer work space containing C matrix information. C RES = External user-supplied subroutine C to evaluate the residual. See RES description C in DDASPK prologue. C IRES = Flag which is equal to zero if no illegal values C in RES, and less than zero otherwise. (If IRES C is less than zero, the matrix was not completed). C In this case (if IRES .LT. 0), then IER = 0. C UROUND = The unit roundoff error of the machine being used. C JACD = Name of the external user-supplied routine C to evaluate the iteration matrix. (This routine C is only used if IWM(MTYPE) is 1 or 4) C See JAC description for the case INFO(12) = 0 C in DDASPK prologue. C RPAR,IPAR= Real and integer parameter arrays that C are used for communication between the C calling program and external user routines. C They are not altered by DMATD. C----------------------------------------------------------------------- C***ROUTINES CALLED C JACD, RES, DGEFA, DGBFA C C***END PROLOGUE DMATD C C IMPLICIT DOUBLE PRECISION(A-H,O-Z) DIMENSION Y(*),YPRIME(*),DELTA(*),EWT(*),E(*) DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*) EXTERNAL RES, JACD C PARAMETER (LML=1, LMU=2, LMTYPE=4, LNRE=12, LNPD=22, LLCIWP=30) C LIPVT = IWM(LLCIWP) IER = 0 MTYPE=IWM(LMTYPE) IF (MTYPE .EQ. 1) THEN GOTO 100 ELSE IF (MTYPE .EQ. 2) THEN GOTO 200 ELSE IF (MTYPE .EQ. 3) THEN GOTO 300 ELSE IF (MTYPE .EQ. 4) THEN GOTO 400 ELSE IF (MTYPE .EQ. 5) THEN GOTO 500 ENDIF C GO TO (100,200,300,400,500),MTYPE C C C Dense user-supplied matrix. C 100 LENPD=IWM(LNPD) DO 110 I=1,LENPD WM(I)=0.0D0 110 CONTINUE CALL JACD(X,Y,YPRIME,WM,CJ,RPAR,IPAR) GO TO 230 C C C Dense finite-difference-generated matrix. C 200 IRES=0 NROW=0 SQUR = SQRT(UROUND) DO 210 I=1,NEQ DEL=SQUR*MAX(ABS(Y(I)),ABS(H*YPRIME(I)), * ABS(1.D0/EWT(I))) DEL=SIGN(DEL,H*YPRIME(I)) DEL=(Y(I)+DEL)-Y(I) YSAVE=Y(I) YPSAVE=YPRIME(I) Y(I)=Y(I)+DEL YPRIME(I)=YPRIME(I)+CJ*DEL IWM(LNRE)=IWM(LNRE)+1 CALL RES(X,Y,YPRIME,CJ,E,IRES,RPAR,IPAR) IF (IRES .LT. 0) RETURN DELINV=1.0D0/DEL DO 220 L=1,NEQ WM(NROW+L)=(E(L)-DELTA(L))*DELINV 220 CONTINUE NROW=NROW+NEQ Y(I)=YSAVE YPRIME(I)=YPSAVE 210 CONTINUE C C C Do dense-matrix LU decomposition on J. C 230 CALL DGEFA(WM,NEQ,NEQ,IWM(LIPVT),IER) RETURN C C C Dummy section for IWM(MTYPE)=3. C 300 RETURN C C C Banded user-supplied matrix. C 400 LENPD=IWM(LNPD) DO 410 I=1,LENPD WM(I)=0.0D0 410 CONTINUE CALL JACD(X,Y,YPRIME,WM,CJ,RPAR,IPAR) MEBAND=2*IWM(LML)+IWM(LMU)+1 GO TO 550 C C C Banded finite-difference-generated matrix. C 500 MBAND=IWM(LML)+IWM(LMU)+1 MBA=MIN0(MBAND,NEQ) MEBAND=MBAND+IWM(LML) MEB1=MEBAND-1 MSAVE=(NEQ/MBAND)+1 ISAVE=IWM(LNPD) IPSAVE=ISAVE+MSAVE IRES=0 SQUR=SQRT(UROUND) DO 540 J=1,MBA DO 510 N=J,NEQ,MBAND K= (N-J)/MBAND + 1 WM(ISAVE+K)=Y(N) WM(IPSAVE+K)=YPRIME(N) DEL=SQUR*MAX(ABS(Y(N)),ABS(H*YPRIME(N)), * ABS(1.D0/EWT(N))) DEL=SIGN(DEL,H*YPRIME(N)) DEL=(Y(N)+DEL)-Y(N) Y(N)=Y(N)+DEL YPRIME(N)=YPRIME(N)+CJ*DEL 510 CONTINUE IWM(LNRE)=IWM(LNRE)+1 CALL RES(X,Y,YPRIME,CJ,E,IRES,RPAR,IPAR) IF (IRES .LT. 0) RETURN DO 530 N=J,NEQ,MBAND K= (N-J)/MBAND + 1 Y(N)=WM(ISAVE+K) YPRIME(N)=WM(IPSAVE+K) DEL=SQUR*MAX(ABS(Y(N)),ABS(H*YPRIME(N)), * ABS(1.D0/EWT(N))) DEL=SIGN(DEL,H*YPRIME(N)) DEL=(Y(N)+DEL)-Y(N) DELINV=1.0D0/DEL I1=MAX0(1,(N-IWM(LMU))) I2=MIN0(NEQ,(N+IWM(LML))) II=N*MEB1-IWM(LML) DO 520 I=I1,I2 WM(II+I)=(E(I)-DELTA(I))*DELINV 520 CONTINUE 530 CONTINUE 540 CONTINUE C C C Do LU decomposition of banded J. C 550 CALL DGBFA (WM,MEBAND,NEQ,IWM(LML),IWM(LMU),IWM(LIPVT),IER) RETURN C C------END OF SUBROUTINE DMATD------------------------------------------ END C Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C SUBROUTINE DSLVD(NEQ,DELTA,WM,IWM) C C***BEGIN PROLOGUE DSLVD C***REFER TO DDASPK C***DATE WRITTEN 890101 (YYMMDD) C***REVISION DATE 900926 (YYMMDD) C***REVISION DATE 940701 (YYMMDD) (new LIPVT) C C----------------------------------------------------------------------- C***DESCRIPTION C C This routine manages the solution of the linear C system arising in the Newton iteration. C Real matrix information and real temporary storage C is stored in the array WM. C Integer matrix information is stored in the array IWM. C For a dense matrix, the LINPACK routine DGESL is called. C For a banded matrix, the LINPACK routine DGBSL is called. C----------------------------------------------------------------------- C***ROUTINES CALLED C DGESL, DGBSL C C***END PROLOGUE DSLVD C C IMPLICIT DOUBLE PRECISION(A-H,O-Z) DIMENSION DELTA(*),WM(*),IWM(*) C PARAMETER (LML=1, LMU=2, LMTYPE=4, LLCIWP=30) C LIPVT = IWM(LLCIWP) MTYPE=IWM(LMTYPE) IF (MTYPE .EQ. 1 . OR. MTYPE .EQ. 2) THEN GOTO 100 ELSE IF (MTYPE .EQ. 3) THEN GOTO 300 ELSE IF (MTYPE .EQ. 4 .OR. MTYPE .EQ. 5) THEN GOTO 400 ENDIF C GO TO(100,100,300,400,400),MTYPE C C Dense matrix. C 100 CALL DGESL(WM,NEQ,NEQ,IWM(LIPVT),DELTA,0) RETURN C C Dummy section for MTYPE=3. C 300 CONTINUE RETURN C C Banded matrix. C 400 MEBAND=2*IWM(LML)+IWM(LMU)+1 CALL DGBSL(WM,MEBAND,NEQ,IWM(LML), * IWM(LMU),IWM(LIPVT),DELTA,0) RETURN C C------END OF SUBROUTINE DSLVD------------------------------------------ END C Work perfored under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C SUBROUTINE DDASIK(X,Y,YPRIME,NEQ,ICOPT,ID,RES,JACK,PSOL,H,WT, * JSKIP,RPAR,IPAR,SAVR,DELTA,R,YIC,YPIC,PWK,WM,IWM,CJ,UROUND, * EPLI,SQRTN,RSQRTN,EPCON,RATEMX,STPTOL,JFLG, * ICNFLG,ICNSTR,IERNLS) C C***BEGIN PROLOGUE DDASIK C***REFER TO DDASPK C***DATE WRITTEN 941026 (YYMMDD) C***REVISION DATE 950808 (YYMMDD) C***REVISION DATE 951110 Removed unreachable block 390. C C C----------------------------------------------------------------------- C***DESCRIPTION C C C DDASIK solves a nonlinear system of algebraic equations of the C form G(X,Y,YPRIME) = 0 for the unknown parts of Y and YPRIME in C the initial conditions. C C An initial value for Y and initial guess for YPRIME are input. C C The method used is a Newton scheme with Krylov iteration and a C linesearch algorithm. C C The parameters represent C C X -- Independent variable. C Y -- Solution vector at x. C YPRIME -- Derivative of solution vector. C NEQ -- Number of equations to be integrated. C ICOPT -- Initial condition option chosen (1 or 2). C ID -- Array of dimension NEQ, which must be initialized C if ICOPT = 1. See DDASIC. C RES -- External user-supplied subroutine C to evaluate the residual. See RES description C in DDASPK prologue. C JACK -- External user-supplied routine to update C the preconditioner. (This is optional). C See JAC description for the case C INFO(12) = 1 in the DDASPK prologue. C PSOL -- External user-supplied routine to solve C a linear system using preconditioning. C (This is optional). See explanation inside DDASPK. C H -- Scaling factor for this initial condition calc. C WT -- Vector of weights for error criterion. C JSKIP -- input flag to signal if initial JAC call is to be C skipped. 1 => skip the call, 0 => do not skip call. C RPAR,IPAR -- Real and integer arrays used for communication C between the calling program and external user C routines. They are not altered within DASPK. C SAVR -- Work vector for DDASIK of length NEQ. C DELTA -- Work vector for DDASIK of length NEQ. C R -- Work vector for DDASIK of length NEQ. C YIC,YPIC -- Work vectors for DDASIK, each of length NEQ. C PWK -- Work vector for DDASIK of length NEQ. C WM,IWM -- Real and integer arrays storing C matrix information for linear system C solvers, and various other information. C CJ -- Matrix parameter = 1/H (ICOPT = 1) or 0 (ICOPT = 2). C UROUND -- Unit roundoff. C EPLI -- convergence test constant. C See DDASPK prologue for more details. C SQRTN -- Square root of NEQ. C RSQRTN -- reciprical of square root of NEQ. C EPCON -- Tolerance to test for convergence of the Newton C iteration. C RATEMX -- Maximum convergence rate for which Newton iteration C is considered converging. C JFLG -- Flag showing whether a Jacobian routine is supplied. C ICNFLG -- Integer scalar. If nonzero, then constraint C violations in the proposed new approximate solution C will be checked for, and the maximum step length C will be adjusted accordingly. C ICNSTR -- Integer array of length NEQ containing flags for C checking constraints. C IERNLS -- Error flag for nonlinear solver. C 0 ==> nonlinear solver converged. C 1,2 ==> recoverable error inside nonlinear solver. C 1 => retry with current Y, YPRIME C 2 => retry with original Y, YPRIME C -1 ==> unrecoverable error in nonlinear solver. C C----------------------------------------------------------------------- C C***ROUTINES CALLED C RES, JACK, DNSIK, DCOPY C C***END PROLOGUE DDASIK C C IMPLICIT DOUBLE PRECISION(A-H,O-Z) DIMENSION Y(*),YPRIME(*),ID(*),WT(*),ICNSTR(*) DIMENSION SAVR(*),DELTA(*),R(*),YIC(*),YPIC(*),PWK(*) DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*) EXTERNAL RES, JACK, PSOL C PARAMETER (LNRE=12, LNJE=13, LLOCWP=29, LLCIWP=30) PARAMETER (LMXNIT=32, LMXNJ=33) C C C Perform initializations. C LWP = IWM(LLOCWP) LIWP = IWM(LLCIWP) MXNIT = IWM(LMXNIT) MXNJ = IWM(LMXNJ) IERNLS = 0 NJ = 0 EPLIN = EPLI*EPCON C C Call RES to initialize DELTA. C IRES = 0 IWM(LNRE) = IWM(LNRE) + 1 CALL RES(X,Y,YPRIME,CJ,DELTA,IRES,RPAR,IPAR) IF (IRES .LT. 0) GO TO 370 C C Looping point for updating the preconditioner. C 300 CONTINUE C C Initialize all error flags to zero. C IERPJ = 0 IRES = 0 IERNEW = 0 C C If a Jacobian routine was supplied, call it. C IF (JFLG .EQ. 1 .AND. JSKIP .EQ. 0) THEN NJ = NJ + 1 IWM(LNJE)=IWM(LNJE)+1 CALL JACK (RES, IRES, NEQ, X, Y, YPRIME, WT, DELTA, R, H, CJ, * WM(LWP), IWM(LIWP), IERPJ, RPAR, IPAR) IF (IRES .LT. 0 .OR. IERPJ .NE. 0) GO TO 370 ENDIF JSKIP = 0 C C Call the nonlinear Newton solver for up to MXNIT iterations. C CALL DNSIK(X,Y,YPRIME,NEQ,ICOPT,ID,RES,PSOL,WT,RPAR,IPAR, * SAVR,DELTA,R,YIC,YPIC,PWK,WM,IWM,CJ,SQRTN,RSQRTN, * EPLIN,EPCON,RATEMX,MXNIT,STPTOL,ICNFLG,ICNSTR,IERNEW) C IF (IERNEW .EQ. 1 .AND. NJ .LT. MXNJ .AND. JFLG .EQ. 1) THEN C C Up to MXNIT iterations were done, the convergence rate is < 1, C a Jacobian routine is supplied, and the number of JACK calls C is less than MXNJ. C Copy the residual SAVR to DELTA, call JACK, and try again. C CALL DCOPY (NEQ, SAVR, 1, DELTA, 1) GO TO 300 ENDIF C IF (IERNEW .NE. 0) GO TO 380 RETURN C C C Unsuccessful exits from nonlinear solver. C Set IERNLS accordingly. C 370 IERNLS = 2 IF (IRES .LE. -2) IERNLS = -1 RETURN C 380 IERNLS = MIN(IERNEW,2) RETURN C C----------------------- END OF SUBROUTINE DDASIK----------------------- END C Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C SUBROUTINE DNSIK(X,Y,YPRIME,NEQ,ICOPT,ID,RES,PSOL,WT,RPAR,IPAR, * SAVR,DELTA,R,YIC,YPIC,PWK,WM,IWM,CJ,SQRTN,RSQRTN,EPLIN,EPCON, * RATEMX,MAXIT,STPTOL,ICNFLG,ICNSTR,IERNEW) C C***BEGIN PROLOGUE DNSIK C***REFER TO DDASPK C***DATE WRITTEN 940701 (YYMMDD) C***REVISION DATE 950714 (YYMMDD) C C C----------------------------------------------------------------------- C***DESCRIPTION C C DNSIK solves a nonlinear system of algebraic equations of the C form G(X,Y,YPRIME) = 0 for the unknown parts of Y and YPRIME in C the initial conditions. C C The method used is a Newton scheme combined with a linesearch C algorithm, using Krylov iterative linear system methods. C C The parameters represent C C X -- Independent variable. C Y -- Solution vector. C YPRIME -- Derivative of solution vector. C NEQ -- Number of unknowns. C ICOPT -- Initial condition option chosen (1 or 2). C ID -- Array of dimension NEQ, which must be initialized C if ICOPT = 1. See DDASIC. C RES -- External user-supplied subroutine C to evaluate the residual. See RES description C in DDASPK prologue. C PSOL -- External user-supplied routine to solve C a linear system using preconditioning. C See explanation inside DDASPK. C WT -- Vector of weights for error criterion. C RPAR,IPAR -- Real and integer arrays used for communication C between the calling program and external user C routines. They are not altered within DASPK. C SAVR -- Work vector for DNSIK of length NEQ. C DELTA -- Residual vector on entry, and work vector of C length NEQ for DNSIK. C R -- Work vector for DNSIK of length NEQ. C YIC,YPIC -- Work vectors for DNSIK, each of length NEQ. C PWK -- Work vector for DNSIK of length NEQ. C WM,IWM -- Real and integer arrays storing C matrix information such as the matrix C of partial derivatives, permutation C vector, and various other information. C CJ -- Matrix parameter = 1/H (ICOPT = 1) or 0 (ICOPT = 2). C SQRTN -- Square root of NEQ. C RSQRTN -- reciprical of square root of NEQ. C EPLIN -- Tolerance for linear system solver. C EPCON -- Tolerance to test for convergence of the Newton C iteration. C RATEMX -- Maximum convergence rate for which Newton iteration C is considered converging. C MAXIT -- Maximum allowed number of Newton iterations. C STPTOL -- Tolerance used in calculating the minimum lambda C value allowed. C ICNFLG -- Integer scalar. If nonzero, then constraint C violations in the proposed new approximate solution C will be checked for, and the maximum step length C will be adjusted accordingly. C ICNSTR -- Integer array of length NEQ containing flags for C checking constraints. C IERNEW -- Error flag for Newton iteration. C 0 ==> Newton iteration converged. C 1 ==> failed to converge, but RATE .lt. 1. C 2 ==> failed to converge, RATE .gt. RATEMX. C 3 ==> other recoverable error. C -1 ==> unrecoverable error inside Newton iteration. C----------------------------------------------------------------------- C C***ROUTINES CALLED C DFNRMK, DSLVK, DDWNRM, DLINSK, DCOPY C C***END PROLOGUE DNSIK C C IMPLICIT DOUBLE PRECISION(A-H,O-Z) DIMENSION Y(*),YPRIME(*),WT(*),ID(*),DELTA(*),R(*),SAVR(*) DIMENSION YIC(*),YPIC(*),PWK(*),WM(*),IWM(*), RPAR(*),IPAR(*) DIMENSION ICNSTR(*) EXTERNAL RES, PSOL C PARAMETER (LNNI=19, LNPS=21, LLOCWP=29, LLCIWP=30) PARAMETER (LLSOFF=35, LSTOL=14) C C C Initializations. M is the Newton iteration counter. C LSOFF = IWM(LLSOFF) M = 0 RATE = 1.0D0 LWP = IWM(LLOCWP) LIWP = IWM(LLCIWP) RLX = 0.4D0 C C Save residual in SAVR. C CALL DCOPY (NEQ, DELTA, 1, SAVR, 1) C C Compute norm of (P-inverse)*(residual). C CALL DFNRMK (NEQ, Y, X, YPRIME, SAVR, R, CJ, WT, SQRTN, RSQRTN, * RES, IRES, PSOL, 1, IER, FNRM, EPLIN, WM(LWP), IWM(LIWP), * PWK, RPAR, IPAR) IWM(LNPS) = IWM(LNPS) + 1 IF (IER .NE. 0) THEN IERNEW = 3 RETURN ENDIF C C Return now if residual norm is .le. EPCON. C IF (FNRM .LE. EPCON) RETURN C C Newton iteration loop. C 300 CONTINUE IWM(LNNI) = IWM(LNNI) + 1 C C Compute a new step vector DELTA. C CALL DSLVK (NEQ, Y, X, YPRIME, SAVR, DELTA, WT, WM, IWM, * RES, IRES, PSOL, IERSL, CJ, EPLIN, SQRTN, RSQRTN, RHOK, * RPAR, IPAR) IF (IRES .NE. 0 .OR. IERSL .NE. 0) GO TO 390 C C Get norm of DELTA. Return now if DELTA is zero. C DELNRM = DDWNRM(NEQ,DELTA,WT,RPAR,IPAR) IF (DELNRM .EQ. 0.0D0) RETURN C C Call linesearch routine for global strategy and set RATE. C OLDFNM = FNRM C CALL DLINSK (NEQ, Y, X, YPRIME, SAVR, CJ, DELTA, DELNRM, WT, * SQRTN, RSQRTN, LSOFF, STPTOL, IRET, RES, IRES, PSOL, WM, IWM, * RHOK, FNRM, ICOPT, ID, WM(LWP), IWM(LIWP), R, EPLIN, YIC, YPIC, * PWK, ICNFLG, ICNSTR, RLX, RPAR, IPAR) C RATE = FNRM/OLDFNM C C Check for error condition from linesearch. IF (IRET .NE. 0) GO TO 390 C C Test for convergence of the iteration, and return or loop. C IF (FNRM .LE. EPCON) RETURN C C The iteration has not yet converged. Update M. C Test whether the maximum number of iterations have been tried. C M=M+1 IF(M .GE. MAXIT) GO TO 380 C C Copy the residual SAVR to DELTA and loop for another iteration. C CALL DCOPY (NEQ, SAVR, 1, DELTA, 1) GO TO 300 C C The maximum number of iterations was done. Set IERNEW and return. C 380 IF (RATE .LE. RATEMX) THEN IERNEW = 1 ELSE IERNEW = 2 ENDIF RETURN C 390 IF (IRES .LE. -2 .OR. IERSL .LT. 0) THEN IERNEW = -1 ELSE IERNEW = 3 IF (IRES .EQ. 0 .AND. IERSL .EQ. 1 .AND. M .GE. 2 1 .AND. RATE .LT. 1.0D0) IERNEW = 1 ENDIF RETURN C C C----------------------- END OF SUBROUTINE DNSIK------------------------ END C Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C SUBROUTINE DLINSK (NEQ, Y, T, YPRIME, SAVR, CJ, P, PNRM, WT, * SQRTN, RSQRTN, LSOFF, STPTOL, IRET, RES, IRES, PSOL, WM, IWM, * RHOK, FNRM, ICOPT, ID, WP, IWP, R, EPLIN, YNEW, YPNEW, PWK, * ICNFLG, ICNSTR, RLX, RPAR, IPAR) C C***BEGIN PROLOGUE DLINSK C***REFER TO DNSIK C***DATE WRITTEN 940830 (YYMMDD) C***REVISION DATE 951006 (Arguments SQRTN, RSQRTN added.) C***REVISION DATE 960129 Moved line RL = ONE to top block. C C C----------------------------------------------------------------------- C***DESCRIPTION C C DLINSK uses a linesearch algorithm to calculate a new (Y,YPRIME) C pair (YNEW,YPNEW) such that C C f(YNEW,YPNEW) .le. (1 - 2*ALPHA*RL)*f(Y,YPRIME) + C ALPHA*RL*RHOK*RHOK , C C where 0 < RL <= 1, and RHOK is the scaled preconditioned norm of C the final residual vector in the Krylov iteration. C Here, f(y,y') is defined as C C f(y,y') = (1/2)*norm( (P-inverse)*G(t,y,y') )**2 , C C where norm() is the weighted RMS vector norm, G is the DAE C system residual function, and P is the preconditioner used C in the Krylov iteration. C C In addition to the parameters defined elsewhere, we have C C SAVR -- Work array of length NEQ, containing the residual C vector G(t,y,y') on return. C P -- Approximate Newton step used in backtracking. C PNRM -- Weighted RMS norm of P. C LSOFF -- Flag showing whether the linesearch algorithm is C to be invoked. 0 means do the linesearch, C 1 means turn off linesearch. C STPTOL -- Tolerance used in calculating the minimum lambda C value allowed. C ICNFLG -- Integer scalar. If nonzero, then constraint violations C in the proposed new approximate solution will be C checked for, and the maximum step length will be C adjusted accordingly. C ICNSTR -- Integer array of length NEQ containing flags for C checking constraints. C RHOK -- Weighted norm of preconditioned Krylov residual. C RLX -- Real scalar restricting update size in DCNSTR. C YNEW -- Array of length NEQ used to hold the new Y in C performing the linesearch. C YPNEW -- Array of length NEQ used to hold the new YPRIME in C performing the linesearch. C PWK -- Work vector of length NEQ for use in PSOL. C Y -- Array of length NEQ containing the new Y (i.e.,=YNEW). C YPRIME -- Array of length NEQ containing the new YPRIME C (i.e.,=YPNEW). C FNRM -- Real scalar containing SQRT(2*f(Y,YPRIME)) for the C current (Y,YPRIME) on input and output. C R -- Work space length NEQ for residual vector. C IRET -- Return flag. C IRET=0 means that a satisfactory (Y,YPRIME) was found. C IRET=1 means that the routine failed to find a new C (Y,YPRIME) that was sufficiently distinct from C the current (Y,YPRIME) pair. C IRET=2 means a failure in RES or PSOL. C----------------------------------------------------------------------- C C***ROUTINES CALLED C DFNRMK, DYYPNW, DCOPY C C***END PROLOGUE DLINSK C IMPLICIT DOUBLE PRECISION(A-H,O-Z) EXTERNAL RES, PSOL DIMENSION Y(*), YPRIME(*), P(*), WT(*), SAVR(*), R(*), ID(*) DIMENSION WM(*), IWM(*), YNEW(*), YPNEW(*), PWK(*), ICNSTR(*) DIMENSION WP(*), IWP(*), RPAR(*), IPAR(*) C PARAMETER (LNRE=12, LNPS=21, LKPRIN=31) C SAVE ALPHA, ONE, TWO DATA ALPHA/1.0D-4/, ONE/1.0D0/, TWO/2.0D0/ C KPRIN=IWM(LKPRIN) F1NRM = (FNRM*FNRM)/TWO RATIO = ONE C IF (KPRIN .GE. 2) THEN call rprintfd1( 1 'daspk-- in routine dlinsd--PNRM (= %g)' // char(0),PNRM) ENDIF TAU = PNRM IVIO = 0 RL = ONE C----------------------------------------------------------------------- C Check for violations of the constraints, if any are imposed. C If any violations are found, the step vector P is rescaled, and the C constraint check is repeated, until no violations are found. C----------------------------------------------------------------------- IF (ICNFLG .NE. 0) THEN 10 CONTINUE CALL DYYPNW (NEQ,Y,YPRIME,CJ,RL,P,ICOPT,ID,YNEW,YPNEW) CALL DCNSTR (NEQ, Y, YNEW, ICNSTR, TAU, RLX, IRET, IVAR) IF (IRET .EQ. 1) THEN IVIO = 1 RATIO1 = TAU/PNRM RATIO = RATIO*RATIO1 DO 20 I = 1,NEQ P(I) = P(I)*RATIO1 20 CONTINUE PNRM = TAU IF (KPRIN .GE. 2) THEN call rprintfid( 1 'daspk-- constraint violation, PNRM(%g), INDEX(%i)' & // char(0),IVAR,PNRM) ENDIF IF (PNRM .LE. STPTOL) THEN IRET = 1 RETURN ENDIF GO TO 10 ENDIF ENDIF C SLPI = (-TWO*F1NRM + RHOK*RHOK)*RATIO RLMIN = STPTOL/PNRM IF (LSOFF .EQ. 0 .AND. KPRIN .GE. 2) THEN call rprintfd1( 1 'daspk-- Min. LAMBDA &g' // char(0), RLMIN) ENDIF C----------------------------------------------------------------------- C Begin iteration to find RL value satisfying alpha-condition. C Update YNEW and YPNEW, then compute norm of new scaled residual and C perform alpha condition test. C----------------------------------------------------------------------- 100 CONTINUE CALL DYYPNW (NEQ,Y,YPRIME,CJ,RL,P,ICOPT,ID,YNEW,YPNEW) CALL DFNRMK (NEQ, YNEW, T, YPNEW, SAVR, R, CJ, WT, SQRTN, RSQRTN, * RES, IRES, PSOL, 0, IER, FNRMP, EPLIN, WP, IWP, PWK, RPAR, IPAR) IWM(LNRE) = IWM(LNRE) + 1 IF (IRES .GE. 0) IWM(LNPS) = IWM(LNPS) + 1 IF (IRES .NE. 0 .OR. IER .NE. 0) THEN IRET = 2 RETURN ENDIF IF (LSOFF .EQ. 1) GO TO 150 C F1NRMP = FNRMP*FNRMP/TWO IF (KPRIN .GE. 2) THEN call rprintfd1( 1 'daspk-- LAMBDA (= %g)' // char(0), RL) call rprintfd2( 1 ' -- NORM(F1) (= %g), NORM(F1NEW) (= %g)' & // char(0), F1NRM, F1NRMP) ENDIF IF (F1NRMP .GT. F1NRM + ALPHA*SLPI*RL) GO TO 200 C----------------------------------------------------------------------- C Alpha-condition is satisfied, or linesearch is turned off. C Copy YNEW,YPNEW to Y,YPRIME and return. C----------------------------------------------------------------------- 150 IRET = 0 CALL DCOPY(NEQ, YNEW, 1, Y, 1) CALL DCOPY(NEQ, YPNEW, 1, YPRIME, 1) FNRM = FNRMP IF (KPRIN .GE. 1) THEN call rprintfd1( 1 'daspk-- leaving routine dlinsk--FNRM %g' // char(0), FNRM) ENDIF RETURN C----------------------------------------------------------------------- C Alpha-condition not satisfied. Perform backtrack to compute new RL C value. If RL is less than RLMIN, i.e. no satisfactory YNEW,YPNEW can C be found sufficiently distinct from Y,YPRIME, then return IRET = 1. C----------------------------------------------------------------------- 200 CONTINUE IF (RL .LT. RLMIN) THEN IRET = 1 RETURN ENDIF C RL = RL/TWO GO TO 100 C C----------------------- END OF SUBROUTINE DLINSK ---------------------- END C Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C SUBROUTINE DFNRMK (NEQ, Y, T, YPRIME, SAVR, R, CJ, WT, * SQRTN, RSQRTN, RES, IRES, PSOL, IRIN, IER, * FNORM, EPLIN, WP, IWP, PWK, RPAR, IPAR) C C***BEGIN PROLOGUE DFNRMK C***REFER TO DLINSK C***DATE WRITTEN 940830 (YYMMDD) C***REVISION DATE 951006 (SQRTN, RSQRTN, and scaling of WT added.) C C C----------------------------------------------------------------------- C***DESCRIPTION C C DFNRMK calculates the scaled preconditioned norm of the nonlinear C function used in the nonlinear iteration for obtaining consistent C initial conditions. Specifically, DFNRMK calculates the weighted C root-mean-square norm of the vector (P-inverse)*G(T,Y,YPRIME), C where P is the preconditioner matrix. C C In addition to the parameters described in the calling program C DLINSK, the parameters represent C C IRIN -- Flag showing whether the current residual vector is C input in SAVR. 1 means it is, 0 means it is not. C R -- Array of length NEQ that contains C (P-inverse)*G(T,Y,YPRIME) on return. C FNORM -- Scalar containing the weighted norm of R on return. C----------------------------------------------------------------------- C C***ROUTINES CALLED C RES, DCOPY, DSCAL, PSOL, DDWNRM C C***END PROLOGUE DFNRMK C C IMPLICIT DOUBLE PRECISION (A-H,O-Z) EXTERNAL RES, PSOL DIMENSION Y(*), YPRIME(*), WT(*), SAVR(*), R(*), PWK(*) DIMENSION WP(*), IWP(*), RPAR(*), IPAR(*) C----------------------------------------------------------------------- C Call RES routine if IRIN = 0. C----------------------------------------------------------------------- IF (IRIN .EQ. 0) THEN IRES = 0 CALL RES (T, Y, YPRIME, CJ, SAVR, IRES, RPAR, IPAR) IF (IRES .LT. 0) RETURN ENDIF C----------------------------------------------------------------------- C Apply inverse of left preconditioner to vector R. C First scale WT array by 1/sqrt(N), and undo scaling afterward. C----------------------------------------------------------------------- CALL DCOPY(NEQ, SAVR, 1, R, 1) CALL DSCAL (NEQ, RSQRTN, WT, 1) IER = 0 CALL PSOL (NEQ, T, Y, YPRIME, SAVR, PWK, CJ, WT, WP, IWP, * R, EPLIN, IER, RPAR, IPAR) CALL DSCAL (NEQ, SQRTN, WT, 1) IF (IER .NE. 0) RETURN C----------------------------------------------------------------------- C Calculate norm of R. C----------------------------------------------------------------------- FNORM = DDWNRM (NEQ, R, WT, RPAR, IPAR) C RETURN C----------------------- END OF SUBROUTINE DFNRMK ---------------------- END C Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C SUBROUTINE DNEDK(X,Y,YPRIME,NEQ,RES,JACK,PSOL, * H,WT,JSTART,IDID,RPAR,IPAR,PHI,GAMMA,SAVR,DELTA,E, * WM,IWM,CJ,CJOLD,CJLAST,S,UROUND,EPLI,SQRTN,RSQRTN, * EPCON,JCALC,JFLG,KP1,NONNEG,NTYPE,IERNLS) C C***BEGIN PROLOGUE DNEDK C***REFER TO DDASPK C***DATE WRITTEN 891219 (YYMMDD) C***REVISION DATE 900926 (YYMMDD) C***REVISION DATE 940701 (YYMMDD) C C C----------------------------------------------------------------------- C***DESCRIPTION C C DNEDK solves a nonlinear system of C algebraic equations of the form C G(X,Y,YPRIME) = 0 for the unknown Y. C C The method used is a matrix-free Newton scheme. C C The parameters represent C X -- Independent variable. C Y -- Solution vector at x. C YPRIME -- Derivative of solution vector C after successful step. C NEQ -- Number of equations to be integrated. C RES -- External user-supplied subroutine C to evaluate the residual. See RES description C in DDASPK prologue. C JACK -- External user-supplied routine to update C the preconditioner. (This is optional). C See JAC description for the case C INFO(12) = 1 in the DDASPK prologue. C PSOL -- External user-supplied routine to solve C a linear system using preconditioning. C (This is optional). See explanation inside DDASPK. C H -- Appropriate step size for this step. C WT -- Vector of weights for error criterion. C JSTART -- Indicates first call to this routine. C If JSTART = 0, then this is the first call, C otherwise it is not. C IDID -- Completion flag, output by DNEDK. C See IDID description in DDASPK prologue. C RPAR,IPAR -- Real and integer arrays used for communication C between the calling program and external user C routines. They are not altered within DASPK. C PHI -- Array of divided differences used by C DNEDK. The length is NEQ*(K+1), where C K is the maximum order. C GAMMA -- Array used to predict Y and YPRIME. The length C is K+1, where K is the maximum order. C SAVR -- Work vector for DNEDK of length NEQ. C DELTA -- Work vector for DNEDK of length NEQ. C E -- Error accumulation vector for DNEDK of length NEQ. C WM,IWM -- Real and integer arrays storing C matrix information for linear system C solvers, and various other information. C CJ -- Parameter always proportional to 1/H. C CJOLD -- Saves the value of CJ as of the last call to DITMD. C Accounts for changes in CJ needed to C decide whether to call DITMD. C CJLAST -- Previous value of CJ. C S -- A scalar determined by the approximate rate C of convergence of the Newton iteration and used C in the convergence test for the Newton iteration. C C If RATE is defined to be an estimate of the C rate of convergence of the Newton iteration, C then S = RATE/(1.D0-RATE). C C The closer RATE is to 0., the faster the Newton C iteration is converging; the closer RATE is to 1., C the slower the Newton iteration is converging. C C On the first Newton iteration with an up-dated C preconditioner S = 100.D0, Thus the initial C RATE of convergence is approximately 1. C C S is preserved from call to call so that the rate C estimate from a previous step can be applied to C the current step. C UROUND -- Unit roundoff. C EPLI -- convergence test constant. C See DDASPK prologue for more details. C SQRTN -- Square root of NEQ. C RSQRTN -- reciprical of square root of NEQ. C EPCON -- Tolerance to test for convergence of the Newton C iteration. C JCALC -- Flag used to determine when to update C the Jacobian matrix. In general: C C JCALC = -1 ==> Call the DITMD routine to update C the Jacobian matrix. C JCALC = 0 ==> Jacobian matrix is up-to-date. C JCALC = 1 ==> Jacobian matrix is out-dated, C but DITMD will not be called unless C JCALC is set to -1. C JFLG -- Flag showing whether a Jacobian routine is supplied. C KP1 -- The current order + 1; updated across calls. C NONNEG -- Flag to determine nonnegativity constraints. C NTYPE -- Identification code for the DNEDK routine. C 1 ==> modified Newton; iterative linear solver. C 2 ==> modified Newton; user-supplied linear solver. C IERNLS -- Error flag for nonlinear solver. C 0 ==> nonlinear solver converged. C 1 ==> recoverable error inside non-linear solver. C -1 ==> unrecoverable error inside non-linear solver. C C The following group of variables are passed as arguments to C the Newton iteration solver. They are explained in greater detail C in DNSK: C TOLNEW, MULDEL, MAXIT, IERNEW C C IERTYP -- Flag which tells whether this subroutine is correct. C 0 ==> correct subroutine. C 1 ==> incorrect subroutine. C C----------------------------------------------------------------------- C***ROUTINES CALLED C RES, JACK, DDWNRM, DNSK C C***END PROLOGUE DNEDK C C IMPLICIT DOUBLE PRECISION(A-H,O-Z) DIMENSION Y(*),YPRIME(*),WT(*) DIMENSION PHI(NEQ,*),SAVR(*),DELTA(*),E(*) DIMENSION WM(*),IWM(*) DIMENSION GAMMA(*),RPAR(*),IPAR(*) EXTERNAL RES, JACK, PSOL C PARAMETER (LNRE=12, LNJE=13, LLOCWP=29, LLCIWP=30) C SAVE MULDEL, MAXIT, XRATE DATA MULDEL/0/, MAXIT/4/, XRATE/0.25D0/ C C Verify that this is the correct subroutine. C IERTYP = 0 IF (NTYPE .NE. 1) THEN IERTYP = 1 GO TO 380 ENDIF C C If this is the first step, perform initializations. C IF (JSTART .EQ. 0) THEN CJOLD = CJ JCALC = -1 S = 100.D0 ENDIF C C Perform all other initializations. C IERNLS = 0 LWP = IWM(LLOCWP) LIWP = IWM(LLCIWP) C C Decide whether to update the preconditioner. C IF (JFLG .NE. 0) THEN TEMP1 = (1.0D0 - XRATE)/(1.0D0 + XRATE) TEMP2 = 1.0D0/TEMP1 IF (CJ/CJOLD .LT. TEMP1 .OR. CJ/CJOLD .GT. TEMP2) JCALC = -1 IF (CJ .NE. CJLAST) S = 100.D0 ELSE JCALC = 0 ENDIF C C Looping point for updating preconditioner with current stepsize. C 300 CONTINUE C C Initialize all error flags to zero. C IERPJ = 0 IRES = 0 IERSL = 0 IERNEW = 0 C C Predict the solution and derivative and compute the tolerance C for the Newton iteration. C DO 310 I=1,NEQ Y(I)=PHI(I,1) YPRIME(I)=0.0D0 310 CONTINUE DO 330 J=2,KP1 DO 320 I=1,NEQ Y(I)=Y(I)+PHI(I,J) YPRIME(I)=YPRIME(I)+GAMMA(J)*PHI(I,J) 320 CONTINUE 330 CONTINUE EPLIN = EPLI*EPCON TOLNEW = EPLIN C C Call RES to initialize DELTA. C IWM(LNRE)=IWM(LNRE)+1 CALL RES(X,Y,YPRIME,CJ,DELTA,IRES,RPAR,IPAR) IF (IRES .LT. 0) GO TO 380 C C C If indicated, update the preconditioner. C Set JCALC to 0 as an indicator that this has been done. C IF(JCALC .EQ. -1)THEN IWM(LNJE) = IWM(LNJE) + 1 JCALC=0 CALL JACK (RES, IRES, NEQ, X, Y, YPRIME, WT, DELTA, E, H, CJ, * WM(LWP), IWM(LIWP), IERPJ, RPAR, IPAR) CJOLD=CJ S = 100.D0 IF (IRES .LT. 0) GO TO 380 IF (IERPJ .NE. 0) GO TO 380 ENDIF C C Call the nonlinear Newton solver. C CALL DNSK(X,Y,YPRIME,NEQ,RES,PSOL,WT,RPAR,IPAR,SAVR, * DELTA,E,WM,IWM,CJ,SQRTN,RSQRTN,EPLIN,EPCON, * S,TEMP1,TOLNEW,MULDEL,MAXIT,IRES,IERSL,IERNEW) C IF (IERNEW .GT. 0 .AND. JCALC .NE. 0) THEN C C The Newton iteration had a recoverable failure with an old C preconditioner. Retry the step with a new preconditioner. C JCALC = -1 GO TO 300 ENDIF C IF (IERNEW .NE. 0) GO TO 380 C C The Newton iteration has converged. If nonnegativity of C solution is required, set the solution nonnegative, if the C perturbation to do it is small enough. If the change is too C large, then consider the corrector iteration to have failed. C IF(NONNEG .EQ. 0) GO TO 390 DO 360 I = 1,NEQ DELTA(I) = MIN(Y(I),0.0D0) 360 CONTINUE DELNRM = DDWNRM(NEQ,DELTA,WT,RPAR,IPAR) IF(DELNRM .GT. EPCON) GO TO 380 DO 370 I = 1,NEQ E(I) = E(I) - DELTA(I) 370 CONTINUE GO TO 390 C C C Exits from nonlinear solver. C No convergence with current preconditioner. C Compute IERNLS and IDID accordingly. C 380 CONTINUE IF (IRES .LE. -2 .OR. IERSL .LT. 0 .OR. IERTYP .NE. 0) THEN IERNLS = -1 IF (IRES .LE. -2) IDID = -11 IF (IERSL .LT. 0) IDID = -13 IF (IERTYP .NE. 0) IDID = -15 ELSE IERNLS = 1 IF (IRES .EQ. -1) IDID = -10 IF (IERPJ .NE. 0) IDID = -5 IF (IERSL .GT. 0) IDID = -14 ENDIF C C 390 JCALC = 1 RETURN C C------END OF SUBROUTINE DNEDK------------------------------------------ END C Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C SUBROUTINE DNSK(X,Y,YPRIME,NEQ,RES,PSOL,WT,RPAR,IPAR, * SAVR,DELTA,E,WM,IWM,CJ,SQRTN,RSQRTN,EPLIN,EPCON, * S,CONFAC,TOLNEW,MULDEL,MAXIT,IRES,IERSL,IERNEW) C C***BEGIN PROLOGUE DNSK C***REFER TO DDASPK C***DATE WRITTEN 891219 (YYMMDD) C***REVISION DATE 900926 (YYMMDD) C***REVISION DATE 950126 (YYMMDD) C C C----------------------------------------------------------------------- C***DESCRIPTION C C DNSK solves a nonlinear system of C algebraic equations of the form C G(X,Y,YPRIME) = 0 for the unknown Y. C C The method used is a modified Newton scheme. C C The parameters represent C C X -- Independent variable. C Y -- Solution vector. C YPRIME -- Derivative of solution vector. C NEQ -- Number of unknowns. C RES -- External user-supplied subroutine C to evaluate the residual. See RES description C in DDASPK prologue. C PSOL -- External user-supplied routine to solve C a linear system using preconditioning. C See explanation inside DDASPK. C WT -- Vector of weights for error criterion. C RPAR,IPAR -- Real and integer arrays used for communication C between the calling program and external user C routines. They are not altered within DASPK. C SAVR -- Work vector for DNSK of length NEQ. C DELTA -- Work vector for DNSK of length NEQ. C E -- Error accumulation vector for DNSK of length NEQ. C WM,IWM -- Real and integer arrays storing C matrix information such as the matrix C of partial derivatives, permutation C vector, and various other information. C CJ -- Parameter always proportional to 1/H (step size). C SQRTN -- Square root of NEQ. C RSQRTN -- reciprical of square root of NEQ. C EPLIN -- Tolerance for linear system solver. C EPCON -- Tolerance to test for convergence of the Newton C iteration. C S -- Used for error convergence tests. C In the Newton iteration: S = RATE/(1.D0-RATE), C where RATE is the estimated rate of convergence C of the Newton iteration. C C The closer RATE is to 0., the faster the Newton C iteration is converging; the closer RATE is to 1., C the slower the Newton iteration is converging. C C The calling routine sends the initial value C of S to the Newton iteration. C CONFAC -- A residual scale factor to improve convergence. C TOLNEW -- Tolerance on the norm of Newton correction in C alternative Newton convergence test. C MULDEL -- A flag indicating whether or not to multiply C DELTA by CONFAC. C 0 ==> do not scale DELTA by CONFAC. C 1 ==> scale DELTA by CONFAC. C MAXIT -- Maximum allowed number of Newton iterations. C IRES -- Error flag returned from RES. See RES description C in DDASPK prologue. If IRES = -1, then IERNEW C will be set to 1. C If IRES < -1, then IERNEW will be set to -1. C IERSL -- Error flag for linear system solver. C See IERSL description in subroutine DSLVK. C If IERSL = 1, then IERNEW will be set to 1. C If IERSL < 0, then IERNEW will be set to -1. C IERNEW -- Error flag for Newton iteration. C 0 ==> Newton iteration converged. C 1 ==> recoverable error inside Newton iteration. C -1 ==> unrecoverable error inside Newton iteration. C----------------------------------------------------------------------- C C***ROUTINES CALLED C RES, DSLVK, DDWNRM C C***END PROLOGUE DNSK C C IMPLICIT DOUBLE PRECISION(A-H,O-Z) DIMENSION Y(*),YPRIME(*),WT(*),DELTA(*),E(*),SAVR(*) DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*) EXTERNAL RES, PSOL C PARAMETER (LNNI=19, LNRE=12) C C Initialize Newton counter M and accumulation vector E. C M = 0 DO 100 I=1,NEQ E(I) = 0.0D0 100 CONTINUE C C Corrector loop. C 300 CONTINUE IWM(LNNI) = IWM(LNNI) + 1 C C If necessary, multiply residual by convergence factor. C IF (MULDEL .EQ. 1) THEN DO 320 I = 1,NEQ DELTA(I) = DELTA(I) * CONFAC 320 CONTINUE ENDIF C C Save residual in SAVR. C DO 340 I = 1,NEQ SAVR(I) = DELTA(I) 340 CONTINUE C C Compute a new iterate. Store the correction in DELTA. C CALL DSLVK (NEQ, Y, X, YPRIME, SAVR, DELTA, WT, WM, IWM, * RES, IRES, PSOL, IERSL, CJ, EPLIN, SQRTN, RSQRTN, RHOK, * RPAR, IPAR) IF (IRES .NE. 0 .OR. IERSL .NE. 0) GO TO 380 C C Update Y, E, and YPRIME. C DO 360 I=1,NEQ Y(I) = Y(I) - DELTA(I) E(I) = E(I) - DELTA(I) YPRIME(I) = YPRIME(I) - CJ*DELTA(I) 360 CONTINUE C C Test for convergence of the iteration. C DELNRM = DDWNRM(NEQ,DELTA,WT,RPAR,IPAR) IF (DELNRM .LE. TOLNEW) GO TO 370 IF (M .EQ. 0) THEN OLDNRM = DELNRM ELSE RATE = (DELNRM/OLDNRM)**(1.0D0/M) IF (RATE .GT. 0.9D0) GO TO 380 S = RATE/(1.0D0 - RATE) ENDIF IF (S*DELNRM .LE. EPCON) GO TO 370 C C The corrector has not yet converged. Update M and test whether C the maximum number of iterations have been tried. C M = M + 1 IF (M .GE. MAXIT) GO TO 380 C C Evaluate the residual, and go back to do another iteration. C IWM(LNRE) = IWM(LNRE) + 1 CALL RES(X,Y,YPRIME,CJ,DELTA,IRES,RPAR,IPAR) IF (IRES .LT. 0) GO TO 380 GO TO 300 C C The iteration has converged. C 370 RETURN C C The iteration has not converged. Set IERNEW appropriately. C 380 CONTINUE IF (IRES .LE. -2 .OR. IERSL .LT. 0) THEN IERNEW = -1 ELSE IERNEW = 1 ENDIF RETURN C C C------END OF SUBROUTINE DNSK------------------------------------------- END C Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C SUBROUTINE DSLVK (NEQ, Y, TN, YPRIME, SAVR, X, EWT, WM, IWM, * RES, IRES, PSOL, IERSL, CJ, EPLIN, SQRTN, RSQRTN, RHOK, * RPAR, IPAR) C C***BEGIN PROLOGUE DSLVK C***REFER TO DDASPK C***DATE WRITTEN 890101 (YYMMDD) C***REVISION DATE 900926 (YYMMDD) C***REVISION DATE 940928 Removed MNEWT and added RHOK in call list. C C C----------------------------------------------------------------------- C***DESCRIPTION C C DSLVK uses a restart algorithm and interfaces to DSPIGM for C the solution of the linear system arising from a Newton iteration. C C In addition to variables described elsewhere, C communication with DSLVK uses the following variables.. C WM = Real work space containing data for the algorithm C (Krylov basis vectors, Hessenberg matrix, etc.). C IWM = Integer work space containing data for the algorithm. C X = The right-hand side vector on input, and the solution vector C on output, of length NEQ. C IRES = Error flag from RES. C IERSL = Output flag .. C IERSL = 0 means no trouble occurred (or user RES routine C returned IRES < 0) C IERSL = 1 means the iterative method failed to converge C (DSPIGM returned IFLAG > 0.) C IERSL = -1 means there was a nonrecoverable error in the C iterative solver, and an error exit will occur. C----------------------------------------------------------------------- C***ROUTINES CALLED C DSCAL, DCOPY, DSPIGM C C***END PROLOGUE DSLVK C INTEGER NEQ, IWM, IRES, IERSL, IPAR DOUBLE PRECISION Y, TN, YPRIME, SAVR, X, EWT, WM, CJ, EPLIN, 1 SQRTN, RSQRTN, RHOK, RPAR DIMENSION Y(*), YPRIME(*), SAVR(*), X(*), EWT(*), 1 WM(*), IWM(*), RPAR(*), IPAR(*) C INTEGER IFLAG, IRST, NRSTS, NRMAX, LR, LDL, LHES, LGMR, LQ, LV, 1 LWK, LZ, MAXLP1, NPSL INTEGER NLI, NPS, NCFL, NRE, MAXL, KMP, MITER EXTERNAL RES, PSOL C PARAMETER (LNRE=12, LNCFL=16, LNLI=20, LNPS=21) PARAMETER (LLOCWP=29, LLCIWP=30) PARAMETER (LMITER=23, LMAXL=24, LKMP=25, LNRMAX=26) C C----------------------------------------------------------------------- C IRST is set to 1, to indicate restarting is in effect. C NRMAX is the maximum number of restarts. C----------------------------------------------------------------------- DATA IRST/1/ C LIWP = IWM(LLCIWP) NLI = IWM(LNLI) NPS = IWM(LNPS) NCFL = IWM(LNCFL) NRE = IWM(LNRE) LWP = IWM(LLOCWP) MAXL = IWM(LMAXL) KMP = IWM(LKMP) NRMAX = IWM(LNRMAX) MITER = IWM(LMITER) IERSL = 0 IRES = 0 C----------------------------------------------------------------------- C Use a restarting strategy to solve the linear system C P*X = -F. Parse the work vector, and perform initializations. C Note that zero is the initial guess for X. C----------------------------------------------------------------------- MAXLP1 = MAXL + 1 LV = 1 LR = LV + NEQ*MAXL LHES = LR + NEQ + 1 LQ = LHES + MAXL*MAXLP1 LWK = LQ + 2*MAXL LDL = LWK + MIN0(1,MAXL-KMP)*NEQ LZ = LDL + NEQ CALL DSCAL (NEQ, RSQRTN, EWT, 1) CALL DCOPY (NEQ, X, 1, WM(LR), 1) DO 110 I = 1,NEQ X(I) = 0.D0 110 CONTINUE C----------------------------------------------------------------------- C Top of loop for the restart algorithm. Initial pass approximates C X and sets up a transformed system to perform subsequent restarts C to update X. NRSTS is initialized to -1, because restarting C does not occur until after the first pass. C Update NRSTS; conditionally copy DL to R; call the DSPIGM C algorithm to solve A*Z = R; updated counters; update X with C the residual solution. C Note: if convergence is not achieved after NRMAX restarts, C then the linear solver is considered to have failed. C----------------------------------------------------------------------- NRSTS = -1 115 CONTINUE NRSTS = NRSTS + 1 IF (NRSTS .GT. 0) CALL DCOPY (NEQ, WM(LDL), 1, WM(LR),1) CALL DSPIGM (NEQ, TN, Y, YPRIME, SAVR, WM(LR), EWT, MAXL, MAXLP1, 1 KMP, EPLIN, CJ, RES, IRES, NRES, PSOL, NPSL, WM(LZ), WM(LV), 2 WM(LHES), WM(LQ), LGMR, WM(LWP), IWM(LIWP), WM(LWK), 3 WM(LDL), RHOK, IFLAG, IRST, NRSTS, RPAR, IPAR) NLI = NLI + LGMR NPS = NPS + NPSL NRE = NRE + NRES DO 120 I = 1,NEQ X(I) = X(I) + WM(LZ+I-1) 120 CONTINUE IF ((IFLAG .EQ. 1) .AND. (NRSTS .LT. NRMAX) .AND. (IRES .EQ. 0)) 1 GO TO 115 C----------------------------------------------------------------------- C The restart scheme is finished. Test IRES and IFLAG to see if C convergence was not achieved, and set flags accordingly. C----------------------------------------------------------------------- IF (IRES .LT. 0) THEN NCFL = NCFL + 1 ELSE IF (IFLAG .NE. 0) THEN NCFL = NCFL + 1 IF (IFLAG .GT. 0) IERSL = 1 IF (IFLAG .LT. 0) IERSL = -1 ENDIF C----------------------------------------------------------------------- C Update IWM with counters, rescale EWT, and return. C----------------------------------------------------------------------- IWM(LNLI) = NLI IWM(LNPS) = NPS IWM(LNCFL) = NCFL IWM(LNRE) = NRE CALL DSCAL (NEQ, SQRTN, EWT, 1) RETURN C C------END OF SUBROUTINE DSLVK------------------------------------------ END C Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C SUBROUTINE DSPIGM (NEQ, TN, Y, YPRIME, SAVR, R, WGHT, MAXL, * MAXLP1, KMP, EPLIN, CJ, RES, IRES, NRE, PSOL, NPSL, Z, V, * HES, Q, LGMR, WP, IWP, WK, DL, RHOK, IFLAG, IRST, NRSTS, * RPAR, IPAR) C C***BEGIN PROLOGUE DSPIGM C***DATE WRITTEN 890101 (YYMMDD) C***REVISION DATE 900926 (YYMMDD) C***REVISION DATE 940927 Removed MNEWT and added RHOK in call list. C C C----------------------------------------------------------------------- C***DESCRIPTION C C This routine solves the linear system A * Z = R using a scaled C preconditioned version of the generalized minimum residual method. C An initial guess of Z = 0 is assumed. C C On entry C C NEQ = Problem size, passed to PSOL. C C TN = Current Value of T. C C Y = Array Containing current dependent variable vector. C C YPRIME = Array Containing current first derivative of Y. C C SAVR = Array containing current value of G(T,Y,YPRIME). C C R = The right hand side of the system A*Z = R. C R is also used as work space when computing C the final approximation and will therefore be C destroyed. C (R is the same as V(*,MAXL+1) in the call to DSPIGM.) C C WGHT = The vector of length NEQ containing the nonzero C elements of the diagonal scaling matrix. C C MAXL = The maximum allowable order of the matrix H. C C MAXLP1 = MAXL + 1, used for dynamic dimensioning of HES. C C KMP = The number of previous vectors the new vector, VNEW, C must be made orthogonal to. (KMP .LE. MAXL.) C C EPLIN = Tolerance on residuals R-A*Z in weighted rms norm. C C CJ = Scalar proportional to current value of C 1/(step size H). C C WK = Real work array used by routine DATV and PSOL. C C DL = Real work array used for calculation of the residual C norm RHO when the method is incomplete (KMP.LT.MAXL) C and/or when using restarting. C C WP = Real work array used by preconditioner PSOL. C C IWP = Integer work array used by preconditioner PSOL. C C IRST = Method flag indicating if restarting is being C performed. IRST .GT. 0 means restarting is active, C while IRST = 0 means restarting is not being used. C C NRSTS = Counter for the number of restarts on the current C call to DSPIGM. If NRSTS .GT. 0, then the residual C R is already scaled, and so scaling of R is not C necessary. C C C On Return C C Z = The final computed approximation to the solution C of the system A*Z = R. C C LGMR = The number of iterations performed and C the current order of the upper Hessenberg C matrix HES. C C NRE = The number of calls to RES (i.e. DATV) C C NPSL = The number of calls to PSOL. C C V = The neq by (LGMR+1) array containing the LGMR C orthogonal vectors V(*,1) to V(*,LGMR). C C HES = The upper triangular factor of the QR decomposition C of the (LGMR+1) by LGMR upper Hessenberg matrix whose C entries are the scaled inner-products of A*V(*,I) C and V(*,K). C C Q = Real array of length 2*MAXL containing the components C of the givens rotations used in the QR decomposition C of HES. It is loaded in DHEQR and used in DHELS. C C IRES = Error flag from RES. C C DL = Scaled preconditioned residual, C (D-inverse)*(P-inverse)*(R-A*Z). Only loaded when C performing restarts of the Krylov iteration. C C RHOK = Weighted norm of final preconditioned residual. C C IFLAG = Integer error flag.. C 0 Means convergence in LGMR iterations, LGMR.LE.MAXL. C 1 Means the convergence test did not pass in MAXL C iterations, but the new residual norm (RHO) is C .LT. the old residual norm (RNRM), and so Z is C computed. C 2 Means the convergence test did not pass in MAXL C iterations, new residual norm (RHO) .GE. old residual C norm (RNRM), and the initial guess, Z = 0, is C returned. C 3 Means there was a recoverable error in PSOL C caused by the preconditioner being out of date. C -1 Means there was an unrecoverable error in PSOL. C C----------------------------------------------------------------------- C***ROUTINES CALLED C PSOL, DNRM2, DSCAL, DATV, DORTH, DHEQR, DCOPY, DHELS, DAXPY C C***END PROLOGUE DSPIGM C INTEGER NEQ,MAXL,MAXLP1,KMP,IRES,NRE,NPSL,LGMR,IWP, 1 IFLAG,IRST,NRSTS,IPAR DOUBLE PRECISION TN,Y,YPRIME,SAVR,R,WGHT,EPLIN,CJ,Z,V,HES,Q,WP,WK, 1 DL,RHOK,RPAR DIMENSION Y(*), YPRIME(*), SAVR(*), R(*), WGHT(*), Z(*), 1 V(NEQ,*), HES(MAXLP1,*), Q(*), WP(*), IWP(*), WK(*), DL(*), 2 RPAR(*), IPAR(*) INTEGER I, IER, INFO, IP1, I2, J, K, LL, LLP1 DOUBLE PRECISION RNRM,C,DLNRM,PROD,RHO,S,SNORMW,DNRM2,TEM EXTERNAL RES, PSOL C IER = 0 IFLAG = 0 LGMR = 0 NPSL = 0 NRE = 0 C----------------------------------------------------------------------- C The initial guess for Z is 0. The initial residual is therefore C the vector R. Initialize Z to 0. C----------------------------------------------------------------------- DO 10 I = 1,NEQ Z(I) = 0.0D0 10 CONTINUE C----------------------------------------------------------------------- C Apply inverse of left preconditioner to vector R if NRSTS .EQ. 0. C Form V(*,1), the scaled preconditioned right hand side. C----------------------------------------------------------------------- IF (NRSTS .EQ. 0) THEN CALL PSOL (NEQ, TN, Y, YPRIME, SAVR, WK, CJ, WGHT, WP, IWP, 1 R, EPLIN, IER, RPAR, IPAR) NPSL = 1 IF (IER .NE. 0) GO TO 300 DO 30 I = 1,NEQ V(I,1) = R(I)*WGHT(I) 30 CONTINUE ELSE DO 35 I = 1,NEQ V(I,1) = R(I) 35 CONTINUE ENDIF C----------------------------------------------------------------------- C Calculate norm of scaled vector V(*,1) and normalize it C If, however, the norm of V(*,1) (i.e. the norm of the preconditioned C residual) is .le. EPLIN, then return with Z=0. C----------------------------------------------------------------------- RNRM = DNRM2 (NEQ, V, 1) IF (RNRM .LE. EPLIN) THEN RHOK = RNRM RETURN ENDIF TEM = 1.0D0/RNRM CALL DSCAL (NEQ, TEM, V(1,1), 1) C----------------------------------------------------------------------- C Zero out the HES array. C----------------------------------------------------------------------- DO 65 J = 1,MAXL DO 60 I = 1,MAXLP1 HES(I,J) = 0.0D0 60 CONTINUE 65 CONTINUE C----------------------------------------------------------------------- C Main loop to compute the vectors V(*,2) to V(*,MAXL). C The running product PROD is needed for the convergence test. C----------------------------------------------------------------------- PROD = 1.0D0 DO 90 LL = 1,MAXL LGMR = LL C----------------------------------------------------------------------- C Call routine DATV to compute VNEW = ABAR*V(LL), where ABAR is C the matrix A with scaling and inverse preconditioner factors applied. C Call routine DORTH to orthogonalize the new vector VNEW = V(*,LL+1). C call routine DHEQR to update the factors of HES. C----------------------------------------------------------------------- CALL DATV (NEQ, Y, TN, YPRIME, SAVR, V(1,LL), WGHT, Z, 1 RES, IRES, PSOL, V(1,LL+1), WK, WP, IWP, CJ, EPLIN, 1 IER, NRE, NPSL, RPAR, IPAR) IF (IRES .LT. 0) RETURN IF (IER .NE. 0) GO TO 300 CALL DORTH (V(1,LL+1), V, HES, NEQ, LL, MAXLP1, KMP, SNORMW) HES(LL+1,LL) = SNORMW CALL DHEQR (HES, MAXLP1, LL, Q, INFO, LL) IF (INFO .EQ. LL) GO TO 120 C----------------------------------------------------------------------- C Update RHO, the estimate of the norm of the residual R - A*ZL. C If KMP .LT. MAXL, then the vectors V(*,1),...,V(*,LL+1) are not C necessarily orthogonal for LL .GT. KMP. The vector DL must then C be computed, and its norm used in the calculation of RHO. C----------------------------------------------------------------------- PROD = PROD*Q(2*LL) RHO = ABS(PROD*RNRM) IF ((LL.GT.KMP) .AND. (KMP.LT.MAXL)) THEN IF (LL .EQ. KMP+1) THEN CALL DCOPY (NEQ, V(1,1), 1, DL, 1) DO 75 I = 1,KMP IP1 = I + 1 I2 = I*2 S = Q(I2) C = Q(I2-1) DO 70 K = 1,NEQ DL(K) = S*DL(K) + C*V(K,IP1) 70 CONTINUE 75 CONTINUE ENDIF S = Q(2*LL) C = Q(2*LL-1)/SNORMW LLP1 = LL + 1 DO 80 K = 1,NEQ DL(K) = S*DL(K) + C*V(K,LLP1) 80 CONTINUE DLNRM = DNRM2 (NEQ, DL, 1) RHO = RHO*DLNRM ENDIF C----------------------------------------------------------------------- C Test for convergence. If passed, compute approximation ZL. C If failed and LL .LT. MAXL, then continue iterating. C----------------------------------------------------------------------- IF (RHO .LE. EPLIN) GO TO 200 IF (LL .EQ. MAXL) GO TO 100 C----------------------------------------------------------------------- C Rescale so that the norm of V(1,LL+1) is one. C----------------------------------------------------------------------- TEM = 1.0D0/SNORMW CALL DSCAL (NEQ, TEM, V(1,LL+1), 1) 90 CONTINUE 100 CONTINUE IF (RHO .LT. RNRM) GO TO 150 120 CONTINUE IFLAG = 2 DO 130 I = 1,NEQ Z(I) = 0.D0 130 CONTINUE RETURN 150 IFLAG = 1 C----------------------------------------------------------------------- C The tolerance was not met, but the residual norm was reduced. C If performing restarting (IRST .gt. 0) calculate the residual vector C RL and store it in the DL array. If the incomplete version is C being used (KMP .lt. MAXL) then DL has already been calculated. C----------------------------------------------------------------------- IF (IRST .GT. 0) THEN IF (KMP .EQ. MAXL) THEN C C Calculate DL from the V(I)'s. C CALL DCOPY (NEQ, V(1,1), 1, DL, 1) MAXLM1 = MAXL - 1 DO 175 I = 1,MAXLM1 IP1 = I + 1 I2 = I*2 S = Q(I2) C = Q(I2-1) DO 170 K = 1,NEQ DL(K) = S*DL(K) + C*V(K,IP1) 170 CONTINUE 175 CONTINUE S = Q(2*MAXL) C = Q(2*MAXL-1)/SNORMW DO 180 K = 1,NEQ DL(K) = S*DL(K) + C*V(K,MAXLP1) 180 CONTINUE ENDIF C C Scale DL by RNRM*PROD to obtain the residual RL. C TEM = RNRM*PROD CALL DSCAL(NEQ, TEM, DL, 1) ENDIF C----------------------------------------------------------------------- C Compute the approximation ZL to the solution. C Since the vector Z was used as work space, and the initial guess C of the Newton correction is zero, Z must be reset to zero. C----------------------------------------------------------------------- 200 CONTINUE LL = LGMR LLP1 = LL + 1 DO 210 K = 1,LLP1 R(K) = 0.0D0 210 CONTINUE R(1) = RNRM CALL DHELS (HES, MAXLP1, LL, Q, R) DO 220 K = 1,NEQ Z(K) = 0.0D0 220 CONTINUE DO 230 I = 1,LL CALL DAXPY (NEQ, R(I), V(1,I), 1, Z, 1) 230 CONTINUE DO 240 I = 1,NEQ Z(I) = Z(I)/WGHT(I) 240 CONTINUE C Load RHO into RHOK. RHOK = RHO RETURN C----------------------------------------------------------------------- C This block handles error returns forced by routine PSOL. C----------------------------------------------------------------------- 300 CONTINUE IF (IER .LT. 0) IFLAG = -1 IF (IER .GT. 0) IFLAG = 3 C RETURN C C------END OF SUBROUTINE DSPIGM----------------------------------------- END C Work performed under the auspices of the U.S. Department of Energy C by Lawrence Livermore National Laboratory under contract number C W-7405-Eng-48. C SUBROUTINE DORTH (VNEW, V, HES, N, LL, LDHES, KMP, SNORMW) C C***BEGIN PROLOGUE DORTH C***DATE WRITTEN 890101 (YYMMDD) C***REVISION DATE 900926 (YYMMDD) C C C----------------------------------------------------------------------- C***DESCRIPTION C C This routine orthogonalizes the vector VNEW against the previous C KMP vectors in the V array. It uses a modified Gram-Schmidt C orthogonalization procedure with conditional reorthogonalization. C C On entry C C VNEW = The vector of length N containing a scaled product C OF The Jacobian and the vector V(*,LL). C C V = The N x LL array containing the previous LL C orthogonal vectors V(*,1) to V(*,LL). C C HES = An LL x LL upper Hessenberg matrix containing, C in HES(I,K), K.LT.LL, scaled inner products of C A*V(*,K) and V(*,I). C C LDHES = The leading dimension of the HES array. C C N = The order of the matrix A, and the length of VNEW. C C LL = The current order of the matrix HES. C C KMP = The number of previous vectors the new vector VNEW C must be made orthogonal to (KMP .LE. MAXL). C C C On return C C VNEW = The new vector orthogonal to V(*,I0), C where I0 = MAX(1, LL-KMP+1). C C HES = Upper Hessenberg matrix with column LL filled in with C scaled inner products of A*V(*,LL) and V(*,I). C C SNORMW = L-2 norm of VNEW. C C----------------------------------------------------------------------- C***ROUTINES CALLED C DDOT, DNRM2, DAXPY C C***END PROLOGUE DORTH C INTEGER N, LL, LDHES, KMP DOUBLE PRECISION VNEW, V, HES, SNORMW DIMENSION VNEW(*), V(N,*), HES(LDHES,*) INTEGER I, I0 DOUBLE PRECISION ARG, DDOT, DNRM2, SUMDSQ, TEM, VNRM C C----------------------------------------------------------------------- C Get norm of unaltered VNEW for later use. C----------------------------------------------------------------------- VNRM = DNRM2 (N, VNEW, 1) C----------------------------------------------------------------------- C Do Modified Gram-Schmidt on VNEW = A*V(LL). C Scaled inner products give new column of HES. C Projections of earlier vectors are subtracted from VNEW. C----------------------------------------------------------------------- I0 = MAX0(1,LL-KMP+1) DO 10 I = I0,LL HES(I,LL) = DDOT (N, V(1,I), 1, VNEW, 1) TEM = -HES(I,LL) CALL DAXPY (N, TEM, V(1,I), 1, VNEW, 1) 10 CONTINUE C----------------------------------------------------------------------- C Compute SNORMW = norm of VNEW. C If VNEW is small compared to its input value (in norm), then C Reorthogonalize VNEW to V(*,1) through V(*,LL). C Correct if relative correction exceeds 1000*(unit roundoff). C Finally, correct SNORMW using the dot products involved. C----------------------------------------------------------------------- SNORMW = DNRM2 (N, VNEW, 1) IF (VNRM + 0.001D0*SNORMW .NE. VNRM) RETURN SUMDSQ = 0.0D0 DO 30 I = I0,LL TEM = -DDOT (N, V(1,I), 1, VNEW, 1) IF (HES(I,LL) + 0.001D0*TEM .EQ. HES(I,LL)) GO TO 30 HES(I,LL) = HES(I,LL) - TEM CALL DAXPY (N, TEM, V(1,I), 1, VNEW, 1) SUMDSQ = SUMDSQ + TEM**2 30 CONTINUE IF (SUMDSQ .EQ. 0.0D0) RETURN ARG = MAX(0.0D0,SNORMW**2 - SUMDSQ) SNORMW = SQRT(ARG) RETURN C C------END OF SUBROUTINE DORTH------------------------------------------ END C----------------------------------------------------------------------- C Karline: C rescaling of error term according to the index of each variable C index 2 variables are scaled with 1/H C index 3 variables are scaled with 1/H^2 C----------------------------------------------------------------------- SUBROUTINE SCALE(NEQ, NIND, SCAL, H) INTEGER NEQ, NIND(3) , I DOUBLE PRECISION SCAL(*), H IF(NIND(2).NE.0) THEN DO I=NIND(1)+1,NIND(1)+NIND(2) SCAL(I)=SCAL(I)/min(1.D0,H) END DO ENDIF IF(NIND(3).NE.0) THEN DO I=NIND(1)+NIND(2)+1,NIND(1)+NIND(2)+NIND(3) SCAL(I)=SCAL(I)/min(1.D0, H*H) END DO ENDIF RETURN END deSolve/src/rprintf.c0000754000175100001440000000176613131751003014316 0ustar hornikusers#include void F77_SUB(rprintf)(char* msg) { Rprintf(msg); Rprintf("\n"); } // may be redundant void F77_SUB(rprintf2)(char* msg) { Rprintf(msg); Rprintf("\n"); } void F77_SUB(rprintfid)(char* msg, int *i, double *d) { Rprintf(msg, *i, *d); Rprintf("\n"); } void F77_SUB(rprintfdi)(char* msg, double *d, int *i) { Rprintf(msg, *d, *i); Rprintf("\n"); } void F77_SUB(rprintfdid)(char* msg, double *d1, int *i, double *d2) { Rprintf(msg, *d1, *i, *d2); Rprintf("\n"); } void F77_SUB(rprintfd1)(char* msg, double *d) { Rprintf(msg, *d); Rprintf("\n"); } void F77_SUB(rprintfd2)(char* msg, double *d1, double *d2) { Rprintf(msg, *d1, *d2); Rprintf("\n"); } void F77_SUB(rprintfi1)(char* msg, int *i) { Rprintf(msg, *i); Rprintf("\n"); } void F77_SUB(rprintfi2)(char* msg, int *i1, int *i2) { Rprintf(msg, *i1, *i2); Rprintf("\n"); } void F77_SUB(rprintfi3)(char* msg, int *i1, int *i2, int* i3) { Rprintf(msg, *i1, *i2, *i3); Rprintf("\n"); } deSolve/src/ex_SCOC.c0000754000175100001440000000156113131751003014046 0ustar hornikusers/* -------- ex_SCOC.c -> ex_SCOC.dll / ex_SCOC.so ------ */ /* compile in R with: system("gcc -shared -o scoc.dll ex_SCOC.c") */ /* or with system("R CMD SHLIB ex_SCOC.c") */ /* Initialiser for parameter commons */ #include static double parms[1]; #define k parms[0] static double forcs[1]; #define depo forcs[0] void scocpar(void (* odeparms)(int *, double *)) { int N=1; odeparms(&N, parms); } /* Initialiser for forcing commons */ void scocforc(void (* odeforcs)(int *, double *)) { int N=1; odeforcs(&N, forcs); } /* Derivatives and output variable */ void scocder (int *neq, double *t, double *y, double *ydot, double *out, int *ip) { if (ip[0] <2) error("nout should be at least 2"); ydot[0] = -k*y[0] + depo; out[0]= k*y[0]; out[1]= depo; } deSolve/src/deSolve.h0000754000175100001440000001207513131751003014233 0ustar hornikusers#ifndef R_R_H # include #endif #ifndef R_DEFINES_H # include #endif #ifndef R_INTERNALS_H_ # include #endif /*============================================================================ global R variables ============================================================================*/ double *timesteps; /* see also: R_init_deSolve.c */ SEXP YOUT, YOUT2, ISTATE, RWORK, IROOT; /* returned to R */ SEXP Y, YPRIME , Rin; int n_eq; /* use in daspk */ long int nrowpd; /* output in DLL globals */ int isOut, *ipar; double *out; /* forcings */ long int nforc; /* the number of forcings */ double *tvec; double *fvec; int *ivec; int fmethod; int *findex; double *intpol; int *maxindex; double *forcings; /* events */ double tEvent; int iEvent, nEvent, typeevent, rootevent, Rootsave; double *troot, *valroot; int *nrroot, *termroot; double *timeevent, *valueevent; int *svarevent, *methodevent; /* time delays */ int interpolMethod; /* for time-delays : 1 = hermite; 2=dense */ /*============================================================================ type definitions for C functions ============================================================================*/ typedef void C_deriv_func_type(int*, double*, double*, double*, double*, int*); C_deriv_func_type* DLL_deriv_func; typedef void C_res_func_type(double*, double*, double*, double*, double*, int*, double*, int*); C_res_func_type* DLL_res_func; /* this is for use in compiled code */ typedef void init_func_type (void (*)(int*, double*)); /*============================================================================ solver R- global functions ============================================================================*/ extern SEXP R_deriv_func; extern SEXP R_jac_func; extern SEXP R_jac_vec; extern SEXP R_root_func; extern SEXP R_event_func; extern SEXP R_envir; /* DAE globals */ extern SEXP R_res_func; extern SEXP R_daejac_func; extern SEXP R_psol_func; extern SEXP R_mas_func; extern SEXP de_gparms; SEXP getListElement(SEXP list, const char* str); SEXP getTimestep(); /*============================================================================ C- utilities, functions ============================================================================*/ void init_N_Protect(void); void incr_N_Protect(void); long int save_N_Protected(void); void restore_N_Protected(long int); void unprotect_all(void); void my_unprotect(int); void lock_solver(void); void unlock_solver(void); void returnearly (int, int, int); void terminate(int, int*, int, int, double *, int, int); /* declarations for initialisations */ void initParms(SEXP Initfunc, SEXP Parms); void Initdeparms(int*, double*); void Initdeforc(int*, double*); void initOutR(int isDll, int *nout, int *ntot, int neq, SEXP nOut, SEXP Rpar, SEXP Ipar); void initOutC(int isDll, int *nout, int *ntot, int neq, SEXP nOut, SEXP Rpar, SEXP Ipar); /* sparsity of Jacobian */ void sparsity1D(SEXP Type, int* iwork, int neq, int liw); void sparsity2D(SEXP Type, int* iwork, int neq, int liw); void sparsity3D(SEXP Type, int* iwork, int neq, int liw); void sparsity2Dmap(SEXP Type, int* iwork, int neq, int liw); /* testing, since version 1.10.4*/ void sparsity3Dmap(SEXP Type, int* iwork, int neq, int liw); /* testing, since version 1.10.4*/ void interactmap (int *ij, int nnz, int *iwork, int *ipres, int ival); void initglobals(int, int); void initdaeglobals(int, int); /* the forcings and event functions */ void updatedeforc(double*); int initForcings(SEXP list); int initEvents(SEXP list, SEXP, int); void updateevent(double*, double*, int*); /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ DECLARATIONS for time lags +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ /*========================================== R-functions ==========================================*/ SEXP getPastValue (SEXP T, SEXP nr); SEXP getPastGradient(SEXP T, SEXP nr); /*========================================== C- utilities, functions ==========================================*/ /* Hermitian interpolation */ double Hermite (double t0, double t1, double y0, double y1, double dy0, double dy1, double t); double dHermite(double t0, double t1, double y0, double y1, double dy0, double dy1, double t); int initLags(SEXP elag, int solver, int nroot); /* history vectors */ void inithist(int max, int maxlags, int solver, int nroot); void updatehistini(double t, double *y, double *dY, double *rwork, int *iwork); void updatehist(double t, double *y, double *dy, double *rwork, int *iwork); int nexthist(int i); double interpolate(int i, int k, double t0, double t1, double t, double *Yh, int nq); /*========================================== Global variables for history arrays ==========================================*/ int indexhist, indexlag, endreached, starthist; double *histvar, *histdvar, *histtime, *histhh, *histsave; int *histord; int histsize, offset; int initialisehist, lyh, lhh, lo; deSolve/src/ex_ChemicalDAE.c0000754000175100001440000000344013131751003015334 0ustar hornikusers/*---------------------------------------------------------------- The chemical model example of daspk but with the production rate a forcing function rather than a parameter... ----------------------------------------------------------------*/ #include /* -------- ChemicalDAE.c -> ChemicalDAE.dll ------ c compile in R with: system("g77 -shared -o ChemicalDAE.dll ChemicalDAE.c") c or with system("R CMD SHLIB ChemicalDAE.c") */ /* A trick to address the parameters and forcings by name */ static double parms[3]; static double forc[1]; #define K parms[0] #define ka parms[1] #define r parms[2] #define prod forc[0] /*---------------------------------------------------------------- Initialiser for parameters ----------------------------------------------------------------*/ void initparms(void (* daspkparms)(int *, double *)) { int N=3; daspkparms(&N, parms); } /*---------------------------------------------------------------- c Initialiser for forcings ----------------------------------------------------------------*/ void initforcs(void (* daspkforcs)(int *, double *)) { int N=1; daspkforcs(&N, forc); } /*---------------------------------------------------------------- Derivatives ----------------------------------------------------------------*/ void chemres (double *t, double *y, double *ydot, double *cj, double *delta, int *ires, double *out, int *ip) { double ra, rb; if (ip[0] <2) error("nout should be at least 2"); ra = ka* y[2]; /* forward rate */ rb = ka/K *y[0] * y[1]; /* backward rate */ /* residuals of rates of changes */ delta[2] = -ydot[2] - ra + rb + prod; delta[0] = -ydot[0] + ra - rb; delta[1] = -ydot[1] + ra - rb - r*y[1]; out[0] = y[0] + y[1] + y[2]; out[1] = prod; } deSolve/src/dintdy2.f0000754000175100001440000000354113131751003014203 0ustar hornikusers SUBROUTINE INTERPOLY(T, K, I, YH, NYH, DKY, nq, tn, h) C***PURPOSE Interpolate solution derivatives to be used in C-code. C computes interpolated values of the K-th derivative of the i-th C dependent variable vector y, and stores it in DKY. This routine C is called within the package with K = 0 and T = TOUT, but may C also be called by the user for any K up to the current order. C (See detailed instructions in the usage documentation.) C C The computed values in DKY are gotten by interpolation using the C Nordsieck history array YH. This array corresponds uniquely to a C vector-valued polynomial of degree NQCUR or less, and DKY is set C to the K-th derivative of this polynomial at T. C The formula for DKY is: C q C DKY(i) = sum c(j,K) * (T - tn)**(j-K) * h**(-j) * YH(i,j+1) C j=K C where c(j,K) = j*(j-1)*...*(j-K+1), q = NQCUR, tn = TCUR, h = HCUR. C The above sum is done in reverse order. C IFLAG is returned negative if either K or T is out of bounds. C C***BASED ON DINTDY IMPLICIT NONE INTEGER K, NYH, NQ, I, IC, J, JB, JB2, JJ, JJ1, JP1 DOUBLE PRECISION T, DKY, H, C, R, S, Tn DOUBLE PRECISION YH(NYH,*) C C***FIRST EXECUTABLE STATEMENT S = (T - TN)/H IC = 1 IF (K .EQ. 0) GO TO 15 JJ1 = nq+1 - K DO 10 JJ = JJ1,NQ IC = IC*JJ 10 CONTINUE 15 C = IC DKY = C*YH(I,nq+1) IF (K .EQ. NQ) GO TO 55 JB2 = NQ - K DO 50 JB = 1,JB2 J = NQ - JB JP1 = J + 1 IC = 1 IF (K .EQ. 0) GO TO 35 JJ1 = JP1 - K DO 30 JJ = JJ1,J IC = IC*JJ 30 CONTINUE 35 C = IC DKY = C*YH(I,JP1) + S*DKY 50 CONTINUE IF (K .EQ. 0) RETURN 55 R = H**(-K) DKY = R*DKY RETURN C----------------------- END OF SUBROUTINE InterpolY ---------------------- END deSolve/src/call_zvode.c0000754000175100001440000002603113131751003014744 0ustar hornikusers/* complex number vode */ #include #include #include "deSolve.h" #include "zvode.h" #include "externalptr.h" /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Ordinary differential equation solver for complex state variables, zvode. The C-wrappers that provide the interface between FORTRAN codes and R-code are: C_zderiv_func: interface with R-code "func", passes derivatives C_zjac_func : interface with R-code "jacfunc", passes jacobian (except lsodes) C_zderiv_func_forc provides the interface between the function specified in a DLL and the integrator, in case there are forcing functions. Events and roots are not implemented for zvode changes since 1.4 karline: version 1.5: added forcing functions in DLL improving names +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ SEXP R_zderiv_func; SEXP R_zjac_func; SEXP R_vode_envir; /* definition of the call to the FORTRAN function dvode - in file zvode.f*/ void F77_NAME(zvode)(void (*)(int *, double *, Rcomplex *, Rcomplex *, Rcomplex *, int *), int *, Rcomplex *, double *, double *, int *, double *, double *, int *, int *, int *, Rcomplex *, int*, double *, int *,int *, int *, void (*)(int *, double *, Rcomplex *, int *, int *, Rcomplex *, int *, Rcomplex*, int*), int *, Rcomplex *, int *); /* interface between FORTRAN function call and R function Fortran code calls cvode_derivs(N, t, y, ydot, yout, iout) R code called as R_zderiv_func(time, y) and returns ydot Note: passing of parameter values and "..." is done in R-function zvode*/ static void C_zderiv_func (int *neq, double *t, Rcomplex *y, Rcomplex *ydot, Rcomplex *yout, int *iout) { int i; SEXP R_fcall, Time, ans; for (i = 0; i < *neq; i++) COMPLEX(cY)[i] = y[i]; PROTECT(Time = ScalarReal(*t)); incr_N_Protect(); PROTECT(R_fcall = lang3(R_zderiv_func,Time,cY)) ;incr_N_Protect(); PROTECT(ans = eval(R_fcall, R_vode_envir)) ;incr_N_Protect(); for (i = 0; i < *neq; i++) ydot[i] = COMPLEX(VECTOR_ELT(ans,0))[i]; my_unprotect(3); } /* interface between FORTRAN call to jacobian and R function */ static void C_zjac_func (int *neq, double *t, Rcomplex *y, int *ml, int *mu, Rcomplex *pd, int *nrowpd, Rcomplex *yout, int *iout) { int i; SEXP R_fcall, Time, ans; for (i = 0; i < *neq; i++) COMPLEX(cY)[i] = y[i]; PROTECT(Time = ScalarReal(*t)); incr_N_Protect(); PROTECT(R_fcall = lang3(R_zjac_func,Time,cY)); incr_N_Protect(); PROTECT(ans = eval(R_fcall, R_vode_envir)); incr_N_Protect(); for (i = 0; i < *neq * *nrowpd; i++) pd[i ] = COMPLEX(ans)[i ]; my_unprotect(3); } /* wrapper above the derivate function that first estimates the values of the forcing functions */ static void C_zderiv_func_forc (int *neq, double *t, Rcomplex *y, Rcomplex *ydot, Rcomplex *yout, int *iout) { updatedeforc(t); DLL_cderiv_func(neq, t, y, ydot, yout, iout); } /* give name to data types */ typedef void C_zjac_func_type(int *, double *, Rcomplex *, int *, int *, Rcomplex *, int *, Rcomplex *, int *); /* MAIN C-FUNCTION, CALLED FROM R-code */ SEXP call_zvode(SEXP y, SEXP times, SEXP derivfunc, SEXP parms, SEXP rtol, SEXP atol, SEXP rho, SEXP tcrit, SEXP jacfunc, SEXP initfunc, SEXP iTask, SEXP rWork, SEXP iWork, SEXP jT, SEXP nOut, SEXP lZw, SEXP lRw, SEXP lIw, SEXP Rpar, SEXP Ipar, SEXP flist) { /******************************************************************************/ /****** DECLARATION SECTION ******/ /******************************************************************************/ int i, j, k, nt, latol, lrtol, lrw, liw, lzw; double tin, tout, *Atol, *Rtol, ss; int neq, itol, itask, istate, iopt, jt, //mflag, is, isDll, isForcing; Rcomplex *xytmp, *dy = NULL, *zwork; int *iwork, it, ntot, nout; double *rwork; C_zderiv_func_type *zderiv_func; C_zjac_func_type *zjac_func = NULL; /******************************************************************************/ /****** STATEMENTS ******/ /******************************************************************************/ lock_solver(); /* prevent nested call of solvers that have global variables */ /* #### initialisation #### */ //init_N_Protect(); long int old_N_Protect = save_N_Protected(); jt = INTEGER(jT)[0]; neq = LENGTH(y); nt = LENGTH(times); nout = INTEGER(nOut)[0]; /* The output: zout and ipar are used to pass output variables (number set by nout) followed by other input (e.g. forcing functions) provided by R-arguments rpar, ipar ipar[0]: number of output variables, ipar[1]: length of rpar, ipar[2]: length of ipar */ /* is function a dll ?*/ if (inherits(derivfunc, "NativeSymbol")) { isDll = 1; } else { isDll = 0; } /* initialise output for Complex variables ... */ initOutComplex(isDll, &nout, &ntot, neq, nOut, Rpar, Ipar); /* copies of all variables that will be changed in the FORTRAN subroutine */ xytmp = (Rcomplex *) R_alloc(neq, sizeof(Rcomplex)); for (j = 0; j < neq; j++) xytmp[j] = COMPLEX(y)[j]; latol = LENGTH(atol); Atol = (double *) R_alloc((int) latol, sizeof(double)); for (j = 0; j < latol; j++) Atol[j] = REAL(atol)[j]; lrtol = LENGTH(rtol); Rtol = (double *) R_alloc((int) lrtol, sizeof(double)); for (j = 0; j < lrtol; j++) Rtol[j] = REAL(rtol)[j]; liw = INTEGER(lIw)[0]; iwork = (int *) R_alloc(liw, sizeof(int)); for (j = 0; j < 30; j++) iwork[j] = INTEGER(iWork)[j]; lrw = INTEGER(lRw)[0]; rwork = (double *) R_alloc(lrw, sizeof(double)); for (j = 0; j < 20; j++) rwork[j] = REAL(rWork)[j]; /* global variable */ //timesteps = (double *) R_alloc(2, sizeof(double)); for (j=0; j<2; j++) timesteps[j] = 0.; lzw = INTEGER(lZw)[0]; zwork = (Rcomplex *) R_alloc(lzw, sizeof(Rcomplex)); /* initialise global R-variables... */ PROTECT(cY = allocVector(CPLXSXP , neq) ) ;incr_N_Protect(); PROTECT(YOUT = allocMatrix(CPLXSXP,ntot+1,nt)) ;incr_N_Protect(); /**************************************************************************/ /****** Initialization of Parameters and Forcings (DLL functions) ******/ /**************************************************************************/ initParms(initfunc, parms); isForcing = initForcings(flist); /* pointers to functions zderiv_func and zjac_func, passed to the FORTRAN subroutine */ if (isDll == 1) { /* DLL address passed to FORTRAN */ zderiv_func = (C_zderiv_func_type *) R_ExternalPtrAddrFn_(derivfunc); /* no need to communicate with R - but output variables set here */ if (isOut) { dy = (Rcomplex *) R_alloc(neq, sizeof(Rcomplex)); /* for (j = 0; j < neq; j++) dy[j] = i0; */ } /* here overruling zderiv_func if forcing */ if (isForcing) { DLL_cderiv_func = (C_zderiv_func_type *) R_ExternalPtrAddrFn_(derivfunc); zderiv_func = (C_zderiv_func_type *) C_zderiv_func_forc; } } else { /* interface function between FORTRAN and R passed to FORTRAN*/ zderiv_func = (C_zderiv_func_type *) C_zderiv_func; /* needed to communicate with R */ R_zderiv_func = derivfunc; R_vode_envir = rho; } if (!isNull(jacfunc)) { if (isDll == 1) { zjac_func = (C_zjac_func_type *) R_ExternalPtrAddrFn_(jacfunc); } else { R_zjac_func = jacfunc; zjac_func = C_zjac_func; } } /* tolerance specifications */ if (latol == 1 && lrtol == 1 ) itol = 1; if (latol > 1 && lrtol == 1 ) itol = 2; if (latol == 1 && lrtol > 1 ) itol = 3; if (latol > 1 && lrtol > 1 ) itol = 4; itask = INTEGER(iTask)[0]; istate = 1; iopt = 0; ss = 0.; is = 0; for (i = 5; i < 8 ; i++) ss = ss+rwork[i]; for (i = 5; i < 10; i++) is = is+iwork[i]; if (ss >0 || is > 0) iopt = 1; /* non-standard input */ /* #### initial time step #### */ /* COMPLEX(YOUT)[0] = COMPLEX(times)[0];*/ for (j = 0; j < neq; j++) { COMPLEX(YOUT)[j+1] = COMPLEX(y)[j]; } /* function in DLL and output */ if (isOut == 1) { tin = REAL(times)[0]; zderiv_func (&neq, &tin, xytmp, dy, zout, ipar) ; for (j = 0; j < nout; j++) COMPLEX(YOUT)[j + neq + 1] = zout[j]; } /* #### main time loop #### */ for (it = 0; it < nt-1; it++) { tin = REAL(times)[it]; tout = REAL(times)[it+1]; F77_CALL(zvode) (zderiv_func, &neq, xytmp, &tin, &tout, &itol, Rtol, Atol, &itask, &istate, &iopt, zwork, &lzw, rwork, &lrw, iwork, &liw, zjac_func, &jt, zout, ipar); /* in case size of timesteps is called for */ timesteps [0] = rwork[10]; timesteps [1] = rwork[11]; if (istate == -1) { warning("an excessive amount of work (> mxstep ) was done, but integration was not successful - increase maxsteps ?"); } else if (istate == -2) { warning("Excessive precision requested. scale up `rtol' and `atol' e.g by the factor %g\n",10.0); } else if (istate == -4) { warning("repeated error test failures on a step, but integration was successful - singularity ?"); } else if (istate == -5) { warning("repeated convergence test failures on a step, but integration was successful - inaccurate Jacobian matrix?"); } else if (istate == -6) { warning("Error term became zero for some i: pure relative error control (ATOL(i)=0.0) for a variable which is now vanished"); } if (istate == -3) { error("illegal input detected before taking any integration steps - see written message"); unprotect_all(); } else { /* REAL(YOUT)[(it+1)*(ntot+1)] = tin;*/ for (j = 0; j < neq; j++) COMPLEX(YOUT)[(it+1)*(ntot + 1) + j + 1] = xytmp[j]; if (isOut == 1) { zderiv_func (&neq, &tin, xytmp, dy, zout, ipar) ; for (j = 0; j < nout; j++) COMPLEX(YOUT)[(it+1)*(ntot + 1) + j + neq + 1] = zout[j]; } } /* #### an error occurred #### */ if (istate < 0 || tin < tout) { warning("Returning early from dvode Results are accurate, as far as they go\n"); /* redimension YOUT */ PROTECT(YOUT2 = allocMatrix(CPLXSXP,ntot+1,(it+2)));incr_N_Protect(); for (k = 0; k < it+2; k++) for (j = 0; j < ntot+1; j++) COMPLEX(YOUT2)[k*(ntot+1) + j] = COMPLEX(YOUT)[k*(ntot+1) + j]; break; } } /* end main time loop */ /* #### returning output #### */ terminate(istate, iwork, 23, 0, rwork, 4, 10); unlock_solver(); //unprotect_all(); restore_N_Protected(old_N_Protect); if (istate > 0) return(YOUT); else return(YOUT2); } deSolve/src/call_rkImplicit.c0000754000175100001440000002371113131751003015726 0ustar hornikusers/*==========================================================================*/ /* Runge-Kutta Solvers, (C) Th. Petzoldt, License: GPL >=2 */ /* RK Solver for implicit methods with fixed step size */ /* (experimental code derived by K.S.) */ /*==========================================================================*/ #include "rk_util.h" SEXP call_rkImplicit(SEXP Xstart, SEXP Times, SEXP Func, SEXP Initfunc, SEXP Parms, SEXP eventfunc, SEXP elist, SEXP Nout, SEXP Rho, SEXP Tcrit, SEXP Verbose, SEXP Hini, SEXP Rpar, SEXP Ipar, SEXP Method, SEXP Maxsteps, SEXP Flist) { /** Initialization **/ long int old_N_Protect = save_N_Protected(); double *tt = NULL, *xs = NULL; double *y, *f, *Fj, *tmp, *tmp2, *tmp3, *FF, *rr; SEXP R_yout; double *y0, *y1, *dy1, *out, *yout; double t, dt, tmax; int fsal = FALSE; /* fixed step methods have no FSAL */ int interpolate = TRUE; /* polynomial interpolation is done by default */ int i = 0, j=0, it=0, it_tot=0, it_ext=0, nt = 0, neq=0; int isForcing, isEvent; double *alpha; int *index; /**************************************************************************/ /****** Processing of Arguments ******/ /**************************************************************************/ double tcrit = REAL(Tcrit)[0]; double hini = REAL(Hini)[0]; int maxsteps = INTEGER(Maxsteps)[0]; int nout = INTEGER(Nout)[0]; /* number of global outputs if func is in a DLL */ int verbose = INTEGER(Verbose)[0]; int stage = (int)REAL(getListElement(Method, "stage"))[0]; SEXP R_A, R_B1, R_C; double *A, *bb1, *cc=NULL; PROTECT(R_A = getListElement(Method, "A")); incr_N_Protect(); A = REAL(R_A); PROTECT(R_B1 = getListElement(Method, "b1")); incr_N_Protect(); bb1 = REAL(R_B1); PROTECT(R_C = getListElement(Method, "c")); incr_N_Protect(); if (length(R_C)) cc = REAL(R_C); double qerr = REAL(getListElement(Method, "Qerr"))[0]; PROTECT(Times = AS_NUMERIC(Times)); incr_N_Protect(); tt = NUMERIC_POINTER(Times); nt = length(Times); PROTECT(Xstart = AS_NUMERIC(Xstart)); incr_N_Protect(); xs = NUMERIC_POINTER(Xstart); neq = length(Xstart); /*------------------------------------------------------------------------*/ /* timesteps (for advection computation in ReacTran) */ /*------------------------------------------------------------------------*/ for (i = 0; i < 2; i++) timesteps[i] = 0; /**************************************************************************/ /****** DLL, ipar, rpar (to be compatible with lsoda) ******/ /**************************************************************************/ int isDll = FALSE; //int ntot = 0; int lrpar= 0, lipar = 0; int *ipar = NULL; if (inherits(Func, "NativeSymbol")) { /* function is a dll */ isDll = TRUE; if (nout > 0) isOut = TRUE; //ntot = neq + nout; /* length of yout */ lrpar = nout + LENGTH(Rpar); /* length of rpar; LENGTH(Rpar) is always >0 */ lipar = 3 + LENGTH(Ipar); /* length of ipar */ } else { /* function is not a dll */ isDll = FALSE; isOut = FALSE; //ntot = neq; lipar = 3; /* in lsoda = 1 */ lrpar = nout; /* in lsoda = 1 */ } out = (double *) R_alloc(lrpar, sizeof(double)); ipar = (int *) R_alloc(lipar, sizeof(int)); ipar[0] = nout; /* first 3 elements of ipar are special */ ipar[1] = lrpar; ipar[2] = lipar; if (isDll == 1) { /* other elements of ipar are set in R-function lsodx via argument *ipar* */ for (j = 0; j < LENGTH(Ipar); j++) ipar[j+3] = INTEGER(Ipar)[j]; /* out: first nout elements of out are reserved for output variables other elements are set via argument *rpar* */ for (j = 0; j < nout; j++) out[j] = 0.0; for (j = 0; j < LENGTH(Rpar); j++) out[nout+j] = REAL(Rpar)[j]; } /*------------------------------------------------------------------------*/ /* Allocation of Workspace */ /*------------------------------------------------------------------------*/ y0 = (double *) R_alloc(neq, sizeof(double)); y1 = (double *) R_alloc(neq, sizeof(double)); dy1 = (double *) R_alloc(neq, sizeof(double)); f = (double *) R_alloc(neq, sizeof(double)); y = (double *) R_alloc(neq, sizeof(double)); Fj = (double *) R_alloc(neq, sizeof(double)); FF = (double *) R_alloc(neq * stage, sizeof(double)); rr = (double *) R_alloc(neq * 5, sizeof(double)); /* ks */ alpha = (double *) R_alloc(neq * stage * neq * stage, sizeof(double)); index = (int *) R_alloc(neq * stage, sizeof(int)); tmp = (double *) R_alloc(neq * stage, sizeof(double)); tmp2 = (double *) R_alloc(neq * stage, sizeof(double)); tmp3 = (double *) R_alloc(neq * stage, sizeof(double)); /* matrix for polynomial interpolation */ SEXP R_nknots; int nknots = 6; /* 6 = 5th order polynomials by default*/ int iknots = 0; /* counter for knots buffer */ double *yknots; PROTECT(R_nknots = getListElement(Method, "nknots")); incr_N_Protect(); if (length(R_nknots)) nknots = INTEGER(R_nknots)[0] + 1; if (nknots < 2) {nknots=1; interpolate = FALSE;} yknots = (double *) R_alloc((neq + 1) * (nknots + 1), sizeof(double)); /* matrix for holding states and global outputs */ PROTECT(R_yout = allocMatrix(REALSXP, nt, neq + nout + 1)); incr_N_Protect(); yout = REAL(R_yout); /* initialize outputs with NA first */ for (i = 0; i < nt * (neq + nout + 1); i++) yout[i] = NA_REAL; /* attribute that stores state information, similar to lsoda */ SEXP R_istate; int *istate; PROTECT(R_istate = allocVector(INTSXP, 22)); incr_N_Protect(); istate = INTEGER(R_istate); istate[0] = 0; /* assume succesful return */ for (i = 0; i < 22; i++) istate[i] = 0; /*------------------------------------------------------------------------*/ /* Initialization of Parameters (for DLL functions) */ /*------------------------------------------------------------------------*/ PROTECT(Y = allocVector(REALSXP,(neq))); incr_N_Protect(); initParms(Initfunc, Parms); isForcing = initForcings(Flist); isEvent = initEvents(elist, eventfunc,0); if (isEvent) interpolate = FALSE; /*------------------------------------------------------------------------*/ /* Initialization of Integration Loop */ /*------------------------------------------------------------------------*/ yout[0] = tt[0]; /* initial time */ yknots[0] = tt[0]; /* for polynomial interpolation */ for (i = 0; i < neq; i++) { y0[i] = xs[i]; /* initial values */ yout[(i + 1) * nt] = y0[i]; /* output array */ yknots[iknots + nknots * (i + 1)] = xs[i]; /* for polynomials */ } iknots++; t = tt[0]; tmax = fmax(tt[nt - 1], tcrit); /* Initialization of work arrays (to be on the safe side, remove this later) */ for (i = 0; i < neq; i++) { y1[i] = 0; Fj[i] = 0; for (j= 0; j < stage; j++) { FF[i + j * neq] = 0; } } /*------------------------------------------------------------------------*/ /* Main Loop */ /*------------------------------------------------------------------------*/ it = 1; /* step counter; zero element is initial state */ it_ext = 0; /* counter for external time step (dense output) */ it_tot = 0; /* total number of time steps */ if (interpolate) { /* integrate over the whole time step and interpolate internally */ rk_implicit( alpha, index, fsal, neq, stage, isDll, isForcing, verbose, nknots, interpolate, maxsteps, nt, &iknots, &it, &it_ext, &it_tot, istate, ipar, t, tmax, hini, &dt, tt, y0, y1, dy1, f, y, Fj, tmp, tmp2, tmp3, FF, rr, A, out, bb1, cc, yknots, yout, Func, Parms, Rho ); } else { for (int j = 0; j < nt - 1; j++) { t = tt[j]; tmax = fmin(tt[j + 1], tcrit); dt = tmax - t; if (isEvent) { updateevent(&t, y0, istate); } rk_implicit(alpha, index, fsal, neq, stage, isDll, isForcing, verbose, nknots, interpolate, maxsteps, nt, &iknots, &it, &it_ext, &it_tot, istate, ipar, t, tmax, hini, &dt, tt, y0, y1, dy1, f, y, Fj, tmp, tmp2, tmp3, FF, rr, A, out, bb1, cc, yknots, yout, Func, Parms, Rho ); /* in this mode, internal interpolation is skipped, so we can simply store the results at the end of each call */ yout[j + 1] = tmax; for (i = 0; i < neq; i++) yout[j + 1 + nt * (1 + i)] = y1[i]; } } /*====================================================================*/ /* call derivs again to get global outputs */ /* j = -1 suppresses unnecessary internal copying */ /*====================================================================*/ if(nout > 0) { for (int j = 0; j < nt; j++) { t = yout[j]; for (i = 0; i < neq; i++) tmp[i] = yout[j + nt * (1 + i)]; derivs(Func, t, tmp, Parms, Rho, FF, out, -1, neq, ipar, isDll, isForcing); for (i = 0; i < nout; i++) { yout[j + nt * (1 + neq + i)] = out[i]; } } } /* attach diagnostic information (codes are compatible to lsoda) */ setIstate(R_yout, R_istate, istate, it_tot, stage, fsal, qerr, 0); /* release R resources */ if (verbose) { Rprintf("Number of time steps it = %d, it_ext = %d, it_tot = %d\n", it, it_ext, it_tot); Rprintf("Maxsteps %d\n", maxsteps); } /* release R resources */ timesteps[0] = 0; timesteps[1] = 0; restore_N_Protected(old_N_Protect); return(R_yout); } deSolve/src/externalptr.h0000754000175100001440000000102513131751003015173 0ustar hornikusers/* Distinguish function pointer from object pointer R >= 3.4 while maintainig compatibility with pre R 3.4 versions */ /* Usage: - include this header - rename R_ExternalPtrAddr to R_ExternalPtrAddr_ - This underscore version and externalptr.h may be removed in future versions of R. Th. Petzoldt, 2016-09-05 */ #include #if defined(R_VERSION) && R_VERSION >= R_Version(3, 4, 0) # define R_ExternalPtrAddrFn_ R_ExternalPtrAddrFn #else # define R_ExternalPtrAddrFn_ R_ExternalPtrAddr #endif deSolve/src/zvode.f0000754000175100001440000052757213131751003013774 0ustar hornikusers*DECK ZVODE SUBROUTINE ZVODE (F, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, ITASK, 1 ISTATE, IOPT, ZWORK, LZW, RWORK, LRW, IWORK, LIW, 2 JAC, MF, RPAR, IPAR) EXTERNAL F, JAC COMPLEX(KIND=8) Y, ZWORK DOUBLE PRECISION T, TOUT, RTOL, ATOL, RWORK INTEGER NEQ, ITOL, ITASK, ISTATE, IOPT, LZW, LRW, IWORK, LIW, 1 MF, IPAR DIMENSION Y(*), RTOL(*), ATOL(*), ZWORK(LZW), RWORK(LRW), 1 IWORK(LIW), RPAR(*), IPAR(*) C----------------------------------------------------------------------- C ZVODE: Variable-coefficient Ordinary Differential Equation solver, C with fixed-leading-coefficient implementation. C This version is in complex double precision. C C ZVODE solves the initial value problem for stiff or nonstiff C systems of first order ODEs, C dy/dt = f(t,y) , or, in component form, C dy(i)/dt = f(i) = f(i,t,y(1),y(2),...,y(NEQ)) (i = 1,...,NEQ). C Here the y vector is treated as complex. C ZVODE is a package based on the EPISODE and EPISODEB packages, and C on the ODEPACK user interface standard, with minor modifications. C C NOTE: When using ZVODE for a stiff system, it should only be used for C the case in which the function f is analytic, that is, when each f(i) C is an analytic function of each y(j). Analyticity means that the C partial derivative df(i)/dy(j) is a unique complex number, and this C fact is critical in the way ZVODE solves the dense or banded linear C systems that arise in the stiff case. For a complex stiff ODE system C in which f is not analytic, ZVODE is likely to have convergence C failures, and for this problem one should instead use DVODE on the C equivalent real system (in the real and imaginary parts of y). C----------------------------------------------------------------------- C Authors: C Peter N. Brown and Alan C. Hindmarsh C Center for Applied Scientific Computing C Lawrence Livermore National Laboratory C Livermore, CA 94551 C and C George D. Byrne (Prof. Emeritus) C Illinois Institute of Technology C Chicago, IL 60616 C----------------------------------------------------------------------- C For references, see DVODE. C----------------------------------------------------------------------- C Summary of usage. C C Communication between the user and the ZVODE package, for normal C situations, is summarized here. This summary describes only a subset C of the full set of options available. See the full description for C details, including optional communication, nonstandard options, C and instructions for special situations. See also the example C problem (with program and output) following this summary. C C A. First provide a subroutine of the form: C SUBROUTINE F (NEQ, T, Y, YDOT, RPAR, IPAR) C DOUBLE COMPLEX Y(NEQ), YDOT(NEQ) C DOUBLE PRECISION T C which supplies the vector function f by loading YDOT(i) with f(i). C C B. Next determine (or guess) whether or not the problem is stiff. C Stiffness occurs when the Jacobian matrix df/dy has an eigenvalue C whose real part is negative and large in magnitude, compared to the C reciprocal of the t span of interest. If the problem is nonstiff, C use a method flag MF = 10. If it is stiff, there are four standard C choices for MF (21, 22, 24, 25), and ZVODE requires the Jacobian C matrix in some form. In these cases (MF .gt. 0), ZVODE will use a C saved copy of the Jacobian matrix. If this is undesirable because of C storage limitations, set MF to the corresponding negative value C (-21, -22, -24, -25). (See full description of MF below.) C The Jacobian matrix is regarded either as full (MF = 21 or 22), C or banded (MF = 24 or 25). In the banded case, ZVODE requires two C half-bandwidth parameters ML and MU. These are, respectively, the C widths of the lower and upper parts of the band, excluding the main C diagonal. Thus the band consists of the locations (i,j) with C i-ML .le. j .le. i+MU, and the full bandwidth is ML+MU+1. C C C. If the problem is stiff, you are encouraged to supply the Jacobian C directly (MF = 21 or 24), but if this is not feasible, ZVODE will C compute it internally by difference quotients (MF = 22 or 25). C If you are supplying the Jacobian, provide a subroutine of the form: C SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD, RPAR, IPAR) C DOUBLE COMPLEX Y(NEQ), PD(NROWPD,NEQ) C DOUBLE PRECISION T C which supplies df/dy by loading PD as follows: C For a full Jacobian (MF = 21), load PD(i,j) with df(i)/dy(j), C the partial derivative of f(i) with respect to y(j). (Ignore the C ML and MU arguments in this case.) C For a banded Jacobian (MF = 24), load PD(i-j+MU+1,j) with C df(i)/dy(j), i.e. load the diagonal lines of df/dy into the rows of C PD from the top down. C In either case, only nonzero elements need be loaded. C C D. Write a main program which calls subroutine ZVODE once for C each point at which answers are desired. This should also provide C for possible use of logical unit 6 for output of error messages C by ZVODE. On the first call to ZVODE, supply arguments as follows: C F = Name of subroutine for right-hand side vector f. C This name must be declared external in calling program. C NEQ = Number of first order ODEs. C Y = Double complex array of initial values, of length NEQ. C T = The initial value of the independent variable. C TOUT = First point where output is desired (.ne. T). C ITOL = 1 or 2 according as ATOL (below) is a scalar or array. C RTOL = Relative tolerance parameter (scalar). C ATOL = Absolute tolerance parameter (scalar or array). C The estimated local error in Y(i) will be controlled so as C to be roughly less (in magnitude) than C EWT(i) = RTOL*abs(Y(i)) + ATOL if ITOL = 1, or C EWT(i) = RTOL*abs(Y(i)) + ATOL(i) if ITOL = 2. C Thus the local error test passes if, in each component, C either the absolute error is less than ATOL (or ATOL(i)), C or the relative error is less than RTOL. C Use RTOL = 0.0 for pure absolute error control, and C use ATOL = 0.0 (or ATOL(i) = 0.0) for pure relative error C control. Caution: Actual (global) errors may exceed these C local tolerances, so choose them conservatively. C ITASK = 1 for normal computation of output values of Y at t = TOUT. C ISTATE = Integer flag (input and output). Set ISTATE = 1. C IOPT = 0 to indicate no optional input used. C ZWORK = Double precision complex work array of length at least: C 15*NEQ for MF = 10, C 8*NEQ + 2*NEQ**2 for MF = 21 or 22, C 10*NEQ + (3*ML + 2*MU)*NEQ for MF = 24 or 25. C LZW = Declared length of ZWORK (in user's DIMENSION statement). C RWORK = Real work array of length at least 20 + NEQ. C LRW = Declared length of RWORK (in user's DIMENSION statement). C IWORK = Integer work array of length at least: C 30 for MF = 10, C 30 + NEQ for MF = 21, 22, 24, or 25. C If MF = 24 or 25, input in IWORK(1),IWORK(2) the lower C and upper half-bandwidths ML,MU. C LIW = Declared length of IWORK (in user's DIMENSION statement). C JAC = Name of subroutine for Jacobian matrix (MF = 21 or 24). C If used, this name must be declared external in calling C program. If not used, pass a dummy name. C MF = Method flag. Standard values are: C 10 for nonstiff (Adams) method, no Jacobian used. C 21 for stiff (BDF) method, user-supplied full Jacobian. C 22 for stiff method, internally generated full Jacobian. C 24 for stiff method, user-supplied banded Jacobian. C 25 for stiff method, internally generated banded Jacobian. C RPAR = user-defined real or complex array passed to F and JAC. C IPAR = user-defined integer array passed to F and JAC. C Note that the main program must declare arrays Y, ZWORK, RWORK, IWORK, C and possibly ATOL, RPAR, and IPAR. RPAR may be declared REAL, DOUBLE, C COMPLEX, or DOUBLE COMPLEX, depending on the user's needs. C C E. The output from the first call (or any call) is: C Y = Array of computed values of y(t) vector. C T = Corresponding value of independent variable (normally TOUT). C ISTATE = 2 if ZVODE was successful, negative otherwise. C -1 means excess work done on this call. (Perhaps wrong MF.) C -2 means excess accuracy requested. (Tolerances too small.) C -3 means illegal input detected. (See printed message.) C -4 means repeated error test failures. (Check all input.) C -5 means repeated convergence failures. (Perhaps bad C Jacobian supplied or wrong choice of MF or tolerances.) C -6 means error weight became zero during problem. (Solution C component i vanished, and ATOL or ATOL(i) = 0.) C C F. To continue the integration after a successful return, simply C reset TOUT and call ZVODE again. No other parameters need be reset. C C----------------------------------------------------------------------- C EXAMPLE PROBLEM C C The program below uses ZVODE to solve the following system of 2 ODEs: C dw/dt = -i*w*w*z, dz/dt = i*z; w(0) = 1/2.1, z(0) = 1; t = 0 to 2*pi. C Solution: w = 1/(z + 1.1), z = exp(it). As z traces the unit circle, C w traces a circle of radius 10/2.1 with center at 11/2.1. C For convenience, Main passes RPAR = (imaginary unit i) to FEX and JEX. C C EXTERNAL FEX, JEX C DOUBLE COMPLEX Y(2), ZWORK(24), RPAR, WTRU, ERR C DOUBLE PRECISION ABERR, AEMAX, ATOL, RTOL, RWORK(22), T, TOUT C DIMENSION IWORK(32) C NEQ = 2 C Y(1) = 1.0D0/2.1D0 C Y(2) = 1.0D0 C T = 0.0D0 C DTOUT = 0.1570796326794896D0 C TOUT = DTOUT C ITOL = 1 C RTOL = 1.D-9 C ATOL = 1.D-8 C ITASK = 1 C ISTATE = 1 C IOPT = 0 C LZW = 24 C LRW = 22 C LIW = 32 C MF = 21 C RPAR = DCMPLX(0.0D0,1.0D0) C AEMAX = 0.0D0 C WRITE(6,10) C 10 FORMAT(' t',11X,'w',26X,'z') C DO 40 IOUT = 1,40 C CALL ZVODE(FEX,NEQ,Y,T,TOUT,ITOL,RTOL,ATOL,ITASK,ISTATE,IOPT, C 1 ZWORK,LZW,RWORK,LRW,IWORK,LIW,JEX,MF,RPAR,IPAR) C WTRU = 1.0D0/DCMPLX(COS(T) + 1.1D0, SIN(T)) C ERR = Y(1) - WTRU C ABERR = ABS(DREAL(ERR)) + ABS(DIMAG(ERR)) C AEMAX = MAX(AEMAX,ABERR) C WRITE(6,20) T, DREAL(Y(1)),DIMAG(Y(1)), DREAL(Y(2)),DIMAG(Y(2)) C 20 FORMAT(F9.5,2X,2F12.7,3X,2F12.7) C IF (ISTATE .LT. 0) THEN C WRITE(6,30) ISTATE C 30 FORMAT(//'***** Error halt. ISTATE =',I3) C STOP C ENDIF C 40 TOUT = TOUT + DTOUT C WRITE(6,50) IWORK(11), IWORK(12), IWORK(13), IWORK(20), C 1 IWORK(21), IWORK(22), IWORK(23), AEMAX C 50 FORMAT(/' No. steps =',I4,' No. f-s =',I5, C 1 ' No. J-s =',I4,' No. LU-s =',I4/ C 2 ' No. nonlinear iterations =',I4/ C 3 ' No. nonlinear convergence failures =',I4/ C 4 ' No. error test failures =',I4/ C 5 ' Max. abs. error in w =',D10.2) C STOP C END C C SUBROUTINE FEX (NEQ, T, Y, YDOT, RPAR, IPAR) C DOUBLE COMPLEX Y(NEQ), YDOT(NEQ), RPAR C DOUBLE PRECISION T C YDOT(1) = -RPAR*Y(1)*Y(1)*Y(2) C YDOT(2) = RPAR*Y(2) C RETURN C END C C SUBROUTINE JEX (NEQ, T, Y, ML, MU, PD, NRPD, RPAR, IPAR) C DOUBLE COMPLEX Y(NEQ), PD(NRPD,NEQ), RPAR C DOUBLE PRECISION T C PD(1,1) = -2.0D0*RPAR*Y(1)*Y(2) C PD(1,2) = -RPAR*Y(1)*Y(1) C PD(2,2) = RPAR C RETURN C END C C The output of this example program is as follows: C C t w z C 0.15708 0.4763242 -0.0356919 0.9876884 0.1564345 C 0.31416 0.4767322 -0.0718256 0.9510565 0.3090170 C 0.47124 0.4774351 -0.1088651 0.8910065 0.4539906 C 0.62832 0.4784699 -0.1473206 0.8090170 0.5877853 C 0.78540 0.4798943 -0.1877789 0.7071067 0.7071069 C 0.94248 0.4817938 -0.2309414 0.5877852 0.8090171 C 1.09956 0.4842934 -0.2776778 0.4539904 0.8910066 C 1.25664 0.4875766 -0.3291039 0.3090169 0.9510566 C 1.41372 0.4919177 -0.3866987 0.1564343 0.9876884 C 1.57080 0.4977376 -0.4524889 -0.0000001 1.0000000 C 1.72788 0.5057044 -0.5293524 -0.1564346 0.9876883 C 1.88496 0.5169274 -0.6215400 -0.3090171 0.9510565 C 2.04204 0.5333540 -0.7356275 -0.4539906 0.8910065 C 2.19911 0.5586542 -0.8823669 -0.5877854 0.8090169 C 2.35619 0.6004188 -1.0806013 -0.7071069 0.7071067 C 2.51327 0.6764486 -1.3664281 -0.8090171 0.5877851 C 2.67035 0.8366909 -1.8175245 -0.8910066 0.4539904 C 2.82743 1.2657121 -2.6260146 -0.9510566 0.3090168 C 2.98451 3.0284506 -4.2182180 -0.9876884 0.1564343 C 3.14159 10.0000699 0.0000663 -1.0000000 -0.0000002 C 3.29867 3.0284170 4.2182053 -0.9876883 -0.1564346 C 3.45575 1.2657041 2.6260067 -0.9510565 -0.3090172 C 3.61283 0.8366878 1.8175205 -0.8910064 -0.4539907 C 3.76991 0.6764469 1.3664259 -0.8090169 -0.5877854 C 3.92699 0.6004178 1.0806000 -0.7071066 -0.7071069 C 4.08407 0.5586535 0.8823662 -0.5877851 -0.8090171 C 4.24115 0.5333535 0.7356271 -0.4539903 -0.8910066 C 4.39823 0.5169271 0.6215398 -0.3090168 -0.9510566 C 4.55531 0.5057041 0.5293523 -0.1564343 -0.9876884 C 4.71239 0.4977374 0.4524890 0.0000002 -1.0000000 C 4.86947 0.4919176 0.3866988 0.1564347 -0.9876883 C 5.02655 0.4875765 0.3291040 0.3090172 -0.9510564 C 5.18363 0.4842934 0.2776780 0.4539907 -0.8910064 C 5.34071 0.4817939 0.2309415 0.5877854 -0.8090169 C 5.49779 0.4798944 0.1877791 0.7071069 -0.7071066 C 5.65487 0.4784700 0.1473208 0.8090171 -0.5877850 C 5.81195 0.4774352 0.1088652 0.8910066 -0.4539903 C 5.96903 0.4767324 0.0718257 0.9510566 -0.3090168 C 6.12611 0.4763244 0.0356920 0.9876884 -0.1564342 C 6.28319 0.4761907 0.0000000 1.0000000 0.0000003 C C No. steps = 542 No. f-s = 610 No. J-s = 10 No. LU-s = 47 C No. nonlinear iterations = 607 C No. nonlinear convergence failures = 0 C No. error test failures = 13 C Max. abs. error in w = 0.13E-03 C C----------------------------------------------------------------------- C Full description of user interface to ZVODE. C C The user interface to ZVODE consists of the following parts. C C i. The call sequence to subroutine ZVODE, which is a driver C routine for the solver. This includes descriptions of both C the call sequence arguments and of user-supplied routines. C Following these descriptions is C * a description of optional input available through the C call sequence, C * a description of optional output (in the work arrays), and C * instructions for interrupting and restarting a solution. C C ii. Descriptions of other routines in the ZVODE package that may be C (optionally) called by the user. These provide the ability to C alter error message handling, save and restore the internal C COMMON, and obtain specified derivatives of the solution y(t). C C iii. Descriptions of COMMON blocks to be declared in overlay C or similar environments. C C iv. Description of two routines in the ZVODE package, either of C which the user may replace with his own version, if desired. C these relate to the measurement of errors. C C----------------------------------------------------------------------- C Part i. Call Sequence. C C The call sequence parameters used for input only are C F, NEQ, TOUT, ITOL, RTOL, ATOL, ITASK, IOPT, LRW, LIW, JAC, MF, C and those used for both input and output are C Y, T, ISTATE. C The work arrays ZWORK, RWORK, and IWORK are also used for conditional C and optional input and optional output. (The term output here refers C to the return from subroutine ZVODE to the user's calling program.) C C The legality of input parameters will be thoroughly checked on the C initial call for the problem, but not checked thereafter unless a C change in input parameters is flagged by ISTATE = 3 in the input. C C The descriptions of the call arguments are as follows. C C F = The name of the user-supplied subroutine defining the C ODE system. The system must be put in the first-order C form dy/dt = f(t,y), where f is a vector-valued function C of the scalar t and the vector y. Subroutine F is to C compute the function f. It is to have the form C SUBROUTINE F (NEQ, T, Y, YDOT, RPAR, IPAR) C DOUBLE COMPLEX Y(NEQ), YDOT(NEQ) C DOUBLE PRECISION T C where NEQ, T, and Y are input, and the array YDOT = f(t,y) C is output. Y and YDOT are double complex arrays of length C NEQ. Subroutine F should not alter Y(1),...,Y(NEQ). C F must be declared EXTERNAL in the calling program. C C Subroutine F may access user-defined real/complex and C integer work arrays RPAR and IPAR, which are to be C dimensioned in the calling program. C C If quantities computed in the F routine are needed C externally to ZVODE, an extra call to F should be made C for this purpose, for consistent and accurate results. C If only the derivative dy/dt is needed, use ZVINDY instead. C C NEQ = The size of the ODE system (number of first order C ordinary differential equations). Used only for input. C NEQ may not be increased during the problem, but C can be decreased (with ISTATE = 3 in the input). C C Y = A double precision complex array for the vector of dependent C variables, of length NEQ or more. Used for both input and C output on the first call (ISTATE = 1), and only for output C on other calls. On the first call, Y must contain the C vector of initial values. In the output, Y contains the C computed solution evaluated at T. If desired, the Y array C may be used for other purposes between calls to the solver. C C This array is passed as the Y argument in all calls to C F and JAC. C C T = The independent variable. In the input, T is used only on C the first call, as the initial point of the integration. C In the output, after each call, T is the value at which a C computed solution Y is evaluated (usually the same as TOUT). C On an error return, T is the farthest point reached. C C TOUT = The next value of t at which a computed solution is desired. C Used only for input. C C When starting the problem (ISTATE = 1), TOUT may be equal C to T for one call, then should .ne. T for the next call. C For the initial T, an input value of TOUT .ne. T is used C in order to determine the direction of the integration C (i.e. the algebraic sign of the step sizes) and the rough C scale of the problem. Integration in either direction C (forward or backward in t) is permitted. C C If ITASK = 2 or 5 (one-step modes), TOUT is ignored after C the first call (i.e. the first call with TOUT .ne. T). C Otherwise, TOUT is required on every call. C C If ITASK = 1, 3, or 4, the values of TOUT need not be C monotone, but a value of TOUT which backs up is limited C to the current internal t interval, whose endpoints are C TCUR - HU and TCUR. (See optional output, below, for C TCUR and HU.) C C ITOL = An indicator for the type of error control. See C description below under ATOL. Used only for input. C C RTOL = A relative error tolerance parameter, either a scalar or C an array of length NEQ. See description below under ATOL. C Input only. C C ATOL = An absolute error tolerance parameter, either a scalar or C an array of length NEQ. Input only. C C The input parameters ITOL, RTOL, and ATOL determine C the error control performed by the solver. The solver will C control the vector e = (e(i)) of estimated local errors C in Y, according to an inequality of the form C rms-norm of ( e(i)/EWT(i) ) .le. 1, C where EWT(i) = RTOL(i)*abs(Y(i)) + ATOL(i), C and the rms-norm (root-mean-square norm) here is C rms-norm(v) = sqrt(sum v(i)**2 / NEQ). Here EWT = (EWT(i)) C is a vector of weights which must always be positive, and C the values of RTOL and ATOL should all be non-negative. C The following table gives the types (scalar/array) of C RTOL and ATOL, and the corresponding form of EWT(i). C C ITOL RTOL ATOL EWT(i) C 1 scalar scalar RTOL*ABS(Y(i)) + ATOL C 2 scalar array RTOL*ABS(Y(i)) + ATOL(i) C 3 array scalar RTOL(i)*ABS(Y(i)) + ATOL C 4 array array RTOL(i)*ABS(Y(i)) + ATOL(i) C C When either of these parameters is a scalar, it need not C be dimensioned in the user's calling program. C C If none of the above choices (with ITOL, RTOL, and ATOL C fixed throughout the problem) is suitable, more general C error controls can be obtained by substituting C user-supplied routines for the setting of EWT and/or for C the norm calculation. See Part iv below. C C If global errors are to be estimated by making a repeated C run on the same problem with smaller tolerances, then all C components of RTOL and ATOL (i.e. of EWT) should be scaled C down uniformly. C C ITASK = An index specifying the task to be performed. C Input only. ITASK has the following values and meanings. C 1 means normal computation of output values of y(t) at C t = TOUT (by overshooting and interpolating). C 2 means take one step only and return. C 3 means stop at the first internal mesh point at or C beyond t = TOUT and return. C 4 means normal computation of output values of y(t) at C t = TOUT but without overshooting t = TCRIT. C TCRIT must be input as RWORK(1). TCRIT may be equal to C or beyond TOUT, but not behind it in the direction of C integration. This option is useful if the problem C has a singularity at or beyond t = TCRIT. C 5 means take one step, without passing TCRIT, and return. C TCRIT must be input as RWORK(1). C C Note: If ITASK = 4 or 5 and the solver reaches TCRIT C (within roundoff), it will return T = TCRIT (exactly) to C indicate this (unless ITASK = 4 and TOUT comes before TCRIT, C in which case answers at T = TOUT are returned first). C C ISTATE = an index used for input and output to specify the C the state of the calculation. C C In the input, the values of ISTATE are as follows. C 1 means this is the first call for the problem C (initializations will be done). See note below. C 2 means this is not the first call, and the calculation C is to continue normally, with no change in any input C parameters except possibly TOUT and ITASK. C (If ITOL, RTOL, and/or ATOL are changed between calls C with ISTATE = 2, the new values will be used but not C tested for legality.) C 3 means this is not the first call, and the C calculation is to continue normally, but with C a change in input parameters other than C TOUT and ITASK. Changes are allowed in C NEQ, ITOL, RTOL, ATOL, IOPT, LRW, LIW, MF, ML, MU, C and any of the optional input except H0. C (See IWORK description for ML and MU.) C Note: A preliminary call with TOUT = T is not counted C as a first call here, as no initialization or checking of C input is done. (Such a call is sometimes useful to include C the initial conditions in the output.) C Thus the first call for which TOUT .ne. T requires C ISTATE = 1 in the input. C C In the output, ISTATE has the following values and meanings. C 1 means nothing was done, as TOUT was equal to T with C ISTATE = 1 in the input. C 2 means the integration was performed successfully. C -1 means an excessive amount of work (more than MXSTEP C steps) was done on this call, before completing the C requested task, but the integration was otherwise C successful as far as T. (MXSTEP is an optional input C and is normally 500.) To continue, the user may C simply reset ISTATE to a value .gt. 1 and call again. C (The excess work step counter will be reset to 0.) C In addition, the user may increase MXSTEP to avoid C this error return. (See optional input below.) C -2 means too much accuracy was requested for the precision C of the machine being used. This was detected before C completing the requested task, but the integration C was successful as far as T. To continue, the tolerance C parameters must be reset, and ISTATE must be set C to 3. The optional output TOLSF may be used for this C purpose. (Note: If this condition is detected before C taking any steps, then an illegal input return C (ISTATE = -3) occurs instead.) C -3 means illegal input was detected, before taking any C integration steps. See written message for details. C Note: If the solver detects an infinite loop of calls C to the solver with illegal input, it will cause C the run to stop. C -4 means there were repeated error test failures on C one attempted step, before completing the requested C task, but the integration was successful as far as T. C The problem may have a singularity, or the input C may be inappropriate. C -5 means there were repeated convergence test failures on C one attempted step, before completing the requested C task, but the integration was successful as far as T. C This may be caused by an inaccurate Jacobian matrix, C if one is being used. C -6 means EWT(i) became zero for some i during the C integration. Pure relative error control (ATOL(i)=0.0) C was requested on a variable which has now vanished. C The integration was successful as far as T. C C Note: Since the normal output value of ISTATE is 2, C it does not need to be reset for normal continuation. C Also, since a negative input value of ISTATE will be C regarded as illegal, a negative output value requires the C user to change it, and possibly other input, before C calling the solver again. C C IOPT = An integer flag to specify whether or not any optional C input is being used on this call. Input only. C The optional input is listed separately below. C IOPT = 0 means no optional input is being used. C Default values will be used in all cases. C IOPT = 1 means optional input is being used. C C ZWORK = A double precision complex working array. C The length of ZWORK must be at least C NYH*(MAXORD + 1) + 2*NEQ + LWM where C NYH = the initial value of NEQ, C MAXORD = 12 (if METH = 1) or 5 (if METH = 2) (unless a C smaller value is given as an optional input), C LWM = length of work space for matrix-related data: C LWM = 0 if MITER = 0, C LWM = 2*NEQ**2 if MITER = 1 or 2, and MF.gt.0, C LWM = NEQ**2 if MITER = 1 or 2, and MF.lt.0, C LWM = NEQ if MITER = 3, C LWM = (3*ML+2*MU+2)*NEQ if MITER = 4 or 5, and MF.gt.0, C LWM = (2*ML+MU+1)*NEQ if MITER = 4 or 5, and MF.lt.0. C (See the MF description for METH and MITER.) C Thus if MAXORD has its default value and NEQ is constant, C this length is: C 15*NEQ for MF = 10, C 15*NEQ + 2*NEQ**2 for MF = 11 or 12, C 15*NEQ + NEQ**2 for MF = -11 or -12, C 16*NEQ for MF = 13, C 17*NEQ + (3*ML+2*MU)*NEQ for MF = 14 or 15, C 16*NEQ + (2*ML+MU)*NEQ for MF = -14 or -15, C 8*NEQ for MF = 20, C 8*NEQ + 2*NEQ**2 for MF = 21 or 22, C 8*NEQ + NEQ**2 for MF = -21 or -22, C 9*NEQ for MF = 23, C 10*NEQ + (3*ML+2*MU)*NEQ for MF = 24 or 25. C 9*NEQ + (2*ML+MU)*NEQ for MF = -24 or -25. C C LZW = The length of the array ZWORK, as declared by the user. C (This will be checked by the solver.) C C RWORK = A real working array (double precision). C The length of RWORK must be at least 20 + NEQ. C The first 20 words of RWORK are reserved for conditional C and optional input and optional output. C C The following word in RWORK is a conditional input: C RWORK(1) = TCRIT = critical value of t which the solver C is not to overshoot. Required if ITASK is C 4 or 5, and ignored otherwise. (See ITASK.) C C LRW = The length of the array RWORK, as declared by the user. C (This will be checked by the solver.) C C IWORK = An integer work array. The length of IWORK must be at least C 30 if MITER = 0 or 3 (MF = 10, 13, 20, 23), or C 30 + NEQ otherwise (abs(MF) = 11,12,14,15,21,22,24,25). C The first 30 words of IWORK are reserved for conditional and C optional input and optional output. C C The following 2 words in IWORK are conditional input: C IWORK(1) = ML These are the lower and upper C IWORK(2) = MU half-bandwidths, respectively, of the C banded Jacobian, excluding the main diagonal. C The band is defined by the matrix locations C (i,j) with i-ML .le. j .le. i+MU. ML and MU C must satisfy 0 .le. ML,MU .le. NEQ-1. C These are required if MITER is 4 or 5, and C ignored otherwise. ML and MU may in fact be C the band parameters for a matrix to which C df/dy is only approximately equal. C C LIW = the length of the array IWORK, as declared by the user. C (This will be checked by the solver.) C C Note: The work arrays must not be altered between calls to ZVODE C for the same problem, except possibly for the conditional and C optional input, and except for the last 2*NEQ words of ZWORK and C the last NEQ words of RWORK. The latter space is used for internal C scratch space, and so is available for use by the user outside ZVODE C between calls, if desired (but not for use by F or JAC). C C JAC = The name of the user-supplied routine (MITER = 1 or 4) to C compute the Jacobian matrix, df/dy, as a function of C the scalar t and the vector y. It is to have the form C SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD, C RPAR, IPAR) C DOUBLE COMPLEX Y(NEQ), PD(NROWPD,NEQ) C DOUBLE PRECISION T C where NEQ, T, Y, ML, MU, and NROWPD are input and the array C PD is to be loaded with partial derivatives (elements of the C Jacobian matrix) in the output. PD must be given a first C dimension of NROWPD. T and Y have the same meaning as in C Subroutine F. C In the full matrix case (MITER = 1), ML and MU are C ignored, and the Jacobian is to be loaded into PD in C columnwise manner, with df(i)/dy(j) loaded into PD(i,j). C In the band matrix case (MITER = 4), the elements C within the band are to be loaded into PD in columnwise C manner, with diagonal lines of df/dy loaded into the rows C of PD. Thus df(i)/dy(j) is to be loaded into PD(i-j+MU+1,j). C ML and MU are the half-bandwidth parameters. (See IWORK). C The locations in PD in the two triangular areas which C correspond to nonexistent matrix elements can be ignored C or loaded arbitrarily, as they are overwritten by ZVODE. C JAC need not provide df/dy exactly. A crude C approximation (possibly with a smaller bandwidth) will do. C In either case, PD is preset to zero by the solver, C so that only the nonzero elements need be loaded by JAC. C Each call to JAC is preceded by a call to F with the same C arguments NEQ, T, and Y. Thus to gain some efficiency, C intermediate quantities shared by both calculations may be C saved in a user COMMON block by F and not recomputed by JAC, C if desired. Also, JAC may alter the Y array, if desired. C JAC must be declared external in the calling program. C Subroutine JAC may access user-defined real/complex and C integer work arrays, RPAR and IPAR, whose dimensions are set C by the user in the calling program. C C MF = The method flag. Used only for input. The legal values of C MF are 10, 11, 12, 13, 14, 15, 20, 21, 22, 23, 24, 25, C -11, -12, -14, -15, -21, -22, -24, -25. C MF is a signed two-digit integer, MF = JSV*(10*METH + MITER). C JSV = SIGN(MF) indicates the Jacobian-saving strategy: C JSV = 1 means a copy of the Jacobian is saved for reuse C in the corrector iteration algorithm. C JSV = -1 means a copy of the Jacobian is not saved C (valid only for MITER = 1, 2, 4, or 5). C METH indicates the basic linear multistep method: C METH = 1 means the implicit Adams method. C METH = 2 means the method based on backward C differentiation formulas (BDF-s). C MITER indicates the corrector iteration method: C MITER = 0 means functional iteration (no Jacobian matrix C is involved). C MITER = 1 means chord iteration with a user-supplied C full (NEQ by NEQ) Jacobian. C MITER = 2 means chord iteration with an internally C generated (difference quotient) full Jacobian C (using NEQ extra calls to F per df/dy value). C MITER = 3 means chord iteration with an internally C generated diagonal Jacobian approximation C (using 1 extra call to F per df/dy evaluation). C MITER = 4 means chord iteration with a user-supplied C banded Jacobian. C MITER = 5 means chord iteration with an internally C generated banded Jacobian (using ML+MU+1 extra C calls to F per df/dy evaluation). C If MITER = 1 or 4, the user must supply a subroutine JAC C (the name is arbitrary) as described above under JAC. C For other values of MITER, a dummy argument can be used. C C RPAR User-specified array used to communicate real or complex C parameters to user-supplied subroutines. If RPAR is an C array, it must be dimensioned in the user's calling program; C if it is unused or it is a scalar, then it need not be C dimensioned. The type of RPAR may be REAL, DOUBLE, COMPLEX, C or DOUBLE COMPLEX, depending on the user program's needs. C RPAR is not type-declared within ZVODE, but simply passed C (by address) to the user's F and JAC routines. C C IPAR User-specified array used to communicate integer parameter C to user-supplied subroutines. If IPAR is an array, it must C be dimensioned in the user's calling program. C----------------------------------------------------------------------- C Optional Input. C C The following is a list of the optional input provided for in the C call sequence. (See also Part ii.) For each such input variable, C this table lists its name as used in this documentation, its C location in the call sequence, its meaning, and the default value. C The use of any of this input requires IOPT = 1, and in that C case all of this input is examined. A value of zero for any C of these optional input variables will cause the default value to be C used. Thus to use a subset of the optional input, simply preload C locations 5 to 10 in RWORK and IWORK to 0.0 and 0 respectively, and C then set those of interest to nonzero values. C C NAME LOCATION MEANING AND DEFAULT VALUE C C H0 RWORK(5) The step size to be attempted on the first step. C The default value is determined by the solver. C C HMAX RWORK(6) The maximum absolute step size allowed. C The default value is infinite. C C HMIN RWORK(7) The minimum absolute step size allowed. C The default value is 0. (This lower bound is not C enforced on the final step before reaching TCRIT C when ITASK = 4 or 5.) C C MAXORD IWORK(5) The maximum order to be allowed. The default C value is 12 if METH = 1, and 5 if METH = 2. C If MAXORD exceeds the default value, it will C be reduced to the default value. C If MAXORD is changed during the problem, it may C cause the current order to be reduced. C C MXSTEP IWORK(6) Maximum number of (internally defined) steps C allowed during one call to the solver. C The default value is 500. C C MXHNIL IWORK(7) Maximum number of messages printed (per problem) C warning that T + H = T on a step (H = step size). C This must be positive to result in a non-default C value. The default value is 10. C C----------------------------------------------------------------------- C Optional Output. C C As optional additional output from ZVODE, the variables listed C below are quantities related to the performance of ZVODE C which are available to the user. These are communicated by way of C the work arrays, but also have internal mnemonic names as shown. C Except where stated otherwise, all of this output is defined C on any successful return from ZVODE, and on any return with C ISTATE = -1, -2, -4, -5, or -6. On an illegal input return C (ISTATE = -3), they will be unchanged from their existing values C (if any), except possibly for TOLSF, LENZW, LENRW, and LENIW. C On any error return, output relevant to the error will be defined, C as noted below. C C NAME LOCATION MEANING C C HU RWORK(11) The step size in t last used (successfully). C C HCUR RWORK(12) The step size to be attempted on the next step. C C TCUR RWORK(13) The current value of the independent variable C which the solver has actually reached, i.e. the C current internal mesh point in t. In the output, C TCUR will always be at least as far from the C initial value of t as the current argument T, C but may be farther (if interpolation was done). C C TOLSF RWORK(14) A tolerance scale factor, greater than 1.0, C computed when a request for too much accuracy was C detected (ISTATE = -3 if detected at the start of C the problem, ISTATE = -2 otherwise). If ITOL is C left unaltered but RTOL and ATOL are uniformly C scaled up by a factor of TOLSF for the next call, C then the solver is deemed likely to succeed. C (The user may also ignore TOLSF and alter the C tolerance parameters in any other way appropriate.) C C NST IWORK(11) The number of steps taken for the problem so far. C C NFE IWORK(12) The number of f evaluations for the problem so far. C C NJE IWORK(13) The number of Jacobian evaluations so far. C C NQU IWORK(14) The method order last used (successfully). C C NQCUR IWORK(15) The order to be attempted on the next step. C C IMXER IWORK(16) The index of the component of largest magnitude in C the weighted local error vector ( e(i)/EWT(i) ), C on an error return with ISTATE = -4 or -5. C C LENZW IWORK(17) The length of ZWORK actually required. C This is defined on normal returns and on an illegal C input return for insufficient storage. C C LENRW IWORK(18) The length of RWORK actually required. C This is defined on normal returns and on an illegal C input return for insufficient storage. C C LENIW IWORK(19) The length of IWORK actually required. C This is defined on normal returns and on an illegal C input return for insufficient storage. C C NLU IWORK(20) The number of matrix LU decompositions so far. C C NNI IWORK(21) The number of nonlinear (Newton) iterations so far. C C NCFN IWORK(22) The number of convergence failures of the nonlinear C solver so far. C C NETF IWORK(23) The number of error test failures of the integrator C so far. C C The following two arrays are segments of the ZWORK array which C may also be of interest to the user as optional output. C For each array, the table below gives its internal name, C its base address in ZWORK, and its description. C C NAME BASE ADDRESS DESCRIPTION C C YH 1 The Nordsieck history array, of size NYH by C (NQCUR + 1), where NYH is the initial value C of NEQ. For j = 0,1,...,NQCUR, column j+1 C of YH contains HCUR**j/factorial(j) times C the j-th derivative of the interpolating C polynomial currently representing the C solution, evaluated at t = TCUR. C C ACOR LENZW-NEQ+1 Array of size NEQ used for the accumulated C corrections on each step, scaled in the output C to represent the estimated local error in Y C on the last step. This is the vector e in C the description of the error control. It is C defined only on a successful return from ZVODE. C C----------------------------------------------------------------------- C Interrupting and Restarting C C If the integration of a given problem by ZVODE is to be C interrrupted and then later continued, such as when restarting C an interrupted run or alternating between two or more ODE problems, C the user should save, following the return from the last ZVODE call C prior to the interruption, the contents of the call sequence C variables and internal COMMON blocks, and later restore these C values before the next ZVODE call for that problem. To save C and restore the COMMON blocks, use subroutine ZVSRCO, as C described below in part ii. C C In addition, if non-default values for either LUN or MFLAG are C desired, an extra call to XSETUN and/or XSETF should be made just C before continuing the integration. See Part ii below for details. C C----------------------------------------------------------------------- C Part ii. Other Routines Callable. C C The following are optional calls which the user may make to C gain additional capabilities in conjunction with ZVODE. C (The routines XSETUN and XSETF are designed to conform to the C SLATEC error handling package.) C C FORM OF CALL FUNCTION C CALL XSETUN(LUN) Set the logical unit number, LUN, for C output of messages from ZVODE, if C the default is not desired. C The default value of LUN is 6. C C CALL XSETF(MFLAG) Set a flag to control the printing of C messages by ZVODE. C MFLAG = 0 means do not print. (Danger: C This risks losing valuable information.) C MFLAG = 1 means print (the default). C C Either of the above calls may be made at C any time and will take effect immediately. C C CALL ZVSRCO(RSAV,ISAV,JOB) Saves and restores the contents of C the internal COMMON blocks used by C ZVODE. (See Part iii below.) C RSAV must be a real array of length 51 C or more, and ISAV must be an integer C array of length 40 or more. C JOB=1 means save COMMON into RSAV/ISAV. C JOB=2 means restore COMMON from RSAV/ISAV. C ZVSRCO is useful if one is C interrupting a run and restarting C later, or alternating between two or C more problems solved with ZVODE. C C CALL ZVINDY(,,,,,) Provide derivatives of y, of various C (See below.) orders, at a specified point T, if C desired. It may be called only after C a successful return from ZVODE. C C The detailed instructions for using ZVINDY are as follows. C The form of the call is: C C CALL ZVINDY (T, K, ZWORK, NYH, DKY, IFLAG) C C The input parameters are: C C T = Value of independent variable where answers are desired C (normally the same as the T last returned by ZVODE). C For valid results, T must lie between TCUR - HU and TCUR. C (See optional output for TCUR and HU.) C K = Integer order of the derivative desired. K must satisfy C 0 .le. K .le. NQCUR, where NQCUR is the current order C (see optional output). The capability corresponding C to K = 0, i.e. computing y(T), is already provided C by ZVODE directly. Since NQCUR .ge. 1, the first C derivative dy/dt is always available with ZVINDY. C ZWORK = The history array YH. C NYH = Column length of YH, equal to the initial value of NEQ. C C The output parameters are: C C DKY = A double complex array of length NEQ containing the C computed value of the K-th derivative of y(t). C IFLAG = Integer flag, returned as 0 if K and T were legal, C -1 if K was illegal, and -2 if T was illegal. C On an error return, a message is also written. C----------------------------------------------------------------------- C Part iii. COMMON Blocks. C If ZVODE is to be used in an overlay situation, the user C must declare, in the primary overlay, the variables in: C (1) the call sequence to ZVODE, C (2) the two internal COMMON blocks C /ZVOD01/ of length 83 (50 double precision words C followed by 33 integer words), C /ZVOD02/ of length 9 (1 double precision word C followed by 8 integer words), C C If ZVODE is used on a system in which the contents of internal C COMMON blocks are not preserved between calls, the user should C declare the above two COMMON blocks in his calling program to insure C that their contents are preserved. C C----------------------------------------------------------------------- C Part iv. Optionally Replaceable Solver Routines. C C Below are descriptions of two routines in the ZVODE package which C relate to the measurement of errors. Either routine can be C replaced by a user-supplied version, if desired. However, since such C a replacement may have a major impact on performance, it should be C done only when absolutely necessary, and only with great caution. C (Note: The means by which the package version of a routine is C superseded by the user's version may be system-dependent.) C C (a) ZEWSET. C The following subroutine is called just before each internal C integration step, and sets the array of error weights, EWT, as C described under ITOL/RTOL/ATOL above: C SUBROUTINE ZEWSET (NEQ, ITOL, RTOL, ATOL, YCUR, EWT) C where NEQ, ITOL, RTOL, and ATOL are as in the ZVODE call sequence, C YCUR contains the current (double complex) dependent variable vector, C and EWT is the array of weights set by ZEWSET. C C If the user supplies this subroutine, it must return in EWT(i) C (i = 1,...,NEQ) a positive quantity suitable for comparison with C errors in Y(i). The EWT array returned by ZEWSET is passed to the C ZVNORM routine (See below.), and also used by ZVODE in the computation C of the optional output IMXER, the diagonal Jacobian approximation, C and the increments for difference quotient Jacobians. C C In the user-supplied version of ZEWSET, it may be desirable to use C the current values of derivatives of y. Derivatives up to order NQ C are available from the history array YH, described above under C Optional Output. In ZEWSET, YH is identical to the YCUR array, C extended to NQ + 1 columns with a column length of NYH and scale C factors of h**j/factorial(j). On the first call for the problem, C given by NST = 0, NQ is 1 and H is temporarily set to 1.0. C NYH is the initial value of NEQ. The quantities NQ, H, and NST C can be obtained by including in ZEWSET the statements: C DOUBLE PRECISION RVOD, H, HU C COMMON /ZVOD01/ RVOD(50), IVOD(33) C COMMON /ZVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST C NQ = IVOD(28) C H = RVOD(21) C Thus, for example, the current value of dy/dt can be obtained as C YCUR(NYH+i)/H (i=1,...,NEQ) (and the division by H is C unnecessary when NST = 0). C C (b) ZVNORM. C The following is a real function routine which computes the weighted C root-mean-square norm of a vector v: C D = ZVNORM (N, V, W) C where: C N = the length of the vector, C V = double complex array of length N containing the vector, C W = real array of length N containing weights, C D = sqrt( (1/N) * sum(abs(V(i))*W(i))**2 ). C ZVNORM is called with N = NEQ and with W(i) = 1.0/EWT(i), where C EWT is as set by subroutine ZEWSET. C C If the user supplies this function, it should return a non-negative C value of ZVNORM suitable for use in the error control in ZVODE. C None of the arguments should be altered by ZVNORM. C For example, a user-supplied ZVNORM routine might: C -substitute a max-norm of (V(i)*W(i)) for the rms-norm, or C -ignore some components of V in the norm, with the effect of C suppressing the error control on those components of Y. C----------------------------------------------------------------------- C REVISION HISTORY (YYYYMMDD) C 20060517 DATE WRITTEN, modified from DVODE of 20020430. C 20061227 Added note on use for analytic f. C----------------------------------------------------------------------- C Other Routines in the ZVODE Package. C C In addition to Subroutine ZVODE, the ZVODE package includes the C following subroutines and function routines: C ZVHIN computes an approximate step size for the initial step. C ZVINDY computes an interpolated value of the y vector at t = TOUT. C ZVSTEP is the core integrator, which does one step of the C integration and the associated error control. C ZVSET sets all method coefficients and test constants. C ZVNLSD solves the underlying nonlinear system -- the corrector. C ZVJAC computes and preprocesses the Jacobian matrix J = df/dy C and the Newton iteration matrix P = I - (h/l1)*J. C ZVSOL manages solution of linear system in chord iteration. C ZVJUST adjusts the history array on a change of order. C ZEWSET sets the error weight vector EWT before each step. C ZVNORM computes the weighted r.m.s. norm of a vector. C ZABSSQ computes the squared absolute value of a double complex z. C ZVSRCO is a user-callable routine to save and restore C the contents of the internal COMMON blocks. C ZACOPY is a routine to copy one two-dimensional array to another. C ZGEFA and ZGESL are routines from LINPACK for solving full C systems of linear algebraic equations. C ZGBFA and ZGBSL are routines from LINPACK for solving banded C linear systems. C DZSCAL scales a double complex array by a double prec. scalar. C DZAXPY adds a D.P. scalar times one complex vector to another. C ZCOPY is a basic linear algebra module from the BLAS. C DUMACH sets the unit roundoff of the machine. C XERRWD, XSETUN, XSETF, IXSAV, and IUMACH handle the printing of all C error messages and warnings. XERRWD is machine-dependent. C Note: ZVNORM, ZABSSQ, DUMACH, IXSAV, and IUMACH are function routines. C All the others are subroutines. C The intrinsic functions called with double precision complex arguments C are: ABS, DREAL, and DIMAG. All of these are expected to return C double precision real values. C C----------------------------------------------------------------------- C C Type declarations for labeled COMMON block ZVOD01 -------------------- C DOUBLE PRECISION ACNRM, CCMXJ, CONP, CRATE, DRC, EL, 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HRL1, HSCAL, PRL1, 2 RC, RL1, SRUR, TAU, TQ, TN, UROUND INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, 1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, 2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, 3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, 4 NSLP, NYH C C Type declarations for labeled COMMON block ZVOD02 -------------------- C DOUBLE PRECISION HU INTEGER NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST C C Type declarations for local variables -------------------------------- C EXTERNAL ZVNLSD LOGICAL IHIT DOUBLE PRECISION ATOLI, BIG, EWTI, FOUR, H0, HMAX, HMX, HUN, ONE, 1 PT2, RH, RTOLI, SIZE, TCRIT, TNEXT, TOLSF, TP, TWO, ZERO INTEGER I, IER, IFLAG, IMXER, JCO, KGO, LENIW, LENJ, LENP, LENZW, 1 LENRW, LENWM, LF0, MBAND, MFA, ML, MORD, MU, MXHNL0, MXSTP0, 2 NITER, NSLAST CHARACTER(LEN=80) MSG C C Type declaration for function subroutines called --------------------- C DOUBLE PRECISION DUMACH, ZVNORM C DIMENSION MORD(2) C----------------------------------------------------------------------- C The following Fortran-77 declaration is to cause the values of the C listed (local) variables to be saved between calls to ZVODE. C----------------------------------------------------------------------- SAVE MORD, MXHNL0, MXSTP0 SAVE ZERO, ONE, TWO, FOUR, PT2, HUN C----------------------------------------------------------------------- C The following internal COMMON blocks contain variables which are C communicated between subroutines in the ZVODE package, or which are C to be saved between calls to ZVODE. C In each block, real variables precede integers. C The block /ZVOD01/ appears in subroutines ZVODE, ZVINDY, ZVSTEP, C ZVSET, ZVNLSD, ZVJAC, ZVSOL, ZVJUST and ZVSRCO. C The block /ZVOD02/ appears in subroutines ZVODE, ZVINDY, ZVSTEP, C ZVNLSD, ZVJAC, and ZVSRCO. C C The variables stored in the internal COMMON blocks are as follows: C C ACNRM = Weighted r.m.s. norm of accumulated correction vectors. C CCMXJ = Threshhold on DRC for updating the Jacobian. (See DRC.) C CONP = The saved value of TQ(5). C CRATE = Estimated corrector convergence rate constant. C DRC = Relative change in H*RL1 since last ZVJAC call. C EL = Real array of integration coefficients. See ZVSET. C ETA = Saved tentative ratio of new to old H. C ETAMAX = Saved maximum value of ETA to be allowed. C H = The step size. C HMIN = The minimum absolute value of the step size H to be used. C HMXI = Inverse of the maximum absolute value of H to be used. C HMXI = 0.0 is allowed and corresponds to an infinite HMAX. C HNEW = The step size to be attempted on the next step. C HRL1 = Saved value of H*RL1. C HSCAL = Stepsize in scaling of YH array. C PRL1 = The saved value of RL1. C RC = Ratio of current H*RL1 to value on last ZVJAC call. C RL1 = The reciprocal of the coefficient EL(1). C SRUR = Sqrt(UROUND), used in difference quotient algorithms. C TAU = Real vector of past NQ step sizes, length 13. C TQ = A real vector of length 5 in which ZVSET stores constants C used for the convergence test, the error test, and the C selection of H at a new order. C TN = The independent variable, updated on each step taken. C UROUND = The machine unit roundoff. The smallest positive real number C such that 1.0 + UROUND .ne. 1.0 C ICF = Integer flag for convergence failure in ZVNLSD: C 0 means no failures. C 1 means convergence failure with out of date Jacobian C (recoverable error). C 2 means convergence failure with current Jacobian or C singular matrix (unrecoverable error). C INIT = Saved integer flag indicating whether initialization of the C problem has been done (INIT = 1) or not. C IPUP = Saved flag to signal updating of Newton matrix. C JCUR = Output flag from ZVJAC showing Jacobian status: C JCUR = 0 means J is not current. C JCUR = 1 means J is current. C JSTART = Integer flag used as input to ZVSTEP: C 0 means perform the first step. C 1 means take a new step continuing from the last. C -1 means take the next step with a new value of MAXORD, C HMIN, HMXI, N, METH, MITER, and/or matrix parameters. C On return, ZVSTEP sets JSTART = 1. C JSV = Integer flag for Jacobian saving, = sign(MF). C KFLAG = A completion code from ZVSTEP with the following meanings: C 0 the step was succesful. C -1 the requested error could not be achieved. C -2 corrector convergence could not be achieved. C -3, -4 fatal error in VNLS (can not occur here). C KUTH = Input flag to ZVSTEP showing whether H was reduced by the C driver. KUTH = 1 if H was reduced, = 0 otherwise. C L = Integer variable, NQ + 1, current order plus one. C LMAX = MAXORD + 1 (used for dimensioning). C LOCJS = A pointer to the saved Jacobian, whose storage starts at C WM(LOCJS), if JSV = 1. C LYH, LEWT, LACOR, LSAVF, LWM, LIWM = Saved integer pointers C to segments of ZWORK, RWORK, and IWORK. C MAXORD = The maximum order of integration method to be allowed. C METH/MITER = The method flags. See MF. C MSBJ = The maximum number of steps between J evaluations, = 50. C MXHNIL = Saved value of optional input MXHNIL. C MXSTEP = Saved value of optional input MXSTEP. C N = The number of first-order ODEs, = NEQ. C NEWH = Saved integer to flag change of H. C NEWQ = The method order to be used on the next step. C NHNIL = Saved counter for occurrences of T + H = T. C NQ = Integer variable, the current integration method order. C NQNYH = Saved value of NQ*NYH. C NQWAIT = A counter controlling the frequency of order changes. C An order change is about to be considered if NQWAIT = 1. C NSLJ = The number of steps taken as of the last Jacobian update. C NSLP = Saved value of NST as of last Newton matrix update. C NYH = Saved value of the initial value of NEQ. C HU = The step size in t last used. C NCFN = Number of nonlinear convergence failures so far. C NETF = The number of error test failures of the integrator so far. C NFE = The number of f evaluations for the problem so far. C NJE = The number of Jacobian evaluations so far. C NLU = The number of matrix LU decompositions so far. C NNI = Number of nonlinear iterations so far. C NQU = The method order last used. C NST = The number of steps taken for the problem so far. C----------------------------------------------------------------------- COMMON /ZVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), ETA, 1 ETAMAX, H, HMIN, HMXI, HNEW, HRL1, HSCAL, PRL1, 2 RC, RL1, SRUR, TAU(13), TQ(5), TN, UROUND, 3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, 4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, 5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, 6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, 7 NSLP, NYH COMMON /ZVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST C DATA MORD(1) /12/, MORD(2) /5/, MXSTP0 /500/, MXHNL0 /10/ DATA ZERO /0.0D0/, ONE /1.0D0/, TWO /2.0D0/, FOUR /4.0D0/, 1 PT2 /0.2D0/, HUN /100.0D0/ C----------------------------------------------------------------------- C Block A. C This code block is executed on every call. C It tests ISTATE and ITASK for legality and branches appropriately. C If ISTATE .gt. 1 but the flag INIT shows that initialization has C not yet been done, an error return occurs. C If ISTATE = 1 and TOUT = T, return immediately. C----------------------------------------------------------------------- IF (ISTATE .LT. 1 .OR. ISTATE .GT. 3) GO TO 601 IF (ITASK .LT. 1 .OR. ITASK .GT. 5) GO TO 602 IF (ISTATE .EQ. 1) GO TO 10 IF (INIT .NE. 1) GO TO 603 IF (ISTATE .EQ. 2) GO TO 200 GO TO 20 10 INIT = 0 IF (TOUT .EQ. T) RETURN C----------------------------------------------------------------------- C Block B. C The next code block is executed for the initial call (ISTATE = 1), C or for a continuation call with parameter changes (ISTATE = 3). C It contains checking of all input and various initializations. C C First check legality of the non-optional input NEQ, ITOL, IOPT, C MF, ML, and MU. C----------------------------------------------------------------------- 20 IF (NEQ .LE. 0) GO TO 604 IF (ISTATE .EQ. 1) GO TO 25 IF (NEQ .GT. N) GO TO 605 25 N = NEQ IF (ITOL .LT. 1 .OR. ITOL .GT. 4) GO TO 606 IF (IOPT .LT. 0 .OR. IOPT .GT. 1) GO TO 607 JSV = SIGN(1,MF) MFA = ABS(MF) METH = MFA/10 MITER = MFA - 10*METH IF (METH .LT. 1 .OR. METH .GT. 2) GO TO 608 IF (MITER .LT. 0 .OR. MITER .GT. 5) GO TO 608 IF (MITER .LE. 3) GO TO 30 ML = IWORK(1) MU = IWORK(2) IF (ML .LT. 0 .OR. ML .GE. N) GO TO 609 IF (MU .LT. 0 .OR. MU .GE. N) GO TO 610 30 CONTINUE C Next process and check the optional input. --------------------------- IF (IOPT .EQ. 1) GO TO 40 MAXORD = MORD(METH) MXSTEP = MXSTP0 MXHNIL = MXHNL0 IF (ISTATE .EQ. 1) H0 = ZERO HMXI = ZERO HMIN = ZERO GO TO 60 40 MAXORD = IWORK(5) IF (MAXORD .LT. 0) GO TO 611 IF (MAXORD .EQ. 0) MAXORD = 100 MAXORD = MIN(MAXORD,MORD(METH)) MXSTEP = IWORK(6) IF (MXSTEP .LT. 0) GO TO 612 IF (MXSTEP .EQ. 0) MXSTEP = MXSTP0 MXHNIL = IWORK(7) IF (MXHNIL .LT. 0) GO TO 613 IF (MXHNIL .EQ. 0) MXHNIL = MXHNL0 IF (ISTATE .NE. 1) GO TO 50 H0 = RWORK(5) IF ((TOUT - T)*H0 .LT. ZERO) GO TO 614 50 HMAX = RWORK(6) IF (HMAX .LT. ZERO) GO TO 615 HMXI = ZERO IF (HMAX .GT. ZERO) HMXI = ONE/HMAX HMIN = RWORK(7) IF (HMIN .LT. ZERO) GO TO 616 C----------------------------------------------------------------------- C Set work array pointers and check lengths LZW, LRW, and LIW. C Pointers to segments of ZWORK, RWORK, and IWORK are named by prefixing C L to the name of the segment. E.g., segment YH starts at ZWORK(LYH). C Segments of ZWORK (in order) are denoted YH, WM, SAVF, ACOR. C Besides optional inputs/outputs, RWORK has only the segment EWT. C Within WM, LOCJS is the location of the saved Jacobian (JSV .gt. 0). C----------------------------------------------------------------------- 60 LYH = 1 IF (ISTATE .EQ. 1) NYH = N LWM = LYH + (MAXORD + 1)*NYH JCO = MAX(0,JSV) IF (MITER .EQ. 0) LENWM = 0 IF (MITER .EQ. 1 .OR. MITER .EQ. 2) THEN LENWM = (1 + JCO)*N*N LOCJS = N*N + 1 ENDIF IF (MITER .EQ. 3) LENWM = N IF (MITER .EQ. 4 .OR. MITER .EQ. 5) THEN MBAND = ML + MU + 1 LENP = (MBAND + ML)*N LENJ = MBAND*N LENWM = LENP + JCO*LENJ LOCJS = LENP + 1 ENDIF LSAVF = LWM + LENWM LACOR = LSAVF + N LENZW = LACOR + N - 1 IWORK(17) = LENZW LEWT = 21 LENRW = 20 + N IWORK(18) = LENRW LIWM = 1 LENIW = 30 + N IF (MITER .EQ. 0 .OR. MITER .EQ. 3) LENIW = 30 IWORK(19) = LENIW IF (LENZW .GT. LZW) GO TO 628 IF (LENRW .GT. LRW) GO TO 617 IF (LENIW .GT. LIW) GO TO 618 C Check RTOL and ATOL for legality. ------------------------------------ RTOLI = RTOL(1) ATOLI = ATOL(1) DO 70 I = 1,N IF (ITOL .GE. 3) RTOLI = RTOL(I) IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) IF (RTOLI .LT. ZERO) GO TO 619 IF (ATOLI .LT. ZERO) GO TO 620 70 CONTINUE IF (ISTATE .EQ. 1) GO TO 100 C If ISTATE = 3, set flag to signal parameter changes to ZVSTEP. ------- JSTART = -1 IF (NQ .LE. MAXORD) GO TO 200 C MAXORD was reduced below NQ. Copy YH(*,MAXORD+2) into SAVF. --------- CALL ZCOPY (N, ZWORK(LWM), 1, ZWORK(LSAVF), 1) GO TO 200 C----------------------------------------------------------------------- C Block C. C The next block is for the initial call only (ISTATE = 1). C It contains all remaining initializations, the initial call to F, C and the calculation of the initial step size. C The error weights in EWT are inverted after being loaded. C----------------------------------------------------------------------- 100 UROUND = DUMACH() TN = T IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 110 TCRIT = RWORK(1) IF ((TCRIT - TOUT)*(TOUT - T) .LT. ZERO) GO TO 625 IF (H0 .NE. ZERO .AND. (T + H0 - TCRIT)*H0 .GT. ZERO) 1 H0 = TCRIT - T 110 JSTART = 0 IF (MITER .GT. 0) SRUR = SQRT(UROUND) CCMXJ = PT2 MSBJ = 50 NHNIL = 0 NST = 0 NJE = 0 NNI = 0 NCFN = 0 NETF = 0 NLU = 0 NSLJ = 0 NSLAST = 0 HU = ZERO NQU = 0 C Initial call to F. (LF0 points to YH(*,2).) ------------------------- LF0 = LYH + NYH CALL F (N, T, Y, ZWORK(LF0), RPAR, IPAR) NFE = 1 C Load the initial value vector in YH. --------------------------------- CALL ZCOPY (N, Y, 1, ZWORK(LYH), 1) C Load and invert the EWT array. (H is temporarily set to 1.0.) ------- NQ = 1 H = ONE CALL ZEWSET (N, ITOL, RTOL, ATOL, ZWORK(LYH), RWORK(LEWT)) DO 120 I = 1,N IF (RWORK(I+LEWT-1) .LE. ZERO) GO TO 621 RWORK(I+LEWT-1) = ONE/RWORK(I+LEWT-1) 120 CONTINUE IF (H0 .NE. ZERO) GO TO 180 C Call ZVHIN to set initial step size H0 to be attempted. -------------- CALL ZVHIN (N, T, ZWORK(LYH), ZWORK(LF0), F, RPAR, IPAR, TOUT, 1 UROUND, RWORK(LEWT), ITOL, ATOL, Y, ZWORK(LACOR), H0, 2 NITER, IER) NFE = NFE + NITER IF (IER .NE. 0) GO TO 622 C Adjust H0 if necessary to meet HMAX bound. --------------------------- 180 RH = ABS(H0)*HMXI IF (RH .GT. ONE) H0 = H0/RH C Load H with H0 and scale YH(*,2) by H0. ------------------------------ H = H0 CALL DZSCAL (N, H0, ZWORK(LF0), 1) GO TO 270 C----------------------------------------------------------------------- C Block D. C The next code block is for continuation calls only (ISTATE = 2 or 3) C and is to check stop conditions before taking a step. C----------------------------------------------------------------------- 200 NSLAST = NST KUTH = 0 IF (ITASK .EQ. 1) THEN GOTO 210 ELSE IF (ITASK .EQ. 2) THEN GOTO 250 ELSE IF (ITASK .EQ. 3) THEN GOTO 220 ELSE IF (ITASK .EQ. 4) THEN GOTO 230 ELSE IF (ITASK .EQ. 5) THEN GOTO 240 ENDIF C GO TO (210, 250, 220, 230, 240), ITASK 210 IF ((TN - TOUT)*H .LT. ZERO) GO TO 250 CALL ZVINDY (TOUT, 0, ZWORK(LYH), NYH, Y, IFLAG) IF (IFLAG .NE. 0) GO TO 627 T = TOUT GO TO 420 220 TP = TN - HU*(ONE + HUN*UROUND) IF ((TP - TOUT)*H .GT. ZERO) GO TO 623 IF ((TN - TOUT)*H .LT. ZERO) GO TO 250 GO TO 400 230 TCRIT = RWORK(1) IF ((TN - TCRIT)*H .GT. ZERO) GO TO 624 IF ((TCRIT - TOUT)*H .LT. ZERO) GO TO 625 IF ((TN - TOUT)*H .LT. ZERO) GO TO 245 CALL ZVINDY (TOUT, 0, ZWORK(LYH), NYH, Y, IFLAG) IF (IFLAG .NE. 0) GO TO 627 T = TOUT GO TO 420 240 TCRIT = RWORK(1) IF ((TN - TCRIT)*H .GT. ZERO) GO TO 624 245 HMX = ABS(TN) + ABS(H) IHIT = ABS(TN - TCRIT) .LE. HUN*UROUND*HMX IF (IHIT) GO TO 400 TNEXT = TN + HNEW*(ONE + FOUR*UROUND) IF ((TNEXT - TCRIT)*H .LE. ZERO) GO TO 250 H = (TCRIT - TN)*(ONE - FOUR*UROUND) KUTH = 1 C----------------------------------------------------------------------- C Block E. C The next block is normally executed for all calls and contains C the call to the one-step core integrator ZVSTEP. C C This is a looping point for the integration steps. C C First check for too many steps being taken, update EWT (if not at C start of problem), check for too much accuracy being requested, and C check for H below the roundoff level in T. C----------------------------------------------------------------------- 250 CONTINUE IF ((NST-NSLAST) .GE. MXSTEP) GO TO 500 CALL ZEWSET (N, ITOL, RTOL, ATOL, ZWORK(LYH), RWORK(LEWT)) DO 260 I = 1,N IF (RWORK(I+LEWT-1) .LE. ZERO) GO TO 510 RWORK(I+LEWT-1) = ONE/RWORK(I+LEWT-1) 260 CONTINUE 270 TOLSF = UROUND*ZVNORM (N, ZWORK(LYH), RWORK(LEWT)) IF (TOLSF .LE. ONE) GO TO 280 TOLSF = TOLSF*TWO IF (NST .EQ. 0) GO TO 626 GO TO 520 280 IF ((TN + H) .NE. TN) GO TO 290 NHNIL = NHNIL + 1 IF (NHNIL .GT. MXHNIL) GO TO 290 MSG = 'ZVODE-- Warning: internal T (=R1) and H (=R2) are' CALL XERRWD (MSG, 50, 101, 1, 0, 0, 0, 0, ZERO, ZERO) MSG=' such that in the machine, T + H = T on the next step ' CALL XERRWD (MSG, 60, 101, 1, 0, 0, 0, 0, ZERO, ZERO) MSG = ' (H = step size). solver will continue anyway' CALL XERRWD (MSG, 50, 101, 1, 0, 0, 0, 2, TN, H) IF (NHNIL .LT. MXHNIL) GO TO 290 MSG = 'ZVODE-- Above warning has been issued I1 times. ' CALL XERRWD (MSG, 50, 102, 1, 0, 0, 0, 0, ZERO, ZERO) MSG = ' it will not be issued again for this problem' CALL XERRWD (MSG, 50, 102, 1, 1, MXHNIL, 0, 0, ZERO, ZERO) 290 CONTINUE C----------------------------------------------------------------------- C CALL ZVSTEP (Y, YH, NYH, YH, EWT, SAVF, VSAV, ACOR, C WM, IWM, F, JAC, F, ZVNLSD, RPAR, IPAR) C----------------------------------------------------------------------- CALL ZVSTEP (Y, ZWORK(LYH), NYH, ZWORK(LYH), RWORK(LEWT), 1 ZWORK(LSAVF), Y, ZWORK(LACOR), ZWORK(LWM), IWORK(LIWM), 2 F, JAC, F, ZVNLSD, RPAR, IPAR) KGO = 1 - KFLAG C Branch on KFLAG. Note: In this version, KFLAG can not be set to -3. C KFLAG .eq. 0, -1, -2 IF (KGO .EQ. 1) THEN GOTO 300 ELSE IF (KGO .EQ. 2) THEN GOTO 530 ELSE IF (KGO .EQ. 3) THEN GOTO 540 ENDIF C GO TO (300, 530, 540), KGO C----------------------------------------------------------------------- C Block F. C The following block handles the case of a successful return from the C core integrator (KFLAG = 0). Test for stop conditions. C----------------------------------------------------------------------- 300 INIT = 1 KUTH = 0 IF (ITASK .EQ. 1) THEN GOTO 310 ELSE IF (ITASK .EQ. 2) THEN GOTO 400 ELSE IF (ITASK .EQ. 3) THEN GOTO 330 ELSE IF (ITASK .EQ. 4) THEN GOTO 340 ELSE IF (ITASK .EQ. 5) THEN GOTO 350 ENDIF C GO TO (310, 400, 330, 340, 350), ITASK C ITASK = 1. If TOUT has been reached, interpolate. ------------------- 310 IF ((TN - TOUT)*H .LT. ZERO) GO TO 250 CALL ZVINDY (TOUT, 0, ZWORK(LYH), NYH, Y, IFLAG) T = TOUT GO TO 420 C ITASK = 3. Jump to exit if TOUT was reached. ------------------------ 330 IF ((TN - TOUT)*H .GE. ZERO) GO TO 400 GO TO 250 C ITASK = 4. See if TOUT or TCRIT was reached. Adjust H if necessary. 340 IF ((TN - TOUT)*H .LT. ZERO) GO TO 345 CALL ZVINDY (TOUT, 0, ZWORK(LYH), NYH, Y, IFLAG) T = TOUT GO TO 420 345 HMX = ABS(TN) + ABS(H) IHIT = ABS(TN - TCRIT) .LE. HUN*UROUND*HMX IF (IHIT) GO TO 400 TNEXT = TN + HNEW*(ONE + FOUR*UROUND) IF ((TNEXT - TCRIT)*H .LE. ZERO) GO TO 250 H = (TCRIT - TN)*(ONE - FOUR*UROUND) KUTH = 1 GO TO 250 C ITASK = 5. See if TCRIT was reached and jump to exit. --------------- 350 HMX = ABS(TN) + ABS(H) IHIT = ABS(TN - TCRIT) .LE. HUN*UROUND*HMX C----------------------------------------------------------------------- C Block G. C The following block handles all successful returns from ZVODE. C If ITASK .ne. 1, Y is loaded from YH and T is set accordingly. C ISTATE is set to 2, and the optional output is loaded into the work C arrays before returning. C----------------------------------------------------------------------- 400 CONTINUE CALL ZCOPY (N, ZWORK(LYH), 1, Y, 1) T = TN IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 420 IF (IHIT) T = TCRIT 420 ISTATE = 2 RWORK(11) = HU RWORK(12) = HNEW RWORK(13) = TN IWORK(11) = NST IWORK(12) = NFE IWORK(13) = NJE IWORK(14) = NQU IWORK(15) = NEWQ IWORK(20) = NLU IWORK(21) = NNI IWORK(22) = NCFN IWORK(23) = NETF RETURN C----------------------------------------------------------------------- C Block H. C The following block handles all unsuccessful returns other than C those for illegal input. First the error message routine is called. C if there was an error test or convergence test failure, IMXER is set. C Then Y is loaded from YH, and T is set to TN. C The optional output is loaded into the work arrays before returning. C----------------------------------------------------------------------- C The maximum number of steps was taken before reaching TOUT. ---------- 500 MSG = 'ZVODE-- At current T (=R1), MXSTEP (=I1) steps ' CALL XERRWD (MSG, 50, 201, 1, 0, 0, 0, 0, ZERO, ZERO) MSG = ' taken on this call before reaching TOUT ' CALL XERRWD (MSG, 50, 201, 1, 1, MXSTEP, 0, 1, TN, ZERO) ISTATE = -1 GO TO 580 C EWT(i) .le. 0.0 for some i (not at start of problem). ---------------- 510 EWTI = RWORK(LEWT+I-1) MSG = 'ZVODE-- At T (=R1), EWT(I1) has become R2 .le. 0.' CALL XERRWD (MSG, 50, 202, 1, 1, I, 0, 2, TN, EWTI) ISTATE = -6 GO TO 580 C Too much accuracy requested for machine precision. ------------------- 520 MSG = 'ZVODE-- At T (=R1), too much accuracy requested ' CALL XERRWD (MSG, 50, 203, 1, 0, 0, 0, 0, ZERO, ZERO) MSG = ' for precision of machine: see TOLSF (=R2) ' CALL XERRWD (MSG, 50, 203, 1, 0, 0, 0, 2, TN, TOLSF) RWORK(14) = TOLSF ISTATE = -2 GO TO 580 C KFLAG = -1. Error test failed repeatedly or with ABS(H) = HMIN. ----- 530 MSG = 'ZVODE-- At T(=R1) and step size H(=R2), the error' CALL XERRWD (MSG, 50, 204, 1, 0, 0, 0, 0, ZERO, ZERO) MSG = ' test failed repeatedly or with abs(H) = HMIN' CALL XERRWD (MSG, 50, 204, 1, 0, 0, 0, 2, TN, H) ISTATE = -4 GO TO 560 C KFLAG = -2. Convergence failed repeatedly or with ABS(H) = HMIN. ---- 540 MSG = 'ZVODE-- At T (=R1) and step size H (=R2), the ' CALL XERRWD (MSG, 50, 205, 1, 0, 0, 0, 0, ZERO, ZERO) MSG = ' corrector convergence failed repeatedly ' CALL XERRWD (MSG, 50, 205, 1, 0, 0, 0, 0, ZERO, ZERO) MSG = ' or with abs(H) = HMIN ' CALL XERRWD (MSG, 30, 205, 1, 0, 0, 0, 2, TN, H) ISTATE = -5 C Compute IMXER if relevant. ------------------------------------------- 560 BIG = ZERO IMXER = 1 DO 570 I = 1,N SIZE = ABS(ZWORK(I+LACOR-1))*RWORK(I+LEWT-1) IF (BIG .GE. SIZE) GO TO 570 BIG = SIZE IMXER = I 570 CONTINUE IWORK(16) = IMXER C Set Y vector, T, and optional output. -------------------------------- 580 CONTINUE CALL ZCOPY (N, ZWORK(LYH), 1, Y, 1) T = TN RWORK(11) = HU RWORK(12) = H RWORK(13) = TN IWORK(11) = NST IWORK(12) = NFE IWORK(13) = NJE IWORK(14) = NQU IWORK(15) = NQ IWORK(20) = NLU IWORK(21) = NNI IWORK(22) = NCFN IWORK(23) = NETF RETURN C----------------------------------------------------------------------- C Block I. C The following block handles all error returns due to illegal input C (ISTATE = -3), as detected before calling the core integrator. C First the error message routine is called. If the illegal input C is a negative ISTATE, the run is aborted (apparent infinite loop). C----------------------------------------------------------------------- 601 MSG = 'ZVODE-- ISTATE (=I1) illegal ' CALL XERRWD (MSG, 30, 1, 1, 1, ISTATE, 0, 0, ZERO, ZERO) IF (ISTATE .LT. 0) GO TO 800 GO TO 700 602 MSG = 'ZVODE-- ITASK (=I1) illegal ' CALL XERRWD (MSG, 30, 2, 1, 1, ITASK, 0, 0, ZERO, ZERO) GO TO 700 603 MSG='ZVODE-- ISTATE (=I1) .gt. 1 but ZVODE not initialized ' CALL XERRWD (MSG, 60, 3, 1, 1, ISTATE, 0, 0, ZERO, ZERO) GO TO 700 604 MSG = 'ZVODE-- NEQ (=I1) .lt. 1 ' CALL XERRWD (MSG, 30, 4, 1, 1, NEQ, 0, 0, ZERO, ZERO) GO TO 700 605 MSG = 'ZVODE-- ISTATE = 3 and NEQ increased (I1 to I2) ' CALL XERRWD (MSG, 50, 5, 1, 2, N, NEQ, 0, ZERO, ZERO) GO TO 700 606 MSG = 'ZVODE-- ITOL (=I1) illegal ' CALL XERRWD (MSG, 30, 6, 1, 1, ITOL, 0, 0, ZERO, ZERO) GO TO 700 607 MSG = 'ZVODE-- IOPT (=I1) illegal ' CALL XERRWD (MSG, 30, 7, 1, 1, IOPT, 0, 0, ZERO, ZERO) GO TO 700 608 MSG = 'ZVODE-- MF (=I1) illegal ' CALL XERRWD (MSG, 30, 8, 1, 1, MF, 0, 0, ZERO, ZERO) GO TO 700 609 MSG = 'ZVODE-- ML (=I1) illegal: .lt.0 or .ge.NEQ (=I2)' CALL XERRWD (MSG, 50, 9, 1, 2, ML, NEQ, 0, ZERO, ZERO) GO TO 700 610 MSG = 'ZVODE-- MU (=I1) illegal: .lt.0 or .ge.NEQ (=I2)' CALL XERRWD (MSG, 50, 10, 1, 2, MU, NEQ, 0, ZERO, ZERO) GO TO 700 611 MSG = 'ZVODE-- MAXORD (=I1) .lt. 0 ' CALL XERRWD (MSG, 30, 11, 1, 1, MAXORD, 0, 0, ZERO, ZERO) GO TO 700 612 MSG = 'ZVODE-- MXSTEP (=I1) .lt. 0 ' CALL XERRWD (MSG, 30, 12, 1, 1, MXSTEP, 0, 0, ZERO, ZERO) GO TO 700 613 MSG = 'ZVODE-- MXHNIL (=I1) .lt. 0 ' CALL XERRWD (MSG, 30, 13, 1, 1, MXHNIL, 0, 0, ZERO, ZERO) GO TO 700 614 MSG = 'ZVODE-- TOUT (=R1) behind T (=R2) ' CALL XERRWD (MSG, 40, 14, 1, 0, 0, 0, 2, TOUT, T) MSG = ' integration direction is given by H0 (=R1) ' CALL XERRWD (MSG, 50, 14, 1, 0, 0, 0, 1, H0, ZERO) GO TO 700 615 MSG = 'ZVODE-- HMAX (=R1) .lt. 0.0 ' CALL XERRWD (MSG, 30, 15, 1, 0, 0, 0, 1, HMAX, ZERO) GO TO 700 616 MSG = 'ZVODE-- HMIN (=R1) .lt. 0.0 ' CALL XERRWD (MSG, 30, 16, 1, 0, 0, 0, 1, HMIN, ZERO) GO TO 700 617 CONTINUE MSG='ZVODE-- RWORK length needed, LENRW (=I1), exceeds LRW (=I2)' CALL XERRWD (MSG, 60, 17, 1, 2, LENRW, LRW, 0, ZERO, ZERO) GO TO 700 618 CONTINUE MSG='ZVODE-- IWORK length needed, LENIW (=I1), exceeds LIW (=I2)' CALL XERRWD (MSG, 60, 18, 1, 2, LENIW, LIW, 0, ZERO, ZERO) GO TO 700 619 MSG = 'ZVODE-- RTOL(I1) is R1 .lt. 0.0 ' CALL XERRWD (MSG, 40, 19, 1, 1, I, 0, 1, RTOLI, ZERO) GO TO 700 620 MSG = 'ZVODE-- ATOL(I1) is R1 .lt. 0.0 ' CALL XERRWD (MSG, 40, 20, 1, 1, I, 0, 1, ATOLI, ZERO) GO TO 700 621 EWTI = RWORK(LEWT+I-1) MSG = 'ZVODE-- EWT(I1) is R1 .le. 0.0 ' CALL XERRWD (MSG, 40, 21, 1, 1, I, 0, 1, EWTI, ZERO) GO TO 700 622 CONTINUE MSG='ZVODE-- TOUT (=R1) too close to T(=R2) to start integration' CALL XERRWD (MSG, 60, 22, 1, 0, 0, 0, 2, TOUT, T) GO TO 700 623 CONTINUE MSG='ZVODE-- ITASK = I1 and TOUT (=R1) behind TCUR - HU (= R2) ' CALL XERRWD (MSG, 60, 23, 1, 1, ITASK, 0, 2, TOUT, TP) GO TO 700 624 CONTINUE MSG='ZVODE-- ITASK = 4 or 5 and TCRIT (=R1) behind TCUR (=R2) ' CALL XERRWD (MSG, 60, 24, 1, 0, 0, 0, 2, TCRIT, TN) GO TO 700 625 CONTINUE MSG='ZVODE-- ITASK = 4 or 5 and TCRIT (=R1) behind TOUT (=R2) ' CALL XERRWD (MSG, 60, 25, 1, 0, 0, 0, 2, TCRIT, TOUT) GO TO 700 626 MSG = 'ZVODE-- At start of problem, too much accuracy ' CALL XERRWD (MSG, 50, 26, 1, 0, 0, 0, 0, ZERO, ZERO) MSG=' requested for precision of machine: see TOLSF (=R1) ' CALL XERRWD (MSG, 60, 26, 1, 0, 0, 0, 1, TOLSF, ZERO) RWORK(14) = TOLSF GO TO 700 627 MSG='ZVODE-- Trouble from ZVINDY. ITASK = I1, TOUT = R1. ' CALL XERRWD (MSG, 60, 27, 1, 1, ITASK, 0, 1, TOUT, ZERO) GO TO 700 628 CONTINUE MSG='ZVODE-- ZWORK length needed, LENZW (=I1), exceeds LZW (=I2)' CALL XERRWD (MSG, 60, 17, 1, 2, LENZW, LZW, 0, ZERO, ZERO) C 700 CONTINUE ISTATE = -3 RETURN C 800 MSG = 'ZVODE-- Run aborted: apparent infinite loop ' CALL XERRWD (MSG, 50, 303, 2, 0, 0, 0, 0, ZERO, ZERO) RETURN C----------------------- End of Subroutine ZVODE ----------------------- END *DECK ZVHIN SUBROUTINE ZVHIN (N, T0, Y0, YDOT, F, RPAR, IPAR, TOUT, UROUND, 1 EWT, ITOL, ATOL, Y, TEMP, H0, NITER, IER) EXTERNAL F COMPLEX(KIND=8) Y0, YDOT, Y, TEMP DOUBLE PRECISION T0, TOUT, UROUND, EWT, ATOL, H0 INTEGER N, IPAR, ITOL, NITER, IER DIMENSION Y0(*), YDOT(*), EWT(*), ATOL(*), Y(*), 1 TEMP(*), RPAR(*), IPAR(*) C----------------------------------------------------------------------- C Call sequence input -- N, T0, Y0, YDOT, F, RPAR, IPAR, TOUT, UROUND, C EWT, ITOL, ATOL, Y, TEMP C Call sequence output -- H0, NITER, IER C COMMON block variables accessed -- None C C Subroutines called by ZVHIN: F C Function routines called by ZVHIN: ZVNORM C----------------------------------------------------------------------- C This routine computes the step size, H0, to be attempted on the C first step, when the user has not supplied a value for this. C C First we check that TOUT - T0 differs significantly from zero. Then C an iteration is done to approximate the initial second derivative C and this is used to define h from w.r.m.s.norm(h**2 * yddot / 2) = 1. C A bias factor of 1/2 is applied to the resulting h. C The sign of H0 is inferred from the initial values of TOUT and T0. C C Communication with ZVHIN is done with the following variables: C C N = Size of ODE system, input. C T0 = Initial value of independent variable, input. C Y0 = Vector of initial conditions, input. C YDOT = Vector of initial first derivatives, input. C F = Name of subroutine for right-hand side f(t,y), input. C RPAR, IPAR = User's real/complex and integer work arrays. C TOUT = First output value of independent variable C UROUND = Machine unit roundoff C EWT, ITOL, ATOL = Error weights and tolerance parameters C as described in the driver routine, input. C Y, TEMP = Work arrays of length N. C H0 = Step size to be attempted, output. C NITER = Number of iterations (and of f evaluations) to compute H0, C output. C IER = The error flag, returned with the value C IER = 0 if no trouble occurred, or C IER = -1 if TOUT and T0 are considered too close to proceed. C----------------------------------------------------------------------- C C Type declarations for local variables -------------------------------- C DOUBLE PRECISION AFI, ATOLI, DELYI, H, HALF, HG, HLB, HNEW, HRAT, 1 HUB, HUN, PT1, T1, TDIST, TROUND, TWO, YDDNRM INTEGER I, ITER C C Type declaration for function subroutines called --------------------- C DOUBLE PRECISION ZVNORM C----------------------------------------------------------------------- C The following Fortran-77 declaration is to cause the values of the C listed (local) variables to be saved between calls to this integrator. C----------------------------------------------------------------------- SAVE HALF, HUN, PT1, TWO DATA HALF /0.5D0/, HUN /100.0D0/, PT1 /0.1D0/, TWO /2.0D0/ C NITER = 0 TDIST = ABS(TOUT - T0) TROUND = UROUND*MAX(ABS(T0),ABS(TOUT)) IF (TDIST .LT. TWO*TROUND) GO TO 100 C C Set a lower bound on h based on the roundoff level in T0 and TOUT. --- HLB = HUN*TROUND C Set an upper bound on h based on TOUT-T0 and the initial Y and YDOT. - HUB = PT1*TDIST ATOLI = ATOL(1) DO 10 I = 1, N IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) DELYI = PT1*ABS(Y0(I)) + ATOLI AFI = ABS(YDOT(I)) IF (AFI*HUB .GT. DELYI) HUB = DELYI/AFI 10 CONTINUE C C Set initial guess for h as geometric mean of upper and lower bounds. - ITER = 0 HG = SQRT(HLB*HUB) C If the bounds have crossed, exit with the mean value. ---------------- IF (HUB .LT. HLB) THEN H0 = HG GO TO 90 ENDIF C C Looping point for iteration. ----------------------------------------- 50 CONTINUE C Estimate the second derivative as a difference quotient in f. -------- H = SIGN (HG, TOUT - T0) T1 = T0 + H DO 60 I = 1, N Y(I) = Y0(I) + H*YDOT(I) 60 CONTINUE CALL F (N, T1, Y, TEMP, RPAR, IPAR) DO 70 I = 1, N TEMP(I) = (TEMP(I) - YDOT(I))/H 70 CONTINUE YDDNRM = ZVNORM (N, TEMP, EWT) C Get the corresponding new value of h. -------------------------------- IF (YDDNRM*HUB*HUB .GT. TWO) THEN HNEW = SQRT(TWO/YDDNRM) ELSE HNEW = SQRT(HG*HUB) ENDIF ITER = ITER + 1 C----------------------------------------------------------------------- C Test the stopping conditions. C Stop if the new and previous h values differ by a factor of .lt. 2. C Stop if four iterations have been done. Also, stop with previous h C if HNEW/HG .gt. 2 after first iteration, as this probably means that C the second derivative value is bad because of cancellation error. C----------------------------------------------------------------------- IF (ITER .GE. 4) GO TO 80 HRAT = HNEW/HG IF ( (HRAT .GT. HALF) .AND. (HRAT .LT. TWO) ) GO TO 80 IF ( (ITER .GE. 2) .AND. (HNEW .GT. TWO*HG) ) THEN HNEW = HG GO TO 80 ENDIF HG = HNEW GO TO 50 C C Iteration done. Apply bounds, bias factor, and sign. Then exit. ---- 80 H0 = HNEW*HALF IF (H0 .LT. HLB) H0 = HLB IF (H0 .GT. HUB) H0 = HUB 90 H0 = SIGN(H0, TOUT - T0) NITER = ITER IER = 0 RETURN C Error return for TOUT - T0 too small. -------------------------------- 100 IER = -1 RETURN C----------------------- End of Subroutine ZVHIN ----------------------- END *DECK ZVINDY SUBROUTINE ZVINDY (T, K, YH, LDYH, DKY, IFLAG) COMPLEX(KIND=8) YH, DKY DOUBLE PRECISION T INTEGER K, LDYH, IFLAG DIMENSION YH(LDYH,*), DKY(*) C----------------------------------------------------------------------- C Call sequence input -- T, K, YH, LDYH C Call sequence output -- DKY, IFLAG C COMMON block variables accessed: C /ZVOD01/ -- H, TN, UROUND, L, N, NQ C /ZVOD02/ -- HU C C Subroutines called by ZVINDY: DZSCAL, XERRWD C Function routines called by ZVINDY: None C----------------------------------------------------------------------- C ZVINDY computes interpolated values of the K-th derivative of the C dependent variable vector y, and stores it in DKY. This routine C is called within the package with K = 0 and T = TOUT, but may C also be called by the user for any K up to the current order. C (See detailed instructions in the usage documentation.) C----------------------------------------------------------------------- C The computed values in DKY are gotten by interpolation using the C Nordsieck history array YH. This array corresponds uniquely to a C vector-valued polynomial of degree NQCUR or less, and DKY is set C to the K-th derivative of this polynomial at T. C The formula for DKY is: C q C DKY(i) = sum c(j,K) * (T - TN)**(j-K) * H**(-j) * YH(i,j+1) C j=K C where c(j,K) = j*(j-1)*...*(j-K+1), q = NQCUR, TN = TCUR, H = HCUR. C The quantities NQ = NQCUR, L = NQ+1, N, TN, and H are C communicated by COMMON. The above sum is done in reverse order. C IFLAG is returned negative if either K or T is out of bounds. C C Discussion above and comments in driver explain all variables. C----------------------------------------------------------------------- C C Type declarations for labeled COMMON block ZVOD01 -------------------- C DOUBLE PRECISION ACNRM, CCMXJ, CONP, CRATE, DRC, EL, 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HRL1, HSCAL, PRL1, 2 RC, RL1, SRUR, TAU, TQ, TN, UROUND INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, 1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, 2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, 3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, 4 NSLP, NYH C C Type declarations for labeled COMMON block ZVOD02 -------------------- C DOUBLE PRECISION HU INTEGER NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST C C Type declarations for local variables -------------------------------- C DOUBLE PRECISION C, HUN, R, S, TFUZZ, TN1, TP, ZERO INTEGER I, IC, J, JB, JB2, JJ, JJ1, JP1 CHARACTER(LEN=80) MSG C----------------------------------------------------------------------- C The following Fortran-77 declaration is to cause the values of the C listed (local) variables to be saved between calls to this integrator. C----------------------------------------------------------------------- SAVE HUN, ZERO C COMMON /ZVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), ETA, 1 ETAMAX, H, HMIN, HMXI, HNEW, HRL1, HSCAL, PRL1, 2 RC, RL1, SRUR, TAU(13), TQ(5), TN, UROUND, 3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, 4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, 5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, 6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, 7 NSLP, NYH COMMON /ZVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST C DATA HUN /100.0D0/, ZERO /0.0D0/ C IFLAG = 0 IF (K .LT. 0 .OR. K .GT. NQ) GO TO 80 TFUZZ = HUN*UROUND*SIGN(ABS(TN) + ABS(HU), HU) TP = TN - HU - TFUZZ TN1 = TN + TFUZZ IF ((T-TP)*(T-TN1) .GT. ZERO) GO TO 90 C S = (T - TN)/H IC = 1 IF (K .EQ. 0) GO TO 15 JJ1 = L - K DO 10 JJ = JJ1, NQ IC = IC*JJ 10 CONTINUE 15 C = REAL(IC) DO 20 I = 1, N DKY(I) = C*YH(I,L) 20 CONTINUE IF (K .EQ. NQ) GO TO 55 JB2 = NQ - K DO 50 JB = 1, JB2 J = NQ - JB JP1 = J + 1 IC = 1 IF (K .EQ. 0) GO TO 35 JJ1 = JP1 - K DO 30 JJ = JJ1, J IC = IC*JJ 30 CONTINUE 35 C = REAL(IC) DO 40 I = 1, N DKY(I) = C*YH(I,JP1) + S*DKY(I) 40 CONTINUE 50 CONTINUE IF (K .EQ. 0) RETURN 55 R = H**(-K) CALL DZSCAL (N, R, DKY, 1) RETURN C 80 MSG = 'ZVINDY-- K (=I1) illegal ' CALL XERRWD (MSG, 30, 51, 1, 1, K, 0, 0, ZERO, ZERO) IFLAG = -1 RETURN 90 MSG = 'ZVINDY-- T (=R1) illegal ' CALL XERRWD (MSG, 30, 52, 1, 0, 0, 0, 1, T, ZERO) MSG=' T not in interval TCUR - HU (= R1) to TCUR (=R2) ' CALL XERRWD (MSG, 60, 52, 1, 0, 0, 0, 2, TP, TN) IFLAG = -2 RETURN C----------------------- End of Subroutine ZVINDY ---------------------- END *DECK ZVSTEP SUBROUTINE ZVSTEP (Y, YH, LDYH, YH1, EWT, SAVF, VSAV, ACOR, 1 WM, IWM, F, JAC, PSOL, VNLS, RPAR, IPAR) EXTERNAL F, JAC, PSOL, VNLS COMPLEX(KIND=8) Y, YH, YH1, SAVF, VSAV, ACOR, WM DOUBLE PRECISION EWT INTEGER LDYH, IWM, IPAR DIMENSION Y(*), YH(LDYH,*), YH1(*), EWT(*), SAVF(*), VSAV(*), 1 ACOR(*), WM(*), IWM(*), RPAR(*), IPAR(*) C----------------------------------------------------------------------- C Call sequence input -- Y, YH, LDYH, YH1, EWT, SAVF, VSAV, C ACOR, WM, IWM, F, JAC, PSOL, VNLS, RPAR, IPAR C Call sequence output -- YH, ACOR, WM, IWM C COMMON block variables accessed: C /ZVOD01/ ACNRM, EL(13), H, HMIN, HMXI, HNEW, HSCAL, RC, TAU(13), C TQ(5), TN, JCUR, JSTART, KFLAG, KUTH, C L, LMAX, MAXORD, N, NEWQ, NQ, NQWAIT C /ZVOD02/ HU, NCFN, NETF, NFE, NQU, NST C C Subroutines called by ZVSTEP: F, DZAXPY, ZCOPY, DZSCAL, C ZVJUST, VNLS, ZVSET C Function routines called by ZVSTEP: ZVNORM C----------------------------------------------------------------------- C ZVSTEP performs one step of the integration of an initial value C problem for a system of ordinary differential equations. C ZVSTEP calls subroutine VNLS for the solution of the nonlinear system C arising in the time step. Thus it is independent of the problem C Jacobian structure and the type of nonlinear system solution method. C ZVSTEP returns a completion flag KFLAG (in COMMON). C A return with KFLAG = -1 or -2 means either ABS(H) = HMIN or 10 C consecutive failures occurred. On a return with KFLAG negative, C the values of TN and the YH array are as of the beginning of the last C step, and H is the last step size attempted. C C Communication with ZVSTEP is done with the following variables: C C Y = An array of length N used for the dependent variable vector. C YH = An LDYH by LMAX array containing the dependent variables C and their approximate scaled derivatives, where C LMAX = MAXORD + 1. YH(i,j+1) contains the approximate C j-th derivative of y(i), scaled by H**j/factorial(j) C (j = 0,1,...,NQ). On entry for the first step, the first C two columns of YH must be set from the initial values. C LDYH = A constant integer .ge. N, the first dimension of YH. C N is the number of ODEs in the system. C YH1 = A one-dimensional array occupying the same space as YH. C EWT = An array of length N containing multiplicative weights C for local error measurements. Local errors in y(i) are C compared to 1.0/EWT(i) in various error tests. C SAVF = An array of working storage, of length N. C also used for input of YH(*,MAXORD+2) when JSTART = -1 C and MAXORD .lt. the current order NQ. C VSAV = A work array of length N passed to subroutine VNLS. C ACOR = A work array of length N, used for the accumulated C corrections. On a successful return, ACOR(i) contains C the estimated one-step local error in y(i). C WM,IWM = Complex and integer work arrays associated with matrix C operations in VNLS. C F = Dummy name for the user-supplied subroutine for f. C JAC = Dummy name for the user-supplied Jacobian subroutine. C PSOL = Dummy name for the subroutine passed to VNLS, for C possible use there. C VNLS = Dummy name for the nonlinear system solving subroutine, C whose real name is dependent on the method used. C RPAR, IPAR = User's real/complex and integer work arrays. C----------------------------------------------------------------------- C C Type declarations for labeled COMMON block ZVOD01 -------------------- C DOUBLE PRECISION ACNRM, CCMXJ, CONP, CRATE, DRC, EL, 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HRL1, HSCAL, PRL1, 2 RC, RL1, SRUR, TAU, TQ, TN, UROUND INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, 1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, 2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, 3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, 4 NSLP, NYH C C Type declarations for labeled COMMON block ZVOD02 -------------------- C DOUBLE PRECISION HU INTEGER NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST C C Type declarations for local variables -------------------------------- C DOUBLE PRECISION ADDON, BIAS1,BIAS2,BIAS3, CNQUOT, DDN, DSM, DUP, 1 ETACF, ETAMIN, ETAMX1, ETAMX2, ETAMX3, ETAMXF, 2 ETAQ, ETAQM1, ETAQP1, FLOTL, ONE, ONEPSM, 3 R, THRESH, TOLD, ZERO INTEGER I, I1, I2, IBACK, J, JB, KFC, KFH, MXNCF, NCF, NFLAG C C Type declaration for function subroutines called --------------------- C DOUBLE PRECISION ZVNORM C----------------------------------------------------------------------- C The following Fortran-77 declaration is to cause the values of the C listed (local) variables to be saved between calls to this integrator. C----------------------------------------------------------------------- SAVE ADDON, BIAS1, BIAS2, BIAS3, 1 ETACF, ETAMIN, ETAMX1, ETAMX2, ETAMX3, ETAMXF, ETAQ, ETAQM1, 2 KFC, KFH, MXNCF, ONEPSM, THRESH, ONE, ZERO C----------------------------------------------------------------------- COMMON /ZVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), ETA, 1 ETAMAX, H, HMIN, HMXI, HNEW, HRL1, HSCAL, PRL1, 2 RC, RL1, SRUR, TAU(13), TQ(5), TN, UROUND, 3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, 4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, 5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, 6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, 7 NSLP, NYH COMMON /ZVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST C DATA KFC/-3/, KFH/-7/, MXNCF/10/ DATA ADDON /1.0D-6/, BIAS1 /6.0D0/, BIAS2 /6.0D0/, 1 BIAS3 /10.0D0/, ETACF /0.25D0/, ETAMIN /0.1D0/, 2 ETAMXF /0.2D0/, ETAMX1 /1.0D4/, ETAMX2 /10.0D0/, 3 ETAMX3 /10.0D0/, ONEPSM /1.00001D0/, THRESH /1.5D0/ DATA ONE/1.0D0/, ZERO/0.0D0/ C KFLAG = 0 TOLD = TN NCF = 0 JCUR = 0 NFLAG = 0 IF (JSTART .GT. 0) GO TO 20 IF (JSTART .EQ. -1) GO TO 100 C----------------------------------------------------------------------- C On the first call, the order is set to 1, and other variables are C initialized. ETAMAX is the maximum ratio by which H can be increased C in a single step. It is normally 10, but is larger during the C first step to compensate for the small initial H. If a failure C occurs (in corrector convergence or error test), ETAMAX is set to 1 C for the next increase. C----------------------------------------------------------------------- LMAX = MAXORD + 1 NQ = 1 L = 2 NQNYH = NQ*LDYH TAU(1) = H PRL1 = ONE RC = ZERO ETAMAX = ETAMX1 NQWAIT = 2 HSCAL = H GO TO 200 C----------------------------------------------------------------------- C Take preliminary actions on a normal continuation step (JSTART.GT.0). C If the driver changed H, then ETA must be reset and NEWH set to 1. C If a change of order was dictated on the previous step, then C it is done here and appropriate adjustments in the history are made. C On an order decrease, the history array is adjusted by ZVJUST. C On an order increase, the history array is augmented by a column. C On a change of step size H, the history array YH is rescaled. C----------------------------------------------------------------------- 20 CONTINUE IF (KUTH .EQ. 1) THEN ETA = MIN(ETA,H/HSCAL) NEWH = 1 ENDIF 50 IF (NEWH .EQ. 0) GO TO 200 IF (NEWQ .EQ. NQ) GO TO 150 IF (NEWQ .LT. NQ) THEN CALL ZVJUST (YH, LDYH, -1) NQ = NEWQ L = NQ + 1 NQWAIT = L GO TO 150 ENDIF IF (NEWQ .GT. NQ) THEN CALL ZVJUST (YH, LDYH, 1) NQ = NEWQ L = NQ + 1 NQWAIT = L GO TO 150 ENDIF C----------------------------------------------------------------------- C The following block handles preliminaries needed when JSTART = -1. C If N was reduced, zero out part of YH to avoid undefined references. C If MAXORD was reduced to a value less than the tentative order NEWQ, C then NQ is set to MAXORD, and a new H ratio ETA is chosen. C Otherwise, we take the same preliminary actions as for JSTART .gt. 0. C In any case, NQWAIT is reset to L = NQ + 1 to prevent further C changes in order for that many steps. C The new H ratio ETA is limited by the input H if KUTH = 1, C by HMIN if KUTH = 0, and by HMXI in any case. C Finally, the history array YH is rescaled. C----------------------------------------------------------------------- 100 CONTINUE LMAX = MAXORD + 1 IF (N .EQ. LDYH) GO TO 120 I1 = 1 + (NEWQ + 1)*LDYH I2 = (MAXORD + 1)*LDYH IF (I1 .GT. I2) GO TO 120 DO 110 I = I1, I2 YH1(I) = ZERO 110 CONTINUE 120 IF (NEWQ .LE. MAXORD) GO TO 140 FLOTL = REAL(LMAX) IF (MAXORD .LT. NQ-1) THEN DDN = ZVNORM (N, SAVF, EWT)/TQ(1) ETA = ONE/((BIAS1*DDN)**(ONE/FLOTL) + ADDON) ENDIF IF (MAXORD .EQ. NQ .AND. NEWQ .EQ. NQ+1) ETA = ETAQ IF (MAXORD .EQ. NQ-1 .AND. NEWQ .EQ. NQ+1) THEN ETA = ETAQM1 CALL ZVJUST (YH, LDYH, -1) ENDIF IF (MAXORD .EQ. NQ-1 .AND. NEWQ .EQ. NQ) THEN DDN = ZVNORM (N, SAVF, EWT)/TQ(1) ETA = ONE/((BIAS1*DDN)**(ONE/FLOTL) + ADDON) CALL ZVJUST (YH, LDYH, -1) ENDIF ETA = MIN(ETA,ONE) NQ = MAXORD L = LMAX 140 IF (KUTH .EQ. 1) ETA = MIN(ETA,ABS(H/HSCAL)) IF (KUTH .EQ. 0) ETA = MAX(ETA,HMIN/ABS(HSCAL)) ETA = ETA/MAX(ONE,ABS(HSCAL)*HMXI*ETA) NEWH = 1 NQWAIT = L IF (NEWQ .LE. MAXORD) GO TO 50 C Rescale the history array for a change in H by a factor of ETA. ------ 150 R = ONE DO 180 J = 2, L R = R*ETA CALL DZSCAL (N, R, YH(1,J), 1 ) 180 CONTINUE H = HSCAL*ETA HSCAL = H RC = RC*ETA NQNYH = NQ*LDYH C----------------------------------------------------------------------- C This section computes the predicted values by effectively C multiplying the YH array by the Pascal triangle matrix. C ZVSET is called to calculate all integration coefficients. C RC is the ratio of new to old values of the coefficient H/EL(2)=h/l1. C----------------------------------------------------------------------- 200 TN = TN + H I1 = NQNYH + 1 DO 220 JB = 1, NQ I1 = I1 - LDYH DO 210 I = I1, NQNYH YH1(I) = YH1(I) + YH1(I+LDYH) 210 CONTINUE 220 CONTINUE CALL ZVSET RL1 = ONE/EL(2) RC = RC*(RL1/PRL1) PRL1 = RL1 C C Call the nonlinear system solver. ------------------------------------ C CALL VNLS (Y, YH, LDYH, VSAV, SAVF, EWT, ACOR, IWM, WM, 1 F, JAC, PSOL, NFLAG, RPAR, IPAR) C IF (NFLAG .EQ. 0) GO TO 450 C----------------------------------------------------------------------- C The VNLS routine failed to achieve convergence (NFLAG .NE. 0). C The YH array is retracted to its values before prediction. C The step size H is reduced and the step is retried, if possible. C Otherwise, an error exit is taken. C----------------------------------------------------------------------- NCF = NCF + 1 NCFN = NCFN + 1 ETAMAX = ONE TN = TOLD I1 = NQNYH + 1 DO 430 JB = 1, NQ I1 = I1 - LDYH DO 420 I = I1, NQNYH YH1(I) = YH1(I) - YH1(I+LDYH) 420 CONTINUE 430 CONTINUE IF (NFLAG .LT. -1) GO TO 680 IF (ABS(H) .LE. HMIN*ONEPSM) GO TO 670 IF (NCF .EQ. MXNCF) GO TO 670 ETA = ETACF ETA = MAX(ETA,HMIN/ABS(H)) NFLAG = -1 GO TO 150 C----------------------------------------------------------------------- C The corrector has converged (NFLAG = 0). The local error test is C made and control passes to statement 500 if it fails. C----------------------------------------------------------------------- 450 CONTINUE DSM = ACNRM/TQ(2) IF (DSM .GT. ONE) GO TO 500 C----------------------------------------------------------------------- C After a successful step, update the YH and TAU arrays and decrement C NQWAIT. If NQWAIT is then 1 and NQ .lt. MAXORD, then ACOR is saved C for use in a possible order increase on the next step. C If ETAMAX = 1 (a failure occurred this step), keep NQWAIT .ge. 2. C----------------------------------------------------------------------- KFLAG = 0 NST = NST + 1 HU = H NQU = NQ DO 470 IBACK = 1, NQ I = L - IBACK TAU(I+1) = TAU(I) 470 CONTINUE TAU(1) = H DO 480 J = 1, L CALL DZAXPY (N, EL(J), ACOR, 1, YH(1,J), 1 ) 480 CONTINUE NQWAIT = NQWAIT - 1 IF ((L .EQ. LMAX) .OR. (NQWAIT .NE. 1)) GO TO 490 CALL ZCOPY (N, ACOR, 1, YH(1,LMAX), 1 ) CONP = TQ(5) 490 IF (ETAMAX .NE. ONE) GO TO 560 IF (NQWAIT .LT. 2) NQWAIT = 2 NEWQ = NQ NEWH = 0 ETA = ONE HNEW = H GO TO 690 C----------------------------------------------------------------------- C The error test failed. KFLAG keeps track of multiple failures. C Restore TN and the YH array to their previous values, and prepare C to try the step again. Compute the optimum step size for the C same order. After repeated failures, H is forced to decrease C more rapidly. C----------------------------------------------------------------------- 500 KFLAG = KFLAG - 1 NETF = NETF + 1 NFLAG = -2 TN = TOLD I1 = NQNYH + 1 DO 520 JB = 1, NQ I1 = I1 - LDYH DO 510 I = I1, NQNYH YH1(I) = YH1(I) - YH1(I+LDYH) 510 CONTINUE 520 CONTINUE IF (ABS(H) .LE. HMIN*ONEPSM) GO TO 660 ETAMAX = ONE IF (KFLAG .LE. KFC) GO TO 530 C Compute ratio of new H to current H at the current order. ------------ FLOTL = REAL(L) ETA = ONE/((BIAS2*DSM)**(ONE/FLOTL) + ADDON) ETA = MAX(ETA,HMIN/ABS(H),ETAMIN) IF ((KFLAG .LE. -2) .AND. (ETA .GT. ETAMXF)) ETA = ETAMXF GO TO 150 C----------------------------------------------------------------------- C Control reaches this section if 3 or more consecutive failures C have occurred. It is assumed that the elements of the YH array C have accumulated errors of the wrong order. The order is reduced C by one, if possible. Then H is reduced by a factor of 0.1 and C the step is retried. After a total of 7 consecutive failures, C an exit is taken with KFLAG = -1. C----------------------------------------------------------------------- 530 IF (KFLAG .EQ. KFH) GO TO 660 IF (NQ .EQ. 1) GO TO 540 ETA = MAX(ETAMIN,HMIN/ABS(H)) CALL ZVJUST (YH, LDYH, -1) L = NQ NQ = NQ - 1 NQWAIT = L GO TO 150 540 ETA = MAX(ETAMIN,HMIN/ABS(H)) H = H*ETA HSCAL = H TAU(1) = H CALL F (N, TN, Y, SAVF, RPAR, IPAR) NFE = NFE + 1 DO 550 I = 1, N YH(I,2) = H*SAVF(I) 550 CONTINUE NQWAIT = 10 GO TO 200 C----------------------------------------------------------------------- C If NQWAIT = 0, an increase or decrease in order by one is considered. C Factors ETAQ, ETAQM1, ETAQP1 are computed by which H could C be multiplied at order q, q-1, or q+1, respectively. C The largest of these is determined, and the new order and C step size set accordingly. C A change of H or NQ is made only if H increases by at least a C factor of THRESH. If an order change is considered and rejected, C then NQWAIT is set to 2 (reconsider it after 2 steps). C----------------------------------------------------------------------- C Compute ratio of new H to current H at the current order. ------------ 560 FLOTL = REAL(L) ETAQ = ONE/((BIAS2*DSM)**(ONE/FLOTL) + ADDON) IF (NQWAIT .NE. 0) GO TO 600 NQWAIT = 2 ETAQM1 = ZERO IF (NQ .EQ. 1) GO TO 570 C Compute ratio of new H to current H at the current order less one. --- DDN = ZVNORM (N, YH(1,L), EWT)/TQ(1) ETAQM1 = ONE/((BIAS1*DDN)**(ONE/(FLOTL - ONE)) + ADDON) 570 ETAQP1 = ZERO IF (L .EQ. LMAX) GO TO 580 C Compute ratio of new H to current H at current order plus one. ------- CNQUOT = (TQ(5)/CONP)*(H/TAU(2))**L DO 575 I = 1, N SAVF(I) = ACOR(I) - CNQUOT*YH(I,LMAX) 575 CONTINUE DUP = ZVNORM (N, SAVF, EWT)/TQ(3) ETAQP1 = ONE/((BIAS3*DUP)**(ONE/(FLOTL + ONE)) + ADDON) 580 IF (ETAQ .GE. ETAQP1) GO TO 590 IF (ETAQP1 .GT. ETAQM1) GO TO 620 GO TO 610 590 IF (ETAQ .LT. ETAQM1) GO TO 610 600 ETA = ETAQ NEWQ = NQ GO TO 630 610 ETA = ETAQM1 NEWQ = NQ - 1 GO TO 630 620 ETA = ETAQP1 NEWQ = NQ + 1 CALL ZCOPY (N, ACOR, 1, YH(1,LMAX), 1) C Test tentative new H against THRESH, ETAMAX, and HMXI, then exit. ---- 630 IF (ETA .LT. THRESH .OR. ETAMAX .EQ. ONE) GO TO 640 ETA = MIN(ETA,ETAMAX) ETA = ETA/MAX(ONE,ABS(H)*HMXI*ETA) NEWH = 1 HNEW = H*ETA GO TO 690 640 NEWQ = NQ NEWH = 0 ETA = ONE HNEW = H GO TO 690 C----------------------------------------------------------------------- C All returns are made through this section. C On a successful return, ETAMAX is reset and ACOR is scaled. C----------------------------------------------------------------------- 660 KFLAG = -1 GO TO 720 670 KFLAG = -2 GO TO 720 680 IF (NFLAG .EQ. -2) KFLAG = -3 IF (NFLAG .EQ. -3) KFLAG = -4 GO TO 720 690 ETAMAX = ETAMX3 IF (NST .LE. 10) ETAMAX = ETAMX2 R = ONE/TQ(2) CALL DZSCAL (N, R, ACOR, 1) 720 JSTART = 1 RETURN C----------------------- End of Subroutine ZVSTEP ---------------------- END *DECK ZVSET SUBROUTINE ZVSET C----------------------------------------------------------------------- C Call sequence communication: None C COMMON block variables accessed: C /ZVOD01/ -- EL(13), H, TAU(13), TQ(5), L(= NQ + 1), C METH, NQ, NQWAIT C C Subroutines called by ZVSET: None C Function routines called by ZVSET: None C----------------------------------------------------------------------- C ZVSET is called by ZVSTEP and sets coefficients for use there. C C For each order NQ, the coefficients in EL are calculated by use of C the generating polynomial lambda(x), with coefficients EL(i). C lambda(x) = EL(1) + EL(2)*x + ... + EL(NQ+1)*(x**NQ). C For the backward differentiation formulas, C NQ-1 C lambda(x) = (1 + x/xi*(NQ)) * product (1 + x/xi(i) ) . C i = 1 C For the Adams formulas, C NQ-1 C (d/dx) lambda(x) = c * product (1 + x/xi(i) ) , C i = 1 C lambda(-1) = 0, lambda(0) = 1, C where c is a normalization constant. C In both cases, xi(i) is defined by C H*xi(i) = t sub n - t sub (n-i) C = H + TAU(1) + TAU(2) + ... TAU(i-1). C C C In addition to variables described previously, communication C with ZVSET uses the following: C TAU = A vector of length 13 containing the past NQ values C of H. C EL = A vector of length 13 in which vset stores the C coefficients for the corrector formula. C TQ = A vector of length 5 in which vset stores constants C used for the convergence test, the error test, and the C selection of H at a new order. C METH = The basic method indicator. C NQ = The current order. C L = NQ + 1, the length of the vector stored in EL, and C the number of columns of the YH array being used. C NQWAIT = A counter controlling the frequency of order changes. C An order change is about to be considered if NQWAIT = 1. C----------------------------------------------------------------------- C C Type declarations for labeled COMMON block ZVOD01 -------------------- C DOUBLE PRECISION ACNRM, CCMXJ, CONP, CRATE, DRC, EL, 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HRL1, HSCAL, PRL1, 2 RC, RL1, SRUR, TAU, TQ, TN, UROUND INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, 1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, 2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, 3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, 4 NSLP, NYH C C Type declarations for local variables -------------------------------- C DOUBLE PRECISION AHATN0, ALPH0, CNQM1, CORTES, CSUM, ELP, EM, 1 EM0, FLOTI, FLOTL, FLOTNQ, HSUM, ONE, RXI, RXIS, S, SIX, 2 T1, T2, T3, T4, T5, T6, TWO, XI, ZERO INTEGER I, IBACK, J, JP1, NQM1, NQM2 C DIMENSION EM(13) C----------------------------------------------------------------------- C The following Fortran-77 declaration is to cause the values of the C listed (local) variables to be saved between calls to this integrator. C----------------------------------------------------------------------- SAVE CORTES, ONE, SIX, TWO, ZERO C COMMON /ZVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), ETA, 1 ETAMAX, H, HMIN, HMXI, HNEW, HRL1, HSCAL, PRL1, 2 RC, RL1, SRUR, TAU(13), TQ(5), TN, UROUND, 3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, 4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, 5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, 6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, 7 NSLP, NYH C DATA CORTES /0.1D0/ DATA ONE /1.0D0/, SIX /6.0D0/, TWO /2.0D0/, ZERO /0.0D0/ C FLOTL = REAL(L) NQM1 = NQ - 1 NQM2 = NQ - 2 IF (METH .EQ. 1) THEN GOTO 100 ELSE IF (METH .EQ. 2) THEN GOTO 200 ENDIF C GO TO (100, 200), METH C C Set coefficients for Adams methods. ---------------------------------- 100 IF (NQ .NE. 1) GO TO 110 EL(1) = ONE EL(2) = ONE TQ(1) = ONE TQ(2) = TWO TQ(3) = SIX*TQ(2) TQ(5) = ONE GO TO 300 110 HSUM = H EM(1) = ONE FLOTNQ = FLOTL - ONE DO 115 I = 2, L EM(I) = ZERO 115 CONTINUE DO 150 J = 1, NQM1 IF ((J .NE. NQM1) .OR. (NQWAIT .NE. 1)) GO TO 130 S = ONE CSUM = ZERO DO 120 I = 1, NQM1 CSUM = CSUM + S*EM(I)/REAL(I+1) S = -S 120 CONTINUE TQ(1) = EM(NQM1)/(FLOTNQ*CSUM) 130 RXI = H/HSUM DO 140 IBACK = 1, J I = (J + 2) - IBACK EM(I) = EM(I) + EM(I-1)*RXI 140 CONTINUE HSUM = HSUM + TAU(J) 150 CONTINUE C Compute integral from -1 to 0 of polynomial and of x times it. ------- S = ONE EM0 = ZERO CSUM = ZERO DO 160 I = 1, NQ FLOTI = REAL(I) EM0 = EM0 + S*EM(I)/FLOTI CSUM = CSUM + S*EM(I)/(FLOTI+ONE) S = -S 160 CONTINUE C In EL, form coefficients of normalized integrated polynomial. -------- S = ONE/EM0 EL(1) = ONE DO 170 I = 1, NQ EL(I+1) = S*EM(I)/REAL(I) 170 CONTINUE XI = HSUM/H TQ(2) = XI*EM0/CSUM TQ(5) = XI/EL(L) IF (NQWAIT .NE. 1) GO TO 300 C For higher order control constant, multiply polynomial by 1+x/xi(q). - RXI = ONE/XI DO 180 IBACK = 1, NQ I = (L + 1) - IBACK EM(I) = EM(I) + EM(I-1)*RXI 180 CONTINUE C Compute integral of polynomial. -------------------------------------- S = ONE CSUM = ZERO DO 190 I = 1, L CSUM = CSUM + S*EM(I)/REAL(I+1) S = -S 190 CONTINUE TQ(3) = FLOTL*EM0/CSUM GO TO 300 C C Set coefficients for BDF methods. ------------------------------------ 200 DO 210 I = 3, L EL(I) = ZERO 210 CONTINUE EL(1) = ONE EL(2) = ONE ALPH0 = -ONE AHATN0 = -ONE HSUM = H RXI = ONE RXIS = ONE IF (NQ .EQ. 1) GO TO 240 DO 230 J = 1, NQM2 C In EL, construct coefficients of (1+x/xi(1))*...*(1+x/xi(j+1)). ------ HSUM = HSUM + TAU(J) RXI = H/HSUM JP1 = J + 1 ALPH0 = ALPH0 - ONE/REAL(JP1) DO 220 IBACK = 1, JP1 I = (J + 3) - IBACK EL(I) = EL(I) + EL(I-1)*RXI 220 CONTINUE 230 CONTINUE ALPH0 = ALPH0 - ONE/REAL(NQ) RXIS = -EL(2) - ALPH0 HSUM = HSUM + TAU(NQM1) RXI = H/HSUM AHATN0 = -EL(2) - RXI DO 235 IBACK = 1, NQ I = (NQ + 2) - IBACK EL(I) = EL(I) + EL(I-1)*RXIS 235 CONTINUE 240 T1 = ONE - AHATN0 + ALPH0 T2 = ONE + REAL(NQ)*T1 TQ(2) = ABS(ALPH0*T2/T1) TQ(5) = ABS(T2/(EL(L)*RXI/RXIS)) IF (NQWAIT .NE. 1) GO TO 300 CNQM1 = RXIS/EL(L) T3 = ALPH0 + ONE/REAL(NQ) T4 = AHATN0 + RXI ELP = T3/(ONE - T4 + T3) TQ(1) = ABS(ELP/CNQM1) HSUM = HSUM + TAU(NQ) RXI = H/HSUM T5 = ALPH0 - ONE/REAL(NQ+1) T6 = AHATN0 - RXI ELP = T2/(ONE - T6 + T5) TQ(3) = ABS(ELP*RXI*(FLOTL + ONE)*T5) 300 TQ(4) = CORTES*TQ(2) RETURN C----------------------- End of Subroutine ZVSET ----------------------- END *DECK ZVJUST SUBROUTINE ZVJUST (YH, LDYH, IORD) COMPLEX(KIND=8) YH INTEGER LDYH, IORD DIMENSION YH(LDYH,*) C----------------------------------------------------------------------- C Call sequence input -- YH, LDYH, IORD C Call sequence output -- YH C COMMON block input -- NQ, METH, LMAX, HSCAL, TAU(13), N C COMMON block variables accessed: C /ZVOD01/ -- HSCAL, TAU(13), LMAX, METH, N, NQ, C C Subroutines called by ZVJUST: DZAXPY C Function routines called by ZVJUST: None C----------------------------------------------------------------------- C This subroutine adjusts the YH array on reduction of order, C and also when the order is increased for the stiff option (METH = 2). C Communication with ZVJUST uses the following: C IORD = An integer flag used when METH = 2 to indicate an order C increase (IORD = +1) or an order decrease (IORD = -1). C HSCAL = Step size H used in scaling of Nordsieck array YH. C (If IORD = +1, ZVJUST assumes that HSCAL = TAU(1).) C See References 1 and 2 for details. C----------------------------------------------------------------------- C C Type declarations for labeled COMMON block ZVOD01 -------------------- C DOUBLE PRECISION ACNRM, CCMXJ, CONP, CRATE, DRC, EL, 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HRL1, HSCAL, PRL1, 2 RC, RL1, SRUR, TAU, TQ, TN, UROUND INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, 1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, 2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, 3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, 4 NSLP, NYH C C Type declarations for local variables -------------------------------- C DOUBLE PRECISION ALPH0, ALPH1, HSUM, ONE, PROD, T1, XI,XIOLD, ZERO INTEGER I, IBACK, J, JP1, LP1, NQM1, NQM2, NQP1 C----------------------------------------------------------------------- C The following Fortran-77 declaration is to cause the values of the C listed (local) variables to be saved between calls to this integrator. C----------------------------------------------------------------------- SAVE ONE, ZERO C COMMON /ZVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), ETA, 1 ETAMAX, H, HMIN, HMXI, HNEW, HRL1, HSCAL, PRL1, 2 RC, RL1, SRUR, TAU(13), TQ(5), TN, UROUND, 3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, 4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, 5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, 6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, 7 NSLP, NYH C DATA ONE /1.0D0/, ZERO /0.0D0/ C IF ((NQ .EQ. 2) .AND. (IORD .NE. 1)) RETURN NQM1 = NQ - 1 NQM2 = NQ - 2 IF (METH .EQ. 1) THEN GOTO 100 ELSE IF (METH .EQ. 2) THEN GOTO 200 ENDIF C GO TO (100, 200), METH C----------------------------------------------------------------------- C Nonstiff option... C Check to see if the order is being increased or decreased. C----------------------------------------------------------------------- 100 CONTINUE IF (IORD .EQ. 1) GO TO 180 C Order decrease. ------------------------------------------------------ DO 110 J = 1, LMAX EL(J) = ZERO 110 CONTINUE EL(2) = ONE HSUM = ZERO DO 130 J = 1, NQM2 C Construct coefficients of x*(x+xi(1))*...*(x+xi(j)). ----------------- HSUM = HSUM + TAU(J) XI = HSUM/HSCAL JP1 = J + 1 DO 120 IBACK = 1, JP1 I = (J + 3) - IBACK EL(I) = EL(I)*XI + EL(I-1) 120 CONTINUE 130 CONTINUE C Construct coefficients of integrated polynomial. --------------------- DO 140 J = 2, NQM1 EL(J+1) = REAL(NQ)*EL(J)/REAL(J) 140 CONTINUE C Subtract correction terms from YH array. ----------------------------- DO 170 J = 3, NQ DO 160 I = 1, N YH(I,J) = YH(I,J) - YH(I,L)*EL(J) 160 CONTINUE 170 CONTINUE RETURN C Order increase. ------------------------------------------------------ C Zero out next column in YH array. ------------------------------------ 180 CONTINUE LP1 = L + 1 DO 190 I = 1, N YH(I,LP1) = ZERO 190 CONTINUE RETURN C----------------------------------------------------------------------- C Stiff option... C Check to see if the order is being increased or decreased. C----------------------------------------------------------------------- 200 CONTINUE IF (IORD .EQ. 1) GO TO 300 C Order decrease. ------------------------------------------------------ DO 210 J = 1, LMAX EL(J) = ZERO 210 CONTINUE EL(3) = ONE HSUM = ZERO DO 230 J = 1,NQM2 C Construct coefficients of x*x*(x+xi(1))*...*(x+xi(j)). --------------- HSUM = HSUM + TAU(J) XI = HSUM/HSCAL JP1 = J + 1 DO 220 IBACK = 1, JP1 I = (J + 4) - IBACK EL(I) = EL(I)*XI + EL(I-1) 220 CONTINUE 230 CONTINUE C Subtract correction terms from YH array. ----------------------------- DO 250 J = 3,NQ DO 240 I = 1, N YH(I,J) = YH(I,J) - YH(I,L)*EL(J) 240 CONTINUE 250 CONTINUE RETURN C Order increase. ------------------------------------------------------ 300 DO 310 J = 1, LMAX EL(J) = ZERO 310 CONTINUE EL(3) = ONE ALPH0 = -ONE ALPH1 = ONE PROD = ONE XIOLD = ONE HSUM = HSCAL IF (NQ .EQ. 1) GO TO 340 DO 330 J = 1, NQM1 C Construct coefficients of x*x*(x+xi(1))*...*(x+xi(j)). --------------- JP1 = J + 1 HSUM = HSUM + TAU(JP1) XI = HSUM/HSCAL PROD = PROD*XI ALPH0 = ALPH0 - ONE/REAL(JP1) ALPH1 = ALPH1 + ONE/XI DO 320 IBACK = 1, JP1 I = (J + 4) - IBACK EL(I) = EL(I)*XIOLD + EL(I-1) 320 CONTINUE XIOLD = XI 330 CONTINUE 340 CONTINUE T1 = (-ALPH0 - ALPH1)/PROD C Load column L + 1 in YH array. --------------------------------------- LP1 = L + 1 DO 350 I = 1, N YH(I,LP1) = T1*YH(I,LMAX) 350 CONTINUE C Add correction terms to YH array. ------------------------------------ NQP1 = NQ + 1 DO 370 J = 3, NQP1 CALL DZAXPY (N, EL(J), YH(1,LP1), 1, YH(1,J), 1 ) 370 CONTINUE RETURN C----------------------- End of Subroutine ZVJUST ---------------------- END *DECK ZVNLSD SUBROUTINE ZVNLSD (Y, YH, LDYH, VSAV, SAVF, EWT, ACOR, IWM, WM, 1 F, JAC, PDUM, NFLAG, RPAR, IPAR) EXTERNAL F, JAC, PDUM COMPLEX(KIND=8) Y, YH, VSAV, SAVF, ACOR, WM DOUBLE PRECISION EWT INTEGER LDYH, IWM, NFLAG, IPAR DIMENSION Y(*), YH(LDYH,*), VSAV(*), SAVF(*), EWT(*), ACOR(*), 1 IWM(*), WM(*), RPAR(*), IPAR(*) C----------------------------------------------------------------------- C Call sequence input -- Y, YH, LDYH, SAVF, EWT, ACOR, IWM, WM, C F, JAC, NFLAG, RPAR, IPAR C Call sequence output -- YH, ACOR, WM, IWM, NFLAG C COMMON block variables accessed: C /ZVOD01/ ACNRM, CRATE, DRC, H, RC, RL1, TQ(5), TN, ICF, C JCUR, METH, MITER, N, NSLP C /ZVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST C C Subroutines called by ZVNLSD: F, DZAXPY, ZCOPY, DZSCAL, ZVJAC, ZVSOL C Function routines called by ZVNLSD: ZVNORM C----------------------------------------------------------------------- C Subroutine ZVNLSD is a nonlinear system solver, which uses functional C iteration or a chord (modified Newton) method. For the chord method C direct linear algebraic system solvers are used. Subroutine ZVNLSD C then handles the corrector phase of this integration package. C C Communication with ZVNLSD is done with the following variables. (For C more details, please see the comments in the driver subroutine.) C C Y = The dependent variable, a vector of length N, input. C YH = The Nordsieck (Taylor) array, LDYH by LMAX, input C and output. On input, it contains predicted values. C LDYH = A constant .ge. N, the first dimension of YH, input. C VSAV = Unused work array. C SAVF = A work array of length N. C EWT = An error weight vector of length N, input. C ACOR = A work array of length N, used for the accumulated C corrections to the predicted y vector. C WM,IWM = Complex and integer work arrays associated with matrix C operations in chord iteration (MITER .ne. 0). C F = Dummy name for user-supplied routine for f. C JAC = Dummy name for user-supplied Jacobian routine. C PDUM = Unused dummy subroutine name. Included for uniformity C over collection of integrators. C NFLAG = Input/output flag, with values and meanings as follows: C INPUT C 0 first call for this time step. C -1 convergence failure in previous call to ZVNLSD. C -2 error test failure in ZVSTEP. C OUTPUT C 0 successful completion of nonlinear solver. C -1 convergence failure or singular matrix. C -2 unrecoverable error in matrix preprocessing C (cannot occur here). C -3 unrecoverable error in solution (cannot occur C here). C RPAR, IPAR = User's real/complex and integer work arrays. C C IPUP = Own variable flag with values and meanings as follows: C 0, do not update the Newton matrix. C MITER .ne. 0, update Newton matrix, because it is the C initial step, order was changed, the error C test failed, or an update is indicated by C the scalar RC or step counter NST. C C For more details, see comments in driver subroutine. C----------------------------------------------------------------------- C Type declarations for labeled COMMON block ZVOD01 -------------------- C DOUBLE PRECISION ACNRM, CCMXJ, CONP, CRATE, DRC, EL, 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HRL1, HSCAL, PRL1, 2 RC, RL1, SRUR, TAU, TQ, TN, UROUND INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, 1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, 2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, 3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, 4 NSLP, NYH C C Type declarations for labeled COMMON block ZVOD02 -------------------- C DOUBLE PRECISION HU INTEGER NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST C C Type declarations for local variables -------------------------------- C DOUBLE PRECISION CCMAX, CRDOWN, CSCALE, DCON, DEL, DELP, ONE, 1 RDIV, TWO, ZERO INTEGER I, IERPJ, IERSL, M, MAXCOR, MSBP C C Type declaration for function subroutines called --------------------- C DOUBLE PRECISION ZVNORM C----------------------------------------------------------------------- C The following Fortran-77 declaration is to cause the values of the C listed (local) variables to be saved between calls to this integrator. C----------------------------------------------------------------------- SAVE CCMAX, CRDOWN, MAXCOR, MSBP, RDIV, ONE, TWO, ZERO C COMMON /ZVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), ETA, 1 ETAMAX, H, HMIN, HMXI, HNEW, HRL1, HSCAL, PRL1, 2 RC, RL1, SRUR, TAU(13), TQ(5), TN, UROUND, 3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, 4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, 5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, 6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, 7 NSLP, NYH COMMON /ZVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST C DATA CCMAX /0.3D0/, CRDOWN /0.3D0/, MAXCOR /3/, MSBP /20/, 1 RDIV /2.0D0/ DATA ONE /1.0D0/, TWO /2.0D0/, ZERO /0.0D0/ C----------------------------------------------------------------------- C On the first step, on a change of method order, or after a C nonlinear convergence failure with NFLAG = -2, set IPUP = MITER C to force a Jacobian update when MITER .ne. 0. C----------------------------------------------------------------------- IF (JSTART .EQ. 0) NSLP = 0 IF (NFLAG .EQ. 0) ICF = 0 IF (NFLAG .EQ. -2) IPUP = MITER IF ( (JSTART .EQ. 0) .OR. (JSTART .EQ. -1) ) IPUP = MITER C If this is functional iteration, set CRATE .eq. 1 and drop to 220 IF (MITER .EQ. 0) THEN CRATE = ONE GO TO 220 ENDIF C----------------------------------------------------------------------- C RC is the ratio of new to old values of the coefficient H/EL(2)=h/l1. C When RC differs from 1 by more than CCMAX, IPUP is set to MITER C to force ZVJAC to be called, if a Jacobian is involved. C In any case, ZVJAC is called at least every MSBP steps. C----------------------------------------------------------------------- DRC = ABS(RC-ONE) IF (DRC .GT. CCMAX .OR. NST .GE. NSLP+MSBP) IPUP = MITER C----------------------------------------------------------------------- C Up to MAXCOR corrector iterations are taken. A convergence test is C made on the r.m.s. norm of each correction, weighted by the error C weight vector EWT. The sum of the corrections is accumulated in the C vector ACOR(i). The YH array is not altered in the corrector loop. C----------------------------------------------------------------------- 220 M = 0 DELP = ZERO CALL ZCOPY (N, YH(1,1), 1, Y, 1 ) CALL F (N, TN, Y, SAVF, RPAR, IPAR) NFE = NFE + 1 IF (IPUP .LE. 0) GO TO 250 C----------------------------------------------------------------------- C If indicated, the matrix P = I - h*rl1*J is reevaluated and C preprocessed before starting the corrector iteration. IPUP is set C to 0 as an indicator that this has been done. C----------------------------------------------------------------------- CALL ZVJAC (Y, YH, LDYH, EWT, ACOR, SAVF, WM, IWM, F, JAC, IERPJ, 1 RPAR, IPAR) IPUP = 0 RC = ONE DRC = ZERO CRATE = ONE NSLP = NST C If matrix is singular, take error return to force cut in step size. -- IF (IERPJ .NE. 0) GO TO 430 250 DO 260 I = 1,N ACOR(I) = ZERO 260 CONTINUE C This is a looping point for the corrector iteration. ----------------- 270 IF (MITER .NE. 0) GO TO 350 C----------------------------------------------------------------------- C In the case of functional iteration, update Y directly from C the result of the last function evaluation. C----------------------------------------------------------------------- DO 280 I = 1,N SAVF(I) = RL1*(H*SAVF(I) - YH(I,2)) 280 CONTINUE DO 290 I = 1,N Y(I) = SAVF(I) - ACOR(I) 290 CONTINUE DEL = ZVNORM (N, Y, EWT) DO 300 I = 1,N Y(I) = YH(I,1) + SAVF(I) 300 CONTINUE CALL ZCOPY (N, SAVF, 1, ACOR, 1) GO TO 400 C----------------------------------------------------------------------- C In the case of the chord method, compute the corrector error, C and solve the linear system with that as right-hand side and C P as coefficient matrix. The correction is scaled by the factor C 2/(1+RC) to account for changes in h*rl1 since the last ZVJAC call. C----------------------------------------------------------------------- 350 DO 360 I = 1,N Y(I) = (RL1*H)*SAVF(I) - (RL1*YH(I,2) + ACOR(I)) 360 CONTINUE CALL ZVSOL (WM, IWM, Y, IERSL) NNI = NNI + 1 IF (IERSL .GT. 0) GO TO 410 IF (METH .EQ. 2 .AND. RC .NE. ONE) THEN CSCALE = TWO/(ONE + RC) CALL DZSCAL (N, CSCALE, Y, 1) ENDIF DEL = ZVNORM (N, Y, EWT) CALL DZAXPY (N, ONE, Y, 1, ACOR, 1) DO 380 I = 1,N Y(I) = YH(I,1) + ACOR(I) 380 CONTINUE C----------------------------------------------------------------------- C Test for convergence. If M .gt. 0, an estimate of the convergence C rate constant is stored in CRATE, and this is used in the test. C----------------------------------------------------------------------- 400 IF (M .NE. 0) CRATE = MAX(CRDOWN*CRATE,DEL/DELP) DCON = DEL*MIN(ONE,CRATE)/TQ(4) IF (DCON .LE. ONE) GO TO 450 M = M + 1 IF (M .EQ. MAXCOR) GO TO 410 IF (M .GE. 2 .AND. DEL .GT. RDIV*DELP) GO TO 410 DELP = DEL CALL F (N, TN, Y, SAVF, RPAR, IPAR) NFE = NFE + 1 GO TO 270 C 410 IF (MITER .EQ. 0 .OR. JCUR .EQ. 1) GO TO 430 ICF = 1 IPUP = MITER GO TO 220 C 430 CONTINUE NFLAG = -1 ICF = 2 IPUP = MITER RETURN C C Return for successful step. ------------------------------------------ 450 NFLAG = 0 JCUR = 0 ICF = 0 IF (M .EQ. 0) ACNRM = DEL IF (M .GT. 0) ACNRM = ZVNORM (N, ACOR, EWT) RETURN C----------------------- End of Subroutine ZVNLSD ---------------------- END *DECK ZVJAC SUBROUTINE ZVJAC (Y, YH, LDYH, EWT, FTEM, SAVF, WM, IWM, F, JAC, 1 IERPJ, RPAR, IPAR) EXTERNAL F, JAC COMPLEX(KIND=8) Y, YH, FTEM, SAVF, WM DOUBLE PRECISION EWT INTEGER LDYH, IWM, IERPJ, IPAR DIMENSION Y(*), YH(LDYH,*), EWT(*), FTEM(*), SAVF(*), 1 WM(*), IWM(*), RPAR(*), IPAR(*) C----------------------------------------------------------------------- C Call sequence input -- Y, YH, LDYH, EWT, FTEM, SAVF, WM, IWM, C F, JAC, RPAR, IPAR C Call sequence output -- WM, IWM, IERPJ C COMMON block variables accessed: C /ZVOD01/ CCMXJ, DRC, H, HRL1, RL1, SRUR, TN, UROUND, ICF, JCUR, C LOCJS, MITER, MSBJ, N, NSLJ C /ZVOD02/ NFE, NST, NJE, NLU C C Subroutines called by ZVJAC: F, JAC, ZACOPY, ZCOPY, ZGBFA, ZGEFA, C DZSCAL C Function routines called by ZVJAC: ZVNORM C----------------------------------------------------------------------- C ZVJAC is called by ZVNLSD to compute and process the matrix C P = I - h*rl1*J , where J is an approximation to the Jacobian. C Here J is computed by the user-supplied routine JAC if C MITER = 1 or 4, or by finite differencing if MITER = 2, 3, or 5. C If MITER = 3, a diagonal approximation to J is used. C If JSV = -1, J is computed from scratch in all cases. C If JSV = 1 and MITER = 1, 2, 4, or 5, and if the saved value of J is C considered acceptable, then P is constructed from the saved J. C J is stored in wm and replaced by P. If MITER .ne. 3, P is then C subjected to LU decomposition in preparation for later solution C of linear systems with P as coefficient matrix. This is done C by ZGEFA if MITER = 1 or 2, and by ZGBFA if MITER = 4 or 5. C C Communication with ZVJAC is done with the following variables. (For C more details, please see the comments in the driver subroutine.) C Y = Vector containing predicted values on entry. C YH = The Nordsieck array, an LDYH by LMAX array, input. C LDYH = A constant .ge. N, the first dimension of YH, input. C EWT = An error weight vector of length N. C SAVF = Array containing f evaluated at predicted y, input. C WM = Complex work space for matrices. In the output, it C contains the inverse diagonal matrix if MITER = 3 and C the LU decomposition of P if MITER is 1, 2 , 4, or 5. C Storage of the saved Jacobian starts at WM(LOCJS). C IWM = Integer work space containing pivot information, C starting at IWM(31), if MITER is 1, 2, 4, or 5. C IWM also contains band parameters ML = IWM(1) and C MU = IWM(2) if MITER is 4 or 5. C F = Dummy name for the user-supplied subroutine for f. C JAC = Dummy name for the user-supplied Jacobian subroutine. C RPAR, IPAR = User's real/complex and integer work arrays. C RL1 = 1/EL(2) (input). C IERPJ = Output error flag, = 0 if no trouble, 1 if the P C matrix is found to be singular. C JCUR = Output flag to indicate whether the Jacobian matrix C (or approximation) is now current. C JCUR = 0 means J is not current. C JCUR = 1 means J is current. C----------------------------------------------------------------------- C C Type declarations for labeled COMMON block ZVOD01 -------------------- C DOUBLE PRECISION ACNRM, CCMXJ, CONP, CRATE, DRC, EL, 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HRL1, HSCAL, PRL1, 2 RC, RL1, SRUR, TAU, TQ, TN, UROUND INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, 1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, 2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, 3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, 4 NSLP, NYH C C Type declarations for labeled COMMON block ZVOD02 -------------------- C DOUBLE PRECISION HU INTEGER NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST C C Type declarations for local variables -------------------------------- C COMPLEX(KIND=8) DI, R1, YI, YJ, YJJ DOUBLE PRECISION CON, FAC, ONE, PT1, R, R0, THOU, ZERO INTEGER I, I1, I2, IER, II, J, J1, JJ, JOK, LENP, MBA, MBAND, 1 MEB1, MEBAND, ML, ML1, MU, NP1 C C Type declaration for function subroutines called --------------------- C DOUBLE PRECISION ZVNORM C----------------------------------------------------------------------- C The following Fortran-77 declaration is to cause the values of the C listed (local) variables to be saved between calls to this subroutine. C----------------------------------------------------------------------- SAVE ONE, PT1, THOU, ZERO C----------------------------------------------------------------------- COMMON /ZVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), ETA, 1 ETAMAX, H, HMIN, HMXI, HNEW, HRL1, HSCAL, PRL1, 2 RC, RL1, SRUR, TAU(13), TQ(5), TN, UROUND, 3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, 4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, 5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, 6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, 7 NSLP, NYH COMMON /ZVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST C DATA ONE /1.0D0/, THOU /1000.0D0/, ZERO /0.0D0/, PT1 /0.1D0/ C IERPJ = 0 HRL1 = H*RL1 C See whether J should be evaluated (JOK = -1) or not (JOK = 1). ------- JOK = JSV IF (JSV .EQ. 1) THEN IF (NST .EQ. 0 .OR. NST .GT. NSLJ+MSBJ) JOK = -1 IF (ICF .EQ. 1 .AND. DRC .LT. CCMXJ) JOK = -1 IF (ICF .EQ. 2) JOK = -1 ENDIF C End of setting JOK. -------------------------------------------------- C IF (JOK .EQ. -1 .AND. MITER .EQ. 1) THEN C If JOK = -1 and MITER = 1, call JAC to evaluate Jacobian. ------------ NJE = NJE + 1 NSLJ = NST JCUR = 1 LENP = N*N DO 110 I = 1,LENP WM(I) = ZERO 110 CONTINUE CALL JAC (N, TN, Y, 0, 0, WM, N, RPAR, IPAR) IF (JSV .EQ. 1) CALL ZCOPY (LENP, WM, 1, WM(LOCJS), 1) ENDIF C IF (JOK .EQ. -1 .AND. MITER .EQ. 2) THEN C If MITER = 2, make N calls to F to approximate the Jacobian. --------- NJE = NJE + 1 NSLJ = NST JCUR = 1 FAC = ZVNORM (N, SAVF, EWT) R0 = THOU*ABS(H)*UROUND*REAL(N)*FAC IF (R0 .EQ. ZERO) R0 = ONE J1 = 0 DO 230 J = 1,N YJ = Y(J) R = MAX(SRUR*ABS(YJ),R0/EWT(J)) Y(J) = Y(J) + R FAC = ONE/R CALL F (N, TN, Y, FTEM, RPAR, IPAR) DO 220 I = 1,N WM(I+J1) = (FTEM(I) - SAVF(I))*FAC 220 CONTINUE Y(J) = YJ J1 = J1 + N 230 CONTINUE NFE = NFE + N LENP = N*N IF (JSV .EQ. 1) CALL ZCOPY (LENP, WM, 1, WM(LOCJS), 1) ENDIF C IF (JOK .EQ. 1 .AND. (MITER .EQ. 1 .OR. MITER .EQ. 2)) THEN JCUR = 0 LENP = N*N CALL ZCOPY (LENP, WM(LOCJS), 1, WM, 1) ENDIF C IF (MITER .EQ. 1 .OR. MITER .EQ. 2) THEN C Multiply Jacobian by scalar, add identity, and do LU decomposition. -- CON = -HRL1 CALL DZSCAL (LENP, CON, WM, 1) J = 1 NP1 = N + 1 DO 250 I = 1,N WM(J) = WM(J) + ONE J = J + NP1 250 CONTINUE NLU = NLU + 1 CALL ZGEFA (WM, N, N, IWM(31), IER) IF (IER .NE. 0) IERPJ = 1 RETURN ENDIF C End of code block for MITER = 1 or 2. -------------------------------- C IF (MITER .EQ. 3) THEN C If MITER = 3, construct a diagonal approximation to J and P. --------- NJE = NJE + 1 JCUR = 1 R = RL1*PT1 DO 310 I = 1,N Y(I) = Y(I) + R*(H*SAVF(I) - YH(I,2)) 310 CONTINUE CALL F (N, TN, Y, WM, RPAR, IPAR) NFE = NFE + 1 DO 320 I = 1,N R1 = H*SAVF(I) - YH(I,2) DI = PT1*R1 - H*(WM(I) - SAVF(I)) WM(I) = ONE IF (ABS(R1) .LT. UROUND/EWT(I)) GO TO 320 IF (ABS(DI) .EQ. ZERO) GO TO 330 WM(I) = PT1*R1/DI 320 CONTINUE RETURN 330 IERPJ = 1 RETURN ENDIF C End of code block for MITER = 3. ------------------------------------- C C Set constants for MITER = 4 or 5. ------------------------------------ ML = IWM(1) MU = IWM(2) ML1 = ML + 1 MBAND = ML + MU + 1 MEBAND = MBAND + ML LENP = MEBAND*N C IF (JOK .EQ. -1 .AND. MITER .EQ. 4) THEN C If JOK = -1 and MITER = 4, call JAC to evaluate Jacobian. ------------ NJE = NJE + 1 NSLJ = NST JCUR = 1 DO 410 I = 1,LENP WM(I) = ZERO 410 CONTINUE CALL JAC (N, TN, Y, ML, MU, WM(ML1), MEBAND, RPAR, IPAR) IF (JSV .EQ. 1) 1 CALL ZACOPY (MBAND, N, WM(ML1), MEBAND, WM(LOCJS), MBAND) ENDIF C IF (JOK .EQ. -1 .AND. MITER .EQ. 5) THEN C If MITER = 5, make ML+MU+1 calls to F to approximate the Jacobian. --- NJE = NJE + 1 NSLJ = NST JCUR = 1 MBA = MIN(MBAND,N) MEB1 = MEBAND - 1 FAC = ZVNORM (N, SAVF, EWT) R0 = THOU*ABS(H)*UROUND*REAL(N)*FAC IF (R0 .EQ. ZERO) R0 = ONE DO 560 J = 1,MBA DO 530 I = J,N,MBAND YI = Y(I) R = MAX(SRUR*ABS(YI),R0/EWT(I)) Y(I) = Y(I) + R 530 CONTINUE CALL F (N, TN, Y, FTEM, RPAR, IPAR) DO 550 JJ = J,N,MBAND Y(JJ) = YH(JJ,1) YJJ = Y(JJ) R = MAX(SRUR*ABS(YJJ),R0/EWT(JJ)) FAC = ONE/R I1 = MAX(JJ-MU,1) I2 = MIN(JJ+ML,N) II = JJ*MEB1 - ML DO 540 I = I1,I2 WM(II+I) = (FTEM(I) - SAVF(I))*FAC 540 CONTINUE 550 CONTINUE 560 CONTINUE NFE = NFE + MBA IF (JSV .EQ. 1) 1 CALL ZACOPY (MBAND, N, WM(ML1), MEBAND, WM(LOCJS), MBAND) ENDIF C IF (JOK .EQ. 1) THEN JCUR = 0 CALL ZACOPY (MBAND, N, WM(LOCJS), MBAND, WM(ML1), MEBAND) ENDIF C C Multiply Jacobian by scalar, add identity, and do LU decomposition. CON = -HRL1 CALL DZSCAL (LENP, CON, WM, 1 ) II = MBAND DO 580 I = 1,N WM(II) = WM(II) + ONE II = II + MEBAND 580 CONTINUE NLU = NLU + 1 CALL ZGBFA (WM, MEBAND, N, ML, MU, IWM(31), IER) IF (IER .NE. 0) IERPJ = 1 RETURN C End of code block for MITER = 4 or 5. -------------------------------- C C----------------------- End of Subroutine ZVJAC ----------------------- END *DECK ZACOPY SUBROUTINE ZACOPY (NROW, NCOL, A, NROWA, B, NROWB) COMPLEX(KIND=8) A, B INTEGER NROW, NCOL, NROWA, NROWB DIMENSION A(NROWA,NCOL), B(NROWB,NCOL) C----------------------------------------------------------------------- C Call sequence input -- NROW, NCOL, A, NROWA, NROWB C Call sequence output -- B C COMMON block variables accessed -- None C C Subroutines called by ZACOPY: ZCOPY C Function routines called by ZACOPY: None C----------------------------------------------------------------------- C This routine copies one rectangular array, A, to another, B, C where A and B may have different row dimensions, NROWA and NROWB. C The data copied consists of NROW rows and NCOL columns. C----------------------------------------------------------------------- INTEGER IC C DO 20 IC = 1,NCOL CALL ZCOPY (NROW, A(1,IC), 1, B(1,IC), 1) 20 CONTINUE C RETURN C----------------------- End of Subroutine ZACOPY ---------------------- END *DECK ZVSOL SUBROUTINE ZVSOL (WM, IWM, X, IERSL) COMPLEX(KIND=8) WM, X INTEGER IWM, IERSL DIMENSION WM(*), IWM(*), X(*) C----------------------------------------------------------------------- C Call sequence input -- WM, IWM, X C Call sequence output -- X, IERSL C COMMON block variables accessed: C /ZVOD01/ -- H, HRL1, RL1, MITER, N C C Subroutines called by ZVSOL: ZGESL, ZGBSL C Function routines called by ZVSOL: None C----------------------------------------------------------------------- C This routine manages the solution of the linear system arising from C a chord iteration. It is called if MITER .ne. 0. C If MITER is 1 or 2, it calls ZGESL to accomplish this. C If MITER = 3 it updates the coefficient H*RL1 in the diagonal C matrix, and then computes the solution. C If MITER is 4 or 5, it calls ZGBSL. C Communication with ZVSOL uses the following variables: C WM = Real work space containing the inverse diagonal matrix if C MITER = 3 and the LU decomposition of the matrix otherwise. C IWM = Integer work space containing pivot information, starting at C IWM(31), if MITER is 1, 2, 4, or 5. IWM also contains band C parameters ML = IWM(1) and MU = IWM(2) if MITER is 4 or 5. C X = The right-hand side vector on input, and the solution vector C on output, of length N. C IERSL = Output flag. IERSL = 0 if no trouble occurred. C IERSL = 1 if a singular matrix arose with MITER = 3. C----------------------------------------------------------------------- C C Type declarations for labeled COMMON block ZVOD01 -------------------- C DOUBLE PRECISION ACNRM, CCMXJ, CONP, CRATE, DRC, EL, 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HRL1, HSCAL, PRL1, 2 RC, RL1, SRUR, TAU, TQ, TN, UROUND INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, 1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, 2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, 3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, 4 NSLP, NYH C C Type declarations for local variables -------------------------------- C COMPLEX(KIND=8) DI DOUBLE PRECISION ONE, PHRL1, R, ZERO INTEGER I, MEBAND, ML, MU C----------------------------------------------------------------------- C The following Fortran-77 declaration is to cause the values of the C listed (local) variables to be saved between calls to this integrator. C----------------------------------------------------------------------- SAVE ONE, ZERO C COMMON /ZVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), ETA, 1 ETAMAX, H, HMIN, HMXI, HNEW, HRL1, HSCAL, PRL1, 2 RC, RL1, SRUR, TAU(13), TQ(5), TN, UROUND, 3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, 4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, 5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, 6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, 7 NSLP, NYH C DATA ONE /1.0D0/, ZERO /0.0D0/ C IERSL = 0 IF (MITER .EQ. 1 .OR. MITER .EQ. 2) THEN GOTO 100 ELSE IF (MITER .EQ. 3) THEN GOTO 300 ELSE IF (MITER .LE. 5) THEN GOTO 400 ENDIF C GO TO (100, 100, 300, 400, 400), MITER 100 CALL ZGESL (WM, N, N, IWM(31), X, 0) RETURN C 300 PHRL1 = HRL1 HRL1 = H*RL1 IF (HRL1 .EQ. PHRL1) GO TO 330 R = HRL1/PHRL1 DO 320 I = 1,N DI = ONE - R*(ONE - ONE/WM(I)) IF (ABS(DI) .EQ. ZERO) GO TO 390 WM(I) = ONE/DI 320 CONTINUE C 330 DO 340 I = 1,N X(I) = WM(I)*X(I) 340 CONTINUE RETURN 390 IERSL = 1 RETURN C 400 ML = IWM(1) MU = IWM(2) MEBAND = 2*ML + MU + 1 CALL ZGBSL (WM, MEBAND, N, ML, MU, IWM(31), X, 0) RETURN C----------------------- End of Subroutine ZVSOL ----------------------- END *DECK ZVSRCO SUBROUTINE ZVSRCO (RSAV, ISAV, JOB) DOUBLE PRECISION RSAV INTEGER ISAV, JOB DIMENSION RSAV(*), ISAV(*) C----------------------------------------------------------------------- C Call sequence input -- RSAV, ISAV, JOB C Call sequence output -- RSAV, ISAV C COMMON block variables accessed -- All of /ZVOD01/ and /ZVOD02/ C C Subroutines/functions called by ZVSRCO: None C----------------------------------------------------------------------- C This routine saves or restores (depending on JOB) the contents of the C COMMON blocks ZVOD01 and ZVOD02, which are used internally by ZVODE. C C RSAV = real array of length 51 or more. C ISAV = integer array of length 41 or more. C JOB = flag indicating to save or restore the COMMON blocks: C JOB = 1 if COMMON is to be saved (written to RSAV/ISAV). C JOB = 2 if COMMON is to be restored (read from RSAV/ISAV). C A call with JOB = 2 presumes a prior call with JOB = 1. C----------------------------------------------------------------------- DOUBLE PRECISION RVOD1, RVOD2 INTEGER IVOD1, IVOD2 INTEGER I, LENIV1, LENIV2, LENRV1, LENRV2 C----------------------------------------------------------------------- C The following Fortran-77 declaration is to cause the values of the C listed (local) variables to be saved between calls to this integrator. C----------------------------------------------------------------------- SAVE LENRV1, LENIV1, LENRV2, LENIV2 C COMMON /ZVOD01/ RVOD1(50), IVOD1(33) COMMON /ZVOD02/ RVOD2(1), IVOD2(8) DATA LENRV1/50/, LENIV1/33/, LENRV2/1/, LENIV2/8/ C IF (JOB .EQ. 2) GO TO 100 DO 10 I = 1,LENRV1 RSAV(I) = RVOD1(I) 10 CONTINUE DO 15 I = 1,LENRV2 RSAV(LENRV1+I) = RVOD2(I) 15 CONTINUE C DO 20 I = 1,LENIV1 ISAV(I) = IVOD1(I) 20 CONTINUE DO 25 I = 1,LENIV2 ISAV(LENIV1+I) = IVOD2(I) 25 CONTINUE C RETURN C 100 CONTINUE DO 110 I = 1,LENRV1 RVOD1(I) = RSAV(I) 110 CONTINUE DO 115 I = 1,LENRV2 RVOD2(I) = RSAV(LENRV1+I) 115 CONTINUE C DO 120 I = 1,LENIV1 IVOD1(I) = ISAV(I) 120 CONTINUE DO 125 I = 1,LENIV2 IVOD2(I) = ISAV(LENIV1+I) 125 CONTINUE C RETURN C----------------------- End of Subroutine ZVSRCO ---------------------- END *DECK ZEWSET SUBROUTINE ZEWSET (N, ITOL, RTOL, ATOL, YCUR, EWT) C***BEGIN PROLOGUE ZEWSET C***SUBSIDIARY C***PURPOSE Set error weight vector. C***TYPE DOUBLE PRECISION (SEWSET-S, DEWSET-D, ZEWSET-Z) C***AUTHOR Hindmarsh, Alan C., (LLNL) C***DESCRIPTION C C This subroutine sets the error weight vector EWT according to C EWT(i) = RTOL(i)*ABS(YCUR(i)) + ATOL(i), i = 1,...,N, C with the subscript on RTOL and/or ATOL possibly replaced by 1 above, C depending on the value of ITOL. C C***SEE ALSO DLSODE C***ROUTINES CALLED (NONE) C***REVISION HISTORY (YYMMDD) C 060502 DATE WRITTEN, modified from DEWSET of 930809. C***END PROLOGUE ZEWSET COMPLEX(KIND=8) YCUR DOUBLE PRECISION RTOL, ATOL, EWT INTEGER N, ITOL INTEGER I DIMENSION RTOL(*), ATOL(*), YCUR(N), EWT(N) C C***FIRST EXECUTABLE STATEMENT ZEWSET IF (ITOL .EQ. 1) THEN GOTO 10 ELSE IF (ITOL .EQ. 2) THEN GOTO 20 ELSE IF (ITOL .EQ. 3) THEN GOTO 30 ELSE IF (ITOL .EQ. 4) THEN GOTO 40 ENDIF C GO TO (10, 20, 30, 40), ITOL 10 CONTINUE DO 15 I = 1,N EWT(I) = RTOL(1)*ABS(YCUR(I)) + ATOL(1) 15 CONTINUE RETURN 20 CONTINUE DO 25 I = 1,N EWT(I) = RTOL(1)*ABS(YCUR(I)) + ATOL(I) 25 CONTINUE RETURN 30 CONTINUE DO 35 I = 1,N EWT(I) = RTOL(I)*ABS(YCUR(I)) + ATOL(1) 35 CONTINUE RETURN 40 CONTINUE DO 45 I = 1,N EWT(I) = RTOL(I)*ABS(YCUR(I)) + ATOL(I) 45 CONTINUE RETURN C----------------------- END OF SUBROUTINE ZEWSET ---------------------- END *DECK ZVNORM DOUBLE PRECISION FUNCTION ZVNORM (N, V, W) C***BEGIN PROLOGUE ZVNORM C***SUBSIDIARY C***PURPOSE Weighted root-mean-square vector norm. C***TYPE DOUBLE COMPLEX (SVNORM-S, DVNORM-D, ZVNORM-Z) C***AUTHOR Hindmarsh, Alan C., (LLNL) C***DESCRIPTION C C This function routine computes the weighted root-mean-square norm C of the vector of length N contained in the double complex array V, C with weights contained in the array W of length N: C ZVNORM = SQRT( (1/N) * SUM( abs(V(i))**2 * W(i)**2 ) C The squared absolute value abs(v)**2 is computed by ZABSSQ. C C***SEE ALSO DLSODE C***ROUTINES CALLED ZABSSQ C***REVISION HISTORY (YYMMDD) C 060502 DATE WRITTEN, modified from DVNORM of 930809. C***END PROLOGUE ZVNORM COMPLEX(KIND=8) V DOUBLE PRECISION W, SUM, ZABSSQ INTEGER N, I DIMENSION V(N), W(N) C C***FIRST EXECUTABLE STATEMENT ZVNORM SUM = 0.0D0 DO 10 I = 1,N SUM = SUM + ZABSSQ(V(I)) * W(I)**2 10 CONTINUE ZVNORM = SQRT(SUM/N) RETURN C----------------------- END OF FUNCTION ZVNORM ------------------------ END *DECK ZABSSQ DOUBLE PRECISION FUNCTION ZABSSQ(Z) C***BEGIN PROLOGUE ZABSSQ C***SUBSIDIARY C***PURPOSE Squared absolute value of a double complex number. C***TYPE DOUBLE PRECISION (ZABSSQ-Z) C***AUTHOR Hindmarsh, Alan C., (LLNL) C***DESCRIPTION C C This function routine computes the square of the absolute value of C a double precision complex number Z, C ZABSSQ = DREAL(Z)**2 * DIMAG(Z)**2 C***REVISION HISTORY (YYMMDD) C 060502 DATE WRITTEN. C***END PROLOGUE ZABSSQ COMPLEX(KIND=8) Z ZABSSQ = DREAL(Z)**2 + DIMAG(Z)**2 RETURN C----------------------- END OF FUNCTION ZABSSQ ------------------------ END *DECK DZSCAL SUBROUTINE DZSCAL(N, DA, ZX, INCX) C***BEGIN PROLOGUE DZSCAL C***SUBSIDIARY C***PURPOSE Scale a double complex vector by a double prec. constant. C***TYPE DOUBLE PRECISION (DZSCAL-Z) C***AUTHOR Hindmarsh, Alan C., (LLNL) C***DESCRIPTION C Scales a double complex vector by a double precision constant. C Minor modification of BLAS routine ZSCAL. C***REVISION HISTORY (YYMMDD) C 060530 DATE WRITTEN. C***END PROLOGUE DZSCAL COMPLEX(KIND=8) ZX(*) DOUBLE PRECISION DA INTEGER I,INCX,IX,N C IF( N.LE.0 .OR. INCX.LE.0 )RETURN IF(INCX.EQ.1)GO TO 20 C Code for increment not equal to 1 IX = 1 DO 10 I = 1,N ZX(IX) = DA*ZX(IX) IX = IX + INCX 10 CONTINUE RETURN C Code for increment equal to 1 20 DO 30 I = 1,N ZX(I) = DA*ZX(I) 30 CONTINUE RETURN END *DECK DZAXPY SUBROUTINE DZAXPY(N, DA, ZX, INCX, ZY, INCY) C***BEGIN PROLOGUE DZAXPY C***PURPOSE Real constant times a complex vector plus a complex vector. C***TYPE DOUBLE PRECISION (DZAXPY-Z) C***AUTHOR Hindmarsh, Alan C., (LLNL) C***DESCRIPTION C Add a D.P. real constant times a complex vector to a complex vector. C Minor modification of BLAS routine ZAXPY. C***REVISION HISTORY (YYMMDD) C 060530 DATE WRITTEN. C***END PROLOGUE DZAXPY COMPLEX(KIND=8) ZX(*),ZY(*) DOUBLE PRECISION DA INTEGER I,INCX,INCY,IX,IY,N IF(N.LE.0)RETURN IF (ABS(DA) .EQ. 0.0D0) RETURN IF (INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 C Code for unequal increments or equal increments not equal to 1 IX = 1 IY = 1 IF(INCX.LT.0)IX = (-N+1)*INCX + 1 IF(INCY.LT.0)IY = (-N+1)*INCY + 1 DO 10 I = 1,N ZY(IY) = ZY(IY) + DA*ZX(IX) IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN C Code for both increments equal to 1 20 DO 30 I = 1,N ZY(I) = ZY(I) + DA*ZX(I) 30 CONTINUE RETURN END subroutine zgesl(a,lda,n,ipvt,b,job) integer lda,n,ipvt(1),job COMPLEX(KIND=8) a(lda,*),b(*) c c zgesl solves the COMPLEX(KIND=8) system c a * x = b or ctrans(a) * x = b c using the factors computed by zgeco or zgefa. c c on entry c c a COMPLEX(KIND=8)(lda, n) c the output from zgeco or zgefa. c c lda integer c the leading dimension of the array a . c c n integer c the order of the matrix a . c c ipvt integer(n) c the pivot vector from zgeco or zgefa. c c b COMPLEX(KIND=8)(n) c the right hand side vector. c c job integer c = 0 to solve a*x = b , c = nonzero to solve ctrans(a)*x = b where c ctrans(a) is the conjugate transpose. c c on return c c b the solution vector x . c c error condition c c a division by zero will occur if the input factor contains a c zero on the diagonal. technically this indicates singularity c but it is often caused by improper arguments or improper c setting of lda . it will not occur if the subroutines are c called correctly and if zgeco has set rcond .gt. 0.0 c or zgefa has set info .eq. 0 . c c to compute inverse(a) * c where c is a matrix c with p columns c call zgeco(a,lda,n,ipvt,rcond,z) c if (rcond is too small) go to ... c do 10 j = 1, p c call zgesl(a,lda,n,ipvt,c(1,j),0) c 10 continue c c linpack. this version dated 08/14/78 . c cleve moler, university of new mexico, argonne national lab. c c subroutines and functions c c blas zaxpy,zdotc c fortran dconjg c c internal variables c COMPLEX(KIND=8) zdotc,t integer k,kb,l,nm1 C KS double precision dreal,dimag C KS COMPLEX(KIND=8) zdumr,zdumi C KS dreal(zdumr) = zdumr C KS dimag(zdumi) = (0.0d0,-1.0d0)*zdumi c nm1 = n - 1 if (job .ne. 0) go to 50 c c job = 0 , solve a * x = b c first solve l*y = b c if (nm1 .lt. 1) go to 30 do 20 k = 1, nm1 l = ipvt(k) t = b(l) if (l .eq. k) go to 10 b(l) = b(k) b(k) = t 10 continue call zaxpy(n-k,t,a(k+1,k),1,b(k+1),1) 20 continue 30 continue c c now solve u*x = y c do 40 kb = 1, n k = n + 1 - kb b(k) = b(k)/a(k,k) t = -b(k) call zaxpy(k-1,t,a(1,k),1,b(1),1) 40 continue go to 100 50 continue c c job = nonzero, solve ctrans(a) * x = b c first solve ctrans(u)*y = b c do 60 k = 1, n t = zdotc(k-1,a(1,k),1,b(1),1) b(k) = (b(k) - t)/dconjg(a(k,k)) 60 continue c c now solve ctrans(l)*x = y c if (nm1 .lt. 1) go to 90 do 80 kb = 1, nm1 k = n - kb b(k) = b(k) + zdotc(n-k,a(k+1,k),1,b(k+1),1) l = ipvt(k) if (l .eq. k) go to 70 t = b(l) b(l) = b(k) b(k) = t 70 continue 80 continue 90 continue 100 continue return end subroutine zgbfa(abd,lda,n,ml,mu,ipvt,info) integer lda,n,ml,mu,ipvt(*),info COMPLEX(KIND=8) abd(lda,*) c c zgbfa factors a COMPLEX(KIND=8) band matrix by elimination. c c zgbfa is usually called by zgbco, but it can be called c directly with a saving in time if rcond is not needed. c c on entry c c abd COMPLEX(KIND=8)(lda, n) c contains the matrix in band storage. the columns c of the matrix are stored in the columns of abd and c the diagonals of the matrix are stored in rows c ml+1 through 2*ml+mu+1 of abd . c see the comments below for details. c c lda integer c the leading dimension of the array abd . c lda must be .ge. 2*ml + mu + 1 . c c n integer c the order of the original matrix. c c ml integer c number of diagonals below the main diagonal. c 0 .le. ml .lt. n . c c mu integer c number of diagonals above the main diagonal. c 0 .le. mu .lt. n . c more efficient if ml .le. mu . c on return c c abd an upper triangular matrix in band storage and c the multipliers which were used to obtain it. c the factorization can be written a = l*u where c l is a product of permutation and unit lower c triangular matrices and u is upper triangular. c c ipvt integer(n) c an integer vector of pivot indices. c c info integer c = 0 normal value. c = k if u(k,k) .eq. 0.0 . this is not an error c condition for this subroutine, but it does c indicate that zgbsl will divide by zero if c called. use rcond in zgbco for a reliable c indication of singularity. c c band storage c c if a is a band matrix, the following program segment c will set up the input. c c ml = (band width below the diagonal) c mu = (band width above the diagonal) c m = ml + mu + 1 c do 20 j = 1, n c i1 = max0(1, j-mu) c i2 = min0(n, j+ml) c do 10 i = i1, i2 c k = i - j + m c abd(k,j) = a(i,j) c 10 continue c 20 continue c c this uses rows ml+1 through 2*ml+mu+1 of abd . c in addition, the first ml rows in abd are used for c elements generated during the triangularization. c the total number of rows needed in abd is 2*ml+mu+1 . c the ml+mu by ml+mu upper left triangle and the c ml by ml lower right triangle are not referenced. c c linpack. this version dated 08/14/78 . c cleve moler, university of new mexico, argonne national lab. c c subroutines and functions c c blas zaxpy,zscal,izamax c fortran dabs,max0,min0 c c internal variables c COMPLEX(KIND=8) t integer i,izamax,i0,j,ju,jz,j0,j1,k,kp1,l,lm,m,mm,nm1 c CKS COMPLEX(KIND=8) zdum double precision cabs1 C double precision dreal,dimag C COMPLEX(KIND=8) zdumr,zdumi C dreal(zdumr) = zdumr C dimag(zdumi) = (0.0d0,-1.0d0)*zdumi CKS cabs1(zdum) = dabs(dreal(zdum)) + dabs(dimag(zdum)) c m = ml + mu + 1 info = 0 c c zero initial fill-in columns c j0 = mu + 2 j1 = min0(n,m) - 1 if (j1 .lt. j0) go to 30 do 20 jz = j0, j1 i0 = m + 1 - jz do 10 i = i0, ml abd(i,jz) = (0.0d0,0.0d0) 10 continue 20 continue 30 continue jz = j1 ju = 0 c c gaussian elimination with partial pivoting c nm1 = n - 1 if (nm1 .lt. 1) go to 130 do 120 k = 1, nm1 kp1 = k + 1 c c zero next fill-in column c jz = jz + 1 if (jz .gt. n) go to 50 if (ml .lt. 1) go to 50 do 40 i = 1, ml abd(i,jz) = (0.0d0,0.0d0) 40 continue 50 continue c c find l = pivot index c lm = min0(ml,n-k) l = izamax(lm+1,abd(m,k),1) + m - 1 ipvt(k) = l + k - m c c zero pivot implies this column already triangularized c if (cabs1(abd(l,k)) .eq. 0.0d0) go to 100 c c interchange if necessary c if (l .eq. m) go to 60 t = abd(l,k) abd(l,k) = abd(m,k) abd(m,k) = t 60 continue c c compute multipliers c t = -(1.0d0,0.0d0)/abd(m,k) call zscal(lm,t,abd(m+1,k),1) c c row elimination with column indexing c ju = min0(max0(ju,mu+ipvt(k)),n) mm = m if (ju .lt. kp1) go to 90 do 80 j = kp1, ju l = l - 1 mm = mm - 1 t = abd(l,j) if (l .eq. mm) go to 70 abd(l,j) = abd(mm,j) abd(mm,j) = t 70 continue call zaxpy(lm,t,abd(m+1,k),1,abd(mm+1,j),1) 80 continue 90 continue go to 110 100 continue info = k 110 continue 120 continue 130 continue ipvt(n) = n if (cabs1(abd(m,n)) .eq. 0.0d0) info = n return end subroutine zgbsl(abd,lda,n,ml,mu,ipvt,b,job) integer lda,n,ml,mu,ipvt(1),job COMPLEX(KIND=8) abd(lda,*),b(*) c c zgbsl solves the COMPLEX(KIND=8) band system c a * x = b or ctrans(a) * x = b c using the factors computed by zgbco or zgbfa. c c on entry c c abd COMPLEX(KIND=8)(lda, n) c the output from zgbco or zgbfa. c c lda integer c the leading dimension of the array abd . c c n integer c the order of the original matrix. c c ml integer c number of diagonals below the main diagonal. c c mu integer c number of diagonals above the main diagonal. c c ipvt integer(n) c the pivot vector from zgbco or zgbfa. c c b COMPLEX(KIND=8)(n) c the right hand side vector. c c job integer c = 0 to solve a*x = b , c = nonzero to solve ctrans(a)*x = b , where c ctrans(a) is the conjugate transpose. c c on return c c b the solution vector x . c c error condition c c a division by zero will occur if the input factor contains a c zero on the diagonal. technically this indicates singularity c but it is often caused by improper arguments or improper c setting of lda . it will not occur if the subroutines are c called correctly and if zgbco has set rcond .gt. 0.0 c or zgbfa has set info .eq. 0 . c c to compute inverse(a) * c where c is a matrix c with p columns c call zgbco(abd,lda,n,ml,mu,ipvt,rcond,z) c if (rcond is too small) go to ... c do 10 j = 1, p c call zgbsl(abd,lda,n,ml,mu,ipvt,c(1,j),0) c 10 continue c c linpack. this version dated 08/14/78 . c cleve moler, university of new mexico, argonne national lab. c c subroutines and functions c c blas zaxpy,zdotc c fortran dconjg,min0 c c internal variables c COMPLEX(KIND=8) zdotc,t integer k,kb,l,la,lb,lm,m,nm1 C double precision dreal,dimag C COMPLEX(KIND=8) zdumr,zdumi C dreal(zdumr) = zdumr C dimag(zdumi) = (0.0d0,-1.0d0)*zdumi c m = mu + ml + 1 nm1 = n - 1 if (job .ne. 0) go to 50 c c job = 0 , solve a * x = b c first solve l*y = b c if (ml .eq. 0) go to 30 if (nm1 .lt. 1) go to 30 do 20 k = 1, nm1 lm = min0(ml,n-k) l = ipvt(k) t = b(l) if (l .eq. k) go to 10 b(l) = b(k) b(k) = t 10 continue call zaxpy(lm,t,abd(m+1,k),1,b(k+1),1) 20 continue 30 continue c c now solve u*x = y c do 40 kb = 1, n k = n + 1 - kb b(k) = b(k)/abd(m,k) lm = min0(k,m) - 1 la = m - lm lb = k - lm t = -b(k) call zaxpy(lm,t,abd(la,k),1,b(lb),1) 40 continue go to 100 50 continue c c job = nonzero, solve ctrans(a) * x = b c first solve ctrans(u)*y = b c do 60 k = 1, n lm = min0(k,m) - 1 la = m - lm lb = k - lm t = zdotc(lm,abd(la,k),1,b(lb),1) b(k) = (b(k) - t)/dconjg(abd(m,k)) 60 continue c c now solve ctrans(l)*x = y c if (ml .eq. 0) go to 90 if (nm1 .lt. 1) go to 90 do 80 kb = 1, nm1 k = n - kb lm = min0(ml,n-k) b(k) = b(k) + zdotc(lm,abd(m+1,k),1,b(k+1),1) l = ipvt(k) if (l .eq. k) go to 70 t = b(l) b(l) = b(k) b(k) = t 70 continue 80 continue 90 continue 100 continue return end C KARLINE: created true functions out of these statement functions C Thomas: removed function definitions for dreal and dimag, C they were already existing. C We may consider to use 'real' and 'imag' consistently for C future versions. double precision function cabs1(zdum) complex (kind = 8), intent (in) :: zdum cabs1 = dabs(dreal(zdum)) + dabs(dimag(zdum)) end function C KARLINE: end new functions subroutine zgefa(a,lda,n,ipvt,info) integer lda,n,ipvt(*),info COMPLEX(KIND=8) a(lda,*) c c zgefa factors a COMPLEX(KIND=8) matrix by gaussian elimination. c c zgefa is usually called by zgeco, but it can be called c directly with a saving in time if rcond is not needed. c (time for zgeco) = (1 + 9/n)*(time for zgefa) . c c on entry c c a COMPLEX(KIND=8)(lda, n) c the matrix to be factored. c c lda integer c the leading dimension of the array a . c c n integer c the order of the matrix a . c c on return c c a an upper triangular matrix and the multipliers c which were used to obtain it. c the factorization can be written a = l*u where c l is a product of permutation and unit lower c triangular matrices and u is upper triangular. c c ipvt integer(n) c an integer vector of pivot indices. c c info integer c = 0 normal value. c = k if u(k,k) .eq. 0.0 . this is not an error c condition for this subroutine, but it does c indicate that zgesl or zgedi will divide by zero c if called. use rcond in zgeco for a reliable c indication of singularity. c c linpack. this version dated 08/14/78 . c cleve moler, university of new mexico, argonne national lab. c c subroutines and functions c c blas zaxpy,zscal,izamax c fortran dabs c c internal variables c COMPLEX(KIND=8) t integer izamax,j,k,kp1,l,nm1 c C KS COMPLEX(KIND=8) zdum double precision cabs1 C double precision dreal,dimag C KS COMPLEX(KIND=8) zdumr,zdumi C Karline: next three statement functions replaced with true functions above C dreal(zdumr) = zdumr C dimag(zdumi) = (0.0d0,-1.0d0)*zdumi C cabs1(zdum) = dabs(dreal(zdum)) + dabs(dimag(zdum)) c c gaussian elimination with partial pivoting c info = 0 nm1 = n - 1 if (nm1 .lt. 1) go to 70 do 60 k = 1, nm1 kp1 = k + 1 c c find l = pivot index c l = izamax(n-k+1,a(k,k),1) + k - 1 ipvt(k) = l c c zero pivot implies this column already triangularized c if (cabs1(a(l,k)) .eq. 0.0d0) go to 40 c c interchange if necessary c if (l .eq. k) go to 10 t = a(l,k) a(l,k) = a(k,k) a(k,k) = t 10 continue c c compute multipliers c t = -(1.0d0,0.0d0)/a(k,k) call zscal(n-k,t,a(k+1,k),1) c c row elimination with column indexing c do 30 j = kp1, n t = a(l,j) if (l .eq. k) go to 20 a(l,j) = a(k,j) a(k,j) = t 20 continue call zaxpy(n-k,t,a(k+1,k),1,a(k+1,j),1) 30 continue go to 50 40 continue info = k 50 continue 60 continue 70 continue ipvt(n) = n if (cabs1(a(n,n)) .eq. 0.0d0) info = n return end deSolve/src/errmsg.f0000754000175100001440000000716613131751003014134 0ustar hornikusers subroutine rprint(msg) character (len=*) msg call dblepr(msg, -1, 0, 0) end subroutine subroutine rprintid(msg, i1, d1) character (len=*) msg double precision d1 integer i1 call dblepr(msg, -1, d1, 1) call intpr(" ", -1, i1, 1) end subroutine subroutine rprintd1(msg, d1) character (len=*) msg double precision d1 call dblepr(msg, -1, d1, 1) end subroutine subroutine rprintd2(msg, d1, d2) character (len=*) msg double precision DBL(2), d1, d2 DBL(1) = d1 DBL(2) = d2 call dblepr(msg, -1, DBL, 2) end subroutine subroutine rprinti1(msg, i1) character (len=*) msg integer i1 call intpr(msg, -1, i1, 1) end subroutine subroutine rprinti2(msg, i1, i2) character (len=*) msg INTEGER IN(2), i1, i2 IN(1) = i1 IN(2) = i2 call intpr(msg, -1, IN, 2) end subroutine subroutine rprinti3(msg, i1, i2, i3) character (len=*) msg INTEGER IN(3), i1, i2, i3 IN(1) = i1 IN(2) = i2 IN(3) = i3 call intpr(msg, -1, IN, 3) end subroutine subroutine rprint2(msg) implicit none character (len = *) msg call dblepr(msg, 61, 0, 0) end subroutine *DECK XERRWD SUBROUTINE XERRWD (MSG, NMES, NERR, LEVEL, NI, I1, I2, NR, R1, R2) C***PURPOSE Write error message with values. C***original AUTHOR Hindmarsh, Alan C., (LLNL) C Rewritten to be used with R by Karline Soetaert C C All arguments are input arguments. C C MSG = The message (character array). C NMES = The length of MSG (number of characters). C NERR = The error number (not used). C LEVEL = The error level.. C 0 or 1 means recoverable (control returns to caller). C 2 means fatal (run is aborted--see note below). C NI = Number of integers (0, 1, or 2) to be printed with message. C I1,I2 = Integers to be printed, depending on NI. C NR = Number of reals (0, 1, or 2) to be printed with message. C R1,R2 = Reals to be printed, depending on NR. C C----------------------------------------------------------------------- C C Declare arguments. C DOUBLE PRECISION R1, R2, RVEC(2), Dummy INTEGER NMES, NERR, LEVEL, NI, I1, I2, NR, Ivec(2) CHARACTER(LEN=*) MSG INTEGER IXSAV dummy = 0.d0 C call dblepr(MSG, NMES, dummy, 0) MSG = MSG(1:NMES) // char(0) call rprintf(MSG) IF (NI .EQ. 1) THEN C call intpr('In above message, I = ', 22, I1, 1) MSG = 'In above message, I1 = %d' // char(0) call rprintfi1(MSG, I1) MSG = ' ' // char(0) call rprintf(MSG) ENDIF IF (NI .EQ. 2) THEN IVEC(1) = I1 IVEC(2) = I2 C call intpr('In above message, I = ', 22, IVEC, 2) MSG = 'In above message, I1 = %d, I2 = %d' // char(0) call rprintfi2(MSG, I1, I2) MSG = ' ' // char(0) call rprintf(MSG) ENDIF IF (NR .EQ. 1) THEN C call dblepr('In above message, R = ', 22, R1, 1) MSG = 'In above message, R1 = %g' // char(0) call rprintfd1(MSG, R1) MSG = ' ' // char(0) call rprintf(MSG) ENDIF IF (NR .EQ. 2) THEN RVEC(1) = R1 RVEC(2) = R2 C call dblepr('In above message, R1 = ', 22, RVEC, 2) MSG = 'In above message, R1 = %g, R2 = %g' // char(0) call rprintfd2(MSG, R1, R2) MSG = ' ' // char(0) call rprintf(MSG) ENDIF C Abort the run if LEVEL = 2. if (LEVEL .eq. 2) call rexit ("fatal error") RETURN END deSolve/NAMESPACE0000754000175100001440000000124212763625671013130 0ustar hornikusersuseDynLib(deSolve) import(methods, graphics, grDevices, stats) export(aquaphy, ccl4model, SCOC, daspk, lsoda, lsodar, lsode, lsodes, ode, ode.1D, ode.2D, ode.3D, ode.band, vode, zvode, radau) export(rk, rk4, euler, euler.1D, rkMethod, lagvalue, lagderiv, dede) export(timestep, nearestEvent, cleanEventTimes, plot.1D, matplot.0D, matplot.1D, matplot.deSolve) exportPattern("^diagnostics.*") export(DLLfunc, DLLres) S3method("print", "deSolve") S3method("plot", "deSolve") S3method("image", "deSolve") S3method("hist", "deSolve") S3method("summary", "deSolve") S3method("subset", "deSolve") S3method("diagnostics", "deSolve") S3method("diagnostics", "default") deSolve/demo/0000755000175100001440000000000013131750050012610 5ustar hornikusersdeSolve/demo/odedim.R0000754000175100001440000001411512352122162014201 0ustar hornikuserspa <- par (ask=FALSE) ##===================================================== ## a predator and its prey diffusing on a flat surface ## in concentric circles ## 1-D model with using cylindrical coordinates ## Lotka-Volterra type biology ##===================================================== ## ================ ## Model equations ## ================ lvmod <- function (time, state, parms, N, rr, ri, dr, dri) { with (as.list(parms), { PREY <- state[1:N] PRED <- state[(N+1):(2*N)] ## Fluxes due to diffusion ## at internal and external boundaries: zero gradient FluxPrey <- -Da * diff(c(PREY[1], PREY, PREY[N]))/dri FluxPred <- -Da * diff(c(PRED[1], PRED, PRED[N]))/dri ## Biology: Lotka-Volterra model Ingestion <- rIng * PREY*PRED GrowthPrey <- rGrow * PREY*(1-PREY/cap) MortPredator <- rMort * PRED ## Rate of change = Flux gradient + Biology dPREY <- -diff(ri * FluxPrey)/rr/dr + GrowthPrey - Ingestion dPRED <- -diff(ri * FluxPred)/rr/dr + Ingestion*assEff -MortPredator return (list(c(dPREY, dPRED))) }) } ## ================== ## Model application ## ================== ## model parameters: R <- 20 # total radius of surface, m N <- 100 # 100 concentric circles dr <- R/N # thickness of each layer r <- seq(dr/2, by = dr, len = N) # distance of center to mid-layer ri <- seq(0, by = dr, len = N+1) # distance to layer interface dri <- dr # dispersion distances parms <- c(Da = 0.05, # m2/d, dispersion coefficient rIng = 0.2, # /day, rate of ingestion rGrow = 1.0, # /day, growth rate of prey rMort = 0.2 , # /day, mortality rate of pred assEff = 0.5, # -, assimilation efficiency cap = 10) # density, carrying capacity ## Initial conditions: both present in central circle (box 1) only state <- rep(0, 2*N) state[1] <- state[N+1] <- 10 ## RUNNING the model: times <- seq(0, 140, by = 0.1) # output wanted at these time intervals ## the model is solved by the two implemented methods: ## 1. Default: banded reformulation print(system.time( out <- ode.1D(y = state, times = times, func = lvmod, parms = parms, nspec = 2, N = N, rr = r, ri = ri, dr = dr, dri = dri) )) ## 2. Using sparse method print(system.time( out2 <- ode.1D(y = state, times = times, func = lvmod, parms = parms, nspec = 2, N = N, rr = r, ri = ri, dr = dr, dri = dri, method = "lsodes") )) # diagnostics of the run diagnostics(out) # plot results ylim <- range(out[,-1]) for (i in seq(1, length(times), by = 1)) { matplot(r, matrix(nr = N, nc = 2, out[i, -1]), main=paste("1-D L-V, day",times[i]), type="l", lwd=2, col = c("blue", "red"), xlab = "x", ylab = "y", ylim = ylim) legend("topright", c("Prey", "Predator"), col= c("blue", "red"), lwd=2) } ## ============================================================ ## A Lotka-Volterra predator-prey model with predator and prey ## dispersing in 2 dimensions ## ============================================================ lvmod2D <- function (time, state, pars, N, Da, dx) { NN <- N*N Prey <- matrix(nr = N, nc = N, state[1:NN]) Pred <- matrix(nr = N, nc = N, state[(NN+1):(2*NN)]) with (as.list(pars), { ## Biology dPrey <- rGrow* Prey *(1- Prey/K) - rIng* Prey *Pred dPred <- rIng* Prey *Pred*assEff -rMort* Pred zero <- rep(0, N) ## 1. Fluxes in x-direction; zero fluxes near boundaries FluxPrey <- -Da * rbind(zero, (Prey[2:N, ]-Prey[1:(N-1),]), zero)/dx FluxPred <- -Da * rbind(zero, (Pred[2:N, ]-Pred[1:(N-1),]), zero)/dx ## Add flux gradient to rate of change dPrey <- dPrey - (FluxPrey[2:(N+1),]-FluxPrey[1:N,])/dx dPred <- dPred - (FluxPred[2:(N+1),]-FluxPred[1:N,])/dx ## 2. Fluxes in y-direction; zero fluxes near boundaries FluxPrey <- -Da * cbind(zero, (Prey[, 2:N]-Prey[,1:(N-1)]), zero)/dx FluxPred <- -Da * cbind(zero, (Pred[,2:N]-Pred[,1:(N-1)]), zero)/dx ## Add flux gradient to rate of change dPrey <- dPrey - (FluxPrey[, 2:(N+1)]-FluxPrey[, 1:N])/dx dPred <- dPred - (FluxPred[, 2:(N+1)]-FluxPred[, 1:N])/dx return (list(c(as.vector(dPrey), as.vector(dPred)))) }) } ## =================== ## Model applications ## =================== pars <- c(rIng = 0.2, # /day, rate of ingestion rGrow = 1.0, # /day, growth rate of prey rMort = 0.2, # /day, mortality rate of predator assEff = 0.5, # -, assimilation efficiency K = 5 ) # mmol/m3, carrying capacity R <- 20 # total length of surface, m N <- 50 # number of boxes in one direction dx <- R/N # thickness of each layer Da <- 0.05 # m2/d, dispersion coefficient NN <- N*N # total number of boxes ## initial conditions yini <- rep(0, 2*N*N) cc <- c((NN/2):(NN/2+1) + N/2, (NN/2):(NN/2+1) - N/2) yini[cc] <- yini[NN + cc] <- 1 ## solve model (5000 state variables... times <- seq(0, 75, by = 0.1) out <- ode.2D(y = yini, times = times, func = lvmod2D, parms = pars, dimens = c(N, N), N = N, dx = dx, Da = Da, lrw = 500000) ## plot results Col <- colorRampPalette(c("#00007F", "blue", "#007FFF", "cyan", "#7FFF7F", "yellow", "#FF7F00", "red", "#7F0000")) zlim <- range(out[, 2:(NN+1)]) for (i in seq(1, length(times), by = 10)) filled.contour(matrix(nr = N, nc = N, out[i, 2:(NN+1)]), main=paste("2-D L-V, day", times[i]), color = Col, xlab = "x", ylab = "y", zlim = zlim) for (i in seq(1, length(times), by = 1)) { Prey <- out[i, (2+N):(1+2*N)] Pred <- out[i, NN+(2+N):(1+2*N)] matplot(1:N, cbind(Prey, Pred), main=paste("2-D L-V, day", times[i]), type = "l", lwd = 2, col = c("blue","red"), xlab = "x", ylab = "Conc", ylim = ylim) legend("topright", c("Prey", "Predator"), col = c("blue", "red"), lwd = 2) } par(pa) deSolve/demo/CCL4model.R0000754000175100001440000002562512352122162014456 0ustar hornikusers### Functions to facilitate fitting the CCl4 inhalation model initparms <- function(...) { arglist <- list(...) Pm <- numeric(36) ## The Changeable parameters are ones that can be modified on input Changeable <- c("BW", "QP", "QC", "VFC", "VLC", "VMC", "QFC", "QLC", "QMC", "PLA", "PFA", "PMA", "PTA", "PB", "MW", "VMAX", "KM", "CONC", "KL", "RATS", "VCHC") ## Computed parameters are strictly functions of the Changeable ones. Computed <- c("VCH", "AI0", "PL", "PF", "PT", "PM", "VTC", "VT", "VF", "VL", "VM", "QF", "QL", "QM", "QT") names(Pm) <- c(Changeable, Computed ) ### Physiological parameters Pm["BW"] <- 0.182 # Body weight (kg) Pm["QP"] <- 4.0 # Alveolar ventilation rate (hr^-1) Pm["QC"] <- 4.0 # Cardiac output (hr^-1) Pm["VFC"] <- 0.08 # Fraction fat tissue (kg/(kg/BW)) Pm["VLC"] <- 0.04 # Fraction liver tissue (kg/(kg/BW)) Pm["VMC"] <- 0.74 # Fraction of muscle tissue (kg/(kg/BW)) Pm["QFC"] <- 0.05 # Fractional blood flow to fat ((hr^-1)/QC Pm["QLC"] <- 0.15 # Fractional blood flow to liver ((hr^-1)/QC) Pm["QMC"] <- 0.32 # Fractional blood flow to muscle ((hr^-1)/QC) ## Chemical specific parameters for chemical Pm["PLA"] <- 16.17 # Liver/air partition coefficient Pm["PFA"] <- 281.48 # Fat/air partition coefficient Pm["PMA"] <- 13.3 # Muscle/air partition coefficient Pm["PTA"] <- 16.17 # Viscera/air partition coefficient Pm["PB"] <- 5.487 # Blood/air partition coefficient Pm["MW"] <- 153.8 # Molecular weight (g/mol) Pm["VMAX"] <- 0.11 # Maximum velocity of metabolism (mg/hr) Pm["KM"] <- 1.3 # Michaelis-Menten constant (mg/l) ## Parameters for simulated experiment Pm["CONC"] <- 1000 # Inhaled concentration Pm["KL"] <- 0.02 # Loss rate from empty chamber /hr Pm["RATS"] <- 1.0 # Number of rats enclosed in chamber Pm["VCHC"] <- 3.8 # Volume of closed chamber (l) ## Now, change anything from the argument list ## First, delete anything in arglist that is not in Changeable whichdel <- which(! names(arglist) %in% Changeable) if (length(whichdel)) { warning(paste("Parameters", paste(names(arglist)[whichdel], collapse=", "), "are not in this model\n")) } arglist[whichdel] <- NULL ## Is there anything else if (length(arglist)) { Pm[names(arglist)] <- as.vector(unlist(arglist)) } ## Computed parameter values Pm["VCH"] <- Pm["VCHC"] - Pm["RATS"]*Pm["BW"] # Net chamber volume Pm["AI0"] <- Pm["CONC"]*Pm["VCH"]*Pm["MW"]/24450 # Initial amt. in chamber (mg) Pm[c("PL", "PF", "PT", "PM")] <- Pm[c("PLA", "PFA", "PTA", "PMA")]/Pm["PB"] ## Fraction viscera (kg/(kg BW)) Pm["VTC"] <- 0.91 - sum(Pm[c("VLC", "VFC", "VMC")]) Pm[c("VT", "VF", "VL", "VM")] <- Pm[c("VTC", "VFC", "VLC", "VMC")]*Pm["BW"] Pm[c("QF", "QL", "QM")] <- Pm[c("QFC", "QLC", "QMC")]*Pm["QC"] Pm["QT"] <- Pm["QC"] - sum(Pm[c("QF", "QL", "QM")]) Pm } ### We don't actually use these functions (though they work) ### They exist because cclmodel.orig is easier to read than ccl4modelG ### The model function also computes some values that are of interest in ### checking the model and for calculating a dose metric: ### the amount metabolized (AM) ### the area under the concentration-time curve in the liver (CLT) ### and the mass balance (MASS), which should be constant if everything ### worked right. ## State variable, y, assignments. ## CI CM CT CF CL ## AI AAM AT AF AL CLT AM ## 1 2 3 4 5 6 7 initstate.orig <- function(Pm) { y <- rep(0, 7) names(y) <- c("AI", "AAM", "AT", "AF", "AL", "CLT", "AM") y["AI"] <- Pm["AI0"] y } parms <- initparms() ccl4model.orig <- with(as.list(parms), function(t, y, parms) { conc <- y[c("AI", "AAM", "AT", "AF", "AL")]/c(VCH, VM, VT, VF, VL) ## Vconc[1] is conc in mixed venous blood Vconc <- c(0, conc[2:5]/parms[c("PM", "PT", "PF", "PL")]) # '0' is a placeholder Vconc[1] <- sum(Vconc[2:5]*c(QM, QT, QF, QL))/QC ## CA is conc in arterial blood CA <- (QC * Vconc[1] + QP * conc[1])/ (QC + QP/PB) ## Exhaled chemical CX <- CA/PB ## return the derivatives and other computed items list(c(RATS*QP*(CX - conc[1]) - KL*y["AI"], QM*(CA - Vconc[2]), QT*(CA - Vconc[3]), QF*(CA - Vconc[4]), QL*(CA - Vconc[5]) - (RAM <- VMAX*Vconc[5]/(KM + Vconc[5])), conc[5], RAM), c(DOSE = as.vector(AI0 - y["AI"]), MASS = as.vector(sum(y[c("AAM","AT", "AF", "AL", "AM")])*RATS), CP=as.vector(conc[1]*24450.0/MW) )) }) ### Versions that only calculate what is needed for parameter estimation initparmmx <- function(parms) { mx <- matrix(nrow=5, ncol=7) mx[1, 6] <- parms["VCH"] mx[1, 7] <- parms["MW"] mx[4, 6] <- parms["VL"]*parms["PL"] mx[5, 6] <- parms["VMAX"] mx[5, 7] <- parms["KM"] mxx <- matrix(parms[c("QP", "QM", "QT", "QF", "QL")], nrow=5, ncol=5, byrow=TRUE) mxx <- sweep(mxx, 2, parms[c("VCH", "VM", "VT", "VF", "VL")], "/") mxx <- sweep(mxx, 2, c(1, parms[c("PM", "PT", "PF", "PL")]), "/") mxx <- mxx/(parms["QC"] + parms["QP"]/parms["PB"]) mxx <- sweep(mxx, 1, c(parms["RATS"]*parms["QP"]/parms["PB"], parms[c("QM", "QT", "QF", "QL")]), "*") dg <- diag(c(parms["RATS"]*parms["QP"]/parms["VCH"] + parms["KL"], parms[c("QM", "QT", "QF", "QL")]/ (parms[c("PM", "PT", "PF", "PL")]*parms[c("VM", "VT", "VF", "VL")]))) mxx <- mxx - dg mx[1:5, 1:5] <- mxx mx } ### Now, include the gradients wrt Vmax, Km, and initial chamber concentration initstateG <- function(Pm) { y <- rep(0, 20) names(y) <- c("AI", "AAM", "AT", "AF", "AL", "dAIdVm", "dAAMdVm", "dATdVm", "dAFdVm", "dALdVm", "dAIdK", "dAAMdK", "dATdK", "dAFdK", "dALdK", "dAIdy0", "dAAMdy0", "dATdy0", "dAFdy0", "dALdy0" ) y["AI"] <- Pm["AI0"] y["dAIdy0"] <- Pm["VCH"] * Pm["MW"]/24450.0 y } ccl4modelG <- function(t, y, parms) { list(c(parms[,1:5] %*% y[1:5] - c(0, 0, 0, 0, parms[5, 6]*y[5] / ((Kms <- parms[5, 7]*parms[4, 6]) + y[5])), parms[, 1:5] %*% y[6:10] - c(0, 0, 0, 0, y[5]/(Kms + y[5]) + parms[5, 6]*Kms*y[10]/ (Kms + y[5])^2), parms[, 1:5] %*% y[11:15] - c(0, 0, 0, 0, parms[5, 6]*(y[15]*Kms - parms[4, 6]*y[5])/ (Kms + y[5])^2), parms[,1:5] %*% y[16:20] - c(0, 0, 0, 0, parms[5, 6]*Kms*y[20]/(Kms + y[5])^2) ), c(CP = as.vector(y[1]*(zz <- 24450.0/parms[1, 6]/parms[1, 7])), dCPdVm = as.vector(y[6]*zz), dCPdK = as.vector(y[11]*zz), dCPdy0 = as.vector(y[16]*zz) ) ) } ### Function to use in gnls. This is more complicated than usual for such ### functions, because each value for each animal depends on the previous ### value for that animal. Normal vectorization doesn't work. Work with ### log(Vmax) and log(Km) ccl4gnls <- function(time, initconc, lVmax, lKm, lconc) { Vmax <- if(length(lVmax) == 1) rep(exp(lVmax), length(time)) else exp(lVmax) Km <- if (length(lKm) == 1) rep(exp(lKm), length(time)) else exp(lKm) conc <- if (length(lconc) == 1) rep(exp(lconc), length(time)) else exp(lconc) Concs <- levels(initconc) CP <- numeric(length(time)) .grad <- matrix(nrow=length(time), ncol=3, dimnames=list(NULL, c("lVmax", "lKm", "lconc"))) ### Run the model once for each unique initial concentration for (Conc in Concs) { sel <- initconc == Conc parms <- initparms(CONC=conc[sel][1], VMAX=Vmax[sel][1], KM=Km[sel][1]) parmmx <- initparmmx(parms) y <- initstateG(parms) TTime <- sort(unique(time[sel])) if (! 0 %in% TTime) TTime <- c(0, TTime) out <- lsoda(y, TTime, ccl4modelG, parmmx, rtol=1e-12, atol=1e-12) CP[sel] <- out[match(time[sel], out[,"time"]),"CP"] .grad[sel, "lVmax"] <- out[match(time[sel], out[, "time"]), "dCPdVm"] .grad[sel, "lKm"] <- out[match(time[sel], out[, "time"]), "dCPdK"] .grad[sel, "lconc"] <- out[match(time[sel], out[, "time"]), "dCPdy0"] } .grad <- .grad * cbind(Vmax, Km, conc) attr(CP, "gradient") <- .grad CP } if (require(nlme, quietly=TRUE)) { start <- log(c(lVmax = 0.11, lKm=1.3, 25, 100, 250, 1000)) ### Data are from: ### Evans, et al. (1994) Applications of sensitivity analysis to a ### physiologically ### based pharmacokinetic model for carbon tetrachloride in rats. ### Toxicology and Applied Pharmacology 128: 36--44. data(ccl4data) ccl4data.avg<-aggregate(ccl4data$ChamberConc, by=ccl4data[c("time", "initconc")], mean) names(ccl4data.avg)[3]<-"ChamberConc" ### Estimate log(Vmax), log(Km), and the logs of the initial ### concentrations with gnls cat("\nThis may take a little while ... \n") ccl4.gnls <- gnls(ChamberConc ~ ccl4gnls(time, factor(initconc), lVmax, lKm, lconc), params = list(lVmax + lKm ~ 1, lconc ~ factor(initconc)-1), data=ccl4data.avg, start=start, weights=varPower(fixed=1), verbose=TRUE) start <- coef(ccl4.gnls) ccl4.gnls2 <- gnls(ChamberConc ~ ccl4gnls(time, factor(initconc), lVmax, lKm, lconc), params = list(lVmax + lKm ~ 1, lconc ~ factor(initconc)-1), data=ccl4data, start=start, weights=varPower(fixed=1), verbose=TRUE) print(summary(ccl4.gnls2)) ### Now fit a separate initial concentration for each animal start <- c(coef(ccl4.gnls)) cat("\nApprox. 95% Confidence Intervals for Metabolic Parameters:\n") tmp <- exp(intervals(ccl4.gnls2)[[1]][1:2,]) row.names(tmp) <- c("Vmax", "Km") print(tmp) cat("\nOf course, the statistical model is inappropriate, since\nthe concentrations within animal are pretty highly autocorrelated:\nsee the graph.\n") opar <- par(ask=TRUE, no.readonly=TRUE) plot(ChamberConc ~ time, data=ccl4data, xlab="Time (hours)", xlim=range(c(0, ccl4data$time)), ylab="Chamber Concentration (ppm)", log="y") out <- predict(ccl4.gnls2, newdata=ccl4data.avg) concentrations <- sort(unique(ccl4data$initconc)) for (conc in concentrations) { times <- ccl4data.avg$time[sel <- ccl4data.avg$initconc == conc] CP <- out[sel] lines(CP ~ times) } par(opar) } else { cat("This example requires the package nlme\n") } deSolve/demo/00Index0000754000175100001440000000022112352122162013740 0ustar hornikusersCCL4model Use gnls to estimate parameters for CCl4 PBPK model odedim Lotka-Volterra dynamics in 1-D and in 2-D, using ode.1D and ode.2D deSolve/NEWS0000754000175100001440000001502413071630777012407 0ustar hornikusers Changes version 1.20 ================================ o register native routines (Thomas) o check if event data frame has ordered time (and if not, order) o change 'event list' to event matrix or data frame in docs o intentional version jump to indicate chances at the C level Changes version 1.14 ================================ o matplot.deSolve is not anymore exported as matplot to avoid the respective startup message o please use matplot.deSolve or the alias matplot.0D instead (Thomas) o small fix that allows parameters in list format for DLLfunc and DLLres o a little bit fortran modification (e.g. avoid real*8 and complex*16 types) Changes version 1.13 ================================ o observed data and plot.deSolve / matplot for multiple outputs (Karline) o combining compiled code function with R code event function (Karline) o check sorting of event times (Karline) o fix bug related to negative event time (patch supplied by J. Stott) o relax setting of tcrit to make integration with events slightly faster (patch from J. Stott) o adapt maxstep calculation for rk methods, print a warning if maxsteps is exceeded, fix diagnostics (Thomas) o more argument checking for rk solvers (Thomas) o add reference to book of Soetaert, Cash and Mazzia (2012) Changes version 1.12 ================================ o new functions matplot.deSolve and matplot.1D o fix valgrind issue (detected by new compilers) o small improvments of plotting functions o import standard packages as required by upcoming R versions Changes version 1.11 ================================ o compiledCode vignette now with dede example o warning and error bug resolved o Time SEXP incompatibility with R 3.1.1 resolved o CFunc compatibility (compiled code) Changes version 1.10.9 ================================ o documentation updates, hyperlinks to examples and vignettes o moved example directories Changes version 1.10.8 ================================ o remove redundant .R files from inst/doc o fixed bug in event code (patch contributed by Jonathan Stott) Changes version 1.10.7 ================================ o Fortran examples of compiled dede models (Woody) o vignettes moved to /vignettes o roles of authors (Authors@R) o function timestep is now internal o small documentation updates Changes version 1.10.6 (Thomas) ================================ o change declaration of variable dimensions from (1) to (*) in legacy Fortran code to pass automatic bounds check o remove the Jacobian examples from ?ode because banddown=0 can lead to problems on some systems; examples will come back in a next release o fixed bug in the "iteration" solver o small documentation updates Changes version 1.10.5 (Karline, Thomas) ================================ o extended subset.deSolve with argument arr, when TRUE returns an array for >2-D output o fixed the R compiler notes o plot.ode.2D now has an mtext argument, via the ..., to label multiple figures in margin... CHECK - see ode.2D o subset can also be a vector with indices in addition to logical o image with legend = TRUE changed size of plot in different layouts - now solved (by adding par(mar = par("mar")) ) o new method to output warnings and error messages o add data type check for external outputs in rk_util.c o add interface for compiled dede models o emphasize consistent order of states in y and return value of func o changes of Fortran error messages (to be continued) Changes version 1.10-4 (Thomas, Karline) ================================ o allow reverted time vector for fixed step solvers - todo: find solution for dense output methods, and Livermore solvers o all solvers now have default atol = 1e-6; before this daspk and vode had 1e-8. o multiple warnings from daspk if num steps = 500 toggled off. o added input argument "nind" to daspk, to make it compatible with radau. this also changes the way the variables are weighed, hence this differs from the original daspk 2.0 code. o improved warning printing in daspk and vode o extended sparse Jacobian input in lsodes. (2-D and 3-D sparsity with mapping var and arbitrary sparsity in ian/jan format). Changes version 1.10-3 (Karline) ================================ o rwork and iwork in lsodes from Fortran -> C (to remove compiler warnings) o roots + events: now certain roots can stop simulation + fixed bug in radau root o improved events\roots help file o diagnostics(out) gave error in case method=iteration (no rstate) now fixed o the package authors agreed to assign the maintainer role to T.P., but the order of authorship and credits remain unchanged. Changes version 1.10-2 (Karline) ================================ o remove NAs from forcing functions - when used in DLL (file forcings.R) o new argument "restructure" in ode.1D, for use with implicit solvers not in deSolve o removed requirement to have eventfunc in compiled code when func is in compiled code o subsetting on summary.deSolve Changes version 1.10-1 (Thomas) =============================== o remove several redundant variables from C code o add NEWS file Changes version 1.10 (Karline, Thomas) ====================================== o compiled code using mass in daspk o cleanEventTimes Changes version 1.9+ (Karline) ============================== o roots, events, lags in radau o roots in lsodes o lags in daspk o ode (method = "iteration") Changes version 1.9 (Karline, Thomas) ===================================== o summary.deSolve o subset.deSolve o plotting deSolve objects improved: - plot more than one output in same figures (scenarios), - add observations o vignette improved o fixed bug in 'timesteps' Changes version 1.8.1 (Thomas, Woody, Karline) ============================================== o fixed compiler warnings using valgrind o fixed compiler warning C-code Changes version 1.8 (Thomas) ============================ o Dormand-Prince 8(7) coefficients use now common instead of decimal fractions Changes version 1.8 (Karline) ============================= o Runge-Kuttas: - extra output: number of failed steps (see also 2) - number of function evaluations + 1 for initial condition - dense output for cash-karp - dopri8(7) added - radau added!! implicit runge kutta, solves also DAE up to index 3! o other: - image function for ode.2-D added. - changed warning printing in FORTRAN code - common interface for radau and daspk: both can solve systems written as M*dy = f(x,y). daspk can also solve systems written as 0 = g(x,y,dy) (=default for daspk) deSolve/data/0000755000175100001440000000000013131750050012575 5ustar hornikusersdeSolve/data/ccl4data.rda0000754000175100001440000001212513131751003014746 0ustar hornikuserswTWW5* (XEKDP,t, faB{=ƨƮwc5ǚآ;/y|s<˞sΝάHf..2Nf(ۋVG szzQdHx}вgfu<>WKmzUV wиYuFG. }O}fͿ_[ebvح~y89ּ5d׳]BF..5/?4=Óhh7]y;ޭBc^B_64 Xּ5Ԛof7[|Ov>jDqG8p1N4nКo$NROfͻG7X|Sk5̚on7=,n~jvzv~Ϗ} -#kPjں)ںӵkV-74ߒ]-+oYqxK[V޲R-+ޢJz./O tMɘQama D؂H[Dقh[؂^ V|nrNV.d=7{AoK]%NNvx蜚⣛?'z.uiQ%+JX571&}&m(>7t1(k@Q 6ϽRӯj(ޢӂ}(YZae]DG-3PWaƜQ\P'#D2VM}E{;%0F$u_G*L((\0Fd 0>bXz(x,޵ }(G?='9C킌ΧムW3 {V/G~ٶ|?v׏QNT8ts7\FEbܔ;woG0R~t _%߻6cGtVμ}WLs E(FfadqP;[S(SZR( -p!.}\rE4mE:wAN'E.,w>S6mY5 Pbݹ[( LZ!?Ǎh޶ Km&79R+c/hQ5莸Y!*[6pjw =']>~*>i*> -|8{(h#.DӋ+'Ʈx9sť"B\ ]6bDe}f/~̩S͏][ vsN藊ym u,{c_ޥfcU1f͵A-W4^|-U&?#5B慊u;D!CZMfv"R=W*R:cHY)kaM9^stisci$?]uZJͣH.(?rU8NjΦܴ|'2Ɖ,xa-;$f0Tmy裫z=O0G_Ð[bBӤ qy1];10[}_8 Nonoy8o^ݑfOj=#!Ror;R,Mq7kD-ko#PBr} !_'.,pCAdѹ$r-/%etm:ĞNb1>" nn#f5YeY&C$f=~ed^];mO&{ Ck:/AnqR -YH>> +ͬH8P\l^H]<,&zZ),dZ9s&&#yAh$h[=j2^/qcq:c}$U\oCRX⛃ͮ }y!Hhzmϩ4$Fġ$:Z|ΖK#i7.B5xXRCn'smR+;hulS boAsVD]:Cñ&CZ+|^q7 B[B> _ "w pwGm6Bi__;ON5C;7"F{z Q )7[+qq_eq3^ewh^ /7Z l90hDg wΙ@\#^8^WgAhx9}-߳pf^;tx5e@ڽcCy=oWQN˫6U7󵬻QNQjIJo>;QP+/ >f[LJ5>Nz#i~ޛumЁ,|~}_6/.LA{ˏnn_w//;l+QO>Y|ko}^$[>>7nn/ݠ=O#"?zd&^wm< ^+6w*zxτvȆoz/ < ZыoZP_9 5'8egaͰg+Ϧ|sfK3! ? AE"e4-roVԧq}~#:zq3:o;/d-3gw03==j /۳c[%/.؀ǧ]}e@|<>Cb'1w{{9[:ށ0k`T7xeGTBww =x <2]v˟5oΰ+C!_o۾.r :Y ޲s(/Yol -@ [*[k`$ERĤK E )RJJR$1`I &1`I &1`K .1K .1K .1!H AbC$ 1!H PH PH PH PH PH PJ PJ PJ PJ PJ PI PI PI PI PI PK PK PK PK PK H H H H AAS( *(TRPM!тL`-hD &Z0тL4F4F4F4F4F4F4F4F4F4F4N4N4N4N4N4N4N4N4N4N4h Ԯ@ Ԯ@ ԮUP jWAP(DSMA4DSMI4%єDSMI4%єDSMI4TDSME4TDSME4TDSMM45DSMM45DSMM4 4DMC4 4DMC4  D#0r #0r #0r #0r #0r #0r #0r #0r #0r #0r #0r #0r #0r #0#0#0#0#0#0#0#0#0#0#0#0#0#0'p'p'p'p'p'p'p'p'p'p'p'p'p'p'p'p'p'p'p'p'p'p'p'p'p'p'p'p'p'p'p'p'p'p'p'pN.N.N.N.N.N.N.N.N.N.N.N.N.N.%D \"Kr@.%D \"Kr@.%D \"Kr@.%D \"Kr@.D#{#/\D`f.;wrt:}#u^ͯeec[s6R0#/WLن|YͯF7eggٙ7wow\crS<<8XgrL.| 7;3r_r徙 length(atol)) atol <- rep(atol, length.out=n) else rtol <- rep(rtol, length.out=n) } ### Number of steps until the solver gives up nsteps <- min(.Machine$integer.max, maxsteps * length(times)) ### index if (length(nind) != 3) stop("length of `nind' must be =3") if (sum(nind) != n) stop("sum of of `nind' must equal n, the number of equations") ### Jacobian full <- TRUE if (jactype == "fullint" ) { # full, calculated internally ijac <- 0 banddown <- n bandup <- n } else if (jactype == "fullusr" ) { # full, specified by user function ijac <- 1 banddown <- n bandup <- n } else if (jactype == "bandusr" ) { # banded, specified by user function ijac <- 1 full <- FALSE if (is.null(banddown) || is.null(bandup)) stop("'bandup' and 'banddown' must be specified if banded Jacobian") } else if (jactype == "bandint" ) { # banded, calculated internally ijac <- 0 full <- FALSE if (is.null(banddown) || is.null(bandup)) stop("'bandup' and 'banddown' must be specified if banded Jacobian") } else stop("'jactype' must be one of 'fullint', 'fullusr', 'bandusr' or 'bandint'") nrjac <- as.integer(c(ijac, banddown, bandup)) # check other specifications depending on Jacobian if (ijac == 1 && is.null(jacfunc)) stop ("'jacfunc' NOT specified; either specify 'jacfunc' or change 'jactype'") ### model and Jacobian function JacFunc <- NULL Ynames <- attr(y,"names") flist <- list(fmat=0,tmat=0,imat=0,ModelForc=NULL) ModelInit <- NULL RootFunc <- NULL Eventfunc <- NULL events <- checkevents(events, times, Ynames, dllname, TRUE) if (! is.null(events$newTimes)) times <- events$newTimes if (is.character(func) | class(func) == "CFunc") { # function specified in a DLL or inline compiled DLL <- checkDLL(func,jacfunc,dllname, initfunc,verbose,nout, outnames) ## Is there a root function? if (!is.null(rootfunc)) { if (!is.character(rootfunc) & class(rootfunc) != "CFunc") stop("If 'func' is dynloaded, so must 'rootfunc' be") rootfuncname <- rootfunc if (class(rootfunc) == "CFunc") RootFunc <- body(rootfunc)[[2]] else if (is.loaded(rootfuncname, PACKAGE = dllname)) { RootFunc <- getNativeSymbolInfo(rootfuncname, PACKAGE = dllname)$address } else stop(paste("root function not loaded in DLL",rootfunc)) if (nroot == 0) stop("if 'rootfunc' is specified in a DLL, then 'nroot' should be > 0") } ModelInit <- DLL$ModelInit Func <- DLL$Func JacFunc <- DLL$JacFunc Nglobal <- DLL$Nglobal Nmtot <- DLL$Nmtot if (! is.null(forcings)) flist <- checkforcings(forcings,times,dllname,initforc,verbose,fcontrol) if (is.null(ipar)) ipar<-0 if (is.null(rpar)) rpar<-0 Eventfunc <- events$func if (is.function(Eventfunc)) rho <- environment(Eventfunc) else rho <- emptyenv() } else { if (is.null(initfunc)) initpar <- NULL # parameter initialisation not needed if function is not a DLL rho <- environment(func) # func overruled, either including ynames, or not # This allows to pass the "..." arguments and the parameters if (ynames) { Func <- function(time,state) { attr(state,"names") <- Ynames unlist(func (time,state,parms,...)) } Func2 <- function(time,state) { attr(state,"names") <- Ynames func (time,state,parms,...) } JacFunc <- function(time,state) { attr(state,"names") <- Ynames jacfunc(time,state,parms,...) } RootFunc <- function(time,state) { attr(state,"names") <- Ynames rootfunc(time,state,parms,...) } if (! is.null(events$Type)) if (events$Type == 2) Eventfunc <- function(time,state) { attr(state,"names") <- Ynames events$func(time,state,parms,...) } } else { # no ynames... Func <- function(time,state) unlist(func (time,state,parms,...)) Func2 <- function(time,state) func (time,state,parms,...) JacFunc <- function(time,state) jacfunc(time,state,parms,...) RootFunc <- function(time,state) rootfunc(time,state,parms,...) if (! is.null(events$Type)) if (events$Type == 2) Eventfunc <- function(time,state) events$func(time,state,parms,...) } ## Check function and return the number of output variables +name FF <- checkFunc(Func2,times,y,rho) Nglobal<-FF$Nglobal Nmtot <- FF$Nmtot ## Check event function if (! is.null(events$Type)) if (events$Type == 2) checkEventFunc(Eventfunc,times,y,rho) ## Check jacobian function if (ijac == 1) { tmp <- eval(JacFunc(times[1], y), rho) if (!is.matrix(tmp)) stop("Jacobian function 'jacfunc' must return a matrix\n") dd <- dim(tmp) if ((!full && dd != c(bandup+banddown+1,n)) || ( full && dd != c(n,n))) stop("Jacobian dimension not ok") } ## and for rootfunc if (! is.null(rootfunc)) { tmp2 <- eval(rootfunc(times[1],y,parms,...), rho) if (!is.vector(tmp2)) stop("root function 'rootfunc' must return a vector\n") nroot <- length(tmp2) } else nroot = 0 } ### The mass matrix mlmas <- n mumas <- n if (is.null(mass)) { imas <- 0 lmas <- n MassFunc <- NULL } else { imas <- 1 dimens <- dim(mass) if(is.null(dimens)) { mass <- matrix(nrow = 1, data = mass) dimens <- dim(mass) } if (dimens[2] != n) stop ("mass matrix should have as many columns as number of variables in 'y'") if (dimens[1] != n) { mumas <- massup mlmas <- massdown if (dimens[1] != mlmas + mumas +1) stop ("nr of rows in mass matrix should equal the number of variables in 'y' or 'massup'+'massdown'+1 ") } MassFunc <- function (n,lm) { if (nrow(mass) != lm || ncol(mass) != n) stop ("dimensions of mass matrix not ok") return(mass) } } lmas <- n nrmas <- as.integer(c(imas, mlmas, mumas)) if (banddown == n) { ljac <- n if (imas == 1) lmas <- n le <- n } else { ljac <- banddown + bandup + 1 lmas <- mlmas + mumas + 1 le <- 2*banddown + bandup + 1 } ### work arrays iwork, rwork # length of rwork and iwork lrw <- n * (ljac + lmas + 3*le + 12) + 20 liw <- 20 + 3*n # only first 20 elements passed; other will be allocated in C-code iwork <- vector("integer",20) rwork <- vector("double",20) rwork[] <- 0. iwork[] <- 0 iwork[2] <- nsteps iwork[5:7] <- nind rwork[1] <- .Machine$double.neg.eps rwork[2] <- 0.9 # safety factor error reductin rwork[3] <- 0.001 # recalculation of jacobian factor rwork[7] <- hmax if(is.null(times)) times<-c(0,1e8) ### print to screen... if (verbose) { printtask(0,func,jacfunc) printM("\n--------------------") printM("Integration method") printM("--------------------") printM( "radau5") } ### lags <- checklags(lags,dllname) ### calling solver storage.mode(y) <- storage.mode(times) <- "double" tcrit <- NULL on.exit(.C("unlock_solver")) out <- .Call("call_radau",y,times,Func,MassFunc,JacFunc,initpar, rtol, atol, nrjac, nrmas, rho, ModelInit, as.double(rwork), as.integer(iwork), as.integer(Nglobal), as.integer(lrw),as.integer(liw), as.double (rpar), as.integer(ipar), as.double(hini), flist, lags, RootFunc, as.integer(nroot), Eventfunc, events, PACKAGE="deSolve") ### saving results out <- saveOut(out, y, n, Nglobal, Nmtot, func, Func2, iin= 1:7, iout=c(1,3,4,2,13,13,10)) attr(out, "type") <- "radau5" if (verbose) diagnostics(out) return(out) } deSolve/R/DLLfunc.R0000754000175100001440000001577512761641076013537 0ustar hornikusers## Karline: made compatible with CFunc DLLfunc <- function (func, times, y, parms, dllname, initfunc=dllname, rpar=NULL, ipar=NULL, nout=0, outnames=NULL, forcings=NULL, initforc = NULL, fcontrol=NULL) { ## check the input if (!is.numeric(y)) stop("`y' must be numeric") n <- length(y) if (! is.null(times)&&!is.numeric(times)) stop("`times' must be NULL or numeric") if (! is.null(outnames)) if (length(outnames) != nout) stop("length outnames should be = nout") if (is.list(func)) { if (!is.null(dllname) & "dllname" %in% names(func)) stop("If 'func' is a list that contains dllname, argument 'dllname' should be NULL") if (!is.null(initfunc) & "initfunc" %in% names(func)) stop("If 'func' is a list that contains initfunc, argument 'initfunc' should be NULL") if (!is.null(initforc) & "initforc" %in% names(func)) stop("If 'func' is a list that contains initforc, argument 'initforc' should be NULL") if (!is.null(func$initfunc)) initfunc <- func$initfunc if (!is.null(func$initforc)) initforc <- func$initforc if (!is.null(func$dllname)) dllname <- func$dllname func <- func$func } ## is there an initialiser? - initialiser has the same name as the dll file ModelInit <- NULL Outinit <- NULL flist <- list(fmat=0,tmat=0,imat=0,ModelForc=NULL) Ynames <- attr(y, "names") if (class(func) != "CFunc") if (is.null(dllname) || !is.character(dllname)) stop("`dllname' must be a name referring to a dll") if (! is.null(initfunc)) { if (class(initfunc) == "CFunc") ModelInit <- body(initfunc)[[2]] else if (is.loaded(initfunc, PACKAGE = dllname, type = "") || is.loaded(initfunc, PACKAGE = dllname, type = "Fortran")) {ModelInit <- getNativeSymbolInfo(initfunc, PACKAGE = dllname)$address } else if (initfunc != dllname && ! is.null(initfunc)) stop(paste("cannot integrate: initfunc not loaded ",initfunc)) } if (is.null(initfunc)) initfunc <- NA if (! is.null(forcings)) flist <- checkforcings(forcings,times,dllname,initforc,TRUE,fcontrol) ## the function if (class(func) == "CFunc") Func <- body(func)[[2]] else if (!is.character(func)) stop("`func' must be a *name* referring to a function in a dll or of class CFunc") else if (is.loaded(func, PACKAGE = dllname)) { Func <- getNativeSymbolInfo(func, PACKAGE = dllname)$address } else stop(paste("cannot run DLLfunc: dyn function not loaded: ",func)) dy <- rep(0,n) storage.mode(y) <- storage.mode(dy) <- "double" # out <- .Call("call_DLL", y, dy, as.double(times[1]), Func, ModelInit, #Outinit, # as.double(parms),as.integer(nout), # as.double(rpar),as.integer(ipar), 1L, # flist, PACKAGE = "deSolve") out <- .Call("call_DLL", y, dy, as.double(times[1]), Func, ModelInit, #Outinit, parms, as.integer(nout), as.double(rpar),as.integer(ipar), 1L, flist, PACKAGE = "deSolve") vout <- if (nout>0) out[(n + 1):(n + nout)] else NA out <- list(dy = out[1:n], var = vout) if (!is.null(Ynames)) names(out$dy) <-Ynames if (! is.null(outnames)) names(out$var) <- outnames return(out) # a list with the rate of change (dy) and output variables (var) } DLLres <- function (res, times, y, dy, parms, dllname, initfunc=dllname, rpar=NULL, ipar=NULL, nout=0, outnames=NULL, forcings=NULL, initforc = NULL, fcontrol=NULL) { ## check the input if (!is.numeric(y)) stop("`y' must be numeric") if (!is.numeric(dy)) stop("`dy' must be numeric") n <- length(y) if (length(dy) != n) stop("`dy' and 'y' muxt hve the same length") if (! is.null(times)&&!is.numeric(times)) stop("`time' must be NULL or numeric") if (! is.null(outnames)) if (length(outnames) != nout) stop("length outnames should be = nout") if (is.list(res)) { if (!is.null(dllname) & "dllname" %in% names(res)) stop("If 'res' is a list that contains dllname, argument 'dllname' should be NULL") if (!is.null(initfunc) & "initfunc" %in% names(res)) stop("If 'res' is a list that contains initfunc, argument 'initfunc' should be NULL") if (!is.null(initforc) & "initforc" %in% names(res)) stop("If 'res' is a list that contains initforc, argument 'initforc' should be NULL") dllname <- res$dllname initfunc <- res$initfunc initforc <- res$initforc res <- res$res } ## is there an initialiser? - initialiser has the same name as the dll file ModelInit <- NULL Outinit<- NULL flist<-list(fmat=0,tmat=0,imat=0,ModelForc=NULL) Ynames <- attr(y, "names") if (class(res) != "CFunc") if(is.null(dllname)|| !is.character(dllname)) stop("`dllname' must be a name referring to a dll") if (! is.null(initfunc)){ if (class(initfunc) == "CFunc") ModelInit <- body(initfunc)[[2]] else if (is.loaded(initfunc, PACKAGE = dllname, type = "") || is.loaded(initfunc, PACKAGE = dllname, type = "Fortran")) {ModelInit <- getNativeSymbolInfo(initfunc, PACKAGE = dllname)$address } else if (initfunc != dllname && ! is.null(initfunc)) stop(paste("cannot integrate: initfunc not loaded ",initfunc)) } if (is.null(initfunc)) initfunc <- NA if (! is.null(forcings)) flist <- checkforcings(forcings,times,dllname,initforc,TRUE,fcontrol) ## the function if (class(res) == "CFunc") Res <- body(res)[[2]] else if (!is.character(res)) stop("`res' must be a *name* referring to a function in a dll") else if (is.loaded(res, PACKAGE = dllname)) { Res <- getNativeSymbolInfo(res, PACKAGE = dllname)$address } else stop(paste("cannot run DLLres: res function not loaded: ",res)) storage.mode(y) <- storage.mode(dy) <- "double" # out <- .Call("call_DLL", y, dy, as.double(times[1]), Res, ModelInit, #Outinit, # as.double(parms),as.integer(nout), # as.double(rpar),as.integer(ipar), 2L, # flist, PACKAGE = "deSolve") out <- .Call("call_DLL", y, dy, as.double(times[1]), Res, ModelInit, #Outinit, parms, as.integer(nout), as.double(rpar), as.integer(ipar), 2L, flist, PACKAGE = "deSolve") vout <- if (nout>0) out[(n + 1):(n + nout)] else NA out <- list(delta = out[1:n], var = vout) if (!is.null(Ynames)) names(out$delta) <-Ynames if (! is.null(outnames)) names(out$var) <- outnames return(out) # a list with the residual and output variables (var) } deSolve/R/checkevents.R0000754000175100001440000001775113071627542014543 0ustar hornikusers### ============================================================================ ### Check events data set ### Changes version 1.11: event can be an R-function, even if DLL model ### continueeroot: to continue even if a root is found ### ============================================================================ checkevents <- function (events, times, vars, dllname, root = FALSE) { if (is.null(events)) return(list()) if (is.null(events$data) && is.null(events$func) && is.null(events$terminalroot)) return(list()) funevent <- events$func if (root) { # check if root should trigger an event... Root <- events$root if (is.null(Root)) Root <- 0 Root <- as.integer(Root) } else Root <- 0L maxroot <- events$maxroot if (is.null(maxroot)) maxroot <- 100 # number of roots to save. if (maxroot < 0) stop("events$maxroot should be > 0 in events") Terminalroot <- events$terminalroot if (! is.null(Terminalroot) && is.null(funevent)) funevent <- function(t,y,p) return(y) # dummy event function if (is.null(Terminalroot)) Terminalroot <- 0 # at which roots simulation should continue ## ---------------------- ## event in a function ## ---------------------- if (!is.null(funevent)) { if (class (funevent) == "CFunc") { funevent <- body(funevent)[[2]] Type <- 3 } else if (is.character(funevent)){ if (is.null(dllname)) stop("'dllname' should be given if 'events$func' is a string") if (is.loaded(funevent, PACKAGE = dllname, type = "") || is.loaded(funevent, PACKAGE = dllname, type = "Fortran")) { funevent <- getNativeSymbolInfo(funevent, PACKAGE = dllname)$address } else stop(paste("'events$func' should be loaded ",funevent)) Type <- 3 } else { Type <- 2 # SHOULD ALSO CHECK THE FUNCTION if R-function.... # if (!is.null(dllname)) KARLINE: removed that 02/07/2011 # stop("'events$func' should be a string, events specified in compiled code if 'dllname' is not NULL") } if (Root == 0) { if (is.null(events$time)) stop("either 'events$time' should be given and contain the times of the events, if 'events$func' is specified and no root function or your solver does not support root functions") eventtime <- sort(as.double(events$time)) # Karline: sorted that 4-01-2016 if (any(!(eventtime %in% times))) { warning("Not all event times 'events$time' are in output 'times' so they are automatically included.") uniqueTimes <- cleanEventTimes(times, eventtime) if (length(uniqueTimes) < length(times)) warning("Some time steps were very close to events - only the event times are used in these cases.") times <- sort(c(uniqueTimes, eventtime)) } } else eventtime <- min(times) - 1 # never reached.... return (list (Time = eventtime, SVar = NULL, Value = NULL, Method = NULL, Type = as.integer(Type), func = funevent, Rootsave = as.integer(maxroot), Root = Root, Terminalroot = as.integer(Terminalroot), newTimes = times)) # added newTimes - Karline 4-01-2016 } ## ---------------------- ## event as a data series ## ---------------------- eventdata <- events$data if (is.matrix(eventdata)) eventdata <- as.data.frame(eventdata) if (ncol(eventdata) < 3) stop("'event' should have at least 3 columns: state variable, time, value") if (!is.data.frame(eventdata)) stop("'event' should be a data.frame with 3(4) columns: state variable, time, value, (method)") ## this should make check < 3 columns obsolete evtcols <- c("var", "time", "value", "method") if (!all(evtcols %in% names(eventdata))) stop("structure of events does not match specification, see help('events')") ## make sure that event data frame has correct order eventdata <- eventdata[evtcols] ## variables, 1st column should be present if (is.factor(eventdata[,1])) eventdata[,1] <- as.character(eventdata[,1]) if (is.character(eventdata[,1])) { vv <- match(eventdata[,1], vars) if (is.character(eventdata[,1])) { vv <- match(eventdata[,1],vars) if (any(is.na(vv))) stop("unknown state variable in 'event': ", paste(eventdata[,1][which(is.na(vv))], ",")) eventdata[,1] <- vv } else if (max(eventdata[,1]) > length(vars)) stop("unknown state variable in 'event': ", paste(eventdata[,1][which(is.na(vv))],",")) eventdata[,1] <- vv } else if (max(eventdata[,1])>length(vars)) stop("too many state variables in 'event'; should be < ", paste(length(vars))) ## 2nd and 3rd columns should be numeric if (!is.numeric(eventdata[,2])) stop("times in 'event', 2nd column should be numeric") if (!is.numeric(eventdata[,3])) stop("values in 'event', 3rd column should be numeric") ## Times in 'event' should be embraced by 'times' rt <- range(times) ii <- c(which(eventdata[,2] < rt[1]), which(eventdata[,2] > rt[2])) if (length(ii) > 0) eventdata <- eventdata [-ii,] if (any(!(eventdata[,2] %in% times))) { warning("Not all event times 'events$times' were in output 'times' so they are automatically included.") uniqueTimes <- cleanEventTimes(times, eventdata[,2]) if (length(uniqueTimes) < length(times)) warning("Some time steps were very close to events - only the event times are used in these cases.") times <- sort(c(uniqueTimes, eventdata[,2])) } if (any(!(eventdata[,2] %in% times))) { warning("Not all event times 'events$times' where in output 'times' so they are automatically included.") uniqueTimes <- cleanEventTimes(times, eventdata[,2]) if (length(uniqueTimes) < length(times)) warning("Some time steps were very close to events - only the event times are used in these cases.") times <- sort(c(uniqueTimes, eventdata[,2])) } ## check if times are ordered and if not, fix it if (any(diff(eventdata[,2]) < 0)) { warning("Time of events ('time' column of 'events') was not ordered.") ord <- order(eventdata[,2]) eventdata <- eventdata[ord,] } ## 4th column: method; if not available: "replace" = method 1 - to date: 3 methods if (ncol(eventdata) ==3) eventdata$method <- rep(1,nrow(eventdata)) else if (is.numeric(eventdata[,4])) { if (max(eventdata[,4]) > 3 | min(eventdata[,4]) < 1) stop("unknown method in 'event': should be >0 and < 4") } else { vv <- charmatch(eventdata[,4],c("replace","add","multiply")) if (any(is.na(vv))) stop("unknown method in 'event': ", paste(eventdata[,3][which(is.na(vv))],","), " should be one of 'replace', 'add', 'multiply'") eventdata$method <- vv } ## Check the other events elements (see optim code) con <- list(ties = "notordered", time = NULL, data = NULL, func = NULL, root = NULL) nmsC <- names(con) con[(namc <- names(events))] <- events if (length(noNms <- namc[!namc %in% nmsC]) > 0) warning("unknown names in events: ", paste(noNms, collapse = ", ")) ## Check what needs to be done in case the time series is not "ordered" if (!identical(con$ties, "ordered")) { # see approx code ## first order with respect to time (2nd col), then to variable (1st col) if(length(x <- unique(eventdata[,1:2])) < nrow(eventdata)){ ties <- mean if (missing(ties)) warning("collapsing to unique 'x' values") eventdata <- aggregate(eventdata[,c(3, 4)], eventdata[,c(1, 2)], ties) ties <- mean if (missing(ties)) warning("collapsing to unique 'x' values") eventdata <- aggregate(eventdata[,c(3,4)], eventdata[,c(1,2)], ties) } } return (list (Time = as.double(eventdata[,2]), SVar = as.integer(eventdata[,1]), Value = as.double(eventdata[,3]), Method = as.integer(eventdata[,4]), Rootsave = as.integer(maxroot), Type = 1L, Root = Root, Terminalroot = as.integer(Terminalroot), newTimes = times)) } deSolve/R/Utilities.R0000754000175100001440000012667212643031573014214 0ustar hornikusers### ============================================================================ ### ============================================================================ ### S3 methods ### karline+Thomas: from version 1.9, also possible to plot multiple ### outputs and to add observations. ### ============================================================================ ### ============================================================================ ### ============================================================================ ### first some common functions ### ============================================================================ ## ============================================================================= ## Update range, taking into account neg values for log transformed values ## ============================================================================= Range <- function(Range, x, log) { if ((log) & (!is.null(x))) x[x <= 0] <- min(x[x > 0]) # remove zeros return(range(Range, x, na.rm = TRUE) ) } ## ============================================================================= ## Checking and expanding arguments in dots (...) with default ## ============================================================================= expanddots <- function (dots, default, n) { dots <- if (is.null(dots)) default else dots rep(dots, length.out = n) } # lists: e.g. xlim and ylim.... expanddotslist <- function (dots, n) { if (is.null(dots)) return(dots) dd <- if (!is.list(dots )) list(dots) else dots rep(dd, length.out = n) } ## ============================================================================= ## Expanding arguments in dots (...) ## ============================================================================= repdots <- function(dots, n) if (is.function(dots)) dots else rep(dots, length.out = n) setdots <- function(dots, n) lapply(dots, repdots, n) ## ============================================================================= ## Extracting element 'index' from dots (...) ## ============================================================================= extractdots <- function(dots, index) { ret <- lapply(dots, "[", index) ret <- lapply(ret, unlist) # flatten list return(ret) } ## ============================================================================= ## Merge two observed data files; assumed that first column = 'x' and ignored ## ============================================================================= # from 3-columned format (what, where, value) to wide format... convert2wide <- function(Data) { cnames <- as.character(unique(Data[,1])) MAT <- Data[Data[,1] == cnames[1], 2:3] colnames.MAT <- c("x", cnames[1]) for ( ivar in cnames[-1]) { sel <- Data[Data[,1] == ivar, 2:3] nt <- cbind(sel[,1], matrix(nrow = nrow(sel), ncol = ncol(MAT)-1, data = NA), sel[,2]) MAT <- cbind(MAT, NA) colnames(nt) <- colnames(MAT) MAT <- rbind(MAT, nt) colnames.MAT <- c(colnames.MAT, ivar) } colnames(MAT) <- colnames.MAT return(MAT) } # merge two observed data sets in one mergeObs <- function(obs, Newobs) { if (! class(Newobs) %in% c("data.frame", "matrix")) stop ("the elements in 'obs' should be either a 'data.frame' or a 'matrix'") if (is.character(Newobs[, 1]) | is.factor(Newobs[, 1])) Newobs <- convert2wide(Newobs) obsname <- colnames(obs) ## check if some observed variables in NewObs are already in obs newname <- colnames(Newobs)[-1] # 1st column = x-var and ignored ii <- which (newname %in% obsname) if (length(ii) > 0) obsname <- c(obsname, newname[-ii] ) else obsname <- c(obsname, newname) ## padding with NA of the two datasets O1 <- matrix(nrow = nrow(Newobs), ncol = ncol(obs), data = NA) O1[ ,1] <- Newobs[, 1] for (j in ii) { # observed data in common are put in correct position jj <- which (obsname == newname[j]) O1[,jj] <- Newobs[, j+1] } O1 <- cbind(O1, Newobs[, -c(1, ii+1)] ) colnames(O1) <- obsname nnewcol <- ncol(Newobs)-1 - length (ii) # number of new columns if (nnewcol > 0) { O2 <- matrix(nrow = nrow(obs), ncol = nnewcol, data = NA) O2 <- cbind(obs, O2) colnames(O2) <- obsname } else O2 <- obs obs <- rbind(O2, O1) return(obs) } ## ============================================================================= ## Set the mfrow parameters and whether to "ask" for opening a new device ## ============================================================================= setplotpar <- function(ldots, nv, ask) { nmdots <- names(ldots) # nv = number of variables to plot if (!any(match(nmdots, c("mfrow", "mfcol"), nomatch = 0))) { nc <- min(ceiling(sqrt(nv)), 3) nr <- min(ceiling(nv/nc), 3) mfrow <- c(nr, nc) } else if ("mfcol" %in% nmdots) mfrow <- rev(ldots$mfcol) else mfrow <- ldots$mfrow if (! is.null(mfrow)) mf <- par(mfrow = mfrow) ## interactively wait if there are remaining figures if (is.null(ask)) ask <- prod(par("mfrow")) < nv && dev.interactive() return(ask) } ## ============================================================================= ## find a variable ## ============================================================================= selectvar <- function (Which, var, NAallowed = FALSE) { if (!is.numeric(Which)) { ln <- length(Which) ## the loop is necessary so as to keep ordering... Select <- NULL for ( i in 1:ln) { ss <- which(Which[i] == var) if (length(ss) ==0 & ! NAallowed) stop("variable ", Which[i], " not in variable names") else if (length(ss) == 0) Select <- c(Select, NA) else Select <- c(Select, ss) } } else { Select <- Which + 1 # "Select" now refers to the column number if (max(Select) > length(var)) stop("index in 'which' too large: ", max(Select)-1) if (min(Select) < 1) stop("index in 'which' should be > 0") } return(Select) } ### ============================================================================ ### print a deSolve object ### ============================================================================ print.deSolve <- function(x, ...) print(as.data.frame(x), ...) ### ============================================================================ ### Create a histogram for a list of variables ### ============================================================================ hist.deSolve <- function (x, select = 1:(ncol(x)-1), which = select, ask = NULL, subset = NULL, ...) { t <- 1 # column with independent variable ("times") varnames <- colnames(x) Which <- selectvar(which, varnames) np <- length(Which) ldots <- list(...) ## Set par mfrow and ask ask <- setplotpar(ldots, np, ask) if (ask) { oask <- devAskNewPage(TRUE) on.exit(devAskNewPage(oask)) } ## expand all dots to np values (no defaults) Dotmain <- setdots(ldots, np) ## different from default settings Dotmain$main <- expanddots (ldots$main, varnames[Which], np) Dotmain$xlab <- expanddots (ldots$xlab, varnames[t], np) # Dotmain$xlab <- expanddots (ldots$xlab, "" , np) ## xlim and ylim are special: they are vectors or lists xxlim <- expanddotslist(ldots$xlim, np) yylim <- expanddotslist(ldots$ylim, np) if (!missing(subset)){ e <- substitute(subset) r <- eval(e, as.data.frame(x), parent.frame()) if (is.numeric(r)) { isub <- r } else { if (!is.logical(r)) stop("'subset' must evaluate to logical or be a vector with integers") isub <- r & !is.na(r) } } else isub <- TRUE ## plotting for (ip in 1:np) { ix <- Which[ip] dotmain <- extractdots(Dotmain, ip) if (! is.null(xxlim[[ip]])) dotmain$xlim <- xxlim[[ip]] if (! is.null(yylim[[ip]])) dotmain$ylim <- yylim[[ip]] do.call("hist", c(alist(x[isub, ix]), dotmain)) } } ### ============================================================================ ### Image, filled.contour and persp plots ### ============================================================================ image.deSolve <- function (x, select = NULL, which = select, ask = NULL, add.contour = FALSE, grid = NULL, method = "image", legend = FALSE, subset = NULL, ...) { if (!missing(subset)){ e <- substitute(subset) r <- eval(e, as.data.frame(x), parent.frame()) if (is.numeric(r)) { isub <- r } else { if (!is.logical(r)) stop("'subset' must evaluate to logical or be a vector with integers") isub <- r & !is.na(r) } } else isub <- TRUE dimens <- attributes(x)$dimens if (is.null(dimens)) stop("cannot make an image from deSolve output which is 0-dimensional") else if (length(dimens) ==1) # 1-D plot.ode1D(x, which, ask, add.contour, grid, method=method, legend = legend, isub = isub, ...) else if (length(dimens) ==2) # 2-D plot.ode2D(x, which, ask, add.contour, grid, method=method, legend = legend, isub = isub, ...) else stop("cannot make an image from deSolve output with more than 2 dimensions") } ### ============================================================================ ### Plot utilities for the S3 plot method, 0-D, 1-D, 2-D ### ============================================================================ ## ============================================================================ ## Observations cleanup ## ============================================================================ SetData <- function(obs) { ## check observed data nobs <- 0 obs.pos <- NULL obsname <- NULL if (! is.null(obs)) { if (!is.data.frame(obs) & is.list(obs)) { # a list with different data sets Obs <- obs obs <- Obs[[1]] obs.pos <- matrix(nrow = 1, c(1, nrow(obs))) if (! class(obs) %in% c("data.frame", "matrix")) stop ("'obs' should be either a 'data.frame' or a 'matrix'") if (length(Obs) > 1) for ( i in 2 : length(Obs)) { obs <- mergeObs(obs, Obs[[i]]) obs.pos <- rbind(obs.pos, c(obs.pos[nrow(obs.pos), 2] +1, nrow(obs))) } obsname <- colnames(obs) } else { # a data.frame or matrix if (is.character(obs[, 1]) | is.factor(obs[, 1])) # long format - convert obs <- convert2wide(obs) obsname <- colnames(obs) if (! class(obs) %in% c("data.frame", "matrix")) stop ("'obs' should be either a 'data.frame' or a 'matrix'") obs.pos <- matrix(nrow = 1, c(1, nrow(obs))) } DD <- duplicated(obsname) if (sum(DD) > 0) obs <- mergeObs(obs[,!DD], cbind(obs[, 1], obs[, DD])) nobs <- nrow(obs.pos) } return(list(dat = obs, pos = obs.pos, name = obsname, length = nobs)) } ## ============================================================================ ## create several lists: x2: other deSolve objects, ## dotmain, dotpoints: remaining (plotting) parameters ## ============================================================================ splitdots <- function(ldots, varnames){ x2 <- list() dots <- list() nd <- 0 nother <- 0 ndots <- names(ldots) if (length(ldots) > 0) for ( i in 1:length(ldots)) if ("deSolve" %in% class(ldots[[i]])) { # a deSolve object x2[[nother <- nother + 1]] <- ldots[[i]] names(x2)[nother] <- ndots[i] # a list of deSolve objects } else if (is.list(ldots[[i]]) & "deSolve" %in% class(ldots[[i]][[1]])) { for (j in 1:length(ldots[[i]])) { x2[[nother <- nother+1]] <- ldots[[i]][[j]] names(x2)[nother] <- names(ldots[[i]])[[j]] } } else if (! is.null(ldots[[i]])) { # a graphical parameter dots[[nd <- nd+1]] <- ldots[[i]] names(dots)[nd] <- ndots[i] } nmdots <- names(dots) # check compatibility of all deSolve objects if (nother > 0) { for ( i in 1:nother) { if (min(colnames(x2[[i]]) == varnames) == 0) stop("'x' is not compatible with other deSolve objects - colnames not the same") } } # plotting parameters : split in plot parameters and point parameters plotnames <- c("xlab", "ylab", "xlim", "ylim", "main", "sub", "log", "asp", "ann", "axes", "frame.plot", "panel.first", "panel.last", "cex.lab", "cex.axis", "cex.main") # plot.default parameters ii <- names(dots) %in% plotnames dotmain <- dots[ii] # point parameters ip <- !names(dots) %in% plotnames dotpoints <- dots[ip] list(points = dotpoints, main = dotmain, nother = nother, x2 = x2) } ## ============================================================================= ## Which variable in common between observed and selected variables ## ============================================================================= WhichVarObs <- function(Which, obs, nvar, varnames, remove1st = TRUE) { if (is.null(Which) & is.null(obs$dat)) # All variables plotted Which <- 1 : nvar else if (is.null(Which)) { # All common variables in x and obs plotted Which <- which(varnames %in% obs$name) if (remove1st) Which <- Which[Which != 1] # remove first element (x-value) Which <- varnames[Which] # names rather than numbers } return(Which) } ## ============================================================================= ## Update Obs with position of observed variable in x ## ============================================================================= updateObs <- function (obs, varnames, xWhich) { if (obs$length > 0 ) { obs$Which <- selectvar(varnames[xWhich], obs$name, NAallowed = TRUE) obs$Which [ obs$Which > ncol(obs$dat)] <- NA # if (nrow(obs$pos) != length(obs$Which)) # obs$pos <- matrix(nrow = length(obs$Which), ncol = ncol(obs$pos), # byrow = TRUE, data =obs$pos[1,]) } else obs$Which <- rep(NA, length(xWhich)) return(obs) } updateObs2 <- function (obs, varnames, xWhich) { if (obs$length > 0 ) { obs$Which <- selectvar(varnames[xWhich], obs$name, NAallowed = TRUE) obs$Which [ obs$Which > ncol(obs$dat)] <- NA if (nrow(obs$pos) != length(obs$Which)) obs$pos <- matrix(nrow = length(obs$Which), ncol = ncol(obs$pos), byrow = TRUE, data =obs$pos[1,]) } else obs$Which <- rep(NA, length(xWhich)) return(obs) } ## ============================================================================= ## Set range of a plot, depending on deSolve object and data... ## ============================================================================= SetRange <- function(lim, x, x2, isub, ix, obs, io, Log) { nother <- length (x2) if ( is.null (lim)) { yrange <- Range(NULL, x[isub, ix], Log) if (nother>0) for (j in 1:nother) yrange <- Range(yrange, x2[[j]][isub,ix], Log) if (! is.na(io)) yrange <- Range(yrange, obs$dat[,io], Log) } else yrange <- lim return(yrange) } ## ============================================================================= ## Add observed data to a plot ## ============================================================================= plotObs <- function (obs, io, xyswap = FALSE) { oLength <- min(nrow(obs$pos), obs$length) if (! xyswap) { for (j in 1: oLength) { i.obs <- obs$pos[j, 1] : obs$pos[j, 2] if (length (i.obs) > 0) do.call("points", c(alist(obs$dat[i.obs, 1], obs$dat[i.obs, io]), extractdots(obs$par, j) )) } } else { for (j in 1: oLength) if (length (i.obs <- obs$pos[j, 1]:obs$pos[j, 2]) > 0) do.call("points", c(alist(obs$dat[i.obs, io], obs$dat[i.obs, 1]), extractdots(obs$par, j) )) } } ### ============================================================================ ### Plotting 0-D variables ### ============================================================================ plot.deSolve <- function (x, ..., select = NULL, which = select, ask = NULL, obs = NULL, obspar = list(), subset = NULL) { t <- 1 # column with independent variable "times" # Set the observed data obs <- SetData(obs) # variables to be plotted varnames <- colnames(x) Which <- WhichVarObs(which, obs, ncol(x) - 1, varnames) # Position of variables to be plotted in "x" xWhich <- selectvar(Which, varnames) np <- length(xWhich) # Position of variables in "obs" (NA = not observed) obs <- updateObs(obs, varnames, xWhich) obs$par <- lapply(obspar, repdots, obs$length) # The ellipsis ldots <- list(...) # number of figures in a row and interactively wait if remaining figures ask <- setplotpar(ldots, np, ask) if (ask) { oask <- devAskNewPage(TRUE) on.exit(devAskNewPage(oask)) } Dots <- splitdots(ldots, varnames) nother <- Dots$nother x2 <- Dots$x2 nx <- nother + 1 # total number of deSolve objects to be plotted Dotmain <- setdots(Dots$main, np) # expand to np for each plot # these are different from the default Dotmain$xlab <- expanddots(ldots$xlab, varnames[t] , np) Dotmain$ylab <- expanddots(ldots$ylab, "" , np) Dotmain$main <- expanddots(ldots$main, varnames[xWhich], np) # ylim and xlim can be lists and are at least two values yylim <- expanddotslist(ldots$ylim, np) xxlim <- expanddotslist(ldots$xlim, np) Dotpoints <- setdots(Dots$points, nx) # expand all dots to nx values # these are different from default Dotpoints$type <- expanddots(ldots$type, "l", nx) Dotpoints$lty <- expanddots(ldots$lty, 1:nx, nx) Dotpoints$pch <- expanddots(ldots$pch, 1:nx, nx) Dotpoints$col <- expanddots(ldots$col, 1:nx, nx) Dotpoints$bg <- expanddots(ldots$bg, 1:nx, nx) if (!missing(subset)){ e <- substitute(subset) r <- eval(e, as.data.frame(x), parent.frame()) if (is.numeric(r)) { isub <- r } else { if (!is.logical(r)) stop("'subset' must evaluate to logical or be a vector with integers") isub <- r & !is.na(r) } } else { isub <- TRUE } # LOOP for each output variable (plot) for (ip in 1 : np) { ix <- xWhich[ip] # position of variable in 'x' io <- obs$Which[ip] # position of variable in 'obs' # plotting parameters for deSolve output 1 (opens a plot) dotmain <- extractdots(Dotmain, ip) dotpoints <- extractdots(Dotpoints, 1) # 1st dotpoints Xlog <- Ylog <- FALSE if (! is.null(dotmain$log)) { Ylog <- length(grep("y",dotmain$log)) Xlog <- length(grep("x",dotmain$log)) } dotmain$ylim <- SetRange(yylim[[ip]], x, x2, isub, ix, obs, io, Ylog) dotmain$xlim <- SetRange(xxlim[[ip]], x, x2, isub, t, obs, 1, Xlog) # first deSolve object plotted (new plot created) do.call("plot", c(alist(x[isub, t], x[isub, ix]), dotmain, dotpoints)) if (nother > 0) # if other deSolve outputs for (j in 2:nx) do.call("lines", c(alist(x2[[j-1]][isub, t], x2[[j-1]][isub, ix]), extractdots(Dotpoints, j)) ) if (! is.na(io)) plotObs(obs, io) # add observed variables } } ## ============================================================================= ## to draw a legend ## ============================================================================= drawlegend <- function (parleg, dots) { Plt <- par(plt = parleg) par(new = TRUE) usr <- par("usr") ix <- 1 minz <- dots$zlim[1] maxz <- dots$zlim[2] binwidth <- (maxz - minz)/64 iy <- seq(minz + binwidth/2, maxz - binwidth/2, by = binwidth) iz <- matrix(iy, nrow = 1, ncol = length(iy)) image(ix, iy, iz, xaxt = "n", yaxt = "n", xlab = "", ylab = "", col = dots$col) do.call("axis", list(side = 4, mgp = c(3, 1, 0), las = 2)) par(plt = Plt) par(usr = usr) par(new = FALSE) } ## ============================================================================= ## to drape a color over a persp plot. ## ============================================================================= drapecol <- function (A, col = colorRampPalette(c("#00007F", "blue", "#007FFF", "cyan", "#7FFF7F", "yellow", "#FF7F00", "red", "#7F0000"))(100), NAcol = "white", Range = NULL) { nr <- nrow(A) nc <- ncol(A) ncol <- length(col) AA <- 0.25 * (A[1:(nr - 1), 1:(nc - 1)] + A[1:(nr - 1), 2:nc] + A[2:nr, 1:(nc - 1)] + A[2:nr, 2:nc]) if (is.null(Range)) Range <- range(A, na.rm = TRUE) else { AA[AA > Range[2]] <- Range[2] AA[AA < Range[1]] <- Range[1] } Ar <- Range rn <- Ar[2] - Ar[1] ifelse(rn != 0, drape <- col[1 + trunc((AA - Ar[1])/rn * (ncol - 1))], drape <- rep(col[1], ncol)) drape[is.na(drape)] <- NAcol return(drape) } ## ============================================================================= ## Finding 1-D variables ## ============================================================================= select1dvar <- function (Which, var, att) { if (is.null(att$map)) proddim <- prod(att$dimens) else proddim <- sum(!is.na(att$map)) ln <- length(Which) csum <- cumsum(att$lengthvar) + 2 if (!is.numeric(Which)) { # loop used to keep ordering... Select <- NULL for ( i in 1 : ln) { ss <- which(Which[i] == var) if (length(ss) == 0) stop("variable ", Which[i], " not in variable names") Select <- c(Select, ss) } } else { Select <- Which # "Select now refers to the column number if (max(Select) > length(var)) stop("index in 'which' too large") if (min(Select) < 1) stop("index in 'which' should be > 0") } istart <- numeric(ln) istop <- numeric(ln) for ( i in 1 : ln) { if (Select[i] <= att$nspec) { ii <- Select[i] istart[i] <- (ii-1)*proddim + 2 istop[i] <- istart[i] + proddim - 1 } else { ii <- Select[i] - att$nspec istart[i] <- csum[ii] istop[i] <- csum[ii+1]-1 } if (istart[i] == istop[i]) stop ("variable ",Which[i], " is not a 1-D variable") } return(list(Which = Select, istart = istart, istop = istop)) } ## ============================================================================= ## Finding 2-D variables ## ============================================================================= select2dvar <- function (Which, var, att) { if (is.null(att$map)) proddim <- prod(att$dimens) else proddim <- sum(!is.na(att$map)) ln <- length(Which) csum <- cumsum(att$lengthvar) + 2 if (!is.numeric(Which)) { # loop to keep ordering... Select <- NULL for ( i in 1 : ln) { ss <- which(Which[i] == var) if (length(ss) == 0) stop("variable ", Which[i], " not in variable names") Select <- c(Select, ss) } } else { Select <- Which # "Select now refers to the column number if (max(Select) > length(var)) stop("index in 'which' too large") if (min(Select) < 1) stop("index in 'which' should be > 0") } istart <- numeric(ln) istop <- numeric(ln) dimens <- list() for ( i in 1 : ln) { if (Select[i] <= att$nspec) { # a state variable ii <- Select[i] istart[i] <- (ii-1)*proddim + 2 istop[i] <- istart[i] + proddim-1 dimens[[i]] <- att$dimens } else { ii <- Select[i] - att$nspec istart[i] <- csum[ii] istop[i] <- csum[ii+1]-1 ij <- which(names(att$dimvar) == var[Select[i]]) if (length(ij) == 0) stop("variable ",var[Select]," is not two-dimensional") dimens[[i]] <- att$dimvar[[ij]] } } return(list(Which = Select, istart = istart, istop = istop, dim = dimens)) } ## ============================================================================= ## Adding a vertical axis to a plot ## ============================================================================= DrawVerticalAxis <- function (dot, xmin) { if (is.null(dot$xlim)) v <- xmin else v <- dot$xlim[1] abline(h = dot$ylim[2]) abline(v = v) axis(side = 2) axis(side = 3, mgp = c(3,0.5,0)) } ### ============================================================================ ### plotting 1-D variables as line plot, one for each time ### ============================================================================ plot.1D <- function (x, ... , select= NULL, which = select, ask = NULL, obs = NULL, obspar = list(), grid = NULL, xyswap = FALSE, delay = 0, vertical = FALSE, subset = NULL) { ## Check settings of x att <- attributes(x) nspec <- att$nspec dimens <- att$dimens proddim <- prod(dimens) if (length(dimens) != 1) stop ("plot.1D only works for models solved with 'ode.1D'") if ((ncol(x)- nspec*proddim) < 1) stop("ncol of 'x' should be > 'nspec' * dimens if x is a vector") # Set the observed data obs <- SetData(obs) # 1-D variable names varnames <- if (! is.null(att$ynames)) att$ynames else 1:nspec if (! is.null(att$lengthvar)) varnames <- c(varnames, names(att$lengthvar)[-1]) # variables to be plotted, common between obs and x Which <- WhichVarObs(which, obs, nspec, varnames, remove1st = FALSE) np <- length(Which) Select <- select1dvar(Which, varnames, att) xWhich <- Select$Which # add Position of variables to be plotted in "obs" obs <- updateObs (obs, varnames, xWhich) obs$par <- lapply(obspar, repdots, obs$length) # karline: small bug fixed here # the ellipsis ldots <- list(...) ## number of figures in a row and interactively wait if remaining figures ask <- setplotpar(ldots, np, ask) if (ask) { oask <- devAskNewPage(TRUE) on.exit(devAskNewPage(oask)) } Dots <- splitdots(ldots, colnames(x)) # for time-moving figures; number of plots should = mfrow settings prodx <- prod(par("mfrow")) if (np < prodx) eplot <- prodx - np else eplot <- 0 nother <- Dots$nother x2 <- Dots$x2 nx <- nother + 1 # total number of deSolve objects to be plotted Dotmain <- setdots(Dots$main, np) # expand to np for each plot Dotpoints <- setdots(Dots$points, nx) # These are different from defaulst Dotmain$xlab <- expanddots(ldots$xlab, "x", np) Dotmain$ylab <- expanddots(ldots$ylab, varnames[xWhich], np) # xlim and ylim are special: xxlim <- expanddotslist(ldots$xlim, np) yylim <- expanddotslist(ldots$ylim, np) xyswap <- rep(xyswap, length = np) vertical <- rep(vertical, length = np) grid <- expanddotslist(grid, np) if (!missing(subset)){ e <- substitute(subset) r <- eval(e, as.data.frame(x), parent.frame()) if (is.numeric(r)) { isub <- r } else { if (!is.logical(r)) stop("'subset' must evaluate to logical or be a vector with integers") isub <- which(r & !is.na(r)) } } else { isub <- 1:nrow(x) } # allow individual xlab and ylab (vectorized) times <- x[isub,1] Dotsmain <- expanddots(Dotmain$main, paste("time", times), length(times)) for (j in isub) { for (ip in 1:np) { istart <- Select$istart[ip] istop <- Select$istop[ip] io <- obs$Which[ip] out <- x[j,istart:istop] Grid <- grid[[ip]] if (is.null(Grid)) Grid <- 1:length(out) dotmain <- extractdots(Dotmain, ip) dotpoints <- extractdots(Dotpoints, 1) # 1st one dotmain$main <- Dotsmain[j] if (vertical[ip]) { # overrules other settings; vertical profiles xyswap[ip] <- TRUE dotmain$axes <- FALSE dotmain$xlab <- "" dotmain$xaxs <- "i" dotmain$yaxs <- "i" } Xlog <- Ylog <- FALSE if (! is.null(dotmain$log)) { Ylog <- length(grep("y",dotmain$log)) Xlog <- length(grep("x",dotmain$log)) } if (! xyswap[ip]) { if (! is.null(xxlim[[ip]])) dotmain$xlim <- xxlim[[ip]] dotmain$ylim <- SetRange(yylim[[ip]], x, x2, isub, istart:istop, obs, io, Ylog) } else { if (! is.null(yylim[[ip]])) dotmain$ylim <- yylim[[ip]] dotmain$xlim <- SetRange(xxlim[[ip]], x, x2, isub, istart:istop, obs, io, Xlog) if (is.null(yylim[[ip]]) & xyswap[ip]) dotmain$ylim <- rev(range(Grid)) # y-axis } if (! xyswap[ip]) { do.call("plot", c(alist(Grid, out), dotmain, dotpoints)) if (nother > 0) # if other deSolve outputs for (jj in 2:nx) do.call("lines", c(alist(Grid, x2[[jj-1]][j,istart:istop]), extractdots(Dotpoints, jj)) ) if (! is.na(io)) plotObs(obs, io) } else { if (is.null(Dotmain$xlab[ip]) | is.null(Dotmain$ylab[ip])) { dotmain$ylab <- Dotmain$xlab[ip] dotmain$xlab <- Dotmain$ylab[ip] } do.call("plot", c(alist(out, Grid), dotmain, dotpoints)) if (nother > 0) # if other deSolve outputs for (jj in 2:nx) do.call("lines", c(alist(x2[[jj-1]][j,istart:istop], Grid), extractdots(Dotpoints, jj)) ) if (vertical[ip]) DrawVerticalAxis(dotmain,min(out)) if (! is.na(io)) plotObs(obs, io, xyswap = TRUE) } } # end loop ip if (eplot > 0) for (i in 1:eplot) plot(0, type ="n", axes = FALSE, xlab="", ylab="") if (delay > 0) Sys.sleep(0.001 * delay) } } ### ============================================================================ plot.ode1D <- function (x, which, ask, add.contour, grid, method = "image", legend, isub = 1:nrow(x), ...) { # Default color scheme BlueRed <- colorRampPalette(c("#00007F", "blue", "#007FFF", "cyan", "#7FFF7F", "yellow", "#FF7F00", "red", "#7F0000")) # if x is vector, check if there are enough columns ... att <- attributes(x) nspec <- att$nspec dimens <- att$dimens proddim <- prod(dimens) if ((ncol(x)- nspec * proddim) < 1) stop("ncol of 'x' should be > 'nspec' * dimens if x is a vector") # variables to be plotted if (is.null(which)) Which <- 1 : nspec else Which <- which np <- length(Which) varnames <- if (! is.null(att$ynames)) att$ynames else 1:nspec if (! is.null(att$lengthvar)) varnames <- c(varnames, names(att$lengthvar)[-1]) Select <- select1dvar(Which, varnames, att) Which <- Select$Which ldots <- list(...) # number of figures in a row and interactively wait if remaining figures ask <- setplotpar(ldots, np, ask) if (ask) { oask <- devAskNewPage(TRUE) on.exit(devAskNewPage(oask)) } Dotmain <- setdots(ldots, np) # expand dots to np values (no defaults) # different from the default Dotmain$main <- expanddots(ldots$main, varnames[Which], np) Dotmain$xlab <- expanddots(ldots$xlab, "times", np) Dotmain$ylab <- expanddots(ldots$ylab, "", np) # colors - different if persp, image or filled.contour if (method == "persp") dotscol <- ldots$col else if (method == "filled.contour") { dotscolorpalette <- if (is.null(ldots$color.palette)) BlueRed else ldots$color.palette dotscol <- dotscolorpalette(100) add.contour <- FALSE legend <- FALSE } else if (is.null(ldots$col)) dotscol <- BlueRed(100) else dotscol <- ldots$col Addcontour <- rep(add.contour, length = np) # xlim, ylim and zlim are special: xxlim <- expanddotslist(ldots$xlim, np) yylim <- expanddotslist(ldots$ylim, np) zzlim <- expanddotslist(ldots$zlim, np) times <- x[isub,1] if (legend) { parplt <- par("plt") - c(0,0.07,0,0) parleg <- c(parplt[2]+0.02, parplt[2]+0.05, parplt[3], parplt[4]) plt.or <- par(plt = parplt) # on.exit(par(plt = plt.or)) } # Check if grid is increasing... if (! is.null(grid)) gridOK <- min(diff (grid)) >0 else gridOK <- TRUE if (! gridOK) grid <- rev(grid) # for each output variable (plot) for (ip in 1:np) { # ix <- Which[ip] istart <- Select$istart[ip] istop <- Select$istop[ip] if (gridOK) out <- x[isub ,istart:istop] else out <- x[isub ,istop:istart] dotmain <- extractdots(Dotmain, ip) if (! is.null(xxlim)) dotmain$xlim <- xxlim[[ip]] if (! is.null(yylim)) dotmain$ylim <- yylim[[ip]] if (! is.null(zzlim)) dotmain$zlim <- zzlim[[ip]] else dotmain$zlim <- range(out, na.rm=TRUE) List <- alist(z = out, x = times) if (! is.null(grid)) List$y = grid if (method == "persp") { if (is.null(dotmain$zlim)) # this to prevent error when range = 0 if (diff(range(out, na.rm=TRUE)) == 0) dotmain$zlim <- c(0, 1) if (is.null(dotscol)) dotmain$col <- drapecol(out, col = BlueRed (100), Range = dotmain$zlim) else dotmain$col <- drapecol(out, col = dotscol, Range = dotmain$zlim) } else if (method == "filled.contour") dotmain$color.palette <- dotscolorpalette else dotmain$col <- dotscol do.call(method, c(List, dotmain)) if (Addcontour[ip]) do.call("contour", c(List, add = TRUE)) if (legend) { if (method == "persp") if (is.null(dotscol)) dotmain$col <- BlueRed(100) else dotmain$col <- dotscol if (is.null(dotmain$zlim)) dotmain$zlim <- range(out, na.rm=TRUE) drawlegend(parleg, dotmain) } } if (legend) { par(plt = plt.or) par(mar = par("mar")) # TRICK TO PREVENT R FROM SETTING DEFAULTPLOT = FALSE } } ### ============================================================================ ### plotting 2-D variables ### ============================================================================ plot.ode2D <- function (x, which, ask, add.contour, grid, method = "image", legend = TRUE, isub = 1:nrow(x), ...) { # Default color scheme BlueRed <- colorRampPalette(c("#00007F", "blue", "#007FFF", "cyan", "#7FFF7F", "yellow", "#FF7F00", "red", "#7F0000")) # if x is vector, check if there are enough columns ... att <- attributes(x) nspec <- att$nspec dimens <- att$dimens proddim <- prod(dimens) Mask <- att$map map <- (! is.null(Mask)) if (!map & (ncol(x) - nspec*proddim) < 1) stop("ncol of 'x' should be > 'nspec' * dimens if x is a vector") # variables to be plotted if (is.null(which)) Which <- 1:nspec else Which <- which np <- length(Which) varnames <- if (! is.null(att$ynames)) att$ynames else 1:nspec if (! is.null(att$lengthvar)) varnames <- c(varnames, names(att$lengthvar)[-1]) Select <- select2dvar(Which,varnames,att) Which <- Select$Which ldots <- list(...) Mtext <- ldots$mtext ldots$mtext <- NULL # number of figures in a row and interactively wait if remaining figures Ask <- setplotpar(ldots, np, ask) # here ask is always true by default... if (is.null(ask)) ask <- TRUE if (ask) { oask <- devAskNewPage(TRUE) on.exit(devAskNewPage(oask)) } N <- np * nrow(x) if (method == "filled.contour") { add.contour <- FALSE legend <- FALSE } Dotmain <- setdots(ldots, N) # expand dots to np values (no defaults) # different from the default Dotmain$main <- expanddots(ldots$main, varnames[Which], N) Dotmain$xlab <- expanddots(ldots$xlab, "x" , N) Dotmain$ylab <- expanddots(ldots$ylab, "y" , N) if (method == "persp") dotscol <- ldots$col else if (method == "filled.contour") { dotscolorpalette <- if (is.null(ldots$color.palette)) BlueRed else ldots$color.palette dotscol <- dotscolorpalette(100) add.contour <- FALSE legend <- FALSE } else if (is.null(ldots$col)) dotscol <- BlueRed(100) else dotscol <- ldots$col dotslim <- ldots$zlim xxlim <- expanddotslist(ldots$xlim, np) yylim <- expanddotslist(ldots$ylim, np) zzlim <- expanddotslist(ldots$zlim, np) Addcontour <- rep(add.contour, length = np) i <- 0 if (legend) { parplt <- par("plt") - c(0, 0.05, 0, 0) parleg <- c(parplt[2] + 0.02, parplt[2] + 0.05, parplt[3], parplt[4]) plt.or <- par(plt = parplt) # on.exit(par(plt = plt.or)) } x <- x[isub,] if (length(isub) > 1 & sum (isub) == 1) x <- matrix (nrow = 1, data =x) if (! is.null(Mtext)) Mtext <- rep(Mtext, length.out = nrow(x)) for (nt in 1:nrow(x)) { for (ip in 1:np) { i <- i+1 istart <- Select$istart[ip] istop <- Select$istop[ip] if (map) { out <- rep (NA, length = prod(Select$dim[[ip]])) ii <- which (! is.na(Mask)) out[ii] <- x[nt, istart:istop] } else out <- x[nt, istart:istop] dim(out) <- Select$dim[[ip]] dotmain <- extractdots(Dotmain, i) if (! is.null(xxlim)) dotmain$xlim <- xxlim[[ip]] if (! is.null(yylim)) dotmain$ylim <- yylim[[ip]] if (! is.null(zzlim)) dotmain$zlim <- zzlim[[ip]] else { dotmain$zlim <- range(out, na.rm=TRUE) if (diff(dotmain$zlim ) == 0 ) dotmain$zlim[2] <- dotmain$zlim[2] +1 } if (map) { if (is.null(dotmain$zlim)) dotmain$zlim <- range(out, na.rm=TRUE) out[is.na(out)] <- dotmain$zlim[1] - 0.01*max(1e-18,diff(dotmain$zlim)) dotmain$zlim [1] <- dotmain$zlim[1] - 0.01*max(1e-18,diff(dotmain$zlim)) } List <- alist(z = out) if (! is.null(grid)) { List$x <- grid$x List$y <- grid$y } if (method == "persp") { if (is.null(dotmain$zlim)) if (diff(range(out, na.rm = TRUE)) == 0) dotmain$zlim <- c(0, 1) if (is.null(dotscol)) dotmain$col <- drapecol(out, col = BlueRed(100), Range = dotmain$zlim) else dotmain$col <- drapecol(out, col = dotscol, Range = dotmain$zlim) } else if (method == "image") { dotmain$col <- dotscol if (map) dotmain$col <- c("black", dotmain$col) } else if (method == "filled.contour") dotmain$color.palette <- dotscolorpalette do.call(method, c(List, dotmain)) if (! method %in% c("persp", "filled.contour")) box() if (add.contour) do.call("contour", c(List, add = TRUE)) if (legend) { if (method == "persp") if (is.null(dotscol)) dotmain$col <- BlueRed(100) else dotmain$col <- dotscol if (is.null(dotmain$zlim)) dotmain$zlim <- range(out, na.rm=TRUE) drawlegend(parleg, dotmain) } } if (! is.null(Mtext)) mtext(outer = TRUE, side = 3, Mtext[nt], cex = 1.5, line = par("oma")[3]-1.5) } if (legend) { par(plt = plt.or) par(mar = par("mar")) # TRICK TO PREVENT R FROM SETTING DEFAULTPLOT = FALSE } # karline: ??? removed that... make it an argument? # if (sum(par("mfrow") - c(1, 1)) == 0 ) # mtext(outer = TRUE, side = 3, paste("time ", x[nt, 1]), # cex = 1.5, line = -1.5) } ### ============================================================================ ### Summaries of ode variables ### ============================================================================ summary.deSolve <- function(object, select = NULL, which = select, subset = NULL, ...){ att <- attributes(object) svar <- att$lengthvar[1] # number of state variables lvar <- att$lengthvar[-1] # length of other variables nspec <- att$nspec # for models solved with ode.1D, ode.2D dimens <- att$dimens if (is.null(svar)) svar <- att$dim[2]-1 # models solved as DLL # variable names: information for state and ordinary variables is different if (is.null(att$ynames)) if (is.null(dimens)) varnames <- colnames(object)[2:(svar+1)] else varnames <- 1:nspec else varnames <- att$ynames # this gives one name for multi-dimensional var. if (length(lvar) > 0) { lvarnames <- names(lvar) if (is.null(lvarnames)) lvarnames <- (length(varnames)+1):(length(varnames)+length(lvar)) varnames <- c(varnames, lvarnames) } # length of state AND other variables if (is.null(dimens)) # all 0-D state variables lvar <- c(rep(1, len = svar), lvar) else lvar <- c(rep(prod(dimens), nspec), lvar) # multi-D state variables if (!missing(subset)){ e <- substitute(subset) r <- eval(e, as.data.frame(object), parent.frame()) if (is.numeric(r)) { isub <- r } else { if (!is.logical(r)) stop("'subset' must evaluate to logical or be a vector with integers") isub <- r & !is.na(r) object <- object[isub,] } } # summaries for all variables Summ <- NULL for (i in 1:length(lvar)) { if (lvar[i] > 1) { Select <- select1dvar(i, varnames, att) out <- as.vector(object[, Select$istart:Select$istop]) } else { Select <- selectvar(varnames[i], colnames(object), NAallowed = TRUE) if (is.na(Select)) # trick for composite names, e.g. "A.x" rather than "A" Select <- cumsum(lvar)[i] out <- object[ ,Select] } Summ <- rbind(Summ, c(summary(out, ...), N = length(out), sd = sd(out))) } rownames(Summ) <- varnames # rownames or an extra column? if (! is.null(which)) Summ <- Summ[which,] data.frame(t(Summ)) # like this or not transposed? } ### ============================================================================ ### Subsets of ode variables ### ============================================================================ subset.deSolve <- function(x, subset = NULL, select = NULL, which = select, arr = FALSE, ...) { Which <- which # for compatibility between plot.deSolve and subset if (arr & length(Which) > 1) stop("cannot combine 'arr = TRUE' when more than one variable is selected") if (missing(subset)) r <- TRUE else { e <- substitute(subset) r <- eval(e, as.data.frame(x), parent.frame()) if (is.numeric(r)) { isub <- r } else { if (!is.logical(r)) stop("'subset' must evaluate to logical or be a vector with integers") r <- r & !is.na(r) } } if (is.numeric(Which)) return(x[r ,Which+1]) if (is.null(Which)) return(x[r , -1]) # Default: all variables, except time att <- attributes(x) svar <- att$lengthvar[1] # number of state variables lvar <- att$lengthvar[-1] # length of other variables nspec <- att$nspec # for models solved with ode.1D, ode.2D dimens <- att$dimens if (arr & length(dimens) <= 1 ) warning("does not make sense to have 'arr = TRUE' when output is not 2D or 3D") if (is.null(svar)) svar <- att$dim[2]-1 # models solved as DLL if(is.null(nspec)) nspec <- svar # variable names: information for state and ordinary variables is different if (is.null(att$ynames)) if (is.null(dimens)) varnames <- colnames(x)[2:(svar+1)] else varnames <- 1:nspec else varnames <- att$ynames # this gives one name for multi-dimensional var. varnames <- c("time",varnames) if (length(lvar) > 0) { lvarnames <- names(lvar) if (is.null(lvarnames)) lvarnames <- (length(varnames)+1):(length(varnames)+length(lvar)) varnames <- c(varnames, lvarnames) } # length of state AND other variables if (is.null(dimens)) # all 0-D state variables lvar <- c(rep(1, len = svar), lvar) else lvar <- c(rep(prod(dimens), nspec), lvar) # multi-D state variables cvar <- cumsum(c(1,lvar)) # Add selected variables to Out Out <- NULL for (iw in 1:length(Which)) { i <- which (varnames == Which[iw]) if (length(i) == 0) { i <- which (colnames(x) == Which[iw]) if (length(i) == 0) stop ("cannot find variable ", Which[iw], " in output") Out <- cbind(Out, x[,i]) } else { if (is.null(i)) stop ("cannot find variable ", Which[iw], " in output") istart <- 1 if (i > 1) istart <- cvar[i-1]+1 istop <- cvar[i] Out <- cbind(Out, x[ ,istart:istop]) } } if (length(Which) == ncol(Out)) colnames(Out) <- Which OO <- Out[r, ] if(is.vector(OO)) OO <- matrix(ncol = ncol(Out), data = OO) times <- x[r,1] if (arr & length(dimens) > 1 & ncol(OO) == prod(dimens)) { Nr <- nrow(OO) OO <- array(dim = c(dimens, Nr) , data = t(OO)) } attr(OO, "times") <- times return(OO) } deSolve/R/rk.R0000754000175100001440000002347012663327633012654 0ustar hornikusers### ============================================================================ ### Interface to a generalized code for solving explicit variable and fixed ### step ODE solvers of the Runge-Kutta family, see helpfile for details. ### ============================================================================ rk <- function(y, times, func, parms, rtol = 1e-6, atol = 1e-6, verbose = FALSE, tcrit = NULL, hmin = 0, hmax = NULL, hini = hmax, ynames = TRUE, method = rkMethod("rk45dp7", ... ), maxsteps = 5000, dllname = NULL, initfunc = dllname, initpar = parms, rpar = NULL, ipar = NULL, nout = 0, outnames = NULL, forcings = NULL, initforc = NULL, fcontrol = NULL, events = NULL, ...) { ## check for unsupported solver options dots <- list(...); nmdots <- names(dots) if(any(c("jacfunc", "jactype", "mf", "bandup", "banddown") %in% nmdots)) { warning("Euler and Runge-Kutta solvers make no use of a Jacobian,\n", " ('jacfunc', 'jactype', 'mf', 'bandup' and 'banddown' are ignored).\n") } if(any(c("lags") %in% nmdots)) { warning("lags are not yet implemented for Euler and Runge-Kutta solvers,\n", " (argument 'lags' is ignored).\n") } if (is.list(func)) { # a list of compiled functions if (!is.null(initfunc) & "initfunc" %in% names(func)) stop("If 'func' is a list that contains initfunc, argument 'initfunc' should be NULL") if (!is.null(dllname) & "dllname" %in% names(func)) stop("If 'func' is a list that contains dllname, argument 'dllname' should be NULL") if (!is.null(initforc) & "initforc" %in% names(func)) stop("If 'func' is a list that contains initforc, argument 'initforc' should be NULL") if (!is.null(events$func) & "eventfunc" %in% names(func)) stop("If 'func' is a list that contains eventfunc, argument 'events$func' should be NULL") if ("eventfunc" %in% names(func)) { if (! is.null(events)) events$func <- func$eventfunc else events <- list(func = func$eventfunc) } if (!is.null(func$initfunc)) initfunc <- func$initfunc if (!is.null(func$dllname)) dllname <- func$dllname if (!is.null(func$initforc)) initforc <- func$initforc func <- func$func } if (is.character(method)) method <- rkMethod(method) varstep <- method$varstep if (!varstep & (hmin != 0 | !is.null(hmax))) cat("'hmin' and 'hmax' are ignored (fixed step Runge-Kutta method).\n") ## Check inputs hmax <- checkInput(y, times, func, rtol, atol, jacfunc = NULL, tcrit, hmin, hmax, hini, dllname) if (hmax == 0) hmax <- .Machine$double.xmax # i.e. practically unlimited n <- length(y) if (maxsteps < 0) stop("maxsteps must be positive") if (!is.finite(maxsteps)) maxsteps <- .Machine$integer.max - 1 if (is.null(tcrit)) tcrit <- max(times) ## ToDo: check for nonsense-combinations of densetype and d if (!is.null(method$densetype)) { ## make this an integer to avoid errors on the C level method$densetype <- as.integer(method$densetype) if (!(method$densetype %in% c(1L, 2L))) { warning("Unknown value of densetype; set to NULL") method$densetype <- NULL } } ## Checks and ajustments for Neville-Aitken interpolation ## - starting from deSolve >= 1.7 this interpolation method ## is disabled by default. ## - Dense output for special RK methods is enabled and ## all others adjust internal time steps to hit external time steps if (is.null(method$nknots)) { method$nknots <- 0L } else { method$nknots <- as.integer(ceiling(method$nknots)) } nknots <- method$nknots if (nknots > 8L) { warning("Large number of nknots does not make sense.") } else if (nknots < 2L) { ## method without or with disabled interpolation method$nknots <- 0L } else { trange <- diff(range(times)) ## ensure that we have at least nknots + 2 data points; + 0.5 for safety) ## to allow 3rd order polynomial interpolation ## for methods without built-in dense output if ((is.null(method$d) & # has no "dense output"? is.null(method$densetype) & # or no dense output type (hmax > 1.0/(nknots + 2.5) * trange))) { # or time steps too large? ## in interpolation mode: automatic adjustment of step size arguments ## to ensure the required minimum of knots hini <- hmax <- 1.0/(nknots + 2.5) * trange if (hmin < hini) hmin <- hini cat("\nNote: Method ", method$ID, " needs intermediate steps for interpolation\n") cat("hmax decreased to", hmax, "\n") } } ## Model as shared object (DLL)? Ynames <- attr(y, "names") Initfunc <- NULL Eventfunc <- NULL events <- checkevents(events, times, Ynames, dllname) if (! is.null(events$newTimes)) times <- events$newTimes ## dummy forcings flist <-list(fmat = 0, tmat = 0, imat = 0, ModelForc = NULL) Nstates <- length(y) # assume length of states is correct ## function specified in a DLL or inline compiled if (is.character(func) | class(func) == "CFunc") { DLL <- checkDLL(func, NULL, dllname, initfunc, verbose, nout, outnames) Initfunc <- DLL$ModelInit Func <- DLL$Func Nglobal <- DLL$Nglobal Nmtot <- DLL$Nmtot Eventfunc <- events$func if (! is.null(forcings)) flist <- checkforcings(forcings, times, dllname, initforc, verbose, fcontrol) if (is.null(ipar)) ipar <- 0 if (is.null(rpar)) rpar <- 0 ## preparation for events in R if function is a DLL (added by KS) if (is.function(Eventfunc)) rho <- environment(Eventfunc) else rho <- NULL } else { ## parameter initialisation not needed if function is not a DLL initpar <- NULL rho <- environment(func) ## func is overruled, either including ynames, or not ## This allows to pass the "..." arguments and the parameters if(ynames) { Func <- function(time, state, parms){ attr(state, "names") <- Ynames func(time, state, parms, ...)} if (! is.null(events$Type)) if (events$Type == 2) Eventfunc <- function(time, state) { attr(state, "names") <- Ynames events$func(time, state, parms, ...) } } else { # no ynames... Func <- function(time, state, parms) func(time, state, parms, ...) if (! is.null(events$Type)) if (events$Type == 2) Eventfunc <- function(time, state) events$func(time, state, parms, ...) } ## Call func once to figure out whether and how many "global" ## results it wants to return and some other safety checks FF <- checkFuncEuler(Func, times, y, parms, rho, Nstates) Nglobal <- FF$Nglobal Nmtot <- FF$Nmtot if (! is.null(events$Type)) if (events$Type == 2) checkEventFunc(Eventfunc, times, y, rho) } ## handle length of atol and rtol if (Nstates %% length(atol)) warning("length of atol does not match number of states") if (Nstates %% length(rtol)) warning("length of rtol does not match number of states") atol <- rep(atol, length.out = Nstates) rtol <- rep(rtol, length.out = Nstates) ## Number of steps until the solver gives up # nsteps <- min(.Machine$integer.max -1, maxsteps * length(times)) ## changed in v.1.13: total number of time steps is set to ## average number per time step * number of time steps ## but not less than required for the largest time step with given hini nsteps <- min(.Machine$integer.max - 1, max(maxsteps * length(times), # max. total number of steps max(diff(times))/hini + 1) # but not less than required ) vrb <- FALSE # TRUE forces some internal debugging output of the C code ## Implicit methods on.exit(.C("unlock_solver")) implicit <- method$implicit if (is.null(implicit)) implicit <- 0 if (implicit) { if (is.null(hini)) hini <- 0 out <- .Call("call_rkImplicit", as.double(y), as.double(times), Func, Initfunc, parms, Eventfunc, events, as.integer(Nglobal), rho, as.double(tcrit), as.integer(vrb), as.double(hini), as.double(rpar), as.integer(ipar), method, as.integer(nsteps), flist) } else if (varstep) { # Methods with variable step size if (is.null(hini)) hini <- hmax out <- .Call("call_rkAuto", as.double(y), as.double(times), Func, Initfunc, parms, Eventfunc, events, as.integer(Nglobal), rho, as.double(atol), as.double(rtol), as.double(tcrit), as.integer(vrb), as.double(hmin), as.double(hmax), as.double(hini), as.double(rpar), as.integer(ipar), method, as.integer(nsteps), flist) } else { # Fixed step methods ## hini = 0 for fixed step methods means ## that steps in "times" are used as they are if (is.null(hini)) hini <- 0 out <- .Call("call_rkFixed", as.double(y), as.double(times), Func, Initfunc, parms, Eventfunc, events, as.integer(Nglobal), rho, as.double(tcrit), as.integer(vrb), as.double(hini), as.double(rpar), as.integer(ipar), method, as.integer(nsteps), flist) } ## output cleanup out <- saveOutrk(out, y, n, Nglobal, Nmtot, iin = c(1, 12:15), iout = c(1:3, 13, 18)) attr(out, "type") <- "rk" if (verbose) diagnostics(out) return(out) } deSolve/R/ccl4model.R0000754000175100001440000000064212352122161014062 0ustar hornikusersccl4model <- function(times, y, parms, ...) { if (length(y) != 7) stop ("length of state variable vector should be 7") if (length(parms) != 21) stop ("length of parameter vector should be 21") names(y) <- c("AI","AAM","AT","AF","AL","CLT","AM") ode(y=y,dllname="deSolve",func="derivsccl4", initfunc = "initccl4",parms=parms, times=times,nout=3,outnames=c("DOSE","MASS","CP"),...) } deSolve/R/ode.R0000754000175100001440000004502412352122161012766 0ustar hornikusers### ============================================================================ ### ### ode.1D, ode.2D ode.band: special-purpose integration routines ### ode.1D is designed for solving multi-component 1-D reaction-transport models ### ode.2D is designed for solving multi-component 2-D reaction-transport models ### ode.band is designed for solving single-component 1-D reaction-transport models ### ode.1D,ode.band offer the choice between the integrators vode, ### lsode, lsoda, lsodar and lsodes. ### ode.2D uses lsodes. ### ### KS: added **bandwidth** to ode.1D ### to do: make it work with lsodes + with ode.2D, ode.3D!! ### ============================================================================ ode <- function (y, times, func, parms, method = c("lsoda","lsode","lsodes","lsodar","vode","daspk", "euler", "rk4", "ode23", "ode45", "radau", "bdf", "bdf_d", "adams", "impAdams", "impAdams_d", "iteration"), ...) { if (is.null(method)) method <- "lsoda" if (is.list(method)) { # is() should work from R 2.7 on ... # if (!is(method, "rkMethod")) if (!"rkMethod" %in% class(method)) stop("'method' should be given as string or as a list of class 'rkMethod'") out <- rk(y, times, func, parms, method = method, ...) } else if (is.function(method)) out <- method(y, times, func, parms,...) else if (is.complex(y)) out <- switch(match.arg(method), vode = zvode(y, times, func, parms, ...), bdf = zvode(y, times, func, parms, mf = 22, ...), bdf_d = zvode(y, times, func, parms, mf = 23, ...), adams = zvode(y, times, func, parms, mf = 10, ...), impAdams = zvode(y, times, func, parms, mf = 12, ...), impAdams_d = zvode(y, times, func, parms, mf = 13, ...) ) else out <- switch(match.arg(method), lsoda = lsoda(y, times, func, parms, ...), vode = vode(y, times, func, parms, ...), lsode = lsode(y, times, func, parms, ...), lsodes= lsodes(y, times, func, parms, ...), lsodar= lsodar(y, times, func, parms, ...), daspk = daspk(y, times, func, parms, ...), euler = rk(y, times, func, parms, method = "euler", ...), rk4 = rk(y, times, func, parms, method = "rk4", ...), ode23 = rk(y, times, func, parms, method = "ode23", ...), ode45 = rk(y, times, func, parms, method = "ode45", ...), radau = radau(y, times, func, parms, ...), bdf = lsode(y, times, func, parms, mf = 22, ...), bdf_d = lsode(y, times, func, parms, mf = 23, ...), adams = lsode(y, times, func, parms, mf = 10, ...), impAdams = lsode(y, times, func, parms, mf = 12, ...), impAdams_d = lsode(y, times, func, parms, mf = 13, ...), iteration = iteration(y, times, func, parms, ...) ) return(out) } ### ============================================================================ ode.1D <- function (y, times, func, parms, nspec = NULL, dimens = NULL, method = c("lsoda","lsode", "lsodes","lsodar","vode","daspk", "euler", "rk4", "ode23", "ode45","radau", "bdf", "adams", "impAdams", "iteration"), names = NULL, bandwidth = 1, restructure = FALSE, ...) { # check input if (is.character(method)) method <- match.arg(method) islsodes <- FALSE if (is.character(method)) if (method=="lsodes") islsodes <- TRUE if (is.null(method)) method <- "lsoda" if (any(!is.na(pmatch(names(list(...)), "jacfunc")))) stop ("cannot run ode.1D with jacfunc specified - remove jacfunc from call list") if (is.null(nspec) && is.null(dimens)) stop ("cannot run ode.1D: nspec OR dimens should be specified") # if (islsodes && bandwidth != 1) # stop ("cannot combine 'method = lsodes' with 'bandwidth' not = 1") iscomplex <- is.complex(y) N <- length(y) if (is.null(nspec) ) nspec <- N/dimens if (N %% nspec != 0 ) stop ("cannot run ode.1D: nspec is not an integer fraction of number of state variables") if (! is.null(names) && length(names) != nspec) stop("length of 'names' should equal 'nspec'") # Use ode.band if implicit method with nspec=1 if (is.character(method)) if( nspec == 1 & method %in% c("lsoda","lsode","lsodar","vode","daspk","radau")) { out <- ode.band(y, times, func, parms, nspec = nspec, method = method, bandup = nspec * bandwidth, banddown = nspec * bandwidth, ...) attr(out,"ynames") <- names if (is.null(dimens)) dimens <- N/nspec attr (out, "dimens") <- dimens attr (out, "nspec") <- nspec return(out) } # Use lsodes explicit <- FALSE adams_expl <- FALSE if (is.character(method)){ if (method %in% c("euler", "rk4", "ode23", "ode45", "iteration")) explicit <- TRUE adams_expl <- explicit | method == "adams" } if (is.character(func) & !explicit || islsodes) { if (is.character(method)) if (! method %in% c("lsodes", "euler", "rk4", "ode23", "ode45", "iteration")) warning("ode.1D: R-function specified in a DLL-> integrating with lsodes") if (is.null(dimens) ) dimens <- N/nspec if (bandwidth != 1) # try to remove this.... out <- lsodes(y=y,times=times,func=func,parms,...) else out <- lsodes(y=y,times=times,func=func,parms,sparsetype="1D", nnz=c(nspec,dimens,bandwidth),...) # a Runge-Kutta or Euler } else if (is.list(method)) { # is() should work from R 2.7 on ... # if (!is(method, "rkMethod")) if (!"rkMethod" %in% class(method)) stop("'method' should be given as string or as a list of class 'rkMethod'") out <- rk(y, times, func, parms, method = method, ...) # a function that does not need restructuring } else if (is.function(method) && !restructure) out <- method(y, times, func, parms,...) else if (is.function(method) && restructure) { NL <- names(y) # internal function # bmodel <- function (time,state,pars,model,...) { Modconc <- model(time,state[ij],pars,...) # ij: reorder state variables c(list(Modconc[[1]][ii]), Modconc[-1]) # ii: reorder rate of change } if (is.character(func)) stop ("cannot run ode.1D with R-function specified in a DLL") ii <- as.vector(t(matrix(data=1:N,ncol=nspec))) # from ordering per slice -> per spec ij <- as.vector(t(matrix(data=1:N,nrow=nspec))) # from ordering per spec -> per slice bmod <- function(time,state,pars,...) bmodel(time,state,pars,func,...) out <- method(y[ii], times, func=bmod, parms=parms, bandup=nspec*bandwidth, banddown=nspec*bandwidth, jactype="bandint", ...) out[,(ii+1)] <- out[,2:(N+1)] if (! is.null(NL)) colnames(out)[2:(N+1)]<- NL } # an explicit method... as a string else if (adams_expl) { if (method == "euler") out <- rk(y, times, func, parms, method = "euler", ...) else if (method == "rk4") out <- rk(y, times, func, parms, method = "rk4", ...) else if (method == "ode23") out <- rk(y, times, func, parms, method = "ode23", ...) else if (method == "ode45") out <- rk(y, times, func, parms, method = "ode45", ...) else if (method == "adams" && ! iscomplex) out <- lsode(y, times, func, parms, mf = 10, ...) else if (method == "adams" && iscomplex) out <- zvode(y, times, func, parms, mf = 10, ...) else if (method == "iteration") out <- iteration(y, times, func, parms, ...) # an implicit method that needs restructuring... } else { NL <- names(y) # internal function # bmodel <- function (time,state,pars,model,...) { Modconc <- model(time,state[ij],pars,...) # ij: reorder state variables c(list(Modconc[[1]][ii]), Modconc[-1]) # ii: reorder rate of change } if (is.character(func)) stop ("cannot run ode.1D with R-function specified in a DLL") ii <- as.vector(t(matrix(data=1:N,ncol=nspec))) # from ordering per slice -> per spec ij <- as.vector(t(matrix(data=1:N,nrow=nspec))) # from ordering per spec -> per slice bmod <- function(time,state,pars,...) bmodel(time,state,pars,func,...) if (is.null(method)) method <- "lsode" if (iscomplex) { if (method == "vode") out <- zvode(y[ii], times, func=bmod, parms=parms, bandup=nspec*bandwidth, banddown=nspec*bandwidth, jactype="bandint", ...) else if (method == "bdf") out <- zvode(y[ii], times, func=bmod, parms=parms, bandup=nspec*bandwidth, banddown=nspec*bandwidth, jactype="bandint", ...) else if (method == "impAdams") out <- zvode(y[ii], times, func=bmod, parms=parms, bandup=nspec*bandwidth, banddown=nspec*bandwidth, mf = 15, ...) } else if (method == "vode") out <- vode(y[ii], times, func=bmod, parms=parms, bandup=nspec*bandwidth, banddown=nspec*bandwidth, jactype="bandint", ...) else if (method == "lsode" || method == "bdf") out <- lsode(y[ii], times, func=bmod, parms=parms, bandup=nspec*bandwidth, banddown=nspec*bandwidth, jactype="bandint", ...) else if (method == "impAdams") out <- lsode(y[ii], times, func=bmod, parms=parms, bandup=nspec*bandwidth, banddown=nspec*bandwidth, mf = 15, ...) else if (method == "lsoda") out <- lsoda(y[ii], times, func=bmod, parms=parms, bandup=nspec*bandwidth, banddown=nspec*bandwidth, jactype="bandint", ...) else if (method == "lsodar") out <- lsodar(y[ii], times, func=bmod, parms=parms, bandup=nspec*bandwidth, banddown=nspec*bandwidth, jactype="bandint", ...) else if (method == "daspk") out <- daspk(y[ii], times, func=bmod, parms=parms, bandup=nspec*bandwidth, banddown=nspec*bandwidth, jactype="bandint", ...) else if (method == "radau") out <- radau(y[ii], times, func=bmod, parms=parms, bandup=nspec*bandwidth, banddown=nspec*bandwidth, jactype="bandint", ...) else stop ("cannot run ode.1D: not a valid 'method'") out[,(ii+1)] <- out[,2:(N+1)] if (! is.null(NL)) colnames(out)[2:(N+1)]<- NL } if (is.null(dimens)) dimens <- N/nspec attr (out, "dimens") <- dimens attr (out, "nspec") <- nspec attr(out, "ynames") <- names return(out) } ### ============================================================================ ode.2D <- function (y, times, func, parms, nspec=NULL, dimens, method= c("lsodes","euler", "rk4", "ode23", "ode45", "adams","iteration"), names = NULL, cyclicBnd = NULL, ...) { # check input if (is.character(method)) method <- match.arg(method) if (is.null(method)) method <- "lsodes" islsodes <- FALSE if (is.character(method)) if (method=="lsodes") islsodes <- TRUE if (any(!is.na(pmatch(names(list(...)), "jacfunc")))) stop ("cannot run ode.2D with jacfunc specified - remove jacfunc from call list") if (is.null(dimens)) stop ("cannot run ode.2D: dimens should be specified") if (length(dimens)!=2) stop ("cannot run ode.2D: dimens should contain 2 values") N <- length(y) if (N%%prod(dimens) !=0 ) stop ("cannot run ode.2D: dimensions are not an integer fraction of number of state variables") if (is.null (nspec)) nspec <- N/prod(dimens) else if (nspec*prod(dimens) != N) stop ("cannot run ode.2D: dimens[1]*dimens[2]*nspec is not equal to number of state variables") if (! is.null(names) && length(names) != nspec) stop("length of 'names' should equal 'nspec'") Bnd <- c(0,0) if (! is.null(cyclicBnd)) { if (max(cyclicBnd) > 2 ) stop ("cannot run ode.2D: cyclicBnd should be a vector or number not exceeding 2") Bnd[cyclicBnd[cyclicBnd>0]]<-1 } # use lsodes - note:expects rev(dimens)... if (is.character(func) || islsodes) { if (is.character(method)) if ( method != "lsodes") warning("ode.2D: R-function specified in a DLL-> integrating with lsodes") # if (bandwidth != 1) # try to use sparsetype also for bandwidth != 1 # out <- lsodes(y=y,times=times,func=func,parms,...) # else bandwidth<-1 out <- lsodes(y=y, times=times, func=func, parms, sparsetype="2D", nnz=c(nspec, rev(dimens), rev(Bnd), bandwidth), ...) # a runge kutta } else if (is.list(method)) { if (!"rkMethod" %in% class(method)) stop("'method' should be given as string or as a list of class 'rkMethod'") out <- rk(y, times, func, parms, method = method, ...) # a function } else if (is.function(method)) out <- method(y, times, func, parms,...) # an explicit method else if (method %in% c("euler", "rk4", "ode23", "ode45", "adams","iteration")) { if (method == "euler") out <- rk(y, times, func, parms, method = "euler", ...) else if (method == "rk4") out <- rk(y, times, func, parms, method = "rk4", ...) else if (method == "ode23") out <- rk(y, times, func, parms, method = "ode23", ...) else if (method == "ode45") out <- rk(y, times, func, parms, method = "ode45", ...) else if (method == "adams") out <- lsode(y, times, func, parms, mf = 10, ...) else if (method == "iteration") out <- iteration(y, times, func, parms, ...) } else { stop ("cannot run ode.2D: not a valid 'method'") } attr (out,"dimens") <- dimens attr (out,"nspec") <- nspec attr (out,"ynames") <- names return(out) } ### ============================================================================ ode.3D <- function (y, times, func, parms, nspec=NULL, dimens, method= c("lsodes","euler", "rk4", "ode23", "ode45", "adams","iteration"), names = NULL, cyclicBnd = NULL, ...){ # check input if (is.character(method)) method <- match.arg(method) if (is.null(method)) method <- "lsodes" if (any(!is.na(pmatch(names(list(...)), "jacfunc")))) stop ("cannot run ode.3D with jacfunc specified - remove jacfunc from call list") if (is.null(dimens)) stop ("cannot run ode.3D: dimens should be specified") if (length(dimens)!=3) stop ("cannot run ode.3D: dimens should contain 3 values") N <- length(y) if (N%%prod(dimens) !=0 ) stop ("cannot run ode.3D: dimensions are not an integer fraction of number of state variables") if (is.null (nspec)) nspec <- N/prod(dimens) else if (nspec*prod(dimens) != N) stop ("cannot run ode.3D: dimens[1]*dimens[2]*dimens[3]*nspec is not equal to number of state variables") if (! is.null(names) && length(names) != nspec) stop("length of 'names' should equal 'nspec'") Bnd <- c(0,0,0) # cyclicBnd not included if (! is.null(cyclicBnd)) { if (max(cyclicBnd) > 3 ) stop ("cannot run ode.3D: cyclicBnd should be a vector or number not exceeding 3") Bnd[cyclicBnd[cyclicBnd>0]]<-1 } # use lsodes - note:expects rev(dimens)... if (is.character(func) || method=="lsodes") { if ( method != "lsodes") warning("ode.3D: R-function specified in a DLL-> integrating with lsodes") # if (bandwidth != 1) # try to use sparsetype also for bandwidth != 1 # out <- lsodes(y=y,times=times,func=func,parms,...) # else bandwidth<-1 out <- lsodes(y=y, times=times, func=func, parms, sparsetype="3D", nnz=c(nspec,rev(dimens), rev(Bnd), bandwidth), ...) # a runge-kutta } else if (is.list(method)) { if (!"rkMethod" %in% class(method)) stop("'method' should be given as string or as a list of class 'rkMethod'") out <- rk(y, times, func, parms, method = method, ...) # another function } else if (is.function(method)) out <- method(y, times, func, parms,...) # an explicit method else if (method %in% c("euler", "rk4", "ode23", "ode45", "adams","iteration")) { if (method == "euler") out <- rk(y, times, func, parms, method="euler", ...) else if (method == "rk4") out <- rk(y, times, func, parms, method = "rk4", ...) else if (method == "ode23") out <- rk(y, times, func, parms, method = "ode23", ...) else if (method == "ode45") out <- rk(y, times, func, parms, method = "ode45", ...) else if (method == "adams") out <- lsode(y, times, func, parms, mf = 10, ...) else if (method == "iteration") out <- iteration(y, times, func, parms, ...) } else { stop ("cannot run ode.3D: not a valid 'method'") } attr (out,"dimens") <- dimens attr (out,"nspec") <- nspec attr (out,"ynames") <- names return(out) } ### ============================================================================ ode.band <- function (y, times, func, parms, nspec = NULL, dimens = NULL, bandup = nspec, banddown = nspec, method = "lsode", names = NULL, ...) { if (is.null(bandup) ) stop ("cannot run ode.band: bandup is not specified") if (is.null(banddown)) stop ("cannot run ode.band: banddown is not specified") if (is.null(nspec) && is.null(dimens)) stop ("cannot run ode.band: nspec OR dimens should be specified") N <- length(y) if (is.null(nspec) ) nspec <- N/dimens if (N %% nspec != 0 ) stop ("cannot run ode.band: nspec is not an integer fraction of number of state variables") if (! is.null(names) && length(names) != nspec) stop("length of 'names' should equal 'nspec'") if (is.null(method)) method <- "lsode" if (method == "vode") out <- vode(y, times, func, parms=parms, bandup=bandup, banddown=banddown, jactype="bandint", ...) else if (method == "lsode") out <- lsode(y, times, func, parms=parms, bandup=bandup, banddown=banddown, jactype="bandint", ...) else if (method == "lsoda") out <- lsoda(y, times, func, parms=parms, bandup=bandup, banddown=banddown, jactype="bandint", ...) else if (method == "lsodar") out <- lsodar(y, times, func, parms=parms, bandup=bandup, banddown=banddown, jactype="bandint", ...) else if (method == "daspk") out <- daspk(y, times, func, parms=parms, bandup=bandup, banddown=banddown, jactype="bandint", ...) else if (method == "radau") out <- radau(y, times, func, parms=parms, bandup=bandup, banddown=banddown, jactype="bandint", ...) else stop ("cannot run ode.band: method should be one of vode, lsoda, lsodar or lsode") N <- length(y) attr (out,"dimens") <- N/nspec attr (out,"nspec") <- nspec attr (out, "ynames") <- names return(out) } deSolve/R/forcings.R0000754000175100001440000001236612443047337014050 0ustar hornikusers### ============================================================================ ### Check forcing function data set, event inputs and time-lag input ### ============================================================================ checkforcings <- function (forcings, times, dllname, initforc, verbose, fcontrol = list()) { ## Check the names of the initialiser function if (is.null(initforc)) stop(paste("initforc should be loaded if there are forcing functions ",initforc)) if (class (initforc) == "CFunc") { ModelForc <- body(initforc)[[2]] } else if (is.loaded(initforc, PACKAGE = dllname, type = "") || is.loaded(initforc, PACKAGE = dllname, type = "Fortran")) { ModelForc <- getNativeSymbolInfo(initforc, PACKAGE = dllname)$address } else stop(paste("initforc should be loaded if there are forcing functions ",initforc)) ## Check the type of the forcing function data series if (is.data.frame(forcings)) forcings <- list(a=forcings) if (! is.list(forcings)) forcings <- list(a=forcings) nf <- length(forcings) #1 check if each forcing function consists of a 2-columned matrix for (i in 1:nf) { if (ncol(forcings[[i]]) != 2) stop("forcing function data sets should consist of two-colum matrix") } ## Check the control elements (see optim code) con <- list(method="linear", rule = 2, f = 0, ties = "ordered") nmsC <- names(con) con[(namc <- names(fcontrol))] <- fcontrol if (length(noNms <- namc[!namc %in% nmsC]) > 0) warning("unknown names in fcontrol: ", paste(noNms, collapse = ", ")) method <- pmatch(con$method, c("linear", "constant")) if (is.na(method)) stop("invalid interpolation method for forcing functions") # 1 if linear, 2 if constant... ## Check the timespan of the forcing function data series # time span of forcing function data sets should embrace simulation time... # although extrapolation is allowed if con$rule = 2 (the default) r_t <- range(times) for (i in 1:nf) { r_f <- range(forcings[[i]][,1]) # time range of this forcing function if (r_f[1] > r_t[1]) { if (con$rule == 2) { mint <- c(r_t[1],forcings[[i]][1,2] ) forcings[[i]] <- rbind(mint,forcings[[i]]) if(verbose) warning(paste("extrapolating forcing function data sets to first timepoint",i)) } else stop(paste("extrapolating forcing function data sets to first timepoint",i)) } nr <- nrow(forcings[[i]]) if (r_f[2] < r_t[2]) { if (con$rule == 2) { maxt <- c(r_t[2],forcings[[i]][nr,2] ) forcings[[i]] <- rbind(forcings[[i]],maxt) if(verbose) warning(paste("extrapolating forcing function data sets to last timepoint",i)) } else stop(paste("extrapolating forcing function data sets to last timepoint",i)) } } ## Check what needs to be done in case the time series is not "ordered" if (!identical(con$ties, "ordered")) { # see approx code for (i in 1:nf) { x <- forcings[[i]][,1] nx <- length(x) if (length(ux <- unique(x)) < nx) { # there are non-unique values y <- forcings[[i]][,2] ties <- con$tiesn if (missing(ties)) warning("collapsing to unique 'x' values") y <- as.vector(tapply(y, x, ties)) x <- sort(ux) forcings[[i]] <- cbind(x, y) } else { # values are unique, but need sorting y <- forcings[[i]][,2] o <- order(x) x <- x[o] y <- y[o] forcings[[i]] <- cbind(x,y) } } # i } ## In case the interpolation is of type "constant" and f not equal to 0 ## convert y-series, so that always the left value is taken if (method == 2 & con$f != 0) { for (i in 1:nf) { y <- forcings[[i]][,2] YY <- c(y,y[length(y)])[-1] forcings[[i]][,2] <- (1-con$f)*y + con$f*YY } } ## all forcings in one vector; adding index to start/end fmat <- tmat <- NULL imat <- rep(1,nf+1) for (i in 1:nf) { # Karline: check for NA in forcing series and remove those ii <- apply(forcings[[i]],1,function(x)any(is.na(x))) if (sum(ii) > 0) forcings[[i]] <- forcings[[i]][!ii,] tmat <- c(tmat, forcings[[i]][,1]) fmat <- c(fmat, forcings[[i]][,2]) imat[i+1]<-imat[i]+nrow(forcings[[i]]) } storage.mode(tmat) <- storage.mode(fmat) <- "double" storage.mode(imat) <- "integer" # DIRTY trick not to inflate the number of arguments: # add method (linear/constant) to imat return(list(tmat = tmat, fmat = fmat, imat = c(imat, method), ModelForc = ModelForc)) } ### ============================================================================ ### Check timelags data set - also passes "dllname" now (not yet used) ### ============================================================================ checklags <- function (lags, dllname) { if (!is.null(lags)) { lags$islag = 1L if (is.null(lags$mxhist)) lags$mxhist <- 1e4 if (lags$mxhist <1) lags$mxhist <- 1e4 lags$mxhist<-as.integer(lags$mxhist) if (is.null(lags$interpol)) # 1= hermitian, 2 = higher order interpolation lags$interpol <- 1 lags$interpol<-as.integer(lags$interpol) lags$isfun <- 0L } else lags$islag <- 0L return(lags) } deSolve/R/lsodar.R0000754000175100001440000002442212643031573013513 0ustar hornikusers### ============================================================================ ### lsodar -- solves ordinary differential equation systems ### Compared to the other integrators of odepack ### (a) lsodar switches automatically between stiff and nonstiff methods. ### This means that the user does not have to determine whether the ### problem is stiff or not, and the solver will automatically choose the ### appropriate method. It always starts with the nonstiff method. ### This is similar to lsoda. ### (b) lsodar finds the root of at least one of a set of constraint ### functions g(i) of the independent and dependent variables. ### It finds only those roots for which some g(i), as a function ### of t, changes sign in the interval of integration. ### It then returns the solution at the root, if that occurs ### sooner than the specified stop condition, and otherwise returns ### the solution according the specified stop condition. ### ============================================================================ lsodar <- function(y, times, func, parms, rtol=1e-6, atol=1e-6, jacfunc=NULL, jactype = "fullint", rootfunc=NULL, verbose=FALSE, nroot = 0, tcrit = NULL, hmin=0, hmax=NULL, hini=0, ynames=TRUE, maxordn = 12, maxords = 5, bandup = NULL, banddown = NULL, maxsteps = 5000, dllname=NULL,initfunc=dllname, initpar=parms, rpar=NULL, ipar=NULL, nout=0, outnames=NULL, forcings=NULL, initforc = NULL, fcontrol=NULL, events=NULL, lags = NULL, ...) { ### check input if (is.list(func)) { ### IF a list if (!is.null(jacfunc) & "jacfunc" %in% names(func)) stop("If 'func' is a list that contains jacfunc, argument 'jacfunc' should be NULL") if (!is.null(rootfunc) & "rootfunc" %in% names(func)) stop("If 'func' is a list that contains rootfunc, argument 'rootfunc' should be NULL") if (!is.null(initfunc) & "initfunc" %in% names(func)) stop("If 'func' is a list that contains initfunc, argument 'initfunc' should be NULL") if (!is.null(dllname) & "dllname" %in% names(func)) stop("If 'func' is a list that contains dllname, argument 'dllname' should be NULL") if (!is.null(initforc) & "initforc" %in% names(func)) stop("If 'func' is a list that contains initforc, argument 'initforc' should be NULL") if (!is.null(events$func) & "eventfunc" %in% names(func)) stop("If 'func' is a list that contains eventfunc, argument 'events$func' should be NULL") if ("eventfunc" %in% names(func)) { if (! is.null(events)) events$func <- func$eventfunc else events <- list(func = func$eventfunc) } if (!is.null(func$jacfunc)) jacfunc <- func$jacfunc if (!is.null(func$rootfunc)) rootfunc <- func$rootfunc if (!is.null(func$initfunc)) initfunc <- func$initfunc if (!is.null(func$dllname)) dllname <- func$dllname if (!is.null(func$initforc)) initforc <- func$initforc func <- func$func } hmax <- checkInput (y, times, func, rtol, atol, jacfunc, tcrit, hmin, hmax, hini, dllname) n <- length(y) if (!is.numeric(maxordn)) stop("`maxordn' must be numeric") if(maxordn < 1 || maxordn > 12) stop("`maxord' must be >1 and <=12") if (!is.numeric(maxords)) stop("`maxords' must be numeric") if(maxords < 1 || maxords > 5) stop("`maxords' must be >1 and <=5") ### Jacobian, method flag if (jactype == "fullint" ) jt <- 2 # full, calculated internally else if (jactype == "fullusr" ) jt <- 1 # full, specified by user function else if (jactype == "bandusr" ) jt <- 4 # banded, specified by user function else if (jactype == "bandint" ) jt <- 5 # banded, calculated internally else stop("'jactype' must be one of 'fullint', 'fullusr', 'bandusr' or 'bandint'") ## check other specifications depending on Jacobian if (jt %in% c(4,5) && is.null(bandup)) stop("'bandup' must be specified if banded Jacobian") if (jt %in% c(4,5) && is.null(banddown)) stop("'banddown' must be specified if banded Jacobian") if (is.null(banddown)) banddown <-1 if (is.null(bandup )) bandup <-1 if (jt %in% c(1,4) && is.null(jacfunc)) stop ("'jacfunc' NOT specified; either specify 'jacfunc' or change 'jactype'") ### model and Jacobian function Ynames <- attr(y,"names") JacFunc <- NULL RootFunc <- NULL flist<-list(fmat=0,tmat=0,imat=0,ModelForc=NULL) ModelInit <- NULL Eventfunc <- NULL events <- checkevents(events, times, Ynames, dllname, TRUE) if (! is.null(events$newTimes)) times <- events$newTimes if (jt == 4 && banddown>0) erow<-matrix(data=0, ncol=n, nrow=banddown) else erow<-NULL if (is.character(func) | class(func) == "CFunc") { # function specified in a DLL or inline compiled DLL <- checkDLL(func,jacfunc,dllname, initfunc,verbose,nout, outnames) ## Is there a root function? if (!is.null(rootfunc)) { if (!is.character(rootfunc) & class(rootfunc) != "CFunc") stop("If 'func' is dynloaded, so must 'rootfunc' be") rootfuncname <- rootfunc if (class(rootfunc) == "CFunc") RootFunc <- body(rootfunc)[[2]] else if (is.loaded(rootfuncname, PACKAGE = dllname)) { RootFunc <- getNativeSymbolInfo(rootfuncname, PACKAGE = dllname)$address } else stop(paste("root function not loaded in DLL",rootfunc)) if (nroot == 0) stop("if 'rootfunc' is specified in a DLL, then 'nroot' should be > 0") } ModelInit <- DLL$ModelInit Func <- DLL$Func JacFunc <- DLL$JacFunc Nglobal <- DLL$Nglobal Nmtot <- DLL$Nmtot if (! is.null(forcings)) flist <- checkforcings(forcings,times,dllname,initforc,verbose,fcontrol) if (is.null(ipar)) ipar<-0 if (is.null(rpar)) rpar<-0 Eventfunc <- events$func if (is.function(Eventfunc)) rho <- environment(Eventfunc) else rho <- NULL } else { if(is.null(initfunc)) initpar <- NULL # parameter initialisation not needed if function is not a DLL rho <- environment(func) ## func and jac are overruled, either including ynames, or not ## This allows to pass the "..." arguments and the parameters if (ynames) { Func <- function(time,state) { attr(state,"names") <- Ynames unlist(func (time,state,parms,...)) } Func2 <- function(time,state) { attr(state,"names") <- Ynames func (time,state,parms,...) } JacFunc <- function(time,state){ attr(state,"names") <- Ynames rbind(jacfunc(time,state,parms,...),erow) } RootFunc <- function(time,state) { attr(state,"names") <- Ynames rootfunc(time,state,parms,...) } if (! is.null(events$Type)) if (events$Type == 2) Eventfunc <- function(time,state) { attr(state,"names") <- Ynames events$func(time,state,parms,...) } } else { # no ynames... Func <- function(time,state) unlist(func (time,state,parms,...)) Func2 <- function(time,state) func (time,state,parms,...) JacFunc <- function(time,state) rbind(jacfunc(time,state,parms,...),erow) RootFunc <- function(time,state) rootfunc(time,state,parms,...) if (! is.null(events$Type)) if (events$Type == 2) Eventfunc <- function(time,state) events$func(time,state,parms,...) } ## Check derivative function and return the number of output variables +name FF <- checkFunc(Func2,times,y,rho) Nglobal<-FF$Nglobal Nmtot <- FF$Nmtot ## Check event function if (! is.null(events$Type)) if (events$Type == 2) checkEventFunc(Eventfunc,times,y,rho) ## and for rootfunc if (! is.null(rootfunc)) { tmp2 <- eval(rootfunc(times[1],y,parms,...), rho) if (!is.vector(tmp2)) stop("root function 'rootfunc' must return a vector\n") nroot <- length(tmp2) } else nroot = 0 if (jt %in% c(1,4)) { tmp <- eval(JacFunc(times[1], y), rho) if (!is.matrix(tmp)) stop("Jacobian function, 'jacfunc' must return a matrix\n") dd <- dim(tmp) if((jt ==4 && dd != c(bandup+banddown+1,n)) || (jt ==1 && dd != c(n,n))) stop("Jacobian dimension not ok") } } ### work arrays iwork, rwork ## length of rwork and iwork if(jt %in% c(1,2)) lmat <- n^2+2 else if(jt %in% c(4,5)) lmat <- (2*banddown+bandup+1)*n+2 lrn = 20+n*(maxordn+1)+ 3*n +3*nroot # length in case non-stiff method lrs = 20+n*(maxords+1)+ 3*n +lmat+3*nroot # length in case stiff method lrw = max(lrn,lrs) # actual length: max of both liw = 20 + n ## only first 20 elements passed to solver; other will be allocated in C-code iwork <- vector("integer",20) rwork <- vector("double",20) rwork[] <- 0. iwork[] <- 0 iwork[1] <- banddown iwork[2] <- bandup iwork[6] <- maxsteps if (maxordn != 12) iwork[8] <- maxordn if (maxords != 5) iwork[9] <- maxords if (verbose) iwork[5] = 1 # prints method switches to screen if(! is.null(tcrit)) rwork[1] <- tcrit rwork[5] <- hini rwork[6] <- hmax rwork[7] <- hmin ## the task to be performed. if (! is.null(times)) itask <- ifelse (is.null (tcrit), 1,4) else # times specified itask <- ifelse (is.null (tcrit), 2,5) # only one step if(is.null(times)) times<-c(0,1e8) ## print to screen... if (verbose) printtask(itask,func,jacfunc) ### calling solver storage.mode(y) <- storage.mode(times) <- "double" IN <-4 lags <- checklags(lags, dllname) on.exit(.C("unlock_solver")) out <- .Call("call_lsoda",y,times,Func,initpar, rtol, atol, rho, tcrit, JacFunc, ModelInit, Eventfunc, as.integer(verbose), as.integer(itask), as.double(rwork), as.integer(iwork), as.integer(jt),as.integer(Nglobal), as.integer(lrw),as.integer(liw),as.integer(IN),RootFunc, as.integer(nroot), as.double (rpar), as.integer(ipar), 0L, flist, events, lags, PACKAGE="deSolve") ### saving results iroot <- attr(out, "iroot") out <- saveOut(out, y, n, Nglobal, Nmtot, func, Func2, iin=c(1,12:21), iout=c(1:3,14,5:9,15:16),nr = 5) attr(out, "iroot") <- iroot attr(out, "type") <- "lsodar" if (verbose) diagnostics(out) return(out) } deSolve/R/diagnostics.R0000754000175100001440000002372612663320445014545 0ustar hornikusers## ============================================================================= ## print the return code settings - all except rk and daspk ## ============================================================================= printidid <- function(idid) { cat(paste("\n return code (idid) = ", idid), "\n") if (idid == 2 || idid ==0) cat(" Integration was successful.\n") else if (idid == 3) cat(" Integration was successful and a root was found before reaching the end.\n") else if (idid == -1) cat(" Excess work done on this call. (Perhaps wrong Jacobian type MF.)\n") else if (idid == -2) cat(" Excess accuracy requested. (Tolerances too small.)\n") else if (idid == -3) cat(" Illegal input detected. (See printed message.)\n") else if (idid == -4) cat(" Repeated error test failures. (Check all input.)\n") else if (idid == -5) cat(" Repeated convergence failures. (Perhaps bad Jacobian supplied or wrong choice of MF or tolerances.)\n") else if (idid == -6) cat(" Error weight became zero during problem. (Solution component i vanished, and ATOL or ATOL(i) = 0.)\n") else if (idid == -7) cat(" Work space insufficient to finish (see messages).\n") else if (idid == -8) cat(" A fatal error came from sparse solver CDRV by way of DPRJS or DSOLSS.\n") } ## ============================================================================= ## print the return code settings - all except rk and daspk ## ============================================================================= printidid_rk <- function(idid) { cat(paste("\n return code (idid) = ", idid), "\n") if (idid == 2 || idid ==0) cat(" Integration was successful.\n") else if (idid == -1) cat(" Excess work done on this call. (Perhaps maxstep exceeded.)\n") else if (idid == -2) cat(" Excess accuracy requested. (Tolerances too small.)\n") else cat(" Unknown error code, please inform package developers.\n") } ## ============================================================================= ## print the return code settings - only daspk ## ============================================================================= printidid_daspk <- function(idid) { cat(paste("\n return code (idid) = ", idid), "\n") if (idid > 0) { cat (" integration was succesful\n") if (idid == 1) cat(" A step was successfully taken in the intermediate-output mode. The code has not yet reached TOUT.\n") if (idid == 2) cat(" The integration to TSTOP was successfully completed (T = TSTOP) by stepping exactly to TSTOP.\n") if (idid == 3) cat(" The integration to TOUT was successfully completed (T = TOUT) by stepping past TOUT. Y(*) and YPRIME(*) are obtained by interpolation.\n") if (idid == 4) cat(" The initial condition calculation, with INFO(11) > 0, was successful, and INFO(14) = 1. No integration steps were taken, and the solution is not considered to have been started.\n") } else if (idid < 0 & idid > -33) { cat (" integration was interrupted\n") if (idid == -1) cat(" A large amount of work has been expended (about 500 steps).\n") else if (idid == -2) cat(" The error tolerances are too stringent.\n") else if (idid == -3) cat(" The local error test cannot be satisfied because a zero component in ATOL was specified and the corresponding computed solution component is zero. Thus, a pure relative error test is impossible for this component.\n") else if (idid == -5) cat(" There were repeated failures in the evaluation or processing of the preconditioner (in jacfunc).\n") else if (idid == -6) cat(" DDASPK had repeated error test failures on the last attempted step.\n") else if (idid == -7) cat(" The nonlinear system solver in the time integration could not converge.\n") else if (idid == -8) cat(" The matrix of partial derivatives appears to be singular (direct method).\n") else if (idid == -9) cat(" The nonlinear system solver in the time integration failed to achieve convergence, and there were repeated error test failures in this step.\n") else if (idid == -10) cat(" The nonlinear system solver in the time integration failed to achieve convergence because IRES was equal to -1.\n") else if (idid == -11) cat(" IRES = -2 was encountered and control is being returned to the calling program.\n") else if (idid == -12) cat(" DDASPK failed to compute the initial Y, YPRIME.\n") else if (idid == -13) cat(" Unrecoverable error encountered inside user's PSOL routine, and control is being returned to the calling program.\n") else if (idid == -14) cat(" The Krylov linear system solver could not achieve convergence.\n") } else if (idid ==-33) { cat (" integration was terminated\n") cat(" The code has encountered trouble from which it cannot recover. A message is printed explaining the trouble and control is returned to the calling program.\n") } } ## ============================================================================= ## print the integer diagnostics ## ============================================================================= printIstate <- function(istate, name, all = TRUE) { df <- c( "The return code :", #1 "The number of steps taken for the problem so far:", #2 "The number of function evaluations for the problem so far:", #3 "The number of Jacobian evaluations so far:", #4 "The method order last used (successfully):", #5 "The order of the method to be attempted on the next step:", #6 "If return flag =-4,-5: the largest component in error vector", #7 "The length of the real work array actually required:", #8 "The length of the integer work array actually required:", #9 "The number of matrix LU decompositions so far:", #10 "The number of nonlinear (Newton) iterations so far:", #11 "The number of convergence failures of the solver so far ", #12 "The number of error test failures of the integrator so far:", #13 "The number of Jacobian evaluations and LU decompositions so far:", #14, "The method indicator for the last succesful step, 1=adams (nonstiff), 2= bdf (stiff):" , #15 "The current method indicator to be attempted on the next step, 1=adams (nonstiff), 2= bdf (stiff):", #16 "The number of nonzero elements in the sparse Jacobian:" , #17 "The order (or maximum order) of the method:", #18 "The number of convergence failures of the linear iteration so far", #19 "The number of linear (Krylov) iterations so far ", #20 "The number of psol calls so far:") #21 if (name =="mebdfi") df[19:21] <- c( "The number of backsolves so far", "The number of times a new coefficient matrix has been formed so far", "The number of times the order of the method has been changed so far") # if (is.na(istate[14])) istate[14]<-istate[4]+istate[10] # Jacobian+LU cat("\n--------------------\n") cat("INTEGER values\n") cat("--------------------\n") if (all) ii <- 1:19 else ii <- which(!is.na(istate)) printmessage(df[ii], istate[ii], Nr=ii) } ## ============================================================================= ## print the real diagnostics ## ============================================================================= printRstate <- function( rstate) { if(is.null(rstate)) return() df <- c( "The step size in t last used (successfully):", "The step size to be attempted on the next step:", "The current value of the independent variable which the solver has reached:", "Tolerance scale factor > 1.0 computed when requesting too much accuracy:", "The value of t at the time of the last method switch, if any:") cat("--------------------\n") cat("RSTATE values\n") cat("--------------------\n") ii <- which(!is.na(rstate)) printmessage(df[ii], rstate[ii]) } ## ============================================================================= ## print all diagnostic messages ## ============================================================================= diagnostics.deSolve <- function(obj, Full = FALSE, ...) { Attr <- attributes(obj) name <- Attr$type istate <- Attr$istate rstate <- Attr$rstate cat("\n--------------------\n") cat(paste(name,"return code")) cat("\n--------------------\n") idid <- istate[1] if (name == "lsodes" && idid == -7) idid <- -8 if (name == "rk") printidid_rk if (name == "daspk") printidid_daspk(idid) else printidid(idid) printIstate(istate, name, all=Full) if (name != "rk") printRstate(rstate) if (!is.null(Attr$nroot)) { cat("--------------------\n") cat("ROOT + event \n") cat("--------------------\n") cat("\n root found at times :", signif(Attr$troot, digits = 5), "\n") } if (name == "lsodar" || (name %in% c("lsode","lsodes","radau") && !is.null(Attr$iroot))) { cat("--------------------\n") cat("ROOT\n") cat("--------------------\n") iroot <- which (Attr$iroot ==1) if (length (iroot) > 0) { cat("\n root found for root equation:", signif(iroot, digits = 0), "\n") cat("\n at time :", signif(Attr$troot, digits = 5), "\n") } else if (is.null(Attr$nroot)) cat("\n NO root found \n") invisible(list(istate=istate, rstate=rstate, iroot = iroot)) } else invisible(list(istate=istate, rstate=rstate)) } diagnostics.default <- function(obj, ...) warning("No diagnostics available for class '", class(obj), "'") diagnostics <- function(obj, ...) UseMethod("diagnostics") deSolve/R/euler.R0000754000175100001440000001445212663327625013355 0ustar hornikusers### ============================================================================ ### Interface to C code for Euler's ODE solver ### with fixed step size and without interpolation, see helpfile for details. ### ============================================================================ euler <- function(y, times, func, parms, verbose = FALSE, ynames = TRUE, dllname = NULL, initfunc = dllname, initpar = parms, rpar = NULL, ipar = NULL, nout = 0, outnames = NULL, forcings = NULL, initforc = NULL, fcontrol = NULL, ...) { if (is.list(func)) { ### IF a list if (!is.null(initfunc) & "initfunc" %in% names(func)) stop("If 'func' is a list that contains initfunc, argument 'initfunc' should be NULL") if (!is.null(dllname) & "dllname" %in% names(func)) stop("If 'func' is a list that contains dllname, argument 'dllname' should be NULL") if (!is.null(initforc) & "initforc" %in% names(func)) stop("If 'func' is a list that contains initforc, argument 'initforc' should be NULL") if (!is.null(func$initfunc)) initfunc <- func$initfunc if (!is.null(func$dllname)) dllname <- func$dllname if (!is.null(func$initforc)) initforc <- func$initforc func <- func$func } ## check for unsupported solver options dots <- list(...); nmdots <- names(dots) if(any(c("hmin", "hmax") %in% nmdots)) cat("hmin and hmax cannot be used in 'euler' (fixed steps).") if("hini" %in% nmdots) { cat("'hini' is not supported by this version of 'euler',\n") cat("but you can use ode(......, method = 'euler', hini= .....)\n") cat("to set internal time steps smaller than external steps.\n") } if(any(c("events", "rootfunc") %in% nmdots)) { warning("events and roots are not supported by this version of euler,\n", " but you can use ode(......, method = 'euler', .....)\n") } if(any(c("jacfunc", "jactype", "mf", "bandup", "banddown") %in% nmdots)) { warning("Euler and Runge-Kutta solvers make no use of a Jacobian,\n", " ('jacfunc', 'jactype', 'mf', 'bandup' and 'banddown' are ignored).\n") } if(any(c("lags") %in% nmdots)) { warning("lags are not yet implemented for Euler and Runge-Kutta solvers,\n", " (argument 'lags' is ignored).\n") } ## check input checkInputEuler(y, times, func, dllname) n <- length(y) ## Model as shared object (DLL)? Ynames <- attr(y, "names") Initfunc <- NULL flist <-list(fmat = 0, tmat = 0, imat = 0, ModelForc = NULL) Nstates <- length(y) # assume length of states is correct if (is.character(func) | class(func) == "CFunc") { # function specified in a DLL or inline compiled DLL <- checkDLL(func, NULL, dllname, initfunc, verbose, nout, outnames) Initfunc <- DLL$ModelInit Func <- DLL$Func Nglobal <- DLL$Nglobal Nmtot <- DLL$Nmtot if (! is.null(forcings)) flist <- checkforcings(forcings, times, dllname, initforc, verbose, fcontrol) rho <- NULL if (is.null(ipar)) ipar <- 0 if (is.null(rpar)) rpar <- 0 } else { initpar <- NULL # parameter initialisation not needed if function is not a DLL rho <- environment(func) ## func and jac are overruled, either including ynames, or not ## This allows to pass the "..." arguments and the parameters if(ynames) { Func <- function(time, state, parms) { attr(state, "names") <- Ynames func (time, state, parms, ...) } } else { # no ynames ... Func <- function(time, state, parms) func (time, state, parms, ...) } ## Call func once to figure out whether and how many "global" ## results it wants to return and some other safety checks FF <- checkFuncEuler(Func, times, y, parms, rho, Nstates) Nglobal <- FF$Nglobal Nmtot <- FF$Nmtot } ## the CALL to the integrator on.exit(.C("unlock_solver")) out <- .Call("call_euler", as.double(y), as.double(times), Func, Initfunc, parms, as.integer(Nglobal), rho, as.integer(verbose), as.double(rpar), as.integer(ipar), flist, PACKAGE = "deSolve") ## saving results out <- saveOutrk(out, y, n, Nglobal, Nmtot, iin = c(1, 12, 13, 15), iout = c(1:3, 18)) ## === testing code === ## 'call_euler_t' is a version with transposed data structure in memory ## for checking a potential influence of memory layout and memory locality ## # out <- .Call("call_euler_t", as.double(y), as.double(times), # Func, Initfunc, parms, as.integer(Nglobal), rho, as.integer(verbose), # as.double(rpar), as.integer(ipar), flist, PACKAGE = "deSolve") # out <- saveOutrk(out, y, n, Nglobal, Nmtot, # iin = c(1, 12, 13, 15), iout = c(1:3, 18), transpose = TRUE) ## === end testing code === attr(out, "type") <- "rk" if (verbose) diagnostics(out) out } ## 1D version that is compatible with ode.1D ## possible inconsistencies and problems: ## - names, outnames, ynames ## - what happens if both nspec and dimens are specified ? euler.1D <- function(y, times, func, parms, nspec = NULL, dimens = NULL, names = NULL, verbose = FALSE, ynames = TRUE, dllname = NULL, initfunc = dllname, initpar = parms, rpar = NULL, ipar = NULL, nout = 0, outnames = NULL, forcings = NULL, initforc = NULL, fcontrol = NULL, ...) { if (is.null(nspec) && is.null(dimens)) stop ("cannot run euler.1D: nspec OR dimens should be specified") N <- length(y) if (is.null(dimens)) dimens <- N/nspec if (is.null(nspec) ) nspec = N/dimens if (N %% nspec != 0 ) stop ("cannot run ode.1D: nspec is not an integer fraction of number of state variables") if (! is.null(names) && length(names) != nspec) stop("length of 'names' should equal 'nspec'") out <- euler(y, times, func, parms, verbose, ynames, dllname, initfunc, initpar, rpar, ipar, nout, outnames, forcings, initforc, fcontrol) attr (out, "dimens") <- dimens attr (out, "nspec") <- nspec attr(out, "ynames") <- names return(out) } deSolve/R/matplot.R0000754000175100001440000002747212732045306013715 0ustar hornikusers## ============================================================================= ## matplot methods - it is not an S3 generic... ## ============================================================================= #matplot <- function (x, ...) UseMethod("matplot") #matplot.default <- function (x, ...) { #if ("deSolve" %in% class (x)) # matplot.deSolve(x,...) #else # graphics::matplot(x,...) # #NextMethod() #} matplot.deSolve <- function(x, ..., select = NULL, which = select, obs = NULL, obspar = list(), subset = NULL, legend = list(x = "topright")) { # legend can be a list t <- 1 # column with independent variable "times" # Set the observed data obs <- SetData(obs) # variables to be plotted and their position in "x" varnames <- colnames(x) xWhich <- NULL lW <- length(which) WhichVar <- function(xWhich, obs, varnames) { if (is.null(xWhich) & is.null(obs$dat)) # All variables plotted Which <- 2 : length(varnames) else if (is.null(xWhich)) { # All common variables in x and obs plotted Which <- which(varnames %in% obs$name) Which <- Which [Which > 1] } else if (is.character(xWhich)) { Which <- which(varnames %in% xWhich) if (length(Which) != length(xWhich)) stop ("unknown variable", paste(xWhich, collapse = ",")) } else Which <- xWhich + 1 return(Which) } if (lW & is.list(which)) xWhich <- lapply(which, FUN = function (x) WhichVar(x, obs, varnames)) else if (lW) xWhich <- list(WhichVar(which, obs, varnames)) else xWhich <- list(2:length(varnames)) vn <- lapply(xWhich, FUN = function(x) paste(varnames[x], collapse = ",")) vn2 <- unlist(lapply(xWhich, FUN = function(x) paste(varnames[x]))) np <- length(xWhich) # number of y-axes nx <- length(unlist(xWhich)) # number of y-variables # add Position of variables to be plotted in "obs" obs <- updateObs2 (obs, varnames, unlist(xWhich)) # The ellipsis ldots <- list(...) Dots <- splitdots(ldots, varnames) if (Dots$nother > 1) stop ("can plot only one deSolve output object at a time with matplot") Dotmain <- setdots(Dots$main, np) # these are different from the default Dotmain$xlab <- expanddots(ldots$xlab, varnames[t] , np) Dotmain$ylab <- expanddots(ldots$ylab, vn , np) Dotmain$main <- expanddots(ldots$main, as.character(substitute(x)), np) # ylim and xlim can be lists and are at least two values yylim <- expanddotslist(ldots$ylim, np) xxlim <- expanddotslist(ldots$xlim, np) Dotpoints <- setdots(Dots$points, nx) # expand all dots to nx values # these are different from default Dotpoints$type <- expanddots(ldots$type, "l", nx) Dotpoints$lty <- expanddots(ldots$lty, 1:nx, nx) Dotpoints$pch <- expanddots(ldots$pch, 1:nx, nx) Dotpoints$col <- expanddots(ldots$col, 1:nx, nx) Dotpoints$bg <- expanddots(ldots$bg, 1:nx, nx) if (! is.null(obs)) { ii <- which(unlist(xWhich) %in% unlist(obs$Which)) ii <- ii[! is.na(ii)] if (is.null(obs$par)) obs$par <- list() else obs$par <- lapply(obspar, repdots, obs$length) if (is.null(obs$par$pch)) obs$par$pch <- Dotpoints$pch[ii] if (is.null(obs$par$cex)) obs$par$cex <- Dotpoints$cex[ii] if (is.null(obs$par$col)) obs$par$col <- Dotpoints$col[ii] if (is.null(obs$par$bg)) obs$par$bg <- Dotpoints$bg[ii] } if (!missing(subset)){ e <- substitute(subset) r <- eval(e, as.data.frame(x), parent.frame()) if (is.numeric(r)) { isub <- r } else { if (!is.logical(r)) stop("'subset' must evaluate to logical or be a vector with integers") isub <- r & !is.na(r) } } else { isub <- TRUE } # LOOP for each (set of) output variables (and y-axes) if (np > 1) par(mar = c(5.1, 4.1, 4.1, 2.1) + c(0, (np-1)*4, 0, 0)) ii <- 1 for (ip in 1 : np) { ix <- xWhich[[ip]] # position of y-variables in 'x' iL <- length(ix) iip <- ii:(ii+iL-1) # for dotpoints ii <- ii + iL io <- obs$Which[iip] # plotting parameters for matplot and axes dotmain <- extractdots(Dotmain, ip) if (is.null(dotmain$axes)) dotmain$axes <- FALSE if (is.null(dotmain$frame.plot)) dotmain$frame.plot <- TRUE dotpoints <- extractdots(Dotpoints, iip) # for all variables Xlog <- Ylog <- FALSE if (! is.null(dotmain$log)) { Ylog <- length(grep("y",dotmain$log)) Xlog <- length(grep("x",dotmain$log)) } SetRangeMat <- function(lim, x, isub, ix, obs, io, Log) { if ( is.null (lim)) { yrange <- Range(NULL, as.vector(x[isub, ix]), Log) if (! is.na(io[1])) yrange <- Range(yrange, as.vector(obs$dat[,io]), Log) } else yrange <- lim return(yrange) } dotmain$ylim <- SetRangeMat(yylim[[ip]], x, isub, ix, obs, io, Ylog) dotmain$xlim <- SetRangeMat(xxlim[[ip]], x, isub, t, obs, io, Xlog) Ylab <- dotmain$ylab dotmain$ylab <- "" if (ip > 1) { par(new = TRUE) dotmain$xlab <- dotmain$main <- "" } do.call("matplot", c(alist(x[isub, t], x[isub, ix]), dotmain, dotpoints)) if (ip == 1) axis(1, cex = dotmain$cex.axis) cex <- ifelse (is.null(dotmain$cex.lab), 0.9, 0.9*dotmain$cex.lab) bL <- 4*(ip-1) axis(side = 2, line = bL, cex = dotmain$cex.axis) mtext(side = 2, line = bL+2, Ylab, cex = cex) if (! is.na(io[1])) for (j in 1: length(io)) { i <- which (obs$Which == io[j]) if (length (i.obs <- obs$pos[i, 1]:obs$pos[i, 2]) > 0) do.call("points", c(alist(obs$dat[i.obs, 1], obs$dat[i.obs, io[j]]), extractdots(obs$par, j) )) } } if (is.null(legend)) legend <- list(x = "topright") if (is.list(legend)){ # can also be FALSE if (length(legend$legend)) L <- legend$legend else L <- vn2 legend$legend <- NULL if (is.null(legend$x)) legend$x <- "topright" lty <- Dotpoints$lty pch <- Dotpoints$pch lty[Dotpoints$type == "p"] <- NA pch[Dotpoints$type == "l"] <- NA do.call ("legend", c(legend, alist(lty = lty, lwd = Dotpoints$lwd, pch =pch, col = Dotpoints$col, pt.bg =Dotpoints$bg, legend = L))) } } ### ============================================================================ ### plotting 1-D variables as line plot, one for each time ### ============================================================================ matplot.1D <- function (x, select= NULL, which = select, ask = NULL, obs = NULL, obspar = list(), grid = NULL, xyswap = FALSE, vertical = FALSE, subset = NULL, ...) { ## Check settings of x att <- attributes(x) nspec <- att$nspec dimens <- att$dimens proddim <- prod(dimens) if (length(dimens) != 1) stop ("matplot.1D only works for models solved with 'ode.1D'") if ((ncol(x)- nspec*proddim) < 1) stop("ncol of 'x' should be > 'nspec' * dimens if x is a vector") # Set the observed data obs <- SetData(obs) # 1-D variable names varnames <- if (! is.null(att$ynames)) att$ynames else 1:nspec if (! is.null(att$lengthvar)) varnames <- c(varnames, names(att$lengthvar)[-1]) # variables to be plotted, common between obs and x Which <- WhichVarObs(which, obs, nspec, varnames, remove1st = FALSE) np <- length(Which) # Position of variables to be plotted in "x" Select <- select1dvar(Which, varnames, att) # also start and end position xWhich <- Select$Which # add Position of variables to be plotted in "obs" obs <- updateObs (obs, varnames, xWhich) obs$par <- lapply(obspar, repdots, obs$length) # the ellipsis ldots <- list(...) # number of figures in a row and interactively wait if remaining figures ask <- setplotpar(ldots, np, ask) if (ask) { oask <- devAskNewPage(TRUE) on.exit(devAskNewPage(oask)) } Dots <- splitdots(ldots, varnames) nother <- Dots$nother Dotpoints <- Dots$points Dotmain <- setdots(Dots$main, np) # expand all dots to np values (no defaults) # These are different from defaults Dotmain$xlab <- expanddots(ldots$xlab, "x", np) Dotmain$ylab <- expanddots(ldots$ylab, "", np) Dotmain$main <- expanddots(ldots$main, varnames[xWhich], np) # xlim and ylim are special: xxlim <- expanddotslist(ldots$xlim, np) yylim <- expanddotslist(ldots$ylim, np) xyswap <- rep(xyswap, length = np) vertical <- rep(vertical, length = np) if (!missing(subset)){ e <- substitute(subset) r <- eval(e, as.data.frame(x), parent.frame()) if (is.numeric(r)) { isub <- r } else { if (!is.logical(r)) stop("'subset' must evaluate to logical or be a vector with integers") isub <- r & !is.na(r) } } else isub <- 1:nrow(x) grid <- expanddotslist(grid, np) for (ip in 1:np) { istart <- Select$istart[ip] istop <- Select$istop[ip] io <- obs$Which[ip] out <- t(x[ isub, istart:istop]) if (length (isub) > 1 & sum (isub) == 1) out <- matrix (out) Grid <- grid[[ip]] if (is.null(Grid)) Grid <- 1:nrow(out) dotmain <- extractdots(Dotmain, ip) Xlog <- Ylog <- FALSE if (! is.null(dotmain$log)) { Ylog <- length(grep("y", dotmain$log)) Xlog <- length(grep("x", dotmain$log)) } if (vertical[ip]) { # overrules other settings; vertical profiles xyswap[ip] <- TRUE dotmain$axes <- FALSE dotmain$xlab <- "" dotmain$xaxs <- "i" dotmain$yaxs <- "i" } if (! xyswap[ip]) { if (! is.null(xxlim[[ip]])) dotmain$xlim <- xxlim[[ip]] dotmain$ylim <- SetRange(yylim[[ip]], x, NULL, isub, istart:istop, obs, io, Ylog) } else { if (! is.null(yylim[[ip]])) dotmain$ylim <- yylim[[ip]] dotmain$xlim <- SetRange(xxlim[[ip]], x, NULL, isub, istart:istop, obs, io, Xlog) if (is.null(yylim[[ip]]) & xyswap[ip]) dotmain$ylim <- rev(range(Grid)) # y-axis } if (! xyswap[ip]) { do.call("matplot", c(alist(Grid, out), dotmain, Dotpoints)) if (! is.na(io)) plotObs(obs, io) } else { if (is.null(dotmain$xlab[ip]) | is.null(dotmain$ylab[ip])) { dotmain$ylab <- dotmain$xlab[ip] dotmain$xlab <- dotmain$ylab[ip] } do.call("matplot", c(alist(out, Grid), dotmain, Dotpoints)) if (vertical[ip]) DrawVerticalAxis(dotmain, min(out)) if (! is.na(io)) plotObs(obs, io, xyswap = TRUE) } } } ## ============================================================================= ## S3/S4 compatibility ## ============================================================================= ## make matplot an S4 method and then extend generic for class deSolve ## but note that matplot.1D is not (yet) a generic, because .1D is just an ## alternative way of plotting and not a well defined class setGeneric("matplot", function(x, ...) graphics::matplot(x, ...)) setOldClass("deSolve") setMethod("matplot", list(x = "deSolve"), matplot.deSolve) ## thpe: 2016-06-20, deSolve 1.14 ## exporting matplot leads to annoying messages during package startup ## experimental approach: ## - do not anymore export matplot ## - instead, use exported 'matplot.deSolve' or alias 'matplot.0D' matplot.0D <- matplot.deSolve deSolve/R/zvode.R0000754000175100001440000002541712363540070013357 0ustar hornikusers ### ============================================================================ ### zvode -- solves ordinary differential equation systems ### ### This is vode for complex numbers ### ============================================================================ zvode <- function(y, times, func, parms, rtol=1e-6, atol=1e-6, jacfunc=NULL, jactype = "fullint", mf = NULL, verbose=FALSE, tcrit = NULL, hmin=0, hmax=NULL, hini=0, ynames=TRUE, maxord=NULL, bandup=NULL, banddown=NULL, maxsteps=5000, dllname=NULL, initfunc=dllname, initpar=parms, rpar=NULL, ipar=NULL, nout=0, outnames=NULL, forcings=NULL, initforc = NULL, fcontrol=NULL, ...) { ### check input n <- length(y) if (! is.null(times) && !is.numeric(times)) stop("`times' must be NULL or numeric") if (!is.function(func) && !is.character(func)) stop("`func' must be a function or character vector") if (is.character(func) && (is.null(dllname) || !is.character(dllname))) stop("specify the name of the dll or shared library where func can be found (without extension)") if (!is.numeric(rtol)) stop("`rtol' must be numeric") if (!is.numeric(atol)) stop("`atol' must be numeric") if (!is.null(tcrit) & !is.numeric(tcrit)) stop("`tcrit' must be numeric") if (!is.null(jacfunc) && !(is.function(jacfunc) || is.character(jacfunc))) stop(paste(jacfunc," must be a function or character vector")) if (length(atol) > 1 && length(atol) != n) stop("`atol' must either be a scalar, or as long as `y'") if (length(rtol) > 1 && length(rtol) != n) stop("`rtol' must either be a scalar, or as long as `y'") if (!is.numeric(hmin)) stop("`hmin' must be numeric") if (hmin < 0) stop("`hmin' must be a non-negative value") if (is.null(hmax)) hmax <- if (is.null(times)) 0 else max(abs(diff(times))) if (!is.numeric(hmax)) stop("`hmax' must be numeric") if (hmax < 0) stop("`hmax' must be a non-negative value") if (hmax == Inf) hmax <- 0 if (!is.null(hini)) if(hini < 0) stop("`hini' must be a non-negative value") if (!is.null(maxord)) if (maxord < 1) stop("`maxord' must be >1") ### Jacobian, method flag if (is.null(mf)) { if (jactype == "fullint" ) imp <- 22 # full, calculated internally else if (jactype == "fullusr" ) imp <- 21 # full, specified by user function else if (jactype == "bandusr" ) imp <- 24 # banded, specified by user function else if (jactype == "bandint" ) imp <- 25 # banded, calculated internally else stop("'jactype' must be one of 'fullint', 'fullusr', 'bandusr' or 'bandint' if 'mf' not specified") } else imp <- mf if (! imp %in% c(10:17, 20:27, -11,-12,-14,-15,-21, -22, -24: -27)) stop ("method flag 'mf' not allowed") # check other specifications depending on Jacobian miter <- abs(imp)%%10 if (miter %in% c(1,4) & is.null(jacfunc)) stop ("'jacfunc' NOT specified; either specify 'jacfunc' or change 'jactype' or 'mf'") meth <- abs(imp)%/%10 # basic linear multistep method jsv <- sign(imp) if (is.null (maxord)) maxord <- ifelse(meth==1,12,5) if (meth==1 && maxord > 12) stop ("'maxord' too large: should be <= 12") if (meth==2 && maxord > 5 ) stop ("'maxord' too large: should be <= 5") if (miter %in% c(4,5) && is.null(bandup)) stop("'bandup' must be specified if banded Jacobian") if (miter %in% c(4,5) && is.null(banddown)) stop("'banddown' must be specified if banded Jacobian") if (is.null(banddown)) banddown <-1 if (is.null(bandup )) bandup <-1 ### model and Jacobian function Func <- NULL JacFunc <- NULL ## if (miter == 4) Jacobian should have banddown empty rows-vode only! if (miter == 4 && banddown>0) erow<-matrix(data=0, ncol=n, nrow=banddown) else erow<-NULL Ynames <- attr(y,"names") flist<-list(fmat=0,tmat=0,imat=0,ModelForc=NULL) ModelInit <- NULL if (is.character(func) | class(func) == "CFunc") { # function specified in a DLL or inline compiled DLL <- checkDLL(func,jacfunc,dllname, initfunc,verbose,nout, outnames) ModelInit <- DLL$ModelInit Func <- DLL$Func JacFunc <- DLL$JacFunc Nglobal <- DLL$Nglobal Nmtot <- DLL$Nmtot if (! is.null(forcings)) flist <- checkforcings(forcings,times,dllname,initforc,verbose,fcontrol) rho <- NULL if (is.null(ipar)) ipar<-0 if (is.null(rpar)) rpar<-0 if (!is.null(jacfunc)) { # if (miter == 4) Jacobian should have empty banddown empty rows # This is so for vode only; other solvers do not need this # As this is not compatible with other solvers, this option has been # toggled off (otherwise DLL function might crash) if (miter == 4&& banddown>0) stop("The combination of user-supplied banded Jacobian in a dll is NOT allowed") } } else { if(is.null(initfunc)) initpar <- NULL # parameter initialisation not needed if function is not a DLL rho <- environment(func) # func and jac are overruled, either including ynames, or not # This allows to pass the "..." arguments and the parameters if(ynames) { Func <- function(time,state) { attr(state,"names") <- Ynames func (time,state,parms,...)[1] } Func2 <- function(time,state){ attr(state,"names") <- Ynames func (time,state,parms,...) } JacFunc <- function(time,state){ attr(state,"names") <- Ynames rbind(jacfunc(time,state,parms,...),erow) } } else { # no ynames... Func <- function(time,state) func (time,state,parms,...)[1] Func2 <- function(time,state) func (time,state,parms,...) JacFunc <- function(time,state) rbind(jacfunc(time,state,parms,...),erow) } ## Check function and return the number of output variables +name FF <- checkFuncComplex(Func2,times,y,rho) Nglobal<-FF$Nglobal Nmtot <- FF$Nmtot if (miter %in% c(1,4)) { tmp <- eval(JacFunc(times[1], y), rho) if (!is.matrix(tmp)) stop("Jacobian function must return a matrix\n") dd <- dim(tmp) if((miter ==4 && dd != c(bandup+banddown+banddown+1,n)) || (miter ==1 && dd != c(n,n))) stop("Jacobian dimension not ok") } } ### work arrays iwork, rwork # length of rwork, zwork and iwork lzw <- n*(maxord+1)+2*n if(miter %in% c(1,2) && imp>0) lzw <- lzw + 2*n*n+2 if(miter %in% c(1,2) && imp<0) lzw <- lzw + n*n if(miter ==3) lzw <- lzw + n if(miter %in% c(4,5) && imp>0) lzw <- lzw + (3*banddown+2*bandup+2)*n if(miter %in% c(4,5) && imp<0) lzw <- lzw + (2*banddown+bandup+1)*n lrw <- 20 +n liw <- ifelse(miter %in% c(0,3),30,30+n) # only first 20 or 30 elements passed; other will be allocated in C-code iwork <- vector("integer",30) rwork <- vector("double",20) rwork[] <- 0. iwork[] <- 0 iwork[1] <- banddown iwork[2] <- bandup iwork[5] <- maxord iwork[6] <- maxsteps if(! is.null(tcrit)) rwork[1] <- tcrit rwork[5] <- hini rwork[6] <- hmax rwork[7] <- hmin ### the task to be performed. if (! is.null(times)) itask <- ifelse (is.null (tcrit), 1,4) else # times specified itask <- ifelse (is.null (tcrit), 2,5) # only one step if(is.null(times)) times<-c(0,1e8) ### print to screen... if (verbose) { printtask(itask,func,jacfunc) printM("\n--------------------") printM("Integration method") printM("--------------------") df <- c("method flag, =", "jsv =", "meth =", "miter =") vals <- c(imp, jsv, meth, miter) txt <- "; (note: mf = jsv * (10 * meth + miter))" if (jsv==1) txt<-c(txt, "; a copy of the Jacobian is saved for reuse in the corrector iteration algorithm" ) else if (jsv==-1)txt<-c(txt, "; a copy of the Jacobian is not saved") if (meth==1)txt<-c(txt, "; the basic linear multistep method: the implicit Adams method") else if (meth==2)txt<-c(txt,"; the basic linear multistep method: based on backward differentiation formulas") if (miter==0)txt<-c(txt, "; functional iteration (no Jacobian matrix is involved") else if (miter==1)txt<-c(txt, "; chord iteration with a user-supplied full (NEQ by NEQ) Jacobian") else if (miter==2)txt<-c(txt, "; chord iteration with an internally generated full Jacobian, (NEQ extra calls to F per df/dy value)") else if (miter==3)txt<-c(txt, "; chord iteration with an internally generated diagonal Jacobian (1 extra call to F per df/dy evaluation)") else if (miter==4)txt<-c(txt, "; chord iteration with a user-supplied banded Jacobian") else if (miter==5)txt<-c(txt, "; chord iteration with an internally generated banded Jacobian (using ML+MU+1 extra calls to F per df/dy evaluation)") printmessage(df, vals, txt) } ### calling solver storage.mode(y) <- "complex" storage.mode(times) <- "double" on.exit(.C("unlock_solver")) out <- .Call("call_zvode", y, times, Func, initpar, rtol, atol, rho, tcrit, JacFunc, ModelInit, as.integer(itask), as.double(rwork),as.integer(iwork), as.integer(imp),as.integer(Nglobal), as.integer(lzw),as.integer(lrw),as.integer(liw), as.complex (rpar), as.integer(ipar),flist,PACKAGE = "deSolve") ### saving results nR <- ncol(out) out [1,] <- as.complex(times[1:nR]) # times not set here... out <- saveOut(out, y, n, Nglobal, Nmtot, func, Func2, iin=c(1,12:23), iout=1:13) attr(out, "type") <- "cvode" if (verbose) diagnostics(out) out } checkFuncComplex<- function (Func2, times, y, rho) { ## Call func once to figure out whether and how many "global" ## results it wants to return and some other safety checks if (! is.complex(y)) stop("'y' should be complex, not real") tmp <- eval(Func2(times[1], y), rho) if (!is.list(tmp)) stop("Model function must return a list\n") if (length(tmp[[1]]) != length(y)) stop(paste("The number of derivatives returned by func() (", length(tmp[[1]]), ") must equal the length of the initial conditions vector (", length(y),")",sep="")) if (! is.complex(tmp[[1]])) stop("derivatives (first element returned by 'func') should be complex, not real") # use "unlist" here because some output variables are vectors/arrays Nglobal <- if (length(tmp) > 1) length(unlist(tmp[-1])) else 0 Nmtot <- attr(unlist(tmp[-1]),"names") return(list(Nglobal = Nglobal, Nmtot=Nmtot)) } deSolve/R/printmessage.R0000754000175100001440000000120312352122161014707 0ustar hornikusers## internal helper functions for printing solver return code messages ## these functions are not exported ## print combined messages (message and numeric output) printmessage <-function(message1, state, message2 = NULL, Nr = 1:length(message1)) { if (is.null(message2)) { cat("\n", paste(formatC(Nr, "##", width = 2), message1, signif(state, digits = getOption("digits")), "\n"), "\n") } else { cat("\n", paste(formatC(Nr, "##", width = 2), message1, signif(state, digits = getOption("digits")), message2, "\n"), "\n") } } ## print short messages printM <- function(message) cat(message, "\n") deSolve/R/functions.R0000754000175100001440000003143412361034427014236 0ustar hornikusers## ======================================================================== ## General functions of deSolve ## ======================================================================== timestep <- function (prev = TRUE) { out <- .Call("getTimestep", PACKAGE = "deSolve") if (prev) return(out[1]) else return(out[2]) } ## ======================================================================== ## Check solver input - livermore solvers and rk ## ======================================================================== checkInput <- function(y, times, func, rtol, atol, jacfunc, tcrit, hmin, hmax, hini, dllname, jacname = "jacfunc") { if (!is.numeric(y)) stop("`y' must be numeric") n <- length(y) if (! is.null(times) && !is.numeric(times)) stop("`times' must be NULL or numeric") if (!is.function(func) && !is.character(func)) stop("`func' must be a function or character vector") if (is.character(func) && (is.null(dllname) || !is.character(dllname))) stop("specify the name of the dll or shared library where func can be found (without extension)") if (!is.numeric(rtol)) stop("`rtol' must be numeric") if (!is.numeric(atol)) stop("`atol' must be numeric") if (!is.null(tcrit) & !is.numeric(tcrit)) stop("`tcrit' must be numeric") if (!is.null(jacfunc) && !(is.function(jacfunc) || is.character(jacfunc))) stop(paste(jacname," must be a function or character vector")) if (length(atol) > 1 && length(atol) != n) stop("`atol' must either be a scalar, or as long as `y'") if (length(rtol) > 1 && length(rtol) != n) stop("`rtol' must either be a scalar, or as long as `y'") if (!is.numeric(hmin)) stop("`hmin' must be numeric") if (hmin < 0) stop("`hmin' must be a non-negative value") if (is.null(hmax)) hmax <- if (is.null(times)) 0 else max(abs(diff(times))) if (!is.numeric(hmax)) stop("`hmax' must be numeric") if (hmax < 0) stop("`hmax' must be a non-negative value") if (hmax == Inf) hmax <- 0 if (!is.null(hini)) if(hini < 0) stop("`hini' must be a non-negative value") return(hmax) } ## ======================================================================== ## Check solver input - euler and rk4 ## ======================================================================== checkInputEuler <- function (y, times, func, dllname) { if (!is.numeric(y)) stop("`y' must be numeric") n <- length(y) if (! is.null(times) && !is.numeric(times)) stop("`times' must be NULL or numeric") if (!is.function(func) && !is.character(func)) stop("`func' must be a function or character vector") if (is.character(func) && (is.null(dllname) || !is.character(dllname))) stop("You need to specify the name of the dll or shared library where func can be found (without extension)") } ## ======================================================================== ## Check ode function call - livermore solvers ## ======================================================================== checkFunc<- function (Func2, times, y, rho) { ## Call func once to figure out whether and how many "global" ## results it wants to return and some other safety checks tmp <- eval(Func2(times[1], y), rho) if (!is.list(tmp)) stop("Model function must return a list\n") if (length(tmp[[1]]) != length(y)) stop(paste("The number of derivatives returned by func() (", length(tmp[[1]]), ") must equal the length of the initial conditions vector (", length(y), ")", sep = "")) ## use "unlist" here because some output variables are vectors/arrays Nglobal <- if (length(tmp) > 1) length(unlist(tmp[-1])) else 0 ## Karline: changed this: ## Nmtot is now a list with names, dimensions,... for 1-D, 2-D vars Nmtot <- list() Nmtot$colnames <- attr(unlist(tmp[-1]), "names") Nmtot$lengthvar <- unlist(lapply(tmp, length)) if (length(Nmtot$lengthvar) < Nglobal+1){ Nmtot$dimvar <- lapply(tmp[-1], dim) } return(list(Nglobal = Nglobal, Nmtot = Nmtot)) } ## ======================================================================== ## Check event function calls ## ======================================================================== checkEventFunc<- function (Func, times, y, rho) { ## Call func once tmp <- eval(Func(times[1], y), rho) if (length(tmp) != length(y)) stop(paste("The number of values returned by events$func() (", length(tmp), ") must equal the length of the initial conditions vector (", length(y), ")", sep = "")) if (!is.vector(tmp)) stop("The event function 'events$func' must return a vector\n") } ## ======================================================================== ## Check ode function call - euler and rk solvers ## ======================================================================== checkFuncEuler<- function (Func, times, y, parms, rho, Nstates) { ## Call func once to figure out whether and how many "global" ## results it wants to return and some other safety checks tmp <- eval(Func(times[1], y, parms), rho) if (!is.list(tmp)) stop("Model function must return a list\n") if (length(tmp[[1]]) != Nstates) stop(paste("The number of derivatives returned by func() (", length(tmp[[1]]), "must equal the length of the initial conditions vector (", Nstates, ")", sep="")) ## use "unlist" because output variables can be vectors/arrays Nglobal <- if (length(tmp) > 1) length(unlist(tmp[-1])) else 0 Nmtot <- list() Nmtot$colnames <- attr(unlist(tmp[-1]), "names") Nmtot$lengthvar <- unlist(lapply(tmp, length)) if (length(Nmtot$lengthvar) < Nglobal+1){ Nmtot$dimvar <- lapply(tmp[-1], dim) } return(list(Nglobal = Nglobal, Nmtot = Nmtot)) } ## ======================================================================== ## check ode DLL input ## ======================================================================== checkDLL <- function (func, jacfunc, dllname, initfunc, verbose, nout, outnames, JT = 1) { if (sum(duplicated (c(func, initfunc, jacfunc))) > 0) stop("func, initfunc, or jacfunc cannot be the same") ModelInit <- NA if (! is.null(initfunc)) # to allow absence of initfunc if (class (initfunc) == "CFunc") ModelInit <- body(initfunc)[[2]] else if (is.loaded(initfunc, PACKAGE = dllname, type = "") || is.loaded(initfunc, PACKAGE = dllname, type = "Fortran")) { ModelInit <- getNativeSymbolInfo(initfunc, PACKAGE = dllname)$address } else if (initfunc != dllname && ! is.null(initfunc)) stop(paste("'initfunc' not loaded ", initfunc)) ## Easier to deal with NA in C-code if (is.null(initfunc)) ModelInit <- NA ## copy value of func to funcname ## check to make sure it describes a function in a loaded dll funcname <- func ## get the pointer and put it in func if (class (func) == "CFunc") Func <- body(func)[[2]] else if(is.loaded(funcname, PACKAGE = dllname)) { Func <- getNativeSymbolInfo(funcname, PACKAGE = dllname)$address } else stop(paste("dyn function 'func' not loaded", funcname)) ## Finally, is there a Jacobian? if (!is.null(jacfunc)) { if (!is.character(jacfunc)) switch (JT, stop("If 'func' is dynloaded, so must 'jacfunc' be"), stop("If 'func' is dynloaded, so must 'jacvec' be") ) jacfuncname <- jacfunc if (class (jacfunc) == "CFunc") JacFunc <- body(jacfunc)[[2]] else if(is.loaded(jacfuncname, PACKAGE = dllname)) { JacFunc <- getNativeSymbolInfo(jacfuncname, PACKAGE = dllname)$address } else stop(paste("cannot integrate: jac function not loaded ", jacfunc)) } else JacFunc <- NULL Nglobal <- nout Nmtot <- list() if (is.null(outnames)) { Nmtot$colnames <- NULL} else if (length(outnames) == nout) { Nmtot$colnames <- outnames} else if (length(outnames) > nout) Nmtot$colnames <- outnames[1:nout] else Nmtot$colnames <- c(outnames,(length(outnames)+1):nout) cnames <- outnames unames <- unique(outnames) if (length(cnames) > length(unames)) Nmtot$lengthvar <- c(NA, sapply (unames, FUN = function(x) length(which(cnames == x)))) return(list(ModelInit = ModelInit, Func = Func, JacFunc = JacFunc, Nglobal = Nglobal, Nmtot = Nmtot)) } ## ============================================================================= ## print integration task ## ============================================================================= printtask <- function(itask, func, jacfunc) { printM("\n--------------------") printM("Time settings") printM("--------------------\n") if (itask==1) printM(" Normal computation of output values of y(t) at t = TOUT") else if (itask==2) printM(" Take one step only and return.") else if (itask==3) printM(" istop at the first internal mesh point at or beyond t = TOUT and return. ") else if (itask==4) printM(" Normal computation of output values of y(t) at t = TOUT but without overshooting t = TCRIT.") else if (itask==5) printM(" Take one step, without passing TCRIT, and return.") printM("\n--------------------") printM("Integration settings") printM("--------------------\n") if (is.character(func)) printM(paste(" Model function a DLL: ", func)) else printM(" Model function an R-function: ") if (is.character(jacfunc)) printM(paste (" Jacobian specified as a DLL: ", jacfunc)) else if (!is.null(jacfunc)) printM(" Jacobian specified as an R-function: ") else printM(" Jacobian not specified") cat("\n") } ## ============================================================================= ## Make Istate vector similar for all solvers. ## ============================================================================= setIstate <- function(istate, iin, iout) { IstateOut <- rep(NA, 21) IstateOut[iout] <- istate[iin] IstateOut } ## ============================================================================= ## Output cleanup - for the Livermore solvers ## ============================================================================= saveOut <- function (out, y, n, Nglobal, Nmtot, func, Func2, iin, iout, nr = 4) { troot <- attr(out, "troot") istate <- attr(out, "istate") istate <- setIstate(istate,iin,iout) valroot <- attr(out, "valroot") indroot <- attr(out, "indroot") Rstate <- attr(out, "rstate") rstate <- rep(NA,5) rstate[1:nr] <- Rstate[1:nr] nm <- c("time", if (!is.null(attr(y, "names"))) names(y) else as.character(1:n)) if (Nglobal > 0) { nm <- c(nm, if (!is.null(Nmtot$colnames)) Nmtot$colnames else as.character((n+1) : (n + Nglobal))) } attr(out,"istate") <- istate attr(out, "rstate") <- rstate if (! is.null(Nmtot$lengthvar)) if (is.na(Nmtot$lengthvar[1]))Nmtot$lengthvar[1] <- length(y) attr(out, "lengthvar") <- Nmtot$lengthvar if (! is.null(troot)) attr(out, "troot") <- troot if (! is.null(valroot)) attr(out, "valroot") <- matrix(nrow = n, valroot) if (! is.null(indroot)) attr(out, "indroot") <- indroot ii <- if (is.null(Nmtot$dimvar)) NULL else !(unlist(lapply(Nmtot$dimvar, is.null))) # variables with dimension if (sum(ii) >0) attr(out, "dimvar") <- Nmtot$dimvar[ii] # dimensions that are not null class(out) <- c("deSolve", "matrix") # a differential equation dimnames(out) <- list(nm, NULL) return (t(out)) } ## ============================================================================= ## Output cleanup - for the Runge-Kutta solvers ## ============================================================================= saveOutrk <- function(out, y, n, Nglobal, Nmtot, iin, iout, transpose = FALSE) { ## Names for the outputs nm <- c("time", if (!is.null(attr(y, "names"))) names(y) else as.character(1:n) ) ## Global outputs if (Nglobal > 0) { nm <- c(nm, if (!is.null(Nmtot$colnames)) Nmtot$colnames else as.character((n + 1) : (n + Nglobal)) ) } ## Column names and state information dimnames(out) <- list(NULL, nm) istate <- attr(out, "istate") istate <- setIstate(istate, iin, iout) attr(out,"istate") <- istate if (! is.null(Nmtot$lengthvar)) if (is.na(Nmtot$lengthvar[1])) Nmtot$lengthvar[1] <- length(y) attr(out, "lengthvar") <- Nmtot$lengthvar ii <- if (is.null(Nmtot$dimvar)) NULL else !(unlist(lapply(Nmtot$dimvar, is.null))) # variables with dimension if (sum(ii) >0) attr(out, "dimvar") <- Nmtot$dimvar[ii] # only those which are not null class(out) <- c("deSolve", "matrix") # output of a differential equation if (transpose) return(t(out)) else return(out) } deSolve/R/Aquaphy.R0000754000175100001440000000126312352122161013624 0ustar hornikusersaquaphy <- function(times, y, parms, PAR=NULL, ...) { if (length(y) != 4) stop ("length of state variable vector should be 4") if (length(parms) != 19) stop ("length of parameter vector should be 19") names(y) <- c("DIN","PROTEIN","RESERVE","LMW") outnames <- c("PAR","TotalN","PhotoSynthesis", "NCratio","ChlCratio","Chlorophyll") if (is.null(PAR)) ode(y,times,dllname="deSolve", func="aquaphy",initfunc="iniaqua", parms=parms,nout=6,outnames=outnames,...) else ode(y,times,dllname="deSolve", func="aquaphyforc",initfunc="iniaqua", initforc="initaqforc",forcings=PAR, parms=parms,nout=6,outnames=outnames,...) } deSolve/R/lsoda.R0000754000175100001440000002172512643031573013334 0ustar hornikusers# ks 21-12-09: Func <- unlist() ... output variables now set in C-code ### ============================================================================ ### lsoda -- solves ordinary differential equation systems ### Compared to the other integrators of odepack ### lsoda switches automatically between stiff and nonstiff methods. ### This means that the user does not have to determine whether the ### problem is stiff or not, and the solver will automatically choose the ### appropriate method. It always starts with the nonstiff method. ### ============================================================================ lsoda <- function(y, times, func, parms, rtol=1e-6, atol=1e-6, jacfunc=NULL, jactype = "fullint", rootfunc = NULL, verbose = FALSE, nroot = 0, tcrit = NULL, hmin=0, hmax=NULL, hini=0, ynames=TRUE, maxordn = 12, maxords = 5, bandup = NULL, banddown = NULL, maxsteps = 5000, dllname=NULL, initfunc=dllname, initpar=parms, rpar=NULL, ipar=NULL, nout=0, outnames=NULL, forcings=NULL, initforc = NULL, fcontrol = NULL, events = NULL, lags=NULL, ...) { ### check input if (! is.null(rootfunc)) return(lsodar (y, times, func, parms, rtol, atol, jacfunc, jactype, rootfunc, verbose, nroot, tcrit, hmin, hmax, hini, ynames, maxordn, maxords, bandup, banddown, maxsteps, dllname, initfunc, initpar, rpar, ipar, nout, outnames, forcings, initforc, fcontrol, events, lags, ...)) if (is.list(func)) { ### IF a list if (!is.null(jacfunc) & "jacfunc" %in% names(func)) stop("If 'func' is a list that contains jacfunc, argument 'jacfunc' should be NULL") if (!is.null(initfunc) & "initfunc" %in% names(func)) stop("If 'func' is a list that contains initfunc, argument 'initfunc' should be NULL") if (!is.null(dllname) & "dllname" %in% names(func)) stop("If 'func' is a list that contains dllname, argument 'dllname' should be NULL") if (!is.null(initforc) & "initforc" %in% names(func)) stop("If 'func' is a list that contains initforc, argument 'initforc' should be NULL") if (!is.null(events$func) & "eventfunc" %in% names(func)) stop("If 'func' is a list that contains eventfunc, argument 'events$func' should be NULL") if ("eventfunc" %in% names(func)) { if (! is.null(events)) events$func <- func$eventfunc else events <- list(func = func$eventfunc) } if (!is.null(func$jacfunc)) jacfunc <- func$jacfunc if (!is.null(func$initfunc)) initfunc <- func$initfunc if (!is.null(func$dllname)) dllname <- func$dllname if (!is.null(func$initforc)) initforc <- func$initforc func <- func$func } hmax <- checkInput (y, times, func, rtol, atol, jacfunc, tcrit, hmin, hmax, hini, dllname) n <- length(y) if (!is.numeric(maxordn)) stop("`maxordn' must be numeric") if(maxordn < 1 || maxordn > 12) stop("`maxord' must be >1 and <=12") if (!is.numeric(maxords)) stop("`maxords' must be numeric") if(maxords < 1 || maxords > 5) stop("`maxords' must be >1 and <=5") ### Jacobian, method flag if (jactype == "fullint" ) jt <- 2 # full, calculated internally else if (jactype == "fullusr" ) jt <- 1 # full, specified by user function else if (jactype == "bandusr" ) jt <- 4 # banded, specified by user function else if (jactype == "bandint" ) jt <- 5 # banded, calculated internally else stop("'jactype' must be one of 'fullint', 'fullusr', 'bandusr' or 'bandint'") ## check other specifications depending on Jacobian if (jt %in% c(4,5) && is.null(bandup)) stop("'bandup' must be specified if banded Jacobian") if (jt %in% c(4,5) && is.null(banddown)) stop("'banddown' must be specified if banded Jacobian") if (is.null(banddown)) banddown <-1 if (is.null(bandup )) bandup <-1 if (jt %in% c(1,4) && is.null(jacfunc)) stop ("'jacfunc' NOT specified; either specify 'jacfunc' or change 'jactype'") ### model and Jacobian function Ynames <- attr(y,"names") JacFunc <- NULL flist<-list(fmat=0,tmat=0,imat=0,ModelForc=NULL) ModelInit <- NULL Eventfunc <- NULL events <- checkevents(events, times, Ynames, dllname) # KS: added... if (! is.null(events$newTimes)) times <- events$newTimes if (jt == 4 && banddown>0) erow<-matrix(data=0, ncol=n, nrow=banddown) else erow<-NULL if (is.character(func) | class(func) == "CFunc") { # function specified in a DLL or inline compiled DLL <- checkDLL(func, jacfunc, dllname, initfunc, verbose, nout, outnames) ModelInit <- DLL$ModelInit Func <- DLL$Func JacFunc <- DLL$JacFunc Nglobal <- DLL$Nglobal Nmtot <- DLL$Nmtot if (! is.null(forcings)) flist <- checkforcings(forcings,times,dllname,initforc,verbose,fcontrol) if (is.null(ipar)) ipar<-0 if (is.null(rpar)) rpar<-0 Eventfunc <- events$func if (is.function(Eventfunc)) rho <- environment(Eventfunc) else rho <- NULL } else { if(is.null(initfunc)) initpar <- NULL # parameter initialisation not needed if function is not a DLL rho <- environment(func) ## func and jac are overruled, either including ynames, or not ## This allows to pass the "..." arguments and the parameters if (ynames) { Func <- function(time,state) { attr(state,"names") <- Ynames unlist(func (time,state,parms,...)) } Func2 <- function(time,state) { attr(state,"names") <- Ynames func (time,state,parms,...) } JacFunc <- function(time,state) { attr(state,"names") <- Ynames rbind(jacfunc(time,state,parms,...),erow) } if (! is.null(events$Type)) if (events$Type == 2) Eventfunc <- function(time,state) { attr(state,"names") <- Ynames events$func(time,state,parms,...) } } else { # no ynames... Func <- function(time,state) unlist(func (time,state,parms,...)) Func2 <- function(time,state) func (time,state,parms,...) JacFunc <- function(time,state) rbind(jacfunc(time,state,parms,...),erow) if (! is.null(events$Type)) if (events$Type == 2) Eventfunc <- function(time,state) events$func(time,state,parms,...) } ## Check function and return the number of output variables +name FF <- checkFunc(Func2,times,y,rho) Nglobal<-FF$Nglobal Nmtot <- FF$Nmtot if (! is.null(events$Type)) if (events$Type == 2) checkEventFunc(Eventfunc,times,y,rho) if (jt %in% c(1,4)) { tmp <- eval(JacFunc(times[1], y), rho) if (!is.matrix(tmp)) stop("Jacobian function, 'jacfunc' must return a matrix\n") dd <- dim(tmp) if((jt ==4 && dd != c(bandup+banddown+banddown+1,n)) || (jt ==1 && dd != c(n,n))) stop("Jacobian dimension not ok") } } ### work arrays iwork, rwork # length of rwork and iwork if(jt %in% c(1,2)) lmat <- n^2+2 else if(jt %in% c(4,5)) lmat <- (2*banddown+bandup+1)*n+2 lrn = 20+n*(maxordn+1)+ 3*n # length in case non-stiff method lrs = 20+n*(maxords+1)+ 3*n +lmat # length in case stiff method lrw = max(lrn,lrs) # actual length: max of both liw = 20 + n # only first 20 elements passed to solver; other will be allocated in C-code iwork <- vector("integer",20) rwork <- vector("double",20) rwork[] <- 0. iwork[] <- 0 iwork[1] <- banddown iwork[2] <- bandup iwork[6] <- maxsteps if (maxordn != 12) iwork[8] <- maxordn if (maxords != 5) iwork[9] <- maxords if (verbose) iwork[5] = 1 # prints method switches to screen if(! is.null(tcrit)) rwork[1] <- tcrit rwork[5] <- hini rwork[6] <- hmax rwork[7] <- hmin ### the task to be performed. if (! is.null(times)) itask <- ifelse (is.null (tcrit), 1,4) else # times specified itask <- ifelse (is.null (tcrit), 2,5) # only one step if(is.null(times)) times<-c(0,1e8) ### print to screen... if (verbose) printtask(itask,func,jacfunc) ### calling solver storage.mode(y) <- storage.mode(times) <- "double" IN <-1 lags <- checklags(lags,dllname) on.exit(.C("unlock_solver")) out <- .Call("call_lsoda",y,times,Func,initpar, rtol, atol, rho, tcrit, JacFunc, ModelInit, Eventfunc, as.integer(verbose), as.integer(itask), as.double(rwork), as.integer(iwork), as.integer(jt), as.integer(Nglobal), as.integer(lrw),as.integer(liw), as.integer(IN), NULL, 0L, as.double(rpar), as.integer(ipar), 0L, flist, events, lags, PACKAGE="deSolve") ### saving results out <- saveOut(out, y, n, Nglobal, Nmtot, func, Func2, iin=c(1,12:21), iout=c(1:3,14,5:9,15:16), nr = 5) attr(out, "type") <- "lsoda" if (verbose) diagnostics(out) out } deSolve/R/cleanEventTimes.R0000754000175100001440000000215312352122161015301 0ustar hornikusers## find nearest event for each time step nearestEvent <- function(times, eventtimes) { eventtimes <- unique(eventtimes) # remove double events first ## sorting does not cost much if already sorted times <- sort(times) eventtimes <- sort(eventtimes) ## find index of events where time is between inearest <- findInterval(times, eventtimes) ## special care for smallest and biggest element lower <- eventtimes[pmax(inearest, 1)] upper <- eventtimes[pmin(inearest + 1, length(eventtimes))] nearest <- ifelse(times - lower < upper - times, lower, upper) return(nearest) } ## remove times that are numerically "too close" to an event cleanEventTimes <- function(times, eventtimes, eps = .Machine$double.eps * 10) { ## sorting does not cost much if already sorted ## sort times to ensure match of returned "nearest" value times <- sort(times) nearest <- nearestEvent(times, eventtimes) ## use bigger of the two numbers div <- pmax(times, nearest) ## special handling of zero div <- ifelse(div == 0, 1, div) reldiff <- abs(times - nearest) / div tooClose <- reldiff < eps times[!tooClose] } deSolve/R/rk4.R0000754000175100001440000001112712663327614012733 0ustar hornikusers### ============================================================================ ### Interface to a special code for the classsical Runge-Kutta ODE solver ### with fixed step size and without interpolation, see helpfile for details. ### ============================================================================ rk4 <- function(y, times, func, parms, verbose = FALSE, ynames = TRUE, dllname = NULL, initfunc = dllname, initpar = parms, rpar = NULL, ipar = NULL, nout = 0, outnames = NULL, forcings = NULL, initforc = NULL, fcontrol = NULL, ...) { if (is.list(func)) { ### IF a list if (!is.null(initfunc) & "initfunc" %in% names(func)) stop("If 'func' is a list that contains initfunc, argument 'initfunc' should be NULL") if (!is.null(dllname) & "dllname" %in% names(func)) stop("If 'func' is a list that contains dllname, argument 'dllname' should be NULL") if (!is.null(initforc) & "initforc" %in% names(func)) stop("If 'func' is a list that contains initforc, argument 'initforc' should be NULL") if (!is.null(func$initfunc)) initfunc <- func$initfunc if (!is.null(func$dllname)) dllname <- func$dllname if (!is.null(func$initforc)) initforc <- func$initforc func <- func$func } ## check for unsupported solver options dots <- list(...); nmdots <- names(dots) if(any(c("hmin", "hmax") %in% nmdots)) warning("hmin and hmax cannot be used in 'rk4' (fixed steps).") if("hini" %in% nmdots) { cat("'hini' is not supported by this version of rk4,\n") cat("but you can use ode(......, method = 'rk4', hini= .....)\n") cat("to set internal time steps smaller than external steps.\n") } if(any(c("events", "rootfunc") %in% nmdots)) { warning("events and roots are not supported by this version of rk4,\n", " but you can use ode(......, method = 'rk4', .....)\n") } if(any(c("jacfunc", "jactype", "mf", "bandup", "banddown") %in% nmdots)) { warning("Euler and Runge-Kutta solvers make no use of a Jacobian,\n", " ('jacfunc', 'jactype', 'mf', 'bandup' and 'banddown' are ignored).\n") } if(any(c("lags") %in% nmdots)) { warning("lags are not yet implemented for Euler and Runge-Kutta solvers,\n", " (argument 'lags' is ignored).\n") } ## check input checkInputEuler(y, times, func, dllname) n <- length(y) Ynames <- attr(y,"names") Initfunc <- NULL flist <-list(fmat = 0, tmat = 0, imat = 0, ModelForc = NULL) Nstates <- length(y) # assume length of states is correct ## Model as shared object (DLL)? if (is.character(func) | class(func) == "CFunc") { # function specified in a DLL or inline compiled DLL <- checkDLL(func, NULL, dllname, initfunc, verbose, nout, outnames) Initfunc <- DLL$ModelInit Func <- DLL$Func Nglobal <- DLL$Nglobal Nmtot <- DLL$Nmtot if (! is.null(forcings)) flist <- checkforcings(forcings, times, dllname, initforc, verbose, fcontrol) rho <- NULL if (is.null(ipar)) ipar <- 0 if (is.null(rpar)) rpar <- 0 } else { initpar <- NULL # parameter initialisation not needed if function is not a DLL rho <- environment(func) ## func and jac are overruled, either including ynames, or not ## This allows to pass the "..." arguments and the parameters if(ynames) { Func <- function(time, state, parms) { attr(state, "names") <- Ynames func (time,state,parms,...) } } else { # no ynames... Func <- function(time, state, parms) func (time, state, parms,...) } ## Call func once to figure out whether and how many "global" ## results it wants to return and some other safety checks FF <- checkFuncEuler(Func,times,y,parms,rho,Nstates) Nglobal <- FF$Nglobal Nmtot <- FF$Nmtot } vrb <- FALSE # TRUE forces internal debugging output of the C code ## the CALL to the integrator ## rk can be nested, so no "unlock_solver" needed on.exit(.C("unlock_solver")) out <- .Call("call_rk4", as.double(y), as.double(times), Func, Initfunc, parms, as.integer(Nglobal), rho, as.integer(vrb), as.double(rpar), as.integer(ipar), flist) out <- saveOutrk(out, y, n, Nglobal, Nmtot, iin = c(1, 12, 13, 15), iout=c(1:3, 18)) attr(out, "type") <- "rk" if (verbose) diagnostics(out) return(out) } deSolve/R/lsode.R0000754000175100001440000002754712643031573013350 0ustar hornikusers### ============================================================================ ### lsode -- solves ordinary differential equation systems ### The user has to specify whether or not ### the problem is stiff and choose the appropriate method. ### It is very similar to vode, except for some implementation details. ### More specifically, in vode it is possible to choose whether or not a copy ### of the Jacobian is saved for reuse in the corrector iteration algorithm; ### In lsode, a copy is not kept; this requires less memory but may be slightly ### slower. ### ### as from deSolve 1.7, lsode finds the root of at least one of a set ### of constraint functions g(i) of the independent and dependent variables. ### It finds only those roots for which some g(i), as a function ### of t, changes sign in the interval of integration. ### It then returns the solution at the root, if that occurs ### sooner than the specified stop condition, and otherwise returns ### the solution according the specified stop condition. ### ============================================================================ lsode <- function(y, times, func, parms, rtol=1e-6, atol=1e-6, jacfunc=NULL, jactype = "fullint", mf = NULL, rootfunc=NULL, verbose=FALSE, nroot = 0, tcrit = NULL, hmin=0, hmax=NULL, hini=0, ynames=TRUE, maxord=NULL, bandup=NULL, banddown=NULL, maxsteps=5000, dllname=NULL,initfunc=dllname, initpar=parms, rpar=NULL, ipar=NULL, nout=0, outnames=NULL,forcings=NULL, initforc = NULL, fcontrol=NULL, events=NULL, lags = NULL, ...) { if (is.list(func)) { ### IF a list if (!is.null(jacfunc) & "jacfunc" %in% names(func)) stop("If 'func' is a list that contains jacfunc, argument 'jacfunc' should be NULL") if (!is.null(rootfunc) & "rootfunc" %in% names(func)) stop("If 'func' is a list that contains rootfunc, argument 'rootfunc' should be NULL") if (!is.null(initfunc) & "initfunc" %in% names(func)) stop("If 'func' is a list that contains initfunc, argument 'initfunc' should be NULL") if (!is.null(dllname) & "dllname" %in% names(func)) stop("If 'func' is a list that contains dllname, argument 'dllname' should be NULL") if (!is.null(initforc) & "initforc" %in% names(func)) stop("If 'func' is a list that contains initforc, argument 'initforc' should be NULL") if (!is.null(events$func) & "eventfunc" %in% names(func)) stop("If 'func' is a list that contains eventfunc, argument 'events$func' should be NULL") if ("eventfunc" %in% names(func)) { if (! is.null(events)) events$func <- func$eventfunc else events <- list(func = func$eventfunc) } if (!is.null(func$jacfunc)) jacfunc <- func$jacfunc if (!is.null(func$rootfunc)) rootfunc <- func$rootfunc if (!is.null(func$initfunc)) initfunc <- func$initfunc if (!is.null(func$dllname)) dllname <- func$dllname if (!is.null(func$initforc)) initforc <- func$initforc func <- func$func } ### check input hmax <- checkInput (y, times, func, rtol, atol, jacfunc, tcrit, hmin, hmax, hini, dllname) n <- length(y) if (!is.null(maxord)) if(maxord < 1) stop("`maxord' must be >1") ### Jacobian, method flag if (is.null(mf)){ if (jactype == "fullint" ) imp <- 22 # full, calculated internally else if (jactype == "fullusr" ) imp <- 21 # full, specified by user function else if (jactype == "bandusr" ) imp <- 24 # banded, specified by user function else if (jactype == "bandint" ) imp <- 25 # banded, calculated internally else stop("'jactype' must be one of 'fullint', 'fullusr', 'bandusr' or 'bandint' if 'mf' not specified") } else imp <- mf if (! imp %in% c(10:15, 20:25)) stop ("method flag 'mf' not allowed") # check other specifications depending on Jacobian miter <- imp%%10 if (miter %in% c(1,4) & is.null(jacfunc)) stop ("'jacfunc' NOT specified; either specify 'jacfunc' or change 'jactype' or 'mf'") meth <- abs(imp)%/%10 # basic linear multistep method if (is.null (maxord)) maxord <- if (meth==1) 12 else 5 if (meth==1 && maxord > 12) stop ("'maxord' too large: should be <= 12") if (meth==2 && maxord > 5 ) stop ("'maxord' too large: should be <= 5") if (miter %in% c(4,5) && is.null(bandup)) stop("'bandup' must be specified if banded Jacobian") if (miter %in% c(4,5) && is.null(banddown)) stop("'banddown' must be specified if banded Jacobian") if (is.null(banddown)) banddown <-1 if (is.null(bandup )) bandup <-1 ### model and Jacobian function JacFunc <- NULL Ynames <- attr(y,"names") RootFunc <- NULL flist <- list(fmat=0,tmat=0,imat=0,ModelForc=NULL) ModelInit <- NULL Eventfunc <- NULL events <- checkevents(events, times, Ynames, dllname,TRUE) if (! is.null(events$newTimes)) times <- events$newTimes ## if (miter == 4) Jacobian should have banddown empty rows if (miter == 4 && banddown>0) erow<-matrix(data=0, ncol=n, nrow=banddown) else erow<-NULL if (is.character(func) | class(func) == "CFunc") { # function specified in a DLL or inline compiled DLL <- checkDLL(func,jacfunc,dllname, initfunc,verbose,nout, outnames) ## Is there a root function? if (!is.null(rootfunc)) { if (!is.character(rootfunc) & class(rootfunc) != "CFunc") stop("If 'func' is dynloaded, so must 'rootfunc' be") rootfuncname <- rootfunc if (class(rootfunc) == "CFunc") RootFunc <- body(rootfunc)[[2]] else if (is.loaded(rootfuncname, PACKAGE = dllname)) { RootFunc <- getNativeSymbolInfo(rootfuncname, PACKAGE = dllname)$address } else stop(paste("root function not loaded in DLL",rootfunc)) if (nroot == 0) stop("if 'rootfunc' is specified in a DLL, then 'nroot' should be > 0") } ModelInit <- DLL$ModelInit Func <- DLL$Func JacFunc <- DLL$JacFunc Nglobal <- DLL$Nglobal Nmtot <- DLL$Nmtot if (! is.null(forcings)) flist <- checkforcings(forcings,times,dllname,initforc,verbose,fcontrol) if (is.null(ipar)) ipar<-0 if (is.null(rpar)) rpar<-0 Eventfunc <- events$func if (is.function(Eventfunc)) rho <- environment(Eventfunc) else rho <- NULL } else { if (is.null(initfunc)) initpar <- NULL # parameter initialisation not needed if function is not a DLL rho <- environment(func) # func and jac are overruled, either including ynames, or not # This allows to pass the "..." arguments and the parameters if (ynames) { Func <- function(time,state) { attr(state,"names") <- Ynames unlist(func (time,state,parms,...)) } Func2 <- function(time,state) { attr(state,"names") <- Ynames func (time,state,parms,...) } JacFunc <- function(time,state) { attr(state,"names") <- Ynames rbind(jacfunc(time,state,parms,...),erow) } RootFunc <- function(time,state) { attr(state,"names") <- Ynames rootfunc(time,state,parms,...) } if (! is.null(events$Type)) if (events$Type == 2) Eventfunc <- function(time,state) { attr(state,"names") <- Ynames events$func(time,state,parms,...) } } else { # no ynames... Func <- function(time,state) unlist(func (time,state,parms,...)) Func2 <- function(time,state) func (time,state,parms,...) JacFunc <- function(time,state) rbind(jacfunc(time,state,parms,...),erow) RootFunc <- function(time,state) rootfunc(time,state,parms,...) if (! is.null(events$Type)) if (events$Type == 2) Eventfunc <- function(time,state) events$func(time,state,parms,...) } ## Check function and return the number of output variables +name FF <- checkFunc(Func2,times,y,rho) Nglobal<-FF$Nglobal Nmtot <- FF$Nmtot ## Check event function if (! is.null(events$Type)) if (events$Type == 2) checkEventFunc(Eventfunc,times,y,rho) ## and for rootfunc if (! is.null(rootfunc)) { tmp2 <- eval(rootfunc(times[1],y,parms,...), rho) if (!is.vector(tmp2)) stop("root function 'rootfunc' must return a vector\n") nroot <- length(tmp2) } else nroot = 0 if (miter %in% c(1,4)) { tmp <- eval(JacFunc(times[1], y), rho) if (!is.matrix(tmp)) stop("Jacobian function 'jacfunc' must return a matrix\n") dd <- dim(tmp) if ((miter == 4 && dd != c(bandup+banddown+banddown+1,n)) || (miter == 1 && dd != c(n,n))) stop("Jacobian dimension not ok") } } ### work arrays iwork, rwork # length of rwork and iwork lrw <- 20+n*(maxord+1)+3*n +3*nroot if(miter %in% c(1,2) ) lrw <- lrw + 2*n*n+2 if(miter ==3) lrw <- lrw + n+2 if(miter %in% c(4,5) ) lrw <- lrw + (2*banddown+ bandup+1)*n+2 liw <- if (miter %in% c(0,3)) 20 else 20+n # only first 20 elements passed; other will be allocated in C-code iwork <- vector("integer",20) rwork <- vector("double",20) rwork[] <- 0. iwork[] <- 0 iwork[1] <- banddown iwork[2] <- bandup iwork[5] <- maxord iwork[6] <- maxsteps if(!is.null(tcrit)) rwork[1] <- tcrit rwork[5] <- hini rwork[6] <- hmax rwork[7] <- hmin ### the task to be performed. itask <- if (! is.null(times)) { if (is.null (tcrit)) 1 else 4 } else { # times specified if (is.null (tcrit)) 2 else 5 # only one step } if(is.null(times)) times<-c(0,1e8) ### print to screen... if (verbose) { printtask(itask,func,jacfunc) printM("\n--------------------") printM("Integration method") printM("--------------------") df <- c("method flag, =", "meth =", "miter =") vals <- c(imp, meth, miter) txt <- "; (note: mf = (10 * meth + miter))" if (meth==1) txt <- c(txt, "; the basic linear multistep method: the implicit Adams method") else if (meth==2) txt <- c(txt, "; the basic linear multistep method: based on backward differentiation formulas") if (miter==0) txt <- c(txt, "; functional iteration (no Jacobian matrix is involved") else if (miter==1) txt <- c(txt, "; chord iteration with a user-supplied full (NEQ by NEQ) Jacobian") else if (miter==2) txt <- c(txt, "; chord iteration with an internally generated full Jacobian, (NEQ extra calls to F per df/dy value)") else if (miter==3) txt <- c(txt, "; chord iteration with an internally generated diagonal Jacobian (1 extra call to F per df/dy evaluation)") else if (miter==4) txt <- c(txt, "; chord iteration with a user-supplied banded Jacobian") else if (miter==5) txt <- c(txt, "; chord iteration with an internally generated banded Jacobian (using ML+MU+1 extra calls to F per df/dy evaluation)") printmessage(df, vals, txt) } ### calling solver storage.mode(y) <- storage.mode(times) <- "double" IN <-2 if (!is.null(rootfunc)) IN <- 6 lags <- checklags(lags, dllname) ## end time lags... on.exit(.C("unlock_solver")) out <- .Call("call_lsoda",y,times,Func,initpar, rtol, atol, rho, tcrit, JacFunc, ModelInit, Eventfunc, as.integer(verbose), as.integer(itask), as.double(rwork), as.integer(iwork), as.integer(imp),as.integer(Nglobal), as.integer(lrw),as.integer(liw),as.integer(IN), RootFunc, as.integer(nroot), as.double (rpar), as.integer(ipar), 0L, flist, events, lags, PACKAGE="deSolve") ### saving results if (nroot>0) iroot <- attr(out, "iroot") out <- saveOut(out, y, n, Nglobal, Nmtot, func, Func2, iin=c(1,12:19), iout=c(1:3,14,5:9)) if (nroot>0) attr(out, "iroot") <- iroot attr(out, "type") <- "lsode" if (verbose) diagnostics(out) return(out) } deSolve/R/vode.R0000754000175100001440000002546512643031573013174 0ustar hornikusers### ============================================================================ ### vode -- solves ordinary differential equation systems ### The user has to specify whether or not ### the problem is stiff and choose the appropriate method. ### It is very similar to lsode, except for some implementation details. ### More specifically, ### 1. there are more methods (mf) available in vode compared to lsode. ### 2. the memory management is more flexible in vode: ### when a method flag (mf) is positive, vode will save ### a copy of the Jacobian for reuse in the corrector iteration algorithm; ### for negative method flags a copy of the Jacobian is not saved. ### Thus negative flags need less memory, but positive flags ### may be (slightly) faster ### nb. this reduced memory strategy is the only option of lsode - a mf=21 ### in lsode is then equivalent to a mf = -21 in vode. ### ============================================================================ vode <- function(y, times, func, parms, rtol=1e-6, atol=1e-6, jacfunc=NULL, jactype = "fullint", mf = NULL, verbose=FALSE, tcrit = NULL, hmin=0, hmax=NULL, hini=0, ynames=TRUE, maxord=NULL, bandup=NULL, banddown=NULL, maxsteps=5000, dllname=NULL, initfunc=dllname, initpar=parms, rpar=NULL, ipar=NULL, nout=0, outnames=NULL, forcings=NULL, initforc = NULL, fcontrol=NULL, events=NULL, lags = NULL, ...) { ### check input if (is.list(func)) { # a list of compiled function specification if (!is.null(jacfunc) & "jacfunc" %in% names(func)) stop("If 'func' is a list that contains jacfunc, argument 'jacfunc' should be NULL") if (!is.null(initfunc) & "initfunc" %in% names(func)) stop("If 'func' is a list that contains initfunc, argument 'initfunc' should be NULL") if (!is.null(dllname) & "dllname" %in% names(func)) stop("If 'func' is a list that contains dllname, argument 'dllname' should be NULL") if (!is.null(initforc) & "initforc" %in% names(func)) stop("If 'func' is a list that contains initforc, argument 'initforc' should be NULL") if (!is.null(events$func) & "eventfunc" %in% names(func)) stop("If 'func' is a list that contains eventfunc, argument 'events$func' should be NULL") if ("eventfunc" %in% names(func)) { if (! is.null(events)) events$func <- func$eventfunc else events <- list(func = func$eventfunc) } if (!is.null(func$jacfunc)) jacfunc <- func$jacfunc if (!is.null(func$initfunc)) initfunc <- func$initfunc if (!is.null(func$dllname)) dllname <- func$dllname if (!is.null(func$initforc)) initforc <- func$initforc func <- func$func } hmax <- checkInput (y, times, func, rtol, atol, jacfunc, tcrit, hmin, hmax, hini, dllname) n <- length(y) if (!is.null(maxord)) if (maxord < 1) stop("`maxord' must be >1") ### Jacobian, method flag if (is.null(mf)) { if (jactype == "fullint" ) imp <- 22 # full, calculated internally else if (jactype == "fullusr" ) imp <- 21 # full, specified by user function else if (jactype == "bandusr" ) imp <- 24 # banded, specified by user function else if (jactype == "bandint" ) imp <- 25 # banded, calculated internally else stop("'jactype' must be one of 'fullint', 'fullusr', 'bandusr' or 'bandint' if 'mf' not specified") } else imp <- mf if (! imp %in% c(10:17, 20:27, -11,-12,-14,-15,-21, -22, -24: -27)) stop ("method flag 'mf' not allowed") # check other specifications depending on Jacobian miter <- abs(imp)%%10 if (miter %in% c(1,4) & is.null(jacfunc)) stop ("'jacfunc' NOT specified; either specify 'jacfunc' or change 'jactype' or 'mf'") meth <- abs(imp)%/%10 # basic linear multistep method jsv <- sign(imp) if (is.null (maxord)) maxord <- ifelse(meth==1,12,5) if (meth==1 && maxord > 12) stop ("'maxord' too large: should be <= 12") if (meth==2 && maxord > 5 ) stop ("'maxord' too large: should be <= 5") if (miter %in% c(4,5) && is.null(bandup)) stop("'bandup' must be specified if banded Jacobian") if (miter %in% c(4,5) && is.null(banddown)) stop("'banddown' must be specified if banded Jacobian") if (is.null(banddown)) banddown <-1 if (is.null(bandup )) bandup <-1 ### model and Jacobian function Func <- NULL JacFunc <- NULL ## if (miter == 4) Jacobian should have banddown empty rows! if (miter == 4 && banddown>0) erow<-matrix(data=0, ncol=n, nrow=banddown) else erow<-NULL Ynames <- attr(y,"names") flist<-list(fmat=0,tmat=0,imat=0,ModelForc=NULL) ModelInit <- NULL Eventfunc <- NULL events <- checkevents(events, times, Ynames, dllname) if (! is.null(events$newTimes)) times <- events$newTimes if (is.character(func) | class(func) == "CFunc") { # function specified in a DLL or inline compiled DLL <- checkDLL(func,jacfunc,dllname, initfunc,verbose,nout, outnames) ModelInit <- DLL$ModelInit Func <- DLL$Func JacFunc <- DLL$JacFunc Nglobal <- DLL$Nglobal Nmtot <- DLL$Nmtot if (! is.null(forcings)) flist <- checkforcings(forcings,times,dllname,initforc,verbose,fcontrol) if (is.null(ipar)) ipar<-0 if (is.null(rpar)) rpar<-0 Eventfunc <- events$func if (is.function(Eventfunc)) rho <- environment(Eventfunc) else rho <- NULL } else { if(is.null(initfunc)) initpar <- NULL # parameter initialisation not needed if function is not a DLL rho <- environment(func) # func and jac are overruled, either including ynames, or not # This allows to pass the "..." arguments and the parameters if(ynames) { Func <- function(time,state) { attr(state,"names") <- Ynames unlist(func (time,state,parms,...)) } Func2 <- function(time,state){ attr(state,"names") <- Ynames func (time,state,parms,...) } JacFunc <- function(time,state){ attr(state,"names") <- Ynames rbind(jacfunc(time,state,parms,...),erow) } if (! is.null(events$Type)) if (events$Type == 2) Eventfunc <- function(time,state) { attr(state,"names") <- Ynames events$func(time,state,parms,...) } } else { # no ynames... Func <- function(time,state) unlist(func (time,state,parms,...)) Func2 <- function(time,state) func (time,state,parms,...) JacFunc <- function(time,state) rbind(jacfunc(time,state,parms,...),erow) if (! is.null(events$Type)) if (events$Type == 2) Eventfunc <- function(time,state) events$func(time,state,parms,...) } ## Check function and return the number of output variables +name FF <- checkFunc(Func2,times,y,rho) Nglobal<-FF$Nglobal Nmtot <- FF$Nmtot if (! is.null(events$Type)) if (events$Type == 2) checkEventFunc(Eventfunc,times,y,rho) if (miter %in% c(1,4)) { tmp <- eval(JacFunc(times[1], y), rho) if (!is.matrix(tmp)) stop("Jacobian function must return a matrix\n") dd <- dim(tmp) if((miter ==4 && dd != c(bandup+banddown+banddown+1,n)) || (miter ==1 && dd != c(n,n))) stop("Jacobian dimension not ok") } } ### work arrays iwork, rwork # length of rwork and iwork lrw <- 20+n*(maxord+1)+3*n if(miter %in% c(1,2) && imp>0) lrw <- lrw + 2*n*n+2 if(miter %in% c(1,2) && imp<0) lrw <- lrw + n*n+2 if(miter ==3) lrw <- lrw + n+2 if(miter %in% c(4,5) && imp>0) lrw <- lrw + (3*banddown+2*bandup+2)*n+2 if(miter %in% c(4,5) && imp<0) lrw <- lrw + (2*banddown+bandup+1)*n+2 liw <- ifelse(miter %in% c(0,3),30,30+n) # only first 20 or 30 elements passed; other will be allocated in C-code iwork <- vector("integer",30) rwork <- vector("double",20) rwork[] <- 0. iwork[] <- 0 iwork[1] <- banddown iwork[2] <- bandup iwork[5] <- maxord iwork[6] <- maxsteps if(! is.null(tcrit)) rwork[1] <- tcrit rwork[5] <- hini rwork[6] <- hmax rwork[7] <- hmin ### the task to be performed. if (! is.null(times)) itask <- ifelse (is.null (tcrit), 1,4) else # times specified itask <- ifelse (is.null (tcrit), 2,5) # only one step if(is.null(times)) times<-c(0,1e8) ### print to screen... if (verbose) { printtask(itask,func,jacfunc) printM("\n--------------------") printM("Integration method") printM("--------------------") df <- c("method flag, =", "jsv =", "meth =", "miter =") vals <- c(imp, jsv, meth, miter) txt <- "; (note: mf = jsv * (10 * meth + miter))" if (jsv==1) txt<-c(txt, "; a copy of the Jacobian is saved for reuse in the corrector iteration algorithm" ) else if (jsv==-1)txt<-c(txt, "; a copy of the Jacobian is not saved") if (meth==1)txt<-c(txt, "; the basic linear multistep method: the implicit Adams method") else if (meth==2)txt<-c(txt,"; the basic linear multistep method: based on backward differentiation formulas") if (miter==0)txt<-c(txt, "; functional iteration (no Jacobian matrix is involved") else if (miter==1)txt<-c(txt, "; chord iteration with a user-supplied full (NEQ by NEQ) Jacobian") else if (miter==2)txt<-c(txt, "; chord iteration with an internally generated full Jacobian, (NEQ extra calls to F per df/dy value)") else if (miter==3)txt<-c(txt, "; chord iteration with an internally generated diagonal Jacobian (1 extra call to F per df/dy evaluation)") else if (miter==4)txt<-c(txt, "; chord iteration with a user-supplied banded Jacobian") else if (miter==5)txt<-c(txt, "; chord iteration with an internally generated banded Jacobian (using ML+MU+1 extra calls to F per df/dy evaluation)") printmessage(df, vals, txt) } ### calling solver storage.mode(y) <- storage.mode(times) <- "double" IN <- 5 # vode is livermore solver type 5 lags <- checklags(lags,dllname) on.exit(.C("unlock_solver")) out <- .Call("call_lsoda", y, times, Func, initpar, rtol, atol, rho, tcrit, JacFunc, ModelInit, Eventfunc, as.integer(verbose),as.integer(itask), as.double(rwork),as.integer(iwork), as.integer(imp),as.integer(Nglobal), as.integer(lrw),as.integer(liw),as.integer(IN),NULL, 0L, as.double (rpar), as.integer(ipar), 0L, flist, events, lags, PACKAGE = "deSolve") ### saving results out [1,1] <- times[1] # t=0 may be altered by dvode! out <- saveOut(out, y, n, Nglobal, Nmtot, func, Func2, iin=c(1,12:23), iout=1:13) attr(out, "type") <- "vode" if (verbose) diagnostics(out) out } deSolve/R/rkMethod.R0000754000175100001440000003532112352122161013773 0ustar hornikusers### ============================================================================ ### Butcher tables for selected explicit ODE solvers of Runge-Kutta type ### Note that for fixed step methods A is a vector (the subdiagonal of matrix A) ### For variable time step methods, A must be strictly lower triangular. ### The underlying rk codes support explicit methods ### and (still experimentally) some implicit methods. ### ============================================================================ rkMethod <- function(method = NULL, ...) { methods <- list( euler = list(ID = "euler", varstep = FALSE, A = c(0), b1 = c(1), c = c(0), stage = 1, Qerr = 1 ), ## Heun's method rk2 = list(ID = "rk2", varstep = FALSE, A = c(0, 1), b1 = c(0.5, 0.5), c = c(0, 1), stage = 2, Qerr = 1 ), ## classical Runge-Kutta 4th order method rk4 = list(ID = "rk4", varstep = FALSE, A = c(0, .5, .5, 1), b1 = c(1/6, 1/3, 1/3, 1/6), c = c(0, .5, .5, 1), stage = 4, Qerr = 4 ), ## One of the numerous RK23 formulae rk23 = list(ID = "rk23", varstep = TRUE, FSAL = FALSE, A = matrix(c(0, 0, 0, 1/2, 0, 0, -1, 2, 0), 3, 3, byrow = TRUE), b1 = c(0, 1, 0), b2 = c(1/6, 2/3, 1/6), c = c(0, 1/2, 2), stage = 3, Qerr = 2 ), ## Bogacki & Shampine rk23bs = list(ID = "rk23bs", varstep = TRUE, FSAL = TRUE, A = matrix(c(0, 0, 0, 0, 1/2, 0, 0, 0, 0, 3/4, 0, 0, 2/9, 1/3, 4/9, 0), 4, 4, byrow = TRUE), b1 = c(7/24, 1/4, 1/3, 1/8), b2 = c(2/9, 1/3, 4/9, 0), c = c(0, 1/2, 3/4, 1), stage = 4, Qerr = 2 ), ## RK-Fehlberg 34 rk34f = list(ID = "rk34f", varstep = TRUE, A = matrix(c(0, 0, 0, 0, 2/7, 0, 0, 0, 77/900, 343/900, 0, 0, 805/1444, -77175/54872, 97125/54872, 0, 79/490, 0, 2175/3626, 2166/9065), 5, 4, byrow = TRUE), b1 = c(79/490, 0, 2175/3626, 2166/9065, 0), b2 = c(229/1470, 0, 1125/1813, 13718/81585, 1/18), c = c(0, 2/7, 7/15, 35/38, 1), stage = 5, Qerr = 3 ), ## RK-Fehlberg Method 45 rk45f = list(ID = "rk45f", varstep = TRUE, A = matrix(c(0, 0, 0, 0, 0, 1/4, 0, 0, 0, 0, 3/32, 9/32, 0, 0, 0, 1932/2197, -7200/2197, 7296/2197, 0, 0, 439/216, -8, 3680/513, -845/4104, 0, -8/27, 2, -3544/2565, 1859/4104, -11/40), 6, 5, byrow = TRUE), b1 = c(25/216, 0, 1408/2565, 2197/4104, -1/5, 0), b2 = c(16/135, 0, 6656/12825, 28561/56430, -9/50, 2/55), c = c(0, 1/4, 3/8, 12/13, 1, 1/2), stage = 6, Qerr = 4 ), ## Cash-Karp method rk45ck = list(ID = "rk45ck", varstep = TRUE, FSAL = TRUE, A = matrix(c(0, 0, 0, 0, 0, 1/5, 0, 0, 0, 0, 3/40, 9/40, 0, 0, 0, 3/10, -9/10, 6/5, 0, 0, -11/54, 5/2, -70/27, 35/27, 0, 1631/55296, 175/512, 575/13824, 44275/110592, 253/4096), 6, 5, byrow = TRUE), b1 = c(2825/27648, 0, 18575/48384, 13525/55296, 277/14336, 1/4), b2 = c(37/378, 0, 250/621, 125/594, 0, 512/1771), c = c(0, 1/5, 3/10, 3/5, 1, 7/8), densetype = 2, # special dense output type 2 stage = 6, Qerr = 4), ## England Method rk45e = list(ID = "rk45e", varstep = TRUE, A = matrix(c(0, 0, 0, 0, 0, 1/2, 0, 0, 0, 0, 1/4, 1/4, 0, 0, 0, 0, -1, 2, 0, 0, 7/27, 10/27, 0, 1/27, 0, 28/625, -125/625, 546/625, 54/625, -378/625), 6, 5, byrow = TRUE), b1 = c(1/6, 0, 4/6, 1/6, 0, 0), b2 = c(14/336, 0, 0, 35/336, 162/336, 125/336), c = c(0, 1/2, 1/2, 1, 2/3, 1/5), stage = 6, Qerr = 4 ), ## Prince-Dormand 5(4)6m rk45dp6 = list(ID = "rk45dp6", varstep = TRUE, A = matrix(c(0, 0, 0, 0, 0, 1/5, 0, 0, 0, 0, 3/40, 9/40, 0, 0, 0, 3/10, -9/10, 6/5, 0, 0, 226/729, -25/27, 880/729, 55/729, 0, -181/270, 5/2, -266/297, -91/27, 189/55), 6, 5, byrow = TRUE), b1 = c(31/540, 0, 190/297, -145/108, 351/220, 1/20), b2 = c(19/216, 0, 1000/2079, -125/216, 81/88, 5/56), c = c(0, 1/5, 3/10, 3/5, 2/3, 1), stage = 6, Qerr = 4 ), ## Prince-Dormand 5(4)7m -- recommended by the Octave developers rk45dp7 = list(ID = "rk45dp7", varstep = TRUE, FSAL = TRUE, A = matrix(c(0, 0, 0, 0, 0, 0, 1/5, 0, 0, 0, 0, 0, 3/40, 9/40, 0, 0, 0, 0, 44/45, -56/15, 32/9, 0, 0, 0, 19372/6561, -25360/2187, 64448/6561, -212/729, 0, 0, 9017/3168, -355/33, 46732/5247, 49/176, -5103/18656, 0, 35/384, 0, 500/1113, 125/192, -2187/6784, 11/84), 7, 6, byrow = TRUE), b1 = c(5179/57600, 0, 7571/16695, 393/640, -92097/339200, 187/2100, 1/40), b2 = c(35/384, 0, 500/1113, 125/192, -2187/6784, 11/84, 0), c = c(0, 1/5, 3/10, 4/5, 8/9, 1, 1), d = c(-12715105075.0/11282082432.0, 0, 87487479700.0/32700410799.0, -10690763975.0/1880347072.0, 701980252875.0/199316789632.0, -1453857185.0/822651844.0, 69997945.0/29380423.0), densetype = 1, # default type of dense output formula, if available stage = 7, Qerr = 4 ), ## Prince-Dormand 78 method rk78dp = list(ID = "rk78dp", varstep = TRUE, FSAL = FALSE, A = matrix(c( 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1/18, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1/48, 1/16, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1/32, 0, 3/32, 0, 0, 0, 0, 0, 0, 0, 0, 0, 5/16, 0, -75/64, 75/64, 0, 0, 0, 0, 0, 0, 0, 0, 3/80, 0, 0, 3/16, 3/20, 0, 0, 0, 0, 0, 0, 0, 29443841/614563906, 0, 0, 77736538/692538347, -28693883/1125000000, 23124283/1800000000, 0, 0, 0, 0, 0, 0, 16016141/946692911, 0, 0, 61564180/158732637, 22789713/633445777, 545815736/2771057229, -180193667/1043307555, 0, 0, 0, 0, 0, 39632708/573591083, 0, 0, -433636366/683701615, -421739975/2616292301, 100302831/723423059, 790204164/839813087, 800635310/3783071287, 0, 0, 0, 0, 246121993/1340847787, 0, 0, -37695042795/15268766246, -309121744/1061227803, -12992083/490766935, 6005943493/2108947869, 393006217/1396673457, 123872331/1001029789, 0, 0, 0, -1028468189/846180014, 0, 0, 8478235783/508512852, 1311729495/1432422823, -10304129995/1701304382, -48777925059/3047939560, 15336726248/1032824649, -45442868181/3398467696, 3065993473/597172653, 0, 0, 185892177/718116043, 0, 0, -3185094517/667107341, -477755414/1098053517, -703635378/230739211, 5731566787/1027545527, 5232866602/850066563, -4093664535/808688257, 3962137247/1805957418, 65686358/487910083, 0, 403863854/491063109, 0, 0, -5068492393/434740067, -411421997/543043805, 652783627/914296604, 11173962825/925320556, -13158990841/6184727034, 3936647629/1978049680, -160528059/685178525, 248638103/1413531060, 0), nrow = 13, ncol = 12 , byrow = TRUE), b1 = c(13451932/455176623, 0, 0, 0, 0, -808719846/976000145, 1757004468/5645159321, 656045339/265891186, -3867574721/1518517206, 465885868/322736535, 53011238/667516719, 2/45, 0), b2 = c(14005451/335480064, 0, 0, 0, 0, -59238493/1068277825, 181606767/758867731, 561292985/797845732, -1041891430/1371343529, 760417239/1151165299, 118820643/751138087, -528747749/2220607170, 1/4), c = c(0, 1/18, 1/12, 1/8, 5/16, 3/8, 59/400, 93/200, 5490023248/9719169821, 13/20, 1201146811/1299019798, 1, 1), stage = 13, Qerr = 7 ), ## Runge-Kutta-Fehlberg 78 method rk78f = list(ID = "rk78f", varstep = TRUE, FSAL = FALSE, A = matrix( c(rep(0,12), 2/27, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1/36, 1/12, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1/24, 0, 1/8, 0, 0, 0, 0, 0, 0, 0, 0, 0, 5/12, 0, -25/16, 25/16, 0, 0, 0, 0, 0, 0, 0, 0, 0.05, 0, 0, 0.25, 0.2, 0, 0, 0, 0, 0, 0, 0, -25/108, 0, 0, 125/108, -65/27, 125/54, 0, 0, 0, 0, 0, 0, 31/300, 0, 0, 0, 61/225, -2/9, 13/900, 0, 0, 0, 0, 0, 2, 0, 0, -53/6, 704/45, -107/9, 67/90, 3, 0, 0, 0, 0, -91/108, 0, 0, 23/108, -976/135, 311/54, -19/60, 17/6, -1/12, 0, 0, 0, 2383/4100, 0, 0, -341/164, 4496/1025, -301/82, 2133/4100, 45/82, 45/164, 18/41, 0, 0, 3/205, 0, 0, 0, 0, -6/41, -3/205, -3/41, 3/41, 6/41, 0, 0, -1777/4100, 0, 0, -341/164, 4496/1025, -289/82, 2193/4100, 51/82, 33/164, 12/41, 0, 1 ), nrow=13, ncol=12, byrow = TRUE), b1 = c(41/840, 0,0,0,0, 34/105, 9/35, 9/35, 9/280, 9/280, 41/840, 0, 0), b2 = c(0, 0, 0, 0, 0, 34/105, 9/35, 9/35, 9/280, 9/280, 0, 41/840, 41/840), c = c(0, 2./27., 1/9, 1/6, 5/12, 0.5, 5/6, 1/6, 2/3, 1/3, 1, 0, 1), stage = 13, Qerr = 7 ), ## ------------------------------------------------------------------------- ## Implicit methods; experimental! ## ------------------------------------------------------------------------- ## Radau order 3 irk3r = list(ID = "irk3r", varstep = FALSE, implicit = TRUE, A = matrix( c(5/12, -1/12, 3/4, 1/4), nrow = 2, ncol = 2, byrow = TRUE), b1 = c(3/4, 1/4) , c = c(1/3, 1/4), stage = 2, Qerr = 3 ), ## Radau IIA order 5 irk5r = list(ID = "irk5r", varstep = FALSE, implicit = TRUE, A = matrix( c((88-7*sqrt(6))/360, (296-169*sqrt(6))/1800, (-2+3*sqrt(6))/225, (296+169*sqrt(6))/1800, (88+7*sqrt(6))/360, (-2-3*sqrt(6))/225, (16-sqrt(6))/36, (16+sqrt(6))/36, 1/9), nrow = 3, ncol = 3, byrow = TRUE), b1 = c((16-sqrt(6))/36, (16+sqrt(6))/36, 1/9), c = c(0.4-sqrt(6)/10, 0.4+sqrt(6)/10, 1), stage = 3, Qerr = 5 ), ## Hammer - Hollingsworth coefficients , order 4 irk4hh = list(ID = "irk4hh", varstep = FALSE, implicit = TRUE, A = matrix( c(1/4, 1/4-sqrt(3)/6, 1/4+sqrt(3)/6, 1/4), nrow = 2, ncol = 2, byrow = TRUE), b1 = c(1/2, 1/2), c = c(0.5-sqrt(3)/6, 0.5+sqrt(3)/6), stage = 2, Qerr = 4 ), ## Kuntzmann and Butcher order 6 irk6kb = list(ID = "irk6kb", varstep = FALSE, implicit = TRUE, A = matrix(c(5/36, 2/9-sqrt(15)/15, 5/36 - sqrt(15)/30, 5/36+sqrt(15)/24, 2/9, 5/36-sqrt(15)/24, 5/36+sqrt(15)/30, 2/9+sqrt(15)/15, 5/36), nrow = 3, ncol = 3, byrow = TRUE), b1 = c(5/18, 4/9, 5/18), c = c(1/2-sqrt(15)/10, 1/2, 1/2+sqrt(15)/10), stage = 3, Qerr = 6 ), ## Lobatto order 4 irk4l = list(ID = "irk4l", varstep = FALSE, implicit = TRUE, A = matrix(c(0, 0, 0, 1/4,1/4,0, 0, 1, 0), nrow=3, ncol=3, byrow = TRUE), b1 = c(1/6, 2/3, 1/6) , c = c(0, 1/2, 1), stage = 3, Qerr = 4 ), ## Lobatto order 6 irk6l = list(ID = "irk6l", varstep = FALSE, implicit = TRUE, A = matrix( c(0, 0, 0, 0, (5+sqrt(5))/60, 1/6, (15-7*sqrt(5))/60, 0, (5-sqrt(5))/60, (15+7*sqrt(5))/60, 1/6, 0, 1/6, (5-sqrt(5))/12, (5+sqrt(5))/12, 0), nrow = 4, ncol = 4, byrow = TRUE), b1 = c(1/12, 5/12, 5/12, 1/12) , c = c(0,(5-sqrt(5))/10, (5+sqrt(5))/10, 1), stage = 4, Qerr = 6 ) ) ## --------------------------------------------------------------------------- ## look if the method is known; ode23 and ode45 are used as synonyms ## --------------------------------------------------------------------------- knownMethods <- c(lapply(methods,"[[", "ID"), "ode23", "ode45") if (!is.null(method)) { method <- unlist(match.arg(method, knownMethods)) if (method == "ode23") method <- "rk23bs" else if (method == "ode45") method <- "rk45dp7" out <- methods[[method]] } else { out <- vector("list", 0) } ## modify a known or add a completely new method) ldots <- list(...) out[names(ldots)] <- ldots ## return the IDs of the methods if called with an empty argument list if (is.null(method) & length(ldots) == 0) { out <- as.vector(unlist(knownMethods)) } else { ## check size consistency of parameter sets sl <- lapply(out, length) stage <- out$stage if (is.matrix(out$A)) { if (nrow(out$A) != stage | ncol(out$A) < stage -1 | ncol(out$A) > stage) stop("Size of matrix A does not match stage") } else { if (length(out$A) != stage) stop("Size of A does not match stage") } if (stage != sl$b1 | stage != sl$c) stop("Wrong rkMethod, length of parameters do not match") if (out$varstep & is.null(out$b2)) stop("Variable stepsize method needs non-empty b2") if (!is.null(out$b2)) if (sl$b2 != stage) stop("Wrong rkMethod, length of b2 must be empty or equal to stage") if (!is.null(out[["d"]])) # exact argument matching! if (sl[["d"]] != stage) stop("Wrong rkMethod, length of d must be empty or equal to stage") ## check densetype if (!is.null(out$densetype)) { if (out$densetype == 1) if (!(out$ID %in% c("rk45dp7", "ode45"))) stop("densetype = 1 not implemented for this method") if (out$densetype == 2) if (!(out$ID %in% c("rk45ck"))) stop("densetype = 2 not implemented for this method") } class(out) <- c("list", "rkMethod") } out } deSolve/R/iteration.R0000754000175100001440000000670212363540070014222 0ustar hornikusers### ============================================================================ ### Interface to C code for Euler's ODE solver ### with fixed step size and without interpolation, see helpfile for details. ### ============================================================================ iteration <- function(y, times, func, parms, hini = NULL, verbose = FALSE, ynames = TRUE, dllname = NULL, initfunc = dllname, initpar = parms, rpar = NULL, ipar = NULL, nout = 0, outnames = NULL, forcings = NULL, initforc = NULL, fcontrol = NULL, ...) { if (is.list(func)) { ### IF a list if (!is.null(initfunc) & "initfunc" %in% names(func)) stop("If 'func' is a list that contains initfunc, argument 'initfunc' should be NULL") if (!is.null(initforc) & "initforc" %in% names(func)) stop("If 'func' is a list that contains initforc, argument 'initforc' should be NULL") initfunc <- func$initfunc initforc <- func$initforc func <- func$func } if (abs(diff(range(diff(times)))) > 1e-10) stop (" times should be equally spaced") dt <- diff(times[1:2]) if (is.null(hini)) hini <- dt nsteps <- as.integer(dt / hini) if (nsteps == 0) stop (" hini should be smaller than times interval ") if (nsteps * hini != dt) warning(" hini recalculated as integer fraction of times interval ",dt/nsteps) ## check input checkInputEuler(y, times, func, dllname) n <- length(y) ## Model as shared object (DLL)? Ynames <- attr(y, "names") Initfunc <- NULL flist <-list(fmat = 0, tmat = 0, imat = 0, ModelForc = NULL) Nstates <- length(y) # assume length of states is correct if (is.character(func) | class(func) == "CFunc") { DLL <- checkDLL(func, NULL, dllname, initfunc, verbose, nout, outnames) Initfunc <- DLL$ModelInit Func <- DLL$Func Nglobal <- DLL$Nglobal Nmtot <- DLL$Nmtot if (! is.null(forcings)) flist <- checkforcings(forcings, times, dllname, initforc, verbose, fcontrol) rho <- NULL if (is.null(ipar)) ipar <- 0 if (is.null(rpar)) rpar <- 0 } else { initpar <- NULL # parameter initialisation not needed if function is not a DLL rho <- environment(func) ## func and jac are overruled, either including ynames, or not ## This allows to pass the "..." arguments and the parameters if(ynames) { Func <- function(time, state, parms) { attr(state, "names") <- Ynames func (time, state, parms, ...) } } else { # no ynames ... Func <- function(time, state, parms) func (time, state, parms, ...) } ## Call func once to figure out whether and how many "global" ## results it wants to return and some other safety checks FF <- checkFuncEuler(Func, times, y, parms, rho, Nstates) Nglobal <- FF$Nglobal Nmtot <- FF$Nmtot } ## the CALL to the integrator on.exit(.C("unlock_solver")) out <- .Call("call_iteration", as.double(y), as.double(times), nsteps, Func, Initfunc, parms, as.integer(Nglobal), rho, as.integer(verbose), as.double(rpar), as.integer(ipar), flist, PACKAGE = "deSolve") ## saving results out <- saveOutrk(out, y, n, Nglobal, Nmtot, iin = c(1, 12, 13, 15), iout = c(1:3, 18)) if (verbose) diagnostics(out) attr(out, "type") <- "iteration" out } deSolve/R/SCOC.R0000754000175100001440000000107312352122161012742 0ustar hornikusersSCOC <- function(times, y=NULL, parms, Flux, ...) { if (is.null(y)){ meanDepo <- mean(approx(Flux[,1],Flux[,2], xout=seq(1,365,by=1))$y) y <- meanDepo/parms } else if (length(y) != 1) stop ("length of state variable vector should be 1") if (length(parms) != 1) stop ("length of parameter vector should be 1") names(y) <- c("C") out <- vode(y, times, func = "scocder", parms = parms, dllname = "deSolve", initforc="scocforc", forcings=Flux, initfunc = "scocpar", nout = 2, outnames = c("Mineralisation","Depo"),...) out } deSolve/R/dede.R0000754000175100001440000000426212352122161013117 0ustar hornikusers### ============================================================================ ### ### timelags and delay differential equations ### ### ============================================================================ ## ============================================================================= ## lagged values and derivates are obtained in the R-code via functions ## lagvalue and lagderiv ## ============================================================================= lagvalue <- function (t, nr=NULL) { if (is.null(nr)) nr <- 0 out <- .Call("getLagValue", t = t, PACKAGE = "deSolve", as.integer(nr)) return(out) } lagderiv <- function (t, nr=NULL) { if (is.null(nr)) nr <- 0 out <- .Call("getLagDeriv", t = t, PACKAGE = "deSolve", as.integer(nr)) return(out) } ### ============================================================================ ### solving Delay Differential Equations ### ============================================================================ dede <- function(y, times, func=NULL, parms, method = c( "lsoda", "lsode", "lsodes", "lsodar", "vode", "daspk", "bdf", "adams", "impAdams", "radau"), control=NULL, ...) { if (is.null(control)) control <- list(mxhist = 1e4) if (is.null(method)) method <- "lsoda" else if (is.function(method)) res <- method(y, times, func, parms, lags = control, ...) else if (is.complex(y)) stop ("cannot run dede with complex y") else res <- switch(match.arg(method), lsoda = lsoda(y, times, func, parms, lags = control, ...), vode = vode(y, times, func, parms, lags = control, ...), lsode = lsode(y, times, func, parms, lags = control, ...), lsodes = lsodes(y, times, func, parms, lags = control, ...), lsodar = lsodar(y, times, func, parms, lags = control, ...), daspk = daspk(y, times, func, parms, lags = control, ...), bdf = lsode(y, times, func, parms, mf = 22, lags = control, ...), adams = lsode(y, times, func, parms, mf = 10, lags = control, ...), radau = radau(y, times, func, parms, lags = control, ...), impAdams = lsode(y, times, func, parms, mf = 12, lags = control, ...) ) return(res) } deSolve/R/lsodes.R0000754000175100001440000004000712536771231013520 0ustar hornikusers### ============================================================================ ### lsodes -- solves ordinary differential equation systems with general ### sparse Jacobian matrix. ### The sparsity structure of the Jacobian is either specified ### by the user, estimated internally (default), or of a special type. ### To date, "1D", "2D", "3D" are supported as special types. ### These are the sparsity associated with 1- 2- and 3-Dimensional PDE models ### ### as from deSolve 1.9.1, lsode1 finds the root of at least one of a set ### of constraint functions g(i) of the independent and dependent variables. ### It finds only those roots for which some g(i), as a function ### of t, changes sign in the interval of integration. ### It then returns the solution at the root, if that occurs ### sooner than the specified stop condition, and otherwise returns ### the solution according the specified stop condition. ### ### Karline: version 1.10.4: ### added 2-D with mapping - still in testing phase, undocumented ### ============================================================================ lsodes <- function(y, times, func, parms, rtol = 1e-6, atol = 1e-6, jacvec = NULL, sparsetype = "sparseint", nnz = NULL, inz = NULL, rootfunc = NULL, verbose = FALSE, nroot = 0, tcrit = NULL, hmin = 0, hmax = NULL, hini = 0, ynames = TRUE, maxord = NULL, maxsteps = 5000, lrw = NULL, liw = NULL, dllname = NULL, initfunc = dllname, initpar = parms, rpar = NULL, ipar = NULL, nout = 0, outnames = NULL, forcings = NULL, initforc = NULL, fcontrol = NULL, events = NULL, lags = NULL, ...) { ### check input if (is.list(func)) { ### IF a list if (!is.null(jacvec) & "jacvec" %in% names(func)) stop("If 'func' is a list that contains jacvec, argument 'jacvec' should be NULL") if (!is.null(rootfunc) & "rootfunc" %in% names(func)) stop("If 'func' is a list that contains rootfunc, argument 'rootfunc' should be NULL") if (!is.null(initfunc) & "initfunc" %in% names(func)) stop("If 'func' is a list that contains initfunc, argument 'initfunc' should be NULL") if (!is.null(dllname) & "dllname" %in% names(func)) stop("If 'func' is a list that contains dllname, argument 'dllname' should be NULL") if (!is.null(initforc) & "initforc" %in% names(func)) stop("If 'func' is a list that contains initforc, argument 'initforc' should be NULL") if (!is.null(events$func) & "eventfunc" %in% names(func)) stop("If 'func' is a list that contains eventfunc, argument 'events$func' should be NULL") if ("eventfunc" %in% names(func)) { if (! is.null(events)) events$func <- func$eventfunc else events <- list(func = func$eventfunc) } if (!is.null(func$jacvec)) jacvec <- func$jacvec if (!is.null(func$rootfunc)) rootfunc <- func$rootfunc if (!is.null(func$initfunc)) initfunc <- func$initfunc if (!is.null(func$dllname)) dllname <- func$dllname if (!is.null(func$initforc)) initforc <- func$initforc func <- func$func } hmax <- checkInput (y, times, func, rtol, atol, jacvec, tcrit, hmin, hmax, hini, dllname,"jacvec") n <- length(y) if (is.null (maxord)) maxord <- 5 if (maxord > 5 ) stop ("'maxord' too large: should be <= 5") if (maxord < 1 ) stop ("`maxord' must be >1") ### Sparsity type and Jacobian method flag imp if (sparsetype=="sparseusr" && is.null(inz)) stop("'inz' must be specified if 'sparsetype' = 'sparseusr'") if (sparsetype=="sparsejan" && is.null(inz)) stop("'inz' must be specified if 'sparsetype' = 'sparsejan'") if (sparsetype=="1D" && ! is.null(jacvec)) stop("cannot combine 'sparsetype=1D' and 'jacvec'") if (sparsetype %in% c("2D", "2Dmap") && ! is.null(jacvec)) stop("cannot combine 'sparsetype=2D' and 'jacvec'") if (sparsetype %in% c("3D", "3Dmap") && ! is.null(jacvec)) stop("cannot combine 'sparsetype=3D' and 'jacvec'") # imp = method flag as used in lsodes if (! is.null(jacvec) && sparsetype %in% c("sparseusr", "sparsejan")) imp <- 21 # inz supplied,jac supplied else if (! is.null(jacvec) && !sparsetype=="sparseusr") imp <- 121 # inz internally generated,jac supplied else if (is.null(jacvec) && sparsetype%in%c("sparseusr","1D","2D","2Dmap","3D","3Dmap","sparsejan")) imp <- 22 # inz supplied,jac not supplied else imp <- 222 # sparse Jacobian, calculated internally ## Special-purpose sparsity structures: 1-D and 2-D reaction-transport problems ## Typically these applications are called via ode.1D, ode.2D and ode.3D ## Here the sparsity is specified in the C-code; this needs extra input: ## the number of components *nspec* and the dimensionality of the problem ## (number of boxes in each direction). ## This information is passed by ode.1D, ode.2D and ode.3D in parameter ## nnz (a vector). ## nnz is altered to include the number of nonzero elements (element 1). ## 'Type' contains the type of sparsity + nspec + num boxes + cyclicBnd + bandwidth if (sparsetype == "1D") { nspec <- nnz[1] bandwidth <- 1 # nnz[3] Type <- c(2,nnz) #type=2 nnz <- n*(2+nspec*bandwidth)-2*nspec } else if (sparsetype %in% c("2D","2Dmap")) { nspec <- nnz[1] dimens <- nnz[2:3] bandwidth <- 1# nnz[6] maxdim <- max(dimens) if (sparsetype == "2D") { Type <- c(3, nnz) #type=3 nnz <- n*(4+nspec*bandwidth)-2*nspec*(sum(dimens)) } else { ## Karline: changes for 2D map Type <- c(30, nnz) #type=30 for 2Dmap nnz <- (nspec*prod(dimens))*(4+nspec*bandwidth)-2*nspec*(sum(dimens)) } if (Type[5]==1) { # cyclic boundary in x-direction nnz <- nnz + 2*maxdim*nspec*bandwidth } if (Type[6] ==1) {# cyclic boundary in y-direction nnz <- nnz + 2*maxdim*nspec*bandwidth } } else if (sparsetype %in% c("3D","3Dmap")) { nspec <- nnz[1] dimens <- nnz[2:4] #type=4 bandwidth <- 1# nnz[8] if (sparsetype == "3D") { Type <- c(4,nnz) nnz <- n*(6+nspec*bandwidth)-2*nspec*(sum(dimens)) } else { ## Karline: changes for 3D map Type <- c(40, nnz) #type=40 for 3Dmap nnz <- (nspec*prod(dimens))*(6+nspec*bandwidth)-2*nspec*(sum(dimens)) } if (Type[6]== 1) { # cyclic boundary in x-direction nnz <- nnz + 2*dimens[2]*dimens[3]*nspec } if (Type[7] == 1) {# cyclic boundary in y-direction nnz <- nnz + 2*dimens[1]*dimens[3]*nspec } if (Type[8] == 1) {# cyclic boundary in y-direction nnz <- nnz + 2*dimens[1]*dimens[2]*nspec } } else if (sparsetype == "sparseusr") { Type <- 0 nnz <- nrow(inz) } else if (sparsetype == "sparsejan") { # ian and jan inputted, as a vector Type <- 0 nnz <- length(inz) - n } else { Type <- 1 if (is.null(nnz)) nnz <- n*n } if (nnz < 1) stop ("Jacobian should at least contain one non-zero value") ### model and Jacobian function JacFunc <- NULL Ynames <- attr(y,"names") RootFunc <- NULL flist <- list(fmat=0,tmat=0,imat=0,ModelForc=NULL) ModelInit <- NULL Eventfunc <- NULL events <- checkevents(events, times, Ynames, dllname,TRUE) if (! is.null(events$newTimes)) times <- events$newTimes if (is.character(func) | class(func) == "CFunc") { # function specified in a DLL or inline compiled DLL <- checkDLL(func,jacvec,dllname, initfunc,verbose,nout, outnames, JT=2) ## Is there a root function? if (!is.null(rootfunc)) { if (!is.character(rootfunc) & class(rootfunc) != "CFunc") stop("If 'func' is dynloaded, so must 'rootfunc' be") rootfuncname <- rootfunc if (class(rootfunc) == "CFunc") RootFunc <- body(rootfunc)[[2]] else if (is.loaded(rootfuncname, PACKAGE = dllname)) { RootFunc <- getNativeSymbolInfo(rootfuncname, PACKAGE = dllname)$address } else stop(paste("root function not loaded in DLL",rootfunc)) if (nroot == 0) stop("if 'rootfunc' is specified in a DLL, then 'nroot' should be > 0") } ModelInit <- DLL$ModelInit Func <- DLL$Func JacFunc <- DLL$JacFunc Nglobal <- DLL$Nglobal Nmtot <- DLL$Nmtot if (! is.null(forcings)) flist <- checkforcings(forcings,times,dllname,initforc,verbose,fcontrol) if (is.null(ipar)) ipar<-0 if (is.null(rpar)) rpar<-0 Eventfunc <- events$func if (is.function(Eventfunc)) rho <- environment(Eventfunc) else rho <- NULL } else { if(is.null(initfunc)) initpar <- NULL # parameter initialisation not needed if function is not a DLL rho <- environment(func) # func and jac are overruled, either including ynames, or not # This allows to pass the "..." arguments and the parameters if (ynames) { Func <- function(time,state) { attr(state,"names") <- Ynames unlist(func (time,state,parms,...)) } Func2 <- function(time,state) { attr(state,"names") <- Ynames func (time,state,parms,...) } JacFunc <- function(time,state,J){ attr(state,"names") <- Ynames jacvec(time,state,J,parms,...) } RootFunc <- function(time,state) { attr(state,"names") <- Ynames rootfunc(time,state,parms,...) } if (! is.null(events$Type)) if (events$Type == 2) Eventfunc <- function(time,state) { attr(state,"names") <- Ynames events$func(time,state,parms,...) } } else { # no ynames... Func <- function(time,state) unlist(func (time,state,parms,...)) Func2 <- function(time,state) func (time,state,parms,...) JacFunc <- function(time,state,J) jacvec(time,state,J,parms,...) RootFunc <- function(time,state) rootfunc(time,state,parms,...) if (! is.null(events$Type)) if (events$Type == 2) Eventfunc <- function(time,state) events$func(time,state,parms,...) } ## Check function and return the number of output variables +name FF <- checkFunc(Func2,times,y,rho) Nglobal<-FF$Nglobal Nmtot <- FF$Nmtot ## Check event function if (! is.null(events$Type)) if (events$Type == 2) checkEventFunc(Eventfunc,times,y,rho) ## and for rootfunc if (! is.null(rootfunc)) { tmp2 <- eval(rootfunc(times[1],y,parms,...), rho) if (!is.vector(tmp2)) stop("root function 'rootfunc' must return a vector\n") nroot <- length(tmp2) } else nroot = 0 } ### work arrays iwork, rwork # 1. Estimate length of rwork and iwork if not provided via arguments lrw, liw moss <- imp%/%100 # method to be used to obtain sparsity meth <- imp%%100%/%10 # basic linear multistep method miter <- imp%%10 # corrector iteration method lenr = 2 # real to integer wordlength ratio (2 due to double precision) if (is.null(lrw)) { # make a guess of real work space needed lrw = 20+n*(maxord+1)+3*n +20 #extra 20 to make sure if(miter == 1) lrw = lrw + 2*nnz + 2*n + (nnz+9*n)/lenr if(miter == 2) lrw = lrw + 2*nnz + 2*n + (nnz+10*n)/lenr if(miter == 3) lrw = lrw + n + 2 if (sparsetype == "1D") lrw <- lrw*1.2 # increase to be sure it is enough... } # if (is.null(liw)) { # make a guess of integer work space needed KS->THOMAS: if not NULL, should be large enough! if (moss == 0 && miter %in% c(1,2)) liw <- max(liw, 31+n+nnz +30) else # extra 30 liw <- max(liw, 30) # } lrw <- max(20, lrw) + 3*nroot # 2. Allocate and set values # only first 20 elements of rwork passed to solver; # other elements will be allocated in C-code # for iwork: only first 30 elements, except when sparsity imposed rwork <- vector("double",20) rwork[] <- 0. # iwork will contain sparsity structure (ian,jan) # See documentation of DLSODES how this is done if(sparsetype=="sparseusr") { iwork <- vector("integer",liw) iwork[] <- 0 iw <- 32+n iwork[31]<- iw # input = 2-columned matrix inz; converted to ian,jan and put in iwork # column indices should be sorted... rr <- inz[,2] if (min(rr[2:nnz]-rr[1:(nnz-1)])<0) stop ("cannot proceed: column indices (2nd column of inz) should be sorted") for(i in 1:n) { ii <- which (rr==i) il <- length(ii) i1 <- iwork[i+30] i2 <- iwork[i+30]+il-1 iwork[i+31] <- i2+1 if (il>0) iwork[i1:i2] <- inz[ii,1] } iwork[31:(31+n)] <- iwork[31:(31+n)]-31-n } else if(sparsetype=="sparsejan") { iwork <- vector("integer",liw) iwork[] <- 0 iw <- 32+n linz <- 30 + length(inz) iwork[31:linz] <- inz } else { # sparsity not imposed; only 30 element of iwork allocated. iwork <- vector("integer",30) iwork[] <- 0 } # other elements of iwork, rwork iwork[5] <- maxord iwork[6] <- maxsteps if(! is.null(tcrit)) rwork[1] <- tcrit rwork[5] <- hini rwork[6] <- hmax rwork[7] <- hmin # the task to be performed. if (! is.null(times)) itask <- ifelse (is.null (tcrit), 1,4) else # times specified itask <- ifelse (is.null (tcrit), 2,5) # only one step if(is.null(times)) times <- c(0,1e8) ### print to screen... if (verbose) { printtask(itask,func,jacvec) printM("\n--------------------") printM("Integration method") printM("--------------------\n") txt <- "" # to avoid txt being not defined... if (imp == 21) txt <- " The user has supplied indices to nonzero elements of Jacobian, and a Jacobian function" else if (imp == 22) { if (sparsetype %in% c("sparseusr","sparsejan")) txt <-" The user has supplied indices to nonzero elements of Jacobian, the Jacobian will be estimated internally, by differences" if (sparsetype=="1D") txt <-" The nonzero elements are according to a 1-D model, the Jacobian will be estimated internally, by differences" if (sparsetype %in% c("2D", "2Dmap")) txt <-" The nonzero elements are according to a 2-D model, the Jacobian will be estimated internally, by differences" if (sparsetype %in% c("3D","3Dmap")) txt <-" The nonzero elements are according to a 3-D model, the Jacobian will be estimated internally, by differences" } else if (imp == 122) txt <-" The user has supplied the Jacobian, its structure (indices to nonzero elements) will be obtained from NEQ+1 calls to jacvec" else if (imp == 222) txt <-" The Jacobian will be generated internally, its structure (indices to nonzero elements) will be obtained from NEQ+1 calls to func" printM(txt) } ### calling solver storage.mode(y) <- storage.mode(times) <- "double" IN <- 3 if (!is.null(rootfunc)) IN <- 7 lags <- checklags(lags, dllname) on.exit(.C("unlock_solver")) out <- .Call("call_lsoda",y,times,Func,initpar, rtol, atol, rho, tcrit, JacFunc, ModelInit, Eventfunc, as.integer(verbose), as.integer(itask), as.double(rwork), as.integer(iwork), as.integer(imp),as.integer(Nglobal), as.integer(lrw),as.integer(liw),as.integer(IN), RootFunc, as.integer(nroot), as.double (rpar), as.integer(ipar), as.integer(Type),flist, events, lags, PACKAGE="deSolve") ### saving results if (nroot>0) iroot <- attr(out, "iroot") out <- saveOut(out, y, n, Nglobal, Nmtot, func, Func2, iin=c(1,12:20), iout=c(1:3,14,5:9,17)) if (nroot>0) attr(out, "iroot") <- iroot attr(out, "type") <- "lsodes" if (verbose) diagnostics(out) out } deSolve/R/daspk.R0000754000175100001440000005233512643031573013335 0ustar hornikusers ### ============================================================================ ### daspk -- solves differential algebraic and ordinary differential equation ### systems defined in res (DAE) or func (ODE) ### and outputs values for the times in `times' ### on input, y and dy contains the initial values of the state ### variables and rates of changes for times[1] ### parms is a vector of parameters for func. They should not ### change during the integration. ### ============================================================================ daspk <- function(y, times, func=NULL, parms, nind = c(length(y), 0, 0), dy = NULL, res = NULL, nalg=0, rtol=1e-6, atol=1e-6, jacfunc=NULL, jacres=NULL, jactype = "fullint", mass = NULL, estini = NULL, verbose=FALSE, tcrit = NULL, hmin=0, hmax=NULL, hini=0, ynames=TRUE, maxord =5, bandup=NULL, banddown=NULL, maxsteps=5000, dllname=NULL, initfunc=dllname, initpar=parms, rpar=NULL, ipar=NULL, nout=0, outnames=NULL, forcings=NULL, initforc = NULL, fcontrol=NULL, events = NULL, lags = NULL, ...) { ### check input if (is.null(res) && is.null(func)) stop("either `func' or 'res' must be specified") if (!is.null(res) && !is.null(func)) stop("either `func' OR 'res' must be specified, not both") if (is.list(func)) { # a list of compiled codes if (!is.null(jacfunc) & "jacfunc" %in% names(func)) stop("If 'func' is a list that contains jacfunc, argument 'jacfunc' should be NULL") if (!is.null(initfunc) & "initfunc" %in% names(func)) stop("If 'func' is a list that contains initfunc, argument 'initfunc' should be NULL") if (!is.null(dllname) & "dllname" %in% names(func)) stop("If 'func' is a list that contains dllname, argument 'dllname' should be NULL") if (!is.null(initforc) & "initforc" %in% names(func)) stop("If 'func' is a list that contains initforc, argument 'initforc' should be NULL") if (!is.null(events$func) & "eventfunc" %in% names(func)) stop("If 'func' is a list that contains eventfunc, argument 'events$func' should be NULL") if ("eventfunc" %in% names(func)) { if (! is.null(events)) events$func <- func$eventfunc else events <- list(func = func$eventfunc) } if (!is.null(func$jacfunc)) jacfunc <- func$jacfunc if (!is.null(func$initfunc)) initfunc <- func$initfunc if (!is.null(func$initforc)) initforc <- func$initforc if (!is.null(func$dllname)) dllname <- func$dllname func <- func$func } if (is.list(res)) { # if (!is.null(jacres) & "jacres" %in% names(res)) stop("If 'res' is a list that contains jacres, argument 'jacres' should be NULL") if (!is.null(initfunc) & "initfunc" %in% names(res)) stop("If 'res' is a list that contains initfunc, argument 'initfunc' should be NULL") if (!is.null(dllname) & "dllname" %in% names(res)) stop("If 'res' is a list that contains dllname, argument 'dllname' should be NULL") if (!is.null(initforc) & "initforc" %in% names(res)) stop("If 'res' is a list that contains initforc, argument 'initforc' should be NULL") if (!is.null(events$func) & "eventfunc" %in% names(res)) stop("If 'res' is a list that contains eventfunc, argument 'events$func' should be NULL") if ("eventfunc" %in% names(res)) { if (! is.null(events)) events$func <- res$eventfunc else events <- list(func = res$eventfunc) } if (!is.null(res$jacres)) jacres <- res$jacres if (!is.null(res$initfunc)) initfunc <- res$initfunc if (!is.null(res$initforc)) initforc <- res$initforc if (!is.null(res$dllname)) dllname <- res$dllname res <- res$res } if (!is.numeric(y)) stop("`y' must be numeric") n <- length(y) if (! is.null(times)&&!is.numeric(times)) stop("`times' must be NULL or numeric") if (!is.null(jacres) && !is.null(jacfunc)) stop("either `jacfunc' OR 'jacres' must be specified, not both") if (!is.null(func) && !is.function(func) && !is.character(func) && ! class(func) == "CFunc") stop("`func' must be a function, a character vector, of class 'CFunc' or NULL") if (!is.null(res) && !is.function(res) && !is.character(res) && ! class(res) == "CFunc") stop("`res' must be NULL, a function or character vector or of class 'CFunc'") if (is.character(res) && (is.null(dllname) || !is.character(dllname))) stop("You need to specify the name of the dll or shared library where res can be found (without extension)") if (!is.numeric(rtol)) stop("`rtol' must be numeric") if (!is.numeric(atol)) stop("`atol' must be numeric") if (!is.null(tcrit) & !is.numeric(tcrit)) stop("`tcrit' must be numeric") if (!is.null(jacfunc) && !(is.function(jacfunc) )) stop("`jacfunc' must be a function or NULL") if (!is.null(jacres) && !(is.function(jacres) || is.character(jacres))) stop("`jacres' must be a function or character vector or of class 'CFunc'") if (length(atol) > 1 && length(atol) != n) stop("`atol' must either be a scalar, or as long as `y'") if (length(rtol) > 1 && length(rtol) != n) stop("`rtol' must either be a scalar, or as long as `y'") if (!is.numeric(hmin)) stop("`hmin' must be numeric") if (hmin < 0) stop("`hmin' must be a non-negative value") if (is.null(hmax)) hmax <- ifelse (is.null(times), 0, max(abs(diff(times)))) if (!is.numeric(hmax)) stop("`hmax' must be numeric") if (hmax < 0) stop("`hmax' must be a non-negative value") if (hini < 0) stop("`hini' must be a non-negative value") if (!is.numeric(maxord)) stop("`maxord' must be numeric") if(maxord < 1 || maxord > 5) stop("`maxord' must be >1 and <=5") if (!is.null(func) && !(is.null(res) )) stop("either `func' OR 'res' must be specified, not both") if (!is.null(mass) && !(is.null(res) )) stop("cannot combine `res' with 'mass' - use 'func' instead, or set 'mass' = NULL") ## max number of iterations ~ maxstep; a multiple of 500 maxIt <- max(1,(maxsteps+499)%/%500) ### Jacobian, method flag if (jactype == "fullint" ) imp <- 22 # full, calculated internally else if (jactype == "fullusr" ) imp <- 21 # full, specified by user function else if (jactype == "bandusr" ) imp <- 24 # banded, specified by user function else if (jactype == "bandint" ) imp <- 25 # banded, calculated internally else stop("'jactype' must be one of 'fullint', 'fullusr', 'bandusr' or 'bandint'") if (imp %in% c(24,25) && is.null(bandup)) stop("'bandup' must be specified if banded Jacobian") if (imp %in% c(24,25) && is.null(banddown)) stop("'banddown' must be specified if banded Jacobian") # if (miter == 4) Jacobian should have banddown empty rows-vode+daspk only! if (imp == 24) erow<-matrix(data=0,ncol=n,nrow=banddown) else erow<-NULL if (is.null(banddown)) banddown <-1 if (is.null(bandup )) bandup <-1 if (is.null(dy)) dy <- rep(0,n) if (!is.numeric(dy)) stop("`dy' must be numeric") ### model and Jacobian function Ynames <- attr(y,"names") dYnames <- attr(dy,"names") Res <- NULL JacRes <- NULL PsolFunc <- NULL funtype <- 1 ModelInit <- NULL flist<-list(fmat=0,tmat=0,imat=0,ModelForc=NULL) Eventfunc <- NULL events <- checkevents(events, times, Ynames, dllname) if (! is.null(events$newTimes)) times <- events$newTimes if (!is.null(dllname)) # Karline.... to avoid wrong address to initfunc ... added 24/7/2014 if (sum(duplicated (c(func, initfunc, jacfunc, res, jacres))) > 0) stop("func, initfunc, jacfunc, res, jacres cannot share the same name") if (!is.null(dllname) | class(func) == "CFunc" | class(res) == "CFunc") { if (class(initfunc) == "CFunc") ModelInit <- body(initfunc)[[2]] else if (is.character(initfunc)) # to allow absence of initfunc if (is.loaded(initfunc, PACKAGE = dllname, type = "") || is.loaded(initfunc, PACKAGE = dllname, type = "Fortran")) { ModelInit <- getNativeSymbolInfo(initfunc, PACKAGE = dllname)$address } else if (initfunc != dllname) stop(paste("cannot integrate: initfunc not loaded ",initfunc)) if (! is.null(forcings)) flist <- checkforcings(forcings,times,dllname,initforc,verbose,fcontrol) # Easier to deal with NA in C-code if (is.null(initfunc)) ModelInit <- NA } psolfunc <- NULL # not yet supported ## If res or func is a character vector, make sure it describes ## a function in a loaded dll if (is.character(res) || is.character(func) || class(res) == "CFunc" || class(func) == "CFunc") { if (is.character(res)){ resname <- res if (is.loaded(resname, PACKAGE = dllname)) { Res <- getNativeSymbolInfo(resname, PACKAGE = dllname)$address } else stop(paste("cannot integrate: res function not loaded",resname)) } else if (class(res) == "CFunc") { Res <- body(res)[[2]] } else if (is.character(func)) { funtype <- 2 resname <- func if (is.loaded(resname, PACKAGE = dllname)) { Res <- getNativeSymbolInfo(resname, PACKAGE = dllname)$address } else stop(paste("cannot integrate: derivs function not loaded",resname)) if (!is.null(mass)) funtype <- 3 } else if (class(func) == "CFunc") { funtype <- 2 Res <- body(func)[[2]] if (!is.null(mass)) funtype <- 3 } # if (is.null(kryltype)) # { if (!is.null(jacres) ) { if (!is.character(jacres) & class(jacres) != "CFunc" ) stop("If 'res' is dynloaded, so must 'jacres' be") jacname <- jacres if (class(jacres) == "CFunc") JacRes <- body(jacres)[[2]] else if (is.loaded(jacname, PACKAGE = dllname)) { JacRes <- getNativeSymbolInfo(jacname, PACKAGE = dllname)$address } else stop(paste("cannot integrate: Jacobian function jacres not loaded ",jacres)) } if (!is.null(psolfunc)) { if (!is.character(psolfunc)& class(psolfunc) != "CFunc" ) stop("If 'res' is dynloaded, so must 'psolfunc' be") if (class(psolfunc) == "CFunc") PsolFunc <- body(psolfunc)[[2]] if (is.loaded(psolfunc, PACKAGE = dllname)) { PsolFunc <- getNativeSymbolInfo(psolfunc, PACKAGE = dllname)$address } else stop(paste("cannot integrate: psolfunc not loaded ",psolfunc)) } # } else if (kryltype =="banded") ### NOT YET IMPLEMENTED # { # lenpd <- (2*banddown + bandup +1) * n # mband <- banddown + bandup +1 # msave <- (n/mband) + 1 # lwp <- lenpd + 2 * msave # lip <- n # if(is.loaded("dbanja",PACKAGE="deSolve")) # JacRes <- getNativeSymbolInfo("dbanja",PACKAGE="deSolve")$address # if(is.loaded("dbanps",PACKAGE="deSolve")) # PsolFunc <- getNativeSymbolInfo("dbanps",PACKAGE="deSolve")$address # ipar <- c(ipar,banddown,bandup) # } else stop(paste("cannot integrate: kryltype not known ",kryltype)) ## If we go this route, the number of "global" results is in nout ## and output variable names are in outnames Nglobal <- nout if (is.null(outnames)) { Nmtot <- NULL} else if (length(outnames) == nout) { Nmtot <- outnames} else if (length(outnames) > nout) Nmtot <- outnames[1:nout] else Nmtot <- c(outnames,(length(outnames)+1):nout) if (is.null(ipar)) ipar<-0 if (is.null(rpar)) rpar<-0 Eventfunc <- events$func if (is.function(Eventfunc)) rho <- environment(Eventfunc) else rho <- NULL } else { if (is.null(initfunc)) initpar <- NULL # parameter initialisation not needed if function is not a DLL ## func or res and jac are overruled, either including ynames, or not ## This allows to pass the "..." arguments and the parameters if (is.null(res) && is.null(mass)) { # res is NOT specified, func is rho <- environment(func) Res <- function(time,y,dy) { if (ynames) attr(y,"names") <- Ynames FF <-func (time,y,parms,...) c(dy-unlist(FF[1]), unlist(FF[-1])) } Res2 <- function(time,y,dy) { if (ynames) attr(y,"names") <- Ynames func (time,y,parms,...) } } else if (is.null(res)) { # func with mass rho <- environment(func) Res <- function(time,y,dy) { if (ynames) attr(y,"names") <- Ynames FF <-func (time,y,parms,...) c(mass %*% dy-unlist(FF[1]), unlist(FF[-1])) } Res2 <- function(time,y,dy) { # just for testing if (ynames) attr(y,"names") <- Ynames func (time,y,parms,...) } } else { # res is specified rho <- environment(res) Res <- function(time,y,dy){ if (ynames) { attr(y,"names") <- Ynames attr(dy,"names") <- dYnames } unlist(res (time,y,dy,parms,...)) } Res2 <- function(time,y,dy) { if(ynames) { attr(y,"names") <- Ynames attr(dy,"names") <- dYnames } res (time,y,dy,parms,...) } } ## the Jacobian if (! is.null(jacfunc)) { # Jacobian associated with func tmp <- eval(jacfunc(times[1], y, parms, ...), rho) if (! is.matrix(tmp)) stop("jacfunc must return a matrix\n") if (is.null(mass)) JacRes <- function(Rin,y,dy) { if(ynames) { attr(y,"names") <- Ynames attr(dy,"names") <- dYnames } JF <- -1* jacfunc(Rin[1],y,parms,...) if (imp %in% c(24,25)) { JF[bandup+1,]<-JF[bandup+1,]+Rin[2] JF <- rbind(erow,JF ) } else JF <-JF + diag(ncol=n,nrow=n,x=Rin[2]) return(JF) } else { if (imp %in% c(24,25)) stop("cannot combine banded jacobian with mass") JacRes <- function(Rin,y,dy) { if(ynames) { attr(y,"names") <- Ynames attr(dy,"names") <- dYnames } JF <- -1* jacfunc(Rin[1],y,parms,...) JF <- JF + Rin[2]*mass return(JF) } } } else if (! is.null(jacres)) { # Jacobian given tmp <- eval(jacres(times[1], y, dy, parms, 1, ...), rho) if (! is.matrix(tmp)) stop("jacres must return a matrix\n") dd <- dim(tmp) if ((imp ==24 && dd != c(bandup+banddown+1,n)) || (imp ==21 && dd != c(n,n))) stop("Jacobian dimension not ok") JacRes <- function(Rin,y,dy) { if (ynames) { attr(y,"names") <- Ynames attr(dy,"names") <- dYnames } rbind(erow,jacres(Rin[1],y,dy,parms,Rin[2],...)) } } else JacRes <- NULL if (! is.null(events$Type)) { if (events$Type == 2) Eventfunc <- function(time,state) { if (ynames) { attr(state,"names") <- Ynames attr(dy,"names") <- dYnames } events$func(time,state,parms,...) } if (events$Type == 2) checkEventFunc(Eventfunc,times,y,rho) } ## Call res once to figure out whether and how many "global" ## results it wants to return and some other safety checks tmp <- eval(Res2(times[1], y, dy), rho) if (!is.list(tmp)) stop("Model function must return a list\n") if (length(tmp[[1]]) != length(y)) stop(paste("The number of derivatives returned by func() (", length(tmp[[1]]), ") must equal the length of the initial conditions vector (", length(y), ")", sep = "")) Nglobal <- if (length(tmp) > 1) length(unlist(tmp[-1])) else 0 ## check for NULL? stop("Problem interpreting model output - check for NULL values") Nmtot <- attr(unlist(tmp[-1]),"names") } # is.character(res) ### work arrays INFO, iwork, rwork ## the INFO vector info <- vector("integer", 25) # Changed to account for the index of variables info[] <- 0 info[20] <- funtype # 1 for a res in DLL, 2 for func in DLL if (length(atol)==n) { if (length(rtol) != n) rtol <- rep(rtol,len=n) } else if (length(rtol)==n) atol <- rep(atol,len=n) info[2] <- length(atol)==n if (is.null(times)) { info[3]<-1 times<-c(0,1e8) } # if (krylov == TRUE) # NOT YET IMPLEMENTED # {if (is.null(kryltype) && is.null(psolfunc)) # stop ("daspk: cannot perform integration: *psolfunc* NOT specified and krylov method chosen..") # if (is.null(kryltype) && ! is.character (psolfunc)) # stop ("daspk: krylov method in R-functions not yet implemented") # if (is.null(kryltype) && is.null(lwp)) stop("daspk: krylov method chosen, but lwp not defined") # if (is.null(kryltype) && is.null(lip)) stop("daspk: krylov method chosen, but lip not defined") # info[12] <- 1 # if (is.null(krylpar )) { # krylpar <- c(min(5,n),min(5,n),5,0.05) # } else { # if (!is.numeric(krylpar)) stop("daspk: krylpar is not numeric") # if (length(krylpar)!=4) stop("daspk: krylpar should contain 4 elements") # if (krylpar[1] <1 || krylpar[1]>n) stop("daspk: krylpar[1] MAXL not valid") # if (krylpar[2] <1 || krylpar[2]>krylpar[1]) stop("daspk: krylpar[2] KMP not valid") # if (krylpar[3] <0 ) stop("daspk: krylpar[3] NRMAX not valid") # if (krylpar[4] <0 || krylpar[4]>1) stop("daspk: krylpar[4] EPLI not valid") # info[13] =1 # } # if (! is.null(JacRes)) info[15] <- 1 # } # info[14], [16], [17], [18] not implemented if (imp %in% c(22,25)) info[5] <- 0 # internal generation Jacobian if (imp %in% c(21,24)) info[5] <- 1 # user-defined generation Jacobian if (imp %in% c(22,21)) info[6] <- 0 # full Jacobian if (imp %in% c(25,24)) info[6] <- 1 # sparse Jacobian info[7] <- hmax != Inf info[8] <- hini != 0 nrowpd <- ifelse(info[6]==0, n, 2*banddown+bandup+1) if (info[5]==1 && is.null(jacfunc) && is.null(jacres)) stop ("daspk: cannot perform integration: *jacfunc* or *jacres* NOT specified; either specify *jacfunc* or *jacres* or change *jactype*") info[9] <- maxord!=5 if (! is.null (estini)) info[11] <- estini # daspk will estimate dy and algebraic equ. if (info[11] > 2 || info[11]< 0 ) stop("daspk: illegal value for estini") # length of rwork and iwork # if (info[12]==0) { lrw <- 50+max(maxord+4,7)*n if (info[6]==0) {lrw <- lrw+ n*n} else { if (info[5]==0) lrw <- lrw+ (2*banddown+bandup+1)*n + 2*(n/(bandup+banddown+1)+1) else lrw <- lrw+ (2*banddown+bandup+1)*n } liw <- 40+n ### index if (length(nind) != 3) stop("length of `nind' must be = 3") if (sum(nind) != n) stop("sum of of `nind' must equal n, the number of equations") info[21:23] <- nind # } else { # maxl <- krylpar[1] # kmp <- krylpar[2] # lrw <- 50+(maxord+5)*n+max(maxl+3+min(1,maxl-kmp))*n + (maxl+3)*maxl+1+lwp # liw <- 40+lip # } if (info[10] %in% c(1,3)) liw <- liw+n if (info[11] ==1) liw <- liw+n if (info[16] ==1) liw <- liw+n if (info[16] ==1) lrw <- lrw+n iwork <- vector("integer",liw) rwork <- vector("double",lrw) if(! is.null(tcrit)) {info[4]<-1;rwork[1] <- tcrit} if(info[6] == 1) {iwork[1]<-banddown; iwork[2]<-bandup} if(info[7] == 1) rwork[2] <- hmax if(info[8] == 1) rwork[3] <- hini if(info[9] == 1) iwork[3] <- maxord # info[10] not implemented if (info[11]>0) { lid <- ifelse(info[10] %in% c(0,2), 40, 40+n) iwork[lid+(1:n) ]<- - 1 iwork[lid+(1:(n-nalg))]<- 1 } # if (info[12]==1) # {iwork[27]<-lwp # iwork[28]<-lip} # if (info[13]==1) # {iwork[24:26]<- krylov[1:3] # rwork[10]<-krylov[4]} # print to screen... # if (verbose) # { # if (info[12] == 0) # {print("uses standard direct method") # }else print("uses Krylov iterative method") # } lags <- checklags(lags,dllname) if (lags$islag == 1) { info[3] = 1 # one step and return maxIt <- maxsteps # maxsteps per iteration... } ### calling solver storage.mode(y) <- storage.mode(dy) <- storage.mode(times) <- "double" storage.mode(rtol) <- storage.mode(atol) <- "double" on.exit(.C("unlock_solver")) out <- .Call("call_daspk", y, dy, times, Res, initpar, rtol, atol,rho, tcrit, JacRes, ModelInit, PsolFunc, as.integer(verbose),as.integer(info), as.integer(iwork),as.double(rwork), as.integer(Nglobal),as.integer(maxIt), as.integer(bandup),as.integer(banddown),as.integer(nrowpd), as.double (rpar), as.integer(ipar), flist, lags, Eventfunc, events, as.double(mass), PACKAGE = "deSolve") ### saving results out [1,1] <- times[1] istate <- attr(out, "istate") istate <- setIstate(istate,iin=c(1,8:9,12:20), iout=c(1,6,5,2:4,13,12,19,9,8,11)) rstate <- attr(out, "rstate") ## ordinary output variables already estimated nm <- c("time", if (!is.null(attr(y, "names"))) names(y) else as.character(1:n)) if (Nglobal > 0) nm <- c(nm, if (!is.null(Nmtot)) Nmtot else as.character((n + 1):(n + Nglobal))) attr(out, "istate") <- istate attr(out, "rstate") <- rstate attr(out, "type") <- "daspk" class(out) <- c("deSolve","matrix") # a differential equation dimnames(out) <- list(nm, NULL) if (verbose) diagnostics(out) t(out) } deSolve/vignettes/0000755000175100001440000000000013131751003013673 5ustar hornikusersdeSolve/vignettes/mymod.f0000754000175100001440000000221212352122166015174 0ustar hornikusersc file mymodf.f subroutine initmod(odeparms) external odeparms double precision parms(3) common /myparms/parms call odeparms(3, parms) return end subroutine derivs (neq, t, y, ydot, yout, ip) double precision t, y, ydot, k1, k2, k3 integer neq, ip(*) dimension y(3), ydot(3), yout(*) common /myparms/k1,k2,k3 if(ip(1) < 1) call rexit("nout should be at least 1") ydot(1) = -k1*y(1) + k2*y(2)*y(3) ydot(3) = k3*y(2)*y(2) ydot(2) = -ydot(1) - ydot(3) yout(1) = y(1) + y(2) + y(3) return end subroutine jac (neq, t, y, ml, mu, pd, nrowpd, yout, ip) integer neq, ml, mu, nrowpd, ip double precision y(*), pd(nrowpd,*), yout(*), t, k1, k2, k3 common /myparms/k1, k2, k3 pd(1,1) = -k1 pd(2,1) = k1 pd(3,1) = 0.0 pd(1,2) = k2*y(3) pd(2,2) = -k2*y(3) - 2*k3*y(2) pd(3,2) = 2*k3*y(2) pd(1,3) = k2*y(2) pd(2,3) = -k2*y(2) pd(3,3) = 0.0 return end c end of file mymodf.f deSolve/vignettes/mymod.c0000754000175100001440000000200112352122166015165 0ustar hornikusers/* file mymod.c */ #include static double parms[3]; #define k1 parms[0] #define k2 parms[1] #define k3 parms[2] /* initializer */ void initmod(void (* odeparms)(int *, double *)) { int N=3; odeparms(&N, parms); } /* Derivatives and 1 output variable */ void derivs (int *neq, double *t, double *y, double *ydot, double *yout, int *ip) { if (ip[0] <1) error("nout should be at least 1"); ydot[0] = -k1*y[0] + k2*y[1]*y[2]; ydot[2] = k3 * y[1]*y[1]; ydot[1] = -ydot[0]-ydot[2]; yout[0] = y[0]+y[1]+y[2]; } /* The Jacobian matrix */ void jac(int *neq, double *t, double *y, int *ml, int *mu, double *pd, int *nrowpd, double *yout, int *ip) { pd[0] = -k1; pd[1] = k1; pd[2] = 0.0; pd[(*nrowpd)] = k2*y[2]; pd[(*nrowpd) + 1] = -k2*y[2] - 2*k3*y[1]; pd[(*nrowpd) + 2] = 2*k3*y[1]; pd[(*nrowpd)*2] = k2*y[1]; pd[2*(*nrowpd) + 1] = -k2 * y[1]; pd[2*(*nrowpd) + 2] = 0.0; } /* END file mymod.c */ deSolve/vignettes/.install_extras0000754000175100001440000000001012627303074016733 0ustar hornikusersmymod.* deSolve/vignettes/compiledCode.Rnw0000754000175100001440000017231712405065301016771 0ustar hornikusers\documentclass[article,nojss]{jss} \DeclareGraphicsExtensions{.pdf,.eps} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Add-on packages and fonts \usepackage{amsmath} \usepackage{xspace} \usepackage{verbatim} \usepackage[english]{babel} %\usepackage{mathptmx} %\usepackage{helvet} \usepackage[T1]{fontenc} \usepackage[latin1]{inputenc} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% User specified LaTeX commands. \newcommand{\Rmodels}{\textbf{\textsf{R models}}\xspace} \newcommand{\DLLmodels}{\textbf{\textsf{DLL models}}\xspace} \title{\proglang{R} Package \pkg{deSolve}, Writing Code in Compiled Languages} \Plaintitle{R Package deSolve, Writing Code in Compiled Languages} \Keywords{differential equation solvers, compiled code, performance, \proglang{FORTRAN}, \proglang{C}} \Plainkeywords{differential equation solvers, compiled code, performance, FORTRAN, C} \author{ Karline Soetaert\\ Royal Netherlands Institute\\ of Sea Research (NIOZ)\\ Yerseke\\ The Netherlands \And Thomas Petzoldt\\ Technische Universit\"at \\ Dresden\\ Germany \And R. Woodrow Setzer\\ National Center for\\ Computational Toxicology\\ US Environmental Protection Agency } \Plainauthor{Karline Soetaert, Thomas Petzoldt, R. Woodrow Setzer} \Abstract{This document describes how to use the \pkg{deSolve} package \citep{deSolve_jss} to solve models that are written in \proglang{FORTRAN} or \proglang{C}.} %% The address of (at least) one author should be given %% in the following format: \Address{ Karline Soetaert\\ Royal Netherlands Institute of Sea Research (NIOZ)\\ 4401 NT Yerseke, Netherlands \\ E-mail: \email{karline.soetaert@nioz.nl}\\ URL: \url{http://www.nioz.nl}\\ \\ Thomas Petzoldt\\ Institut f\"ur Hydrobiologie\\ Technische Universit\"at Dresden\\ 01062 Dresden, Germany\\ E-mail: \email{thomas.petzoldt@tu-dresden.de}\\ URL: \url{http://tu-dresden.de/Members/thomas.petzoldt/}\\ \\ R. Woodrow Setzer\\ National Center for Computational Toxicology\\ US Environmental Protection Agency\\ URL: \url{http://www.epa.gov/comptox} } %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% R/Sweave specific LaTeX commands. %% need no \usepackage{Sweave} %\VignetteIndexEntry{R Package deSolve: Writing Code in Compiled Languages} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Begin of the document \begin{document} \SweaveOpts{engine=R,eps=FALSE} <>= library("deSolve") options(prompt = "R> ") options(width=70) @ \maketitle \section{Introduction} \pkg{deSolve} \citep{deSolve_jss,deSolve}, the successor of \proglang{R} package \pkg{odesolve} \citep{Setzer01} is a package to solve ordinary differential equations (ODE), differential algebraic equations (DAE) and partial differential equations (PDE). One of the prominent features of \pkg{deSolve} is that it allows specifying the differential equations either as: \begin{itemize} \item pure \proglang{R} code \citep{Rcore}, \item functions defined in lower-level languages such as \proglang{FORTRAN}, \proglang{C}, or \proglang{C++}, which are compiled into a dynamically linked library (DLL) and loaded into \proglang{R}. \end{itemize} In what follows, these implementations will be referred to as \Rmodels and \DLLmodels respectively. Whereas \Rmodels are easy to implement, they allow simple interactive development, produce highly readible code and access to \proglang{R}s high-level procedures, \DLLmodels have the benefit of increased simulation speed. Depending on the problem, there may be a gain of up to several orders of magnitude computing time when using compiled code. Here are some rules of thumb when it is worthwhile or not to switch to \DLLmodels: \begin{itemize} \item As long as one makes use only of \proglang{R}s high-level commands, the time gain will be modest. This was demonstrated in \citet{deSolve_jss}, where a formulation of two interacting populations dispersing on a 1-dimensional or a 2-dimensional grid led to a time gain of a factor two only when using \DLLmodels. \item Generally, the more statements in the model, the higher will be the gain of using compiled code. Thus, in the same paper \citep{deSolve_jss}, a very simple, 0-D, Lotka-Volterrra type of model describing only 2 state variables was solved 50 times faster when using compiled code. \item As even \Rmodels are quite performant, the time gain induced by compiled code will often not be discernible when the model is only solved once (who can grasp the difference between a run taking 0.001 or 0.05 seconds to finish). However, if the model is to be applied multiple times, e.g. because the model is to be fitted to data, or its sensitivity is to be tested, then it may be worthwhile to implement the model in a compiled language. \end{itemize} Starting from \pkg{deSolve} version 1.4, it is now also possible to use \emph{forcing functions} in compiled code. These forcing functions are automatically updated by the integrators. See last chapter. \section{A simple ODE example} Assume the following simple ODE (which is from the \code{LSODA} source code): \begin{align*} \frac{{dy_1}}{{dt}} &= - k_1 \cdot y_1 + k_2 \cdot y_2 \cdot y_3 \\ \frac{{dy_2}}{{dt}} &= k_1 \cdot y_1 - k_2 \cdot y_2 \cdot y_3 - k_3 \cdot y_2 \cdot y_2 \\ \frac{{dy_3}}{{dt}} &= k_3 \cdot y_2 \cdot y_2 \\ \end{align*} where $y_1$, $y_2$ and $y_3$ are state variables, and $k_1$, $k_2$ and $k_3$ are parameters. We first implement and run this model in pure \proglang{R}, then show how to do this in \proglang{C} and in \proglang{FORTRAN}. \subsection{ODE model implementation in R} An ODE model implemented in \textbf{pure \proglang{R}} should be defined as: \begin{verbatim} yprime = func(t, y, parms, ...) \end{verbatim} where \code{t} is the current time point in the integration, \code{y} is the current estimate of the variables in the ODE system, and \code{parms} is a vector or list containing the parameter values. The optional dots argument (\code{\dots}) can be used to pass any other arguments to the function. The return value of \code{func} should be a list, whose first element is a vector containing the derivatives of \code{y} with respect to time, and whose next elements contain output variables that are required at each point in time. The \proglang{R} implementation of the simple ODE is given below: <>= model <- function(t, Y, parameters) { with (as.list(parameters),{ dy1 = -k1*Y[1] + k2*Y[2]*Y[3] dy3 = k3*Y[2]*Y[2] dy2 = -dy1 - dy3 list(c(dy1, dy2, dy3)) }) } @ The Jacobian ($\frac{{\partial y'}}{{\partial y}}$) associated to the above example is: <>= jac <- function (t, Y, parameters) { with (as.list(parameters),{ PD[1,1] <- -k1 PD[1,2] <- k2*Y[3] PD[1,3] <- k2*Y[2] PD[2,1] <- k1 PD[2,3] <- -PD[1,3] PD[3,2] <- k3*Y[2] PD[2,2] <- -PD[1,2] - PD[3,2] return(PD) }) } @ This model can then be run as follows: <>= parms <- c(k1 = 0.04, k2 = 1e4, k3=3e7) Y <- c(1.0, 0.0, 0.0) times <- c(0, 0.4*10^(0:11)) PD <- matrix(nrow = 3, ncol = 3, data = 0) out <- ode(Y, times, model, parms = parms, jacfunc = jac) @ \subsection{ODE model implementation in C} \label{sec:Cexamp} In order to create compiled models (.DLL = dynamic link libraries on Windows or .so = shared objects on other systems) you must have a recent version of the GNU compiler suite installed, which is quite standard for Linux. Windows users find all the required tools on \url{http://www.murdoch-sutherland.com/Rtools/}. Getting DLLs produced by other compilers to communicate with R is much more complicated and therefore not recommended. More details can be found on \url{http://cran.r-project.org/doc/manuals/R-admin.html}. The call to the derivative and Jacobian function is more complex for compiled code compared to \proglang{R}-code, because it has to comply with the interface needed by the integrator source codes. Below is an implementation of this model in \proglang{C}: \verbatiminput{mymod.c} The implementation in \proglang{C} consists of three parts: \begin{enumerate} \item After defining the parameters in global \proglang{C}-variables, through the use of \code{\#define} statements, a function called \code{initmod} initialises the parameter values, passed from the \proglang{R}-code. This function has as its sole argument a pointer to \proglang{C}-function \code{odeparms} that fills a double array with double precision values, to copy the parameter values into the global variable. \item Function \code{derivs} then calculates the values of the derivatives. The derivative function is defined as: \begin{verbatim} void derivs (int *neq, double *t, double *y, double *ydot, double *yout, int *ip) \end{verbatim} where \code{*neq} is the number of equations, \code{*t} is the value of the independent variable, \code{*y} points to a double precision array of length \code{*neq} that contains the current value of the state variables, and \code{*ydot} points to an array that will contain the calculated derivatives. \code{*yout} points to a double precision vector whose first \code{nout} values are other output variables (different from the state variables \code{y}), and the next values are double precision values as passed by parameter \code{rpar} when calling the integrator. The key to the elements of \code{*yout} is set in \code{*ip} \code{*ip} points to an integer vector whose length is at least 3; the first element (\code{ip[0]}) contains the number of output values (which should be equal or larger than \code{nout}), its second element contains the length of \code{*yout}, and the third element contains the length of \code{*ip}; next are integer values, as passed by parameter \code{ipar} when calling the integrator.\footnote{Readers familiar with the source code of the \pkg{ODEPACK} solvers may be surprised to find the double precision vector \code{yout} and the integer vector \code{ip} at the end. Indeed none of the \pkg{ODEPACK} functions allow this, although it is standard in the \code{vode} and \code{daspk} codes. To make all integrators compatible, we have altered the \pkg{ODEPACK} \proglang{FORTRAN} codes to consistently pass these vectors.} Note that, in function \code{derivs}, we start by checking whether enough memory is allocated for the output variables (\code{if (ip[0] < 1)}), else an error is passed to \proglang{R} and the integration is stopped. \item In \proglang{C}, the call to the function that generates the Jacobian is as: \begin{verbatim} void jac(int *neq, double *t, double *y, int *ml, int *mu, double *pd, int *nrowpd, double *yout, int *ip) \end{verbatim} where \code{*ml} and \code{*mu} are the number of non-zero bands below and above the diagonal of the Jacobian respectively. These integers are only relevant if the option of a banded Jacobian is selected. \code{*nrow} contains the number of rows of the Jacobian. Only for full Jacobian matrices, is this equal to \code{*neq}. In case the Jacobian is banded, the size of \code{*nrowpd} depends on the integrator. If the method is one of \code{lsode, lsoda, vode}, then \code{*nrowpd} will be equal to \code{*mu + 2 * *ml + 1}, where the last \code{*ml} rows should be filled with $0$s. For \code{radau}, \code{*nrowpd} will be equal to \code{*mu + *ml + 1} See example ``odeband'' in the directory \url{doc/examples/dynload}, and chapter \ref{band}. \end{enumerate} \subsection{ODE model implementation in FORTRAN} \label{sec:forexamp} Models may also be defined in \proglang{FORTRAN}. \verbatiminput{mymod.f} In \proglang{FORTRAN}, parameters may be stored in a common block (here called \code{myparms}). During the initialisation, this common block is defined to consist of a 3-valued vector (unnamed), but in the subroutines \code{derivs} and \code{jac}, the parameters are given a name (\code{k1}, ...). \subsection{Running ODE models implemented in compiled code} To run the models described above, the code in \code{mymod.f} and \code{mymod.c} must first be compiled\footnote{This requires a correctly installed GNU compiler, see above.}. This can simply be done in \proglang{R} itself, using the \code{system} command: <>= system("R CMD SHLIB mymod.f") @ for the \proglang{FORTRAN} code or <>= system("R CMD SHLIB mymod.c") @ for the \proglang{C} code. This will create file \code{mymod.dll} on windows, or \code{mymod.so} on other platforms. We load the DLL, in windows as: \begin{verbatim} dyn.load("mymod.dll") \end{verbatim} and in unix: \begin{verbatim} dyn.load("mymod.so") \end{verbatim} or, using a general statement: \begin{verbatim} dyn.load(paste("mymod", .Platform$dynlib.ext, sep = "")) \end{verbatim} The model can now be run as follows: \begin{verbatim} parms <- c(k1 = 0.04, k2 = 1e4, k3=3e7) Y <- c(y1 = 1.0, y2 = 0.0, y3 = 0.0) times <- c(0, 0.4*10^(0:11) ) out <- ode(Y, times, func = "derivs", parms = parms, jacfunc = "jac", dllname = "mymod", initfunc = "initmod", nout = 1, outnames = "Sum") \end{verbatim} The integration routine (here \code{ode}) recognizes that the model is specified as a DLL due to the fact that arguments \code{func} and \code{jacfunc} are not regular \proglang{R}-functions but character strings. Thus, the integrator will check whether the function is loaded in the DLL with name \code{mymod}. Note that \code{mymod}, as specified by \code{dllname} gives the name of the shared library \emph{without extension}. This DLL should contain all the compiled function or subroutine definitions referred to in \code{func}, \code{jacfunc} and \code{initfunc}. Also, if \code{func} is specified in compiled code, then \code{jacfunc} and \code{initfunc} (if present) should also be specified in a compiled language. It is not allowed to mix \proglang{R}-functions and compiled functions. Note also that, when invoking the integrator, we have to specify the number of ordinary output variables, \code{nout}. This is because the integration routine has to allocate memory to pass these output variables back to \proglang{R}. There is no way to check for the number of output variables in a DLL automatically. If in the calling of the integration routine the number of output variables is too low, then \proglang{R} may freeze and need to be terminated! Therefore it is advised that one checks in the code whether \code{nout} has been specified correctly. In the \proglang{FORTRAN} example above, the statement \code{if (ip(1) < 1) call rexit("nout should be at least 1")} does this. Note that it is not an error (just a waste of memory) to set \code{nout} to a too large value. Finally, in order to label the output matrix, the names of the ordinary output variables have to be passed explicitly (\code{outnames}). This is not necessary for the state variables, as their names are known through their initial condition (\code{y}). \section{Alternative way of passing parameters and data in compiled code} \label{sec:parms} All of the solvers in \pkg{deSolve} take an argument \code{parms} which may be an arbitrary \proglang{R} object. In models defined in \proglang{R} code, this argument is passed unprocessed to the various functions that make up the model. It is possible, as well, to pass such R-objects to models defined in native code. The problem is that data passed to, say, \code{ode} in the argument \code{parms} is not visible by default to the routines that define the model. This is handled by a user-written initialization function, for example \code{initmod} in the \proglang{C} and \proglang{FORTRAN} examples from sections \ref{sec:Cexamp} and \ref{sec:forexamp}. However, these set only the \emph{values} of the parameters. R-objects have many attributes that may also be of interest. To have access to these, we need to do more work, and this mode of passing parameters and data is much more complex than what we saw in previous chapters. In \proglang{C}, the initialization routine is declared: \begin{verbatim} void initmod(void (* odeparms)(int *, double *)); \end{verbatim} That is, \code{initmod} has a single argument, a pointer to a function that has as arguments a pointer to an \texttt{int} and a pointer to a \texttt{double}. In \proglang{FORTRAN}, the initialization routine has a single argument, a subroutine declared to be external. The name of the initialization function is passed as an argument to the \pkg{deSolve} solver functions. In \proglang{C}, two approaches are available for making the values passed in \code{parms} visible to the model routines, while only the simpler approach is available in \proglang{FORTRAN}. The simpler requires that \code{parms} be a numeric vector. In \proglang{C}, the function passed from \pkg{deSolve} to the initialization function (called \code{odeparms} in the example) copies the values from the parameter vector to a static array declared globally in the file where the model is defined. In \proglang{FORTRAN}, the values are copied into a \code{COMMON} block. It is possible to pass more complicated structures to \proglang{C} functions. Here is an example, an initializer called \code{deltamethrin} from a model describing the pharmacokinetics of that pesticide: \begin{verbatim} #include #include #include #include "deltamethrin.h" /* initializer */ void deltamethrin(void(* odeparms)(int *, double *)) { int Nparms; DL_FUNC get_deSolve_gparms; SEXP gparms; get_deSolve_gparms = R_GetCCallable("deSolve","get_deSolve_gparms"); gparms = get_deSolve_gparms(); Nparms = LENGTH(gparms); if (Nparms != N_PARMS) { PROBLEM "Confusion over the length of parms" ERROR; } else { _RDy_deltamethrin_parms = REAL(gparms); } } \end{verbatim} In \texttt{deltamethrin.h}, the variable \code{\_RDy\_deltamethrin\_parms} and macro N\_PARMS are declared: \begin{verbatim} #define N_PARMS 63 static double *_RDy_deltamethrin_parms; \end{verbatim} The critical element of this method is the function \code{R\_GetCCallable} which returns a function (called \code{get\_deSolve\_gparms} in this implementation) that returns the parms argument as a \code{SEXP} data type. In this example, \code{parms} was just a real vector, but in principle, this method can handle arbitrarily complex objects. For more detail on handling \proglang{R} objects in native code, see \proglang{R} Development Core Team (2008). \section{deSolve integrators that support DLL models} In the most recent version of \pkg{deSolve} all integration routines can solve \DLLmodels. They are: \begin{itemize} \item all solvers of the \code{lsode} familiy: \code{lsoda}, \code{lsode}, \code{lsodar}, \code {lsodes}, \item \code{vode}, \code{zvode}, \item \code{daspk}, \item \code{radau}, \item the Runge-Kutta integration routines (including the Euler method). \end{itemize} For some of these solvers the interface is slightly different (e.g. \code{zvode, daspk}), while in others (\code{lsodar}, \code{lsodes}) different functions can be defined. How this is implemented in a compiled language is discussed next. \subsection{Complex numbers, function zvode} \code{zvode} solves ODEs that are composed of complex variables. The program below uses \code{zvode} to solve the following system of 2 ODEs: \begin{align*} \frac{{dz}}{{dt}} &= i \cdot z\\ \frac{{dw}}{{dt}} &= -i \cdot w \cdot w \cdot z\\ \end{align*} where \begin{align*} w(0) = 1/2.1 +0i\\ z(0) = 1i \end{align*} on the interval t = [0, 2 $\pi$] The example is implemented in \proglang{FORTRAN}% \footnote{this can be found in file "zvodedll.f", in the dynload subdirectory of the package}, \code{FEX} implements the function \code{func}: \begin{verbatim} SUBROUTINE FEX (NEQ, T, Y, YDOT, RPAR, IPAR) INTEGER NEQ, IPAR(*) DOUBLE COMPLEX Y(NEQ), YDOT(NEQ), RPAR(*), CMP DOUBLE PRECISION T character(len=100) msg c the imaginary unit i CMP = DCMPLX(0.0D0,1.0D0) YDOT(1) = CMP*Y(1) YDOT(2) = -CMP*Y(2)*Y(2)*Y(1) RETURN END \end{verbatim} \code{JEX} implements the function \code{jacfunc} \begin{verbatim} SUBROUTINE JEX (NEQ, T, Y, ML, MU, PD, NRPD, RPAR, IPAR) INTEGER NEQ, ML, MU, NRPD, IPAR(*) DOUBLE COMPLEX Y(NEQ), PD(NRPD,NEQ), RPAR(*), CMP DOUBLE PRECISION T c the imaginary unit i CMP = DCMPLX(0.0D0,1.0D0) PD(2,3) = -2.0D0*CMP*Y(1)*Y(2) PD(2,1) = -CMP*Y(2)*Y(2) PD(1,1) = CMP RETURN END \end{verbatim} Assuming this code has been compiled and is in a DLL called "zvodedll.dll", this model is solved in R as follows: \begin{verbatim} dyn.load("zvodedll.dll") outF <- zvode(func = "fex", jacfunc = "jex", y = yini, parms = NULL, times = times, atol = 1e-10, rtol = 1e-10, dllname = "zvodedll", initfunc = NULL) \end{verbatim} Note that in \proglang{R} names of \proglang{FORTRAN} DLL functions (e.g. for \code{func} and \code{jacfunc}) have to be given in lowercase letters, even if they are defined upper case in \proglang{FORTRAN}. Also, there is no initialiser function here (\code{initfunc = NULL}). \subsection{DAE models, integrator daspk} \code{daspk} is one of the integrators in the package that solve DAE models. In order to be used with DASPK, DAEs are specified in implicit form: \[0 = F(t, y, y', p)\] i.e. the DAE function (passed via argument \code{res}) specifies the ``residuals'' rather than the derivatives (as for ODEs). Consequently the DAE function specification in a compiled language is also different. For code written in \proglang{C}, the calling sequence for \code{res} must be: \begin{verbatim} void myres(double *t, double *y, double *ydot, double *cj, double *delta, int *ires, double *yout, int *ip) \end{verbatim} where \code{*t} is the value of the independent variable, \code{*y} points to a double precision vector that contains the current value of the state variables, \code{*ydot} points to an array that will contain the derivatives, \code{*delta} points to a vector that will contain the calculated residuals. \code{*cj} points to a scalar, which is normally proportional to the inverse of the stepsize, while \code{*ires} points to an integer (not used). \code{*yout} points to any other output variables (different from the state variables y), followed by the double precision values as passed via argument \code{rpar}; finally \code{*ip} is an integer vector containing at least 3 elements, its first value (\code{*ip[0]}) equals the number of output variables, calculated in the function (and which should be equal to \code{nout}), its second element equals the total length of \code{*yout}, its third element equals the total length of \code{*ip}, and finally come the integer values as passed via argument \code{ipar}. For code written in \proglang{FORTRAN}, the calling sequence for \code{res} must be as in the following example: \begin{verbatim} subroutine myresf(t, y, ydot, cj, delta, ires, out, ip) integer :: ires, ip(*) integer, parameter :: neq = 3 double precision :: t, y(neq), ydot(neq), delta(neq), out(*) double precision :: K, ka, r, prod, ra, rb common /myparms/K,ka,r,prod if(ip(1) < 1) call rexit("nout should be at least 1") ra = ka* y(3) rb = ka/K *y(1) * y(2) !! residuals of rates of changes delta(3) = -ydot(3) - ra + rb + prod delta(1) = -ydot(1) + ra - rb delta(2) = -ydot(2) + ra - rb - r*y(2) out(1) = y(1) + y(2) + y(3) return end \end{verbatim} Similarly as for the ODE model discussed above, the parameters are kept in a common block which is initialised by an initialiser subroutine: \begin{verbatim} subroutine initpar(daspkparms) external daspkparms integer, parameter :: N = 4 double precision parms(N) common /myparms/parms call daspkparms(N, parms) return end \end{verbatim} See the ODE example for how to initialise parameter values in \proglang{C}. Similarly, the function that specifies the Jacobian in a DAE differs from the Jacobian when the model is an ODE. The DAE Jacobian is set with argument \code{jacres} rather than \code{jacfunc} when an ODE. For code written in \proglang{FORTRAN}, the \code{jacres} must be as: \begin{verbatim} subroutine resjacfor (t, y, dy, pd, cj, out, ipar) integer, parameter :: neq = 3 integer :: ipar(*) double precision :: K, ka, r, prod double precision :: pd(neq,neq),y(neq),dy(neq),out(*) common /myparms/K,ka,r,prod !res1 = -dD - ka*D + ka/K *A*B + prod PD(1,1) = ka/K *y(2) PD(1,2) = ka/K *y(1) PD(1,3) = -ka -cj !res2 = -dA + ka*D - ka/K *A*B PD(2,1) = -ka/K *y(2) -cj PD(2,2) = -ka/K *y(2) PD(2,3) = ka !res3 = -dB + ka*D - ka/K *A*B - r*B PD(3,1) = -ka/K *y(2) PD(3,2) = -ka/K *y(2) -r -cj PD(3,3) = ka return end \end{verbatim} \subsection{DAE models, integrator radau} Function \code{radau} solves DAEs in linearly implicit form, i.e. in the form $M y' = f(t, y, p)$. The derivative function $f$ is specified in the same way as for an ODE, i.e. \begin{verbatim} void derivs (int *neq, double *t, double *y, double *ydot, double *yout, int *ip) \end{verbatim} and \begin{verbatim} subroutine derivs (neq, t, y, ydot, out, IP) \end{verbatim} for \proglang{C} and \proglang{FORTRAN} code respectively. To show how it should be used, we implement the caraxis problem as in \citep{testset}. The implementation of this index 3 DAE, comprising 8 differential, and 2 algebraic equations in R is the last example of the \code{radau} help page. We first repeat the R implementation: <<>>= caraxisfun <- function(t, y, parms) { with(as.list(c(y, parms)), { yb <- r * sin(w * t) xb <- sqrt(L * L - yb * yb) Ll <- sqrt(xl^2 + yl^2) Lr <- sqrt((xr - xb)^2 + (yr - yb)^2) dxl <- ul; dyl <- vl; dxr <- ur; dyr <- vr dul <- (L0-Ll) * xl/Ll + 2 * lam2 * (xl-xr) + lam1*xb dvl <- (L0-Ll) * yl/Ll + 2 * lam2 * (yl-yr) + lam1*yb - k * g dur <- (L0-Lr) * (xr-xb)/Lr - 2 * lam2 * (xl-xr) dvr <- (L0-Lr) * (yr-yb)/Lr - 2 * lam2 * (yl-yr) - k * g c1 <- xb * xl + yb * yl c2 <- (xl - xr)^2 + (yl - yr)^2 - L * L list(c(dxl, dyl, dxr, dyr, dul, dvl, dur, dvr, c1, c2)) }) } eps <- 0.01; M <- 10; k <- M * eps^2/2; L <- 1; L0 <- 0.5; r <- 0.1; w <- 10; g <- 1 parameter <- c(eps = eps, M = M, k = k, L = L, L0 = L0, r = r, w = w, g = g) yini <- c(xl = 0, yl = L0, xr = L, yr = L0, ul = -L0/L, vl = 0, ur = -L0/L, vr = 0, lam1 = 0, lam2 = 0) # the mass matrix Mass <- diag(nrow = 10, 1) Mass[5,5] <- Mass[6,6] <- Mass[7,7] <- Mass[8,8] <- M * eps * eps/2 Mass[9,9] <- Mass[10,10] <- 0 Mass # index of the variables: 4 of index 1, 4 of index 2, 2 of index 3 index <- c(4, 4, 2) times <- seq(0, 3, by = 0.01) out <- radau(y = yini, mass = Mass, times = times, func = caraxisfun, parms = parameter, nind = index) @ <>= plot(out, which = 1:4, type = "l", lwd = 2) @ \setkeys{Gin}{width=0.8\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{Solution of the caraxis model - see text for R-code} \label{fig:caraxis} \end{figure} The implementation in \proglang{FORTRAN} consists of an initialiser function and a derivative function. \begin{verbatim} c---------------------------------------------------------------- c Initialiser for parameter common block c---------------------------------------------------------------- subroutine initcaraxis(daeparms) external daeparms integer, parameter :: N = 8 double precision parms(N) common /myparms/parms call daeparms(N, parms) return end c---------------------------------------------------------------- c rate of change c---------------------------------------------------------------- subroutine caraxis(neq, t, y, ydot, out, ip) implicit none integer neq, IP(*) double precision t, y(neq), ydot(neq), out(*) double precision eps, M, k, L, L0, r, w, g common /myparms/ eps, M, k, L, L0, r, w, g double precision xl, yl, xr, yr, ul, vl, ur, vr, lam1, lam2 double precision yb, xb, Ll, Lr, dxl, dyl, dxr, dyr double precision dul, dvl, dur, dvr, c1, c2 c expand state variables xl = y(1) yl = y(2) xr = y(3) yr = y(4) ul = y(5) vl = y(6) ur = y(7) vr = y(8) lam1 = y(9) lam2 = y(10) yb = r * sin(w * t) xb = sqrt(L * L - yb * yb) Ll = sqrt(xl**2 + yl**2) Lr = sqrt((xr - xb)**2 + (yr - yb)**2) dxl = ul dyl = vl dxr = ur dyr = vr dul = (L0-Ll) * xl/Ll + 2 * lam2 * (xl-xr) + lam1*xb dvl = (L0-Ll) * yl/Ll + 2 * lam2 * (yl-yr) + lam1*yb - k*g dur = (L0-Lr) * (xr-xb)/Lr - 2 * lam2 * (xl-xr) dvr = (L0-Lr) * (yr-yb)/Lr - 2 * lam2 * (yl-yr) - k*g c1 = xb * xl + yb * yl c2 = (xl - xr)**2 + (yl - yr)**2 - L * L c function values in ydot ydot(1) = dxl ydot(2) = dyl ydot(3) = dxr ydot(4) = dyr ydot(5) = dul ydot(6) = dvl ydot(7) = dur ydot(8) = dvr ydot(9) = c1 ydot(10) = c2 return end \end{verbatim} Assuming that the code is in file ``radaudae.f'', this model is compiled, loaded and solved in R as: \begin{verbatim} system("R CMD SHLIB radaudae.f") dyn.load(paste("radaudae", .Platform$dynlib.ext, sep = "")) outDLL <- radau(y = yini, mass = Mass, times = times, func = "caraxis", initfunc = "initcaraxis", parms = parameter, dllname = "radaudae", nind = index) dyn.unload(paste("radaudae", .Platform$dynlib.ext, sep = "")) \end{verbatim} \subsection{The root function from integrators lsodar and lsode} \code{lsodar} is an extended version of integrator \code{lsoda} that includes a root finding function. This function is spedified via argument \code{rootfunc}. In \code{deSolve} version 1.7, \code{lsode} has also been extended with root finding capabilities. Here is how to program such a function in a lower-level language. For code written in \proglang{C}, the calling sequence for \code{rootfunc} must be: \begin{verbatim} void myroot(int *neq, double *t, double *y, int *ng, double *gout, double *out, int *ip ) \end{verbatim} where \code{*neq} and \code{*ng} are the number of state variables and root functions respectively, \code{*t} is the value of the independent variable, \code{y} points to a double precision array that contains the current value of the state variables, and \code{gout} points to an array that will contain the values of the constraint function whose root is sought. \code{*out} and \code{*ip} are a double precision and integer vector respectively, as described in the ODE example above. For code written in \proglang{FORTRAN}, the calling sequence for \code{rootfunc} must be as in following example: \begin{verbatim} subroutine myroot(neq, t, y, ng, gout, out, ip) integer :: neq, ng, ip(*) double precision :: t, y(neq), gout(ng), out(*) gout(1) = y(1) - 1.e-4 gout(2) = y(3) - 1e-2 return end \end{verbatim} \subsection{jacvec, the Jacobian vector for integrator lsodes} Finally, in integration function \code{lsodes}, not the Jacobian \emph{matrix} is specified, but a \emph{vector}, one for each column of the Jacobian. This function is specified via argument \code{jacvec}. In \proglang{FORTRAN}, the calling sequence for \code{jacvec} is: \begin{verbatim} SUBROUTINE JAC (NEQ, T, Y, J, IAN, JAN, PDJ, OUT, IP) DOUBLE PRECISION T, Y(*), IAN(*), JAN(*), PDJ(*), OUT(*) INTEGER NEQ, J, IP(*) \end{verbatim} \subsection{Banded jacobians in compiled code}\label{band} In the call of the jacobian function, the number of bands below and above the diagonal (\code{ml, mu}) and the number of rows of the Jacobian matrix, \code{nrowPD} is specified, e.g. for \proglang{FORTRAN} code: \begin{verbatim} SUBROUTINE JAC (neq, T, Y, ml, mu, PD, nrowPD, RPAR, IPAR) \end{verbatim} The jacobian matrix to be returned should have dimension \code{nrowPD, neq}. In case the Jacobian is banded, the size of \code{nrowPD} depends on the integrator. If the method is one of \code{lsode, lsoda, vode}, or related, then \code{nrowPD} will be equal to \code{mu + 2 * ml + 1}, where the last ml rows should be filled with $0$s. For \code{radau}, \code{nrowpd} will be equal to \code{mu + ml + 1} Thus, it is important to write the FORTRAN or C-code in such a way that it can be used with both types of integrators - else it is likely that R will freeze if the wrong integrator is used. We implement in FORTRAN, the example of the \code{lsode} help file. The R-code reads: <<>>= ## the model, 5 state variables f1 <- function (t, y, parms) { ydot <- vector(len = 5) ydot[1] <- 0.1*y[1] -0.2*y[2] ydot[2] <- -0.3*y[1] +0.1*y[2] -0.2*y[3] ydot[3] <- -0.3*y[2] +0.1*y[3] -0.2*y[4] ydot[4] <- -0.3*y[3] +0.1*y[4] -0.2*y[5] ydot[5] <- -0.3*y[4] +0.1*y[5] return(list(ydot)) } ## the Jacobian, written in banded form bandjac <- function (t, y, parms) { jac <- matrix(nrow = 3, ncol = 5, byrow = TRUE, data = c( 0 , -0.2, -0.2, -0.2, -0.2, 0.1, 0.1, 0.1, 0.1, 0.1, -0.3, -0.3, -0.3, -0.3, 0)) return(jac) } ## initial conditions and output times yini <- 1:5 times <- 1:20 ## stiff method, user-generated banded Jacobian out <- lsode(yini, times, f1, parms = 0, jactype = "bandusr", jacfunc = bandjac, bandup = 1, banddown = 1) @ In FORTRAN, the code might look like this: \begin{verbatim} c Rate of change subroutine derivsband (neq, t, y, ydot,out,IP) integer neq, IP(*) DOUBLE PRECISION T, Y(5), YDOT(5), out(*) ydot(1) = 0.1*y(1) -0.2*y(2) ydot(2) = -0.3*y(1) +0.1*y(2) -0.2*y(3) ydot(3) = -0.3*y(2) +0.1*y(3) -0.2*y(4) ydot(4) = -0.3*y(3) +0.1*y(4) -0.2*y(5) ydot(5) = -0.3*y(4) +0.1*y(5) RETURN END c The banded jacobian subroutine jacband (neq, t, y, ml, mu, pd, nrowpd, RP, IP) INTEGER neq, ml, mu, nrowpd, ip(*) DOUBLE PRECISION T, Y(5), PD(nrowpd,5), rp(*) PD(:,:) = 0.D0 PD(1,1) = 0.D0 PD(1,2) = -.02D0 PD(1,3) = -.02D0 PD(1,4) = -.02D0 PD(1,5) = -.02D0 PD(2,:) = 0.1D0 PD(3,1) = -0.3D0 PD(3,2) = -0.3D0 PD(3,3) = -0.3D0 PD(3,4) = -0.3D0 PD(3,5) = 0.D0 RETURN END \end{verbatim} Assuming that this code is in file \code{"odeband.f"}, we compile from within R and load the shared library (assuming the working directory holds the source file) with: \begin{verbatim} system("R CMD SHLIB odeband.f") dyn.load(paste("odeband", .Platform$dynlib.ext, sep = "")) \end{verbatim} To solve this problem, we write in R \begin{verbatim} out2 <- lsode(yini, times, "derivsband", parms = 0, jactype = "bandusr", jacfunc = "jacband", bandup = 1, banddown = 1, dllname = "odeband") out2 <- radau(yini, times, "derivsband", parms = 0, jactype = "bandusr", jacfunc = "jacband", bandup = 1, banddown = 1, dllname = "odeband") \end{verbatim} This will work both for the \code{lsode} family as for \code{radau}. In the first case, when entering subroutine \code{jacband}, \code{nrowpd} will have the value $5$, in the second case, it will be equal to $4$. \section{Testing functions written in compiled code} Two utilities have been included to test the function implementation in compiled code: \begin{itemize} \item \code{DLLfunc} to test the implementation of the derivative function as used in ODEs. This function returns the derivative $\frac{dy}{dt}$ and the output variables. \item \code{DLLres} to test the implementation of the residual function as used in DAEs. This function returns the residual function $\frac{dy}{dt}-f(y,t)$ and the output variables. \end{itemize} These functions serve no other purpose than to test whether the compiled code returns what it should. \subsection{DLLfunc} We test whether the ccl4 model, which is part of \code{deSolve} package, returns the proper rates of changes. (Note: see \code{example(ccl4model)} for a more comprehensive implementation) <<>>= ## Parameter values and initial conditions Parms <- c(0.182, 4.0, 4.0, 0.08, 0.04, 0.74, 0.05, 0.15, 0.32, 16.17, 281.48, 13.3, 16.17, 5.487, 153.8, 0.04321671, 0.4027255, 1000, 0.02, 1.0, 3.8) yini <- c( AI=21, AAM=0, AT=0, AF=0, AL=0, CLT=0, AM=0 ) ## the rate of change DLLfunc(y = yini, dllname = "deSolve", func = "derivsccl4", initfunc = "initccl4", parms = Parms, times = 1, nout = 3, outnames = c("DOSE", "MASS", "CP") ) @ \subsection{DLLres} The deSolve package contains a FORTRAN implementation of the chemical model described above (section 4.1), where the production rate is included as a forcing function (see next section). Here we use \code{DLLres} to test it: <<>>= pars <- c(K = 1, ka = 1e6, r = 1) ## Initial conc; D is in equilibrium with A,B y <- c(A = 2, B = 3, D = 2*3/pars["K"]) ## Initial rate of change dy <- c(dA = 0, dB = 0, dD = 0) ## production increases with time prod <- matrix(nc=2,data=c(seq(0,100,by=10),seq(0.1,0.5,len=11))) DLLres(y=y,dy=dy,times=5,res="chemres", dllname="deSolve", initfunc="initparms", initforc="initforcs", parms=pars, forcings=prod, nout=2, outnames=c("CONC","Prod")) @ \section{Using forcing functions} Forcing functions in DLLs are implemented in a similar way as parameters. This means: \begin{itemize} \item They are initialised by means of an initialiser function. Its name should be passed to the solver via argument \code{initforc}. Similar as the parameter initialiser function, the function denoted by \code{initforc} has as its sole argument a pointer to the vector that contains the forcing funcion values in the compiled code. In case of \proglang{C} code, this will be a global vector; in case of \proglang{FORTRAN}, this will be a vector in a common block. The solver puts a pointer to this vector and updates the forcing functions in this memory area at each time step. Hence, within the compiled code, forcing functions can be assessed as if they are parameters (although, in contrast to the latter, their values will generally change). No need to update the values for the current time step; this has been done before entering the \code{derivs} function. \item The forcing function data series are passed to the integrator, via argument \code{forcings}; if there is only one forcing function data set, then a 2-columned matrix (time, value) will do; else the data should be passed as a list, containing (time, value) matrices with the individual forcing function data sets. Note that the data sets in this list should be \emph{in the same ordering} as the declaration of the forcings in the compiled code. \end{itemize} A number of options allow to finetune certain settings. They are in a list called \code{fcontrol} which can be supplied as argument when calling the solvers. The options are similar to the arguments from R function \code{approx}, howevers the default settings are often different. The following options can be specified: \begin{itemize} \item \code{method} specifies the interpolation method to be used. Choices are "linear" or "constant", the default is "linear", which means linear interpolation (same as \code{approx}) \item \code{rule}, an integer describing how interpolation is to take place \emph{outside} the interval [min(times), max(times)]. If \code{rule} is \code{1} then an error will be triggered and the calculation will stop if extrapolation is necessary. If it is \code{2}, the default, the value at the closest data extreme is used, a warning will be printed if \code{verbose} is TRUE. Note that the default differs from the \code{approx} default. \item \code{f}, for method=\code{"constant"} is a number between \code{0} and \code{1} inclusive, indicating a compromise between left- and right-continuous step functions. If \code{y0} and \code{y1} are the values to the left and right of the point then the value is \code{y0*(1-f)+y1*f} so that \code{f=0} is right-continuous and \code{f=1} is left-continuous. The default is to have \code{f=0}. For some data sets it may be more realistic to set \code{f=0.5}. \item \code{ties}, the handling of tied \code{times} values. Either a function with a single vector argument returning a single number result or the string "ordered". Note that the default is "ordered", hence the existence of ties will NOT be investigated; in practice this means that, if ties exist, the first value will be used; if the dataset is not ordered, then nonsense will be produced. Alternative values for \code{ties} are \code{mean}, \code{min} etc... which will average, or take the minimal value if multiple values exist at one time level. \end{itemize} The default settings of \code{fcontrol} are: \code{fcontrol=list(method="linear", rule = 2, f = 0, ties = "ordered")} Note that only ONE specification is allowed, even if there is more than one forcing function data set. (may/should change in the future). \subsection{A simple FORTRAN example} We implement the example from chapter 3 of the book \citep{Soetaert08} in FORTRAN. This model describes the oxygen consumption of a (marine) sediment in response to deposition of organic matter (the forcing function). One state variable, the organic matter content in the sediment is modeled; it changes as a function of the deposition \code{Flux} (forcing) and organic matter decay (first-order decay rate \code{k}). \[ \frac{dC}{dt}=Flux_t-k \cdot C \] with initial condition $C(t=0)=C_0$; the latter is estimated as the mean of the flux divided by the decay rate. The FORTRAN code looks like this: \begin{verbatim} c Initialiser for parameter common block subroutine scocpar(odeparms) external odeparms integer N double precision parms(2) common /myparms/parms N = 1 call odeparms(N, parms) return end c Initialiser for forcing common block subroutine scocforc(odeforcs) external odeforcs integer N double precision forcs(1) common /myforcs/forcs N = 1 call odeforcs(N, forcs) return end c Rate of change and output variables subroutine scocder (neq, t, y, ydot,out,IP) integer neq, IP(*) double precision t, y(neq), ydot(neq), out(*), k, depo common /myparms/k common /myforcs/depo if(IP(1) < 2) call rexit("nout should be at least 2") ydot(1) = -k*y(1) + depo out(1)= k*y(1) out(2)= depo return end \end{verbatim} Here the subroutine \code{scocpar} is business as usual; it initialises the parameter common block (there is only one parameter). Subroutine \code{odeforcs} does the same for the forcing function, which is also positioned in a common block, called \code{myforcs}. This common block is made available in the derivative subroutine (here called \code{scocder}), where the forcing function is named \code{depo}. At each time step, the integrator updates the value of this forcing function to the correct time point. In this way, the forcing functions can be used as if they are (time-varying) parameters. All that's left to do is to pass the forcing function data set and the name of the forcing function initialiser routine. This is how to do it in R. First the data are inputted: <<>>= Flux <- matrix(ncol=2,byrow=TRUE,data=c( 1, 0.654, 11, 0.167, 21, 0.060, 41, 0.070, 73,0.277, 83,0.186, 93,0.140,103, 0.255, 113, 0.231,123, 0.309,133,1.127,143,1.923, 153,1.091,163,1.001, 173, 1.691,183, 1.404,194,1.226,204,0.767, 214, 0.893,224,0.737, 234,0.772,244, 0.726,254,0.624,264,0.439, 274,0.168,284 ,0.280, 294,0.202,304, 0.193,315,0.286,325,0.599, 335, 1.889,345, 0.996,355,0.681,365,1.135)) head(Flux) @ and the parameter given a value (there is only one) <<>>= parms <- 0.01 @ The initial condition \code{Yini} is estimated as the annual mean of the Flux and divided by the decay rate (parameter). <<>>= meanDepo <- mean(approx(Flux[,1],Flux[,2], xout=seq(1,365,by=1))$y) Yini <- c(y=meanDepo/parms) @ After defining the output times, the model is run, using integration routine \code{ode}. The \emph{name} of the derivate function \code{"scocder"}, of the dll \code{"deSolve"}\footnote{this example is made part of the deSolve package, hence the name of the dll is "deSolve"} and of the initialiser function \code{"scocpar"} are passed, as in previous examples. In addition, the forcing function data set is also passed (\code{forcings=Flux}) as is the name of the forcing initialisation function (\code{initforc="scocforc"}). <<>>= times <- 1:365 out <- ode(y=Yini, times, func = "scocder", parms = parms, dllname = "deSolve", initforc="scocforc", forcings=Flux, initfunc = "scocpar", nout = 2, outnames = c("Mineralisation","Depo")) head(out) @ Now, the way the forcing functions are interpolated are changed: Rather than linear interpolation, constant (block, step) interpolation is used. <<>>= fcontrol <- list(method="constant") out2 <- ode(y=Yini, times, func = "scocder", parms = parms, dllname = "deSolve", initforc="scocforc", forcings=Flux, fcontrol=fcontrol, initfunc = "scocpar", nout = 2, outnames = c("Mineralisation","Depo")) @ Finally, the results are plotted: <>= par (mfrow=c(1,2)) plot(out, which = "Depo", col="red", xlab="days", ylab="mmol C/m2/ d", main="method='linear'") lines(out[,"time"], out[,"Mineralisation"], lwd=2, col="blue") legend("topleft",lwd=1:2,col=c("red","blue"), c("Flux","Mineralisation")) plot(out, which = "Depo", col="red", xlab="days", ylab="mmol C/m2/ d", main="method='constant'") lines(out2[,"time"], out2[,"Mineralisation"], lwd=2, col="blue") @ \setkeys{Gin}{width=0.8\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{Solution of the SCOC model, implemented in compiled code, and including a forcing function - see text for R-code} \label{fig:scoc} \end{figure} \subsection{An example in C} Consider the following R-code which implements a resource-producer-consumer Lotka-Volterra type of model in R (it is a modified version of the example of function \code{ode}): <<>>= SPCmod <- function(t, x, parms, input) { with(as.list(c(parms, x)), { import <- input(t) dS <- import - b*S*P + g*C # substrate dP <- c*S*P - d*C*P # producer dC <- e*P*C - f*C # consumer res <- c(dS, dP, dC) list(res, signal = import) }) } ## The parameters parms <- c(b = 0.1, c = 0.1, d = 0.1, e = 0.1, f = 0.1, g = 0.0) ## vector of timesteps times <- seq(0, 100, by=0.1) ## external signal with several rectangle impulses signal <- as.data.frame(list(times = times, import = rep(0, length(times)))) signal$import <- ifelse((trunc(signal$times) %% 2 == 0), 0, 1) sigimp <- approxfun(signal$times, signal$import, rule = 2) ## Start values for steady state xstart <- c(S = 1, P = 1, C = 1) ## Solve model print (system.time( out <- ode(y = xstart,times = times, func = SPCmod, parms, input = sigimp) )) @ All output is printed at once: <>= plot(out) @ \setkeys{Gin}{width=1.0\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{Solution of the Lotka-Volterra resource (S)-producer (P) - consumer (C) model with time-variable input (signal) - see text for R-code} \label{fig:lv} \end{figure} The C-code, in file \url{Forcing\_lv.c}, can be found in the packages \url{/doc/examples/dynload} subdirectory\footnote{this can be opened by typing \code{browseURL(paste(system.file(package = "deSolve"), "/doc/examples/dynload", sep = ""))}}. It can be compiled, from within R by \begin{verbatim} system("R CMD SHLIB Forcing_lv.c") \end{verbatim} After defining the parameter and forcing vectors, and giving them comprehensible names, the parameter and forcing initialiser functions are defined (\code{parmsc} and \code{forcc} respectively). Next is the derivative function, \code{derivsc}. \begin{verbatim} #include static double parms[6]; static double forc[1]; /* A trick to keep up with the parameters and forcings */ #define b parms[0] #define c parms[1] #define d parms[2] #define e parms[3] #define f parms[4] #define g parms[5] #define import forc[0] /* initializers: */ void odec(void (* odeparms)(int *, double *)) { int N=6; odeparms(&N, parms); } void forcc(void (* odeforcs)(int *, double *)) { int N=1; odeforcs(&N, forc); } /* derivative function */ void derivsc(int *neq, double *t, double *y, double *ydot, double *yout, int*ip) { if (ip[0] <2) error("nout should be at least 2"); ydot[0] = import - b*y[0]*y[1] + g*y[2]; ydot[1] = c*y[0]*y[1] - d*y[2]*y[1]; ydot[2] = e*y[1]*y[2] - f*y[2]; yout[0] = y[0] + y[1] + y[2]; yout[1] = import; } \end{verbatim} After defining the forcing function time series, which is to be interpolated by the integration routine, and loading the DLL, the model is run: \begin{verbatim} Sigimp <- approx(signal$times, signal$import, xout=ftime,rule = 2)$y forcings <- cbind(ftime,Sigimp) dyn.load("Forcing_lv.dll") out <- ode(y=xstart, times, func = "derivsc", parms = parms, dllname = "Forcing_lv",initforc = "forcc", forcings=forcings, initfunc = "parmsc", nout = 2, outnames = c("Sum","signal"), method = rkMethod("rk34f")) dyn.unload("Forcing_lv.dll") \end{verbatim} This code executes about 30 times faster than the \proglang{R}-code. With a longer simulation time, the difference becomes more pronounced, e.g. with times till 800 days, the DLL code executes 200 times faster% \footnote{this is due to the sequential update of the forcing functions by the solvers, compared to the bisectioning approach used by approxfun}. \section{Implementing events in compiled code} An \code{event} occurs when the value of a state variable is suddenly changed, e.g. a certain amount is added, or part is removed. The integration routines cannot deal easily with such state variable changes. Typically these events occur only at specific times. In \code{deSolve}, events can be imposed by means of an input file that specifies at which time a certain state variable is altered, or via an event function. Both types of events combine with compiled code. Take the previous example, the Lotka-Volterra SPC model. Suppose that every 10 days, half of the consumer is removed. We first implement these events as a \code{data.frame} <<>>= eventdata <- data.frame(var=rep("C",10),time=seq(10,100,10),value=rep(0.5,10), method=rep("multiply",10)) eventdata @ This model is solved, and plotted as: \begin{verbatim} dyn.load("Forcing_lv.dll") out2 <- ode(y = y, times, func = "derivsc", parms = parms, dllname = "Forcing_lv", initforc="forcc", forcings = forcings, initfunc = "parmsc", nout = 2, outnames = c("Sum", "signal"), events=list(data=eventdata)) dyn.unload("Forcing_lv.dll") plot(out2, which = c("S","P","C"), type = "l") \end{verbatim} The event can also be implemented in \proglang{C} as: \begin{verbatim} void event(int *n, double *t, double *y) { y[2] = y[2]*0.5; } \end{verbatim} Here n is the length of the state variable vector \code{y}. and is then solved as: \begin{verbatim} dyn.load("Forcing_lv.dll") out3 <- ode(y = y, times, func = "derivsc", parms = parms, dllname = "Forcing_lv", initforc="forcc", forcings = forcings, initfunc = "parmsc", nout = 2, outnames = c("Sum", "signal"), events = list(func="event",time=seq(10,90,10))) dyn.unload("Forcing_lv.dll") \end{verbatim} \setkeys{Gin}{width=1.0\textwidth} \begin{figure} \begin{center} \includegraphics{comp-event} \end{center} \caption{Solution of the Lotka-Volterra resource (S)~-- producer (P)~-- consumer (C) model with time-variable input (signal) and with half of the consumer removed every 10 days - see text for R-code} \label{fig:lv2} \end{figure} \section{Delay differential equations} It is now also very simple to implement delay differential equations in compiled code and solve them with \code{dede}. In order to do so, you need to get access to the R-functions \code{lagvalue} and \code{lagderiv} that will give you the past value of the state variable or its derivative respectively. \subsection{Delays implemented in Fortran} If you use \proglang{Fortran}, then the easiest way is to link your code with a file called \code{dedeUtils.c} that you will find in the packages subdirectory \code{inst/doc/dynload-dede}. This file contains Fortran-callable interfaces to the delay-differential utility functions from package \pkg{deSolve}, and that are written in \proglang{C}. Its content is: \begin{verbatim} void F77_SUB(lagvalue)(double *T, int *nr, int *N, double *ytau) { static void(*fun)(double, int*, int, double*) = NULL; if (fun == NULL) fun = (void(*)(double, int*, int, double*))R_GetCCallable("deSolve", "lagvalue"); fun(*T, nr, *N, ytau); return; } void F77_SUB(lagderiv)(double *T, int *nr, int *N, double *ytau) { static void(*fun)(double, int*, int, double*) = NULL; if (fun == NULL) fun = (void(*)(double, int*, int, double*))R_GetCCallable("deSolve", "lagderiv"); fun(*T, nr, *N, ytau); return; } \end{verbatim} Here \code{T} is the time at which the value needs to be retrieved, \code{nr} is an integer that defines the number of the state variable or its derivative whose delay we want, \code{N} is the total number of state variabes and \code{ytau} will have the result. We start with an example, a Lotka-Volterra system with delay, that we will implement in \proglang{Fortran} (you will find this example in the package directory \code{inst/doc/dynload-dede}, in file \code{dede_lvF.f} The R-code would be: <<>>= derivs <- function(t, y, parms) { with(as.list(c(y, parms)), { if (t < tau) ytau <- c(1, 1) else ytau <- lagvalue(t - tau, c(1, 2)) dN <- f * N - g * N * P dP <- e * g * ytau[1] * ytau[2] - m * P list(c(dN, dP), tau=ytau[1], tau=ytau[2]) }) } yinit <- c(N = 1, P = 1) times <- seq(0, 500) parms <- c(f = 0.1, g = 0.2, e = 0.1, m = 0.1, tau = .2) yout <- dede(y = yinit, times = times, func = derivs, parms = parms) head(yout) @ In Fortran the code looks like this: \begin{verbatim} ! file dede_lfF.f ! Initializer for parameter common block subroutine initmod(odeparms) external odeparms double precision parms(5) common /myparms/parms call odeparms(5, parms) return end ! Derivatives and one output variable subroutine derivs(neq, t, y, ydot, yout, ip) integer neq, ip(*) double precision t, y(neq), ydot(neq), yout(*) double precision N, P, ytau(2), tlag integer nr(2) double precision f, g, e, m, tau common /myparms/f, g, e, m, tau if (ip(1) < 2) call rexit("nout should be at least 2") N = y(1) P = y(2) nr(1) = 0 nr(2) = 1 ytau(1) = 1.0 ytau(2) = 1.0 tlag = t - tau if (tlag .GT. 0.0) call lagvalue(tlag, nr, 2, ytau) ydot(1) = f * N - g * N * P ydot(2) = e * g * ytau(1) * ytau(2) - m * P yout(1) = ytau(1) yout(2) = ytau(2) return end \end{verbatim} During compilation, we need to also compile the file \code{dedeUtils.c}. Assuming that the above \proglang{Fortran} code is in file \code{dede_lvF.f}, which is found in the working directory that also contains file \code{dedeUtils.c}, the problem is compiled and run as: \begin{verbatim} system("R CMD SHLIB dede_lvF.f dedeUtils.c") dyn.load(paste("dede_lvF", .Platform$dynlib.ext, sep="")) yout3 <- dede(yinit, times = times, func = "derivs", parms = parms, dllname = "dede_lvF", initfunc = "initmod", nout = 2) \end{verbatim} \subsection{Delays implemented in C} We now give the same example in \proglang{C}-code (you will find this in directory \code{inst/doc/dynload-dede/dede_lv.c}). \begin{verbatim} #include #include #include #include static double parms[5]; #define f parms[0] #define g parms[1] #define e parms[2] #define m parms[3] #define tau parms[4] /* Interface to dede utility functions in package deSolve */ void lagvalue(double T, int *nr, int N, double *ytau) { static void(*fun)(double, int*, int, double*) = NULL; if (fun == NULL) fun = (void(*)(double, int*, int, double*))R_GetCCallable("deSolve", "lagvalue"); return fun(T, nr, N, ytau); } void lagderiv(double T, int *nr, int N, double *ytau) { static void(*fun)(double, int*, int, double*) = NULL; if (fun == NULL) fun = (void(*)(double, int*, int, double*))R_GetCCallable("deSolve", "lagderiv"); return fun(T, nr, N, ytau); } /* Initializer */ void initmod(void (* odeparms)(int *, double *)) { int N = 5; odeparms(&N, parms); } /* Derivatives */ void derivs (int *neq, double *t, double *y, double *ydot, double *yout, int *ip) { if (ip[0] < 2) error("nout should be at least 1"); double N = y[0]; double P = y[1]; int Nout = 2; // number of returned lags ( <= n_eq !!) int nr[2] = {0, 1}; // which lags are needed? // numbering starts from zero ! double ytau[2] = {1.0, 1.0}; // array; initialize with default values ! double T = *t - tau; if (*t > tau) { lagvalue(T, nr, Nout, ytau); } ydot[0] = f * N - g * N * P; ydot[1] = e * g * ytau[0] * ytau[1] - m * P; yout[0] = ytau[0]; yout[1] = ytau[1]; } \end{verbatim} Assuming this code is in a file called \code{dede_lv.c}, which is in the working directory, this file is then compiled and run as: \begin{verbatim} system("R CMD SHLIB dede_lv.c") dyn.load(paste("dede_lv", .Platform$dynlib.ext, sep="")) yout2 <- dede(yinit, times = times, func = "derivs", parms = parms, dllname = "dede_lv", initfunc = "initmod", nout = 2) dyn.unload(paste("dede_lv", .Platform$dynlib.ext, sep="")) \end{verbatim} \section{Difference equations in compiled code} There is one special-purpose solver, triggered with \code{method = "iteration"} which can be used in cases where the new values of the state variables are estimated by the user, and need not be found by integration. This is for instance useful when the model consists of difference equations, or for 1-D models when transport is implemented by an implicit or a semi-implicit method. An example of a discrete time model, represented by a difference equation is given in the help file of solver \code{ode}. It consists of the host-parasitoid model described as from \citet[p283]{Soetaert08}. We first give the R-code, and how it is solved: \begin{verbatim} Parasite <- function (t, y, ks) { P <- y[1] H <- y[2] f <- A * P / (ks +H) Pnew <- H* (1-exp(-f)) Hnew <- H * exp(rH*(1.-H) - f) list (c(Pnew, Hnew)) } rH <- 2.82 # rate of increase A <- 100 # attack rate ks <- 15. # half-saturation density out <- ode (func = Parasite, y = c(P = 0.5, H = 0.5), times = 0:50, parms = ks, method = "iteration") \end{verbatim} Note that the function returns the updated value of the state variables rather than the rate of change (derivative). The method ``iteration'' does not perform any integration. The implementation in \proglang{FORTRAN} consists of an initialisation function to pass the parameter values (\code{initparms}) and the "update" function that returns the new values of the state variables (\code{parasite}): \begin{verbatim} subroutine initparms(odeparms) external odeparms double precision parms(3) common /myparms/parms call odeparms(3, parms) return end subroutine parasite (neq, t, y, ynew, out, iout) integer neq, iout(*) double precision t, y(neq), ynew(neq), out(*), rH, A, ks common /myparms/ rH, A, ks double precision P, H, f P = y(1) H = y(2) f = A * P / (ks + H) ynew(1) = H * (1.d0 - exp(-f)) ynew(2) = H * exp (rH * (1.d0 - H) - f) return end \end{verbatim} The model is compiled, loaded and executed in R as: \begin{verbatim} system("R CMD SHLIB difference.f") dyn.load(paste("difference", .Platform$dynlib.ext, sep = "")) require(deSolve) rH <- 2.82 # rate of increase A <- 100 # attack rate ks <- 15. # half-saturation density parms <- c(rH = rH, A = A, ks = ks) out <- ode (func = "parasite", y = c(P = 0.5, H = 0.5), times = 0:50, initfunc = "initparms", dllname = "difference", parms = parms, method = "iteration") \end{verbatim} \section{Final remark} Detailed information about communication between \proglang{C}, \proglang{FORTRAN} and \proglang{R} can be found in \citet{Rexts2009}. Notwithstanding the speed gain when using compiled code, one should not carelessly decide to always resort to this type of modelling. Because the code needs to be formally compiled and linked to \proglang{R} much of the elegance when using pure \proglang{R} models is lost. Moreover, mistakes are easily made and paid harder in compiled code: often a programming error will terminate \proglang{R}. In addition, these errors may not be simple to trace. \clearpage %% this adds References to the PDF-Index without adding an obsolete section \phantomsection \addcontentsline{toc}{section}{References} \bibliography{integration} \end{document} deSolve/vignettes/deSolve.Rnw0000754000175100001440000020043212352122166015775 0ustar hornikusers\documentclass[article,nojss]{jss} \DeclareGraphicsExtensions{.pdf, .eps, .png, .jpeg} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Add-on packages and fonts \usepackage{graphicx} \usepackage{amsmath} \newcommand{\noun}[1]{\textsc{#1}} %% Bold symbol macro for standard LaTeX users \providecommand{\boldsymbol}[1]{\mbox{\boldmath $#1$}} %% Because html converters don't know tabularnewline \providecommand{\tabularnewline}{\\} \usepackage{array} % table commands \setlength{\extrarowheight}{0.1cm} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% User specified LaTeX commands. \newcommand{\R}{\proglang{R }} \newcommand{\ds}{\textbf{\textsf{deSolve }}} \newcommand{\bs}{\textbf{\textsf{bvpSolve }}} \newcommand{\rt}{\textbf{\textsf{ReacTran }}} \newcommand{\rb}[1]{\raisebox{1.5ex}{#1}} \title{Package \pkg{deSolve}: Solving Initial Value Differential Equations in \proglang{R}} \Plaintitle{Package deSolve: Solving Initial Value Differential Equations in R} \Keywords{differential equations, ordinary differential equations, differential algebraic equations, partial differential equations, initial value problems, \proglang{R}} \Plainkeywords{differential equations, ordinary differential equations, differential algebraic equations, partial differential equations, initial value problems, R} \author{ Karline Soetaert\\ Royal Netherlands Institute\\ of Sea Research (NIOZ)\\ Yerseke, The Netherlands \And Thomas Petzoldt\\ Technische Universit\"at \\ Dresden\\ Germany \And R. Woodrow Setzer\\ National Center for\\ Computational Toxicology\\ US Environmental Protection Agency } \Plainauthor{Karline Soetaert, Thomas Petzoldt, R. Woodrow Setzer} \Abstract{ \R package \ds \citep{deSolve_jss,deSolve} the successor of \proglang{R} package \pkg{odesolve} is a package to solve initial value problems (IVP) of: \begin{itemize} \item ordinary differential equations (ODE), \item differential algebraic equations (DAE), \item partial differential equations (PDE) and \item delay differential equations (DeDE). \end{itemize} The implementation includes stiff and nonstiff integration routines based on the \pkg{ODEPACK} \proglang{FORTRAN} codes \citep{Hindmarsh83}. It also includes fixed and adaptive time-step explicit Runge-Kutta solvers and the Euler method \citep{Press92}, and the implicit Runge-Kutta method RADAU \citep{Hairer2}. In this vignette we outline how to implement differential equations as \R-functions. Another vignette (``compiledCode'') \citep{compiledCode}, deals with differential equations implemented in lower-level languages such as \proglang{FORTRAN}, \proglang{C}, or \proglang{C++}, which are compiled into a dynamically linked library (DLL) and loaded into \proglang{R} \citep{Rcore}. Note that another package, \bs provides methods to solve boundary value problems \citep{bvpSolve}. } %% The address of (at least) one author should be given %% in the following format: \Address{ Karline Soetaert\\ Centre for Estuarine and Marine Ecology (CEME)\\ Royal Netherlands Institute of Sea Research (NIOZ)\\ 4401 NT Yerseke, Netherlands \\ E-mail: \email{karline.soetaert@nioz.nl}\\ URL: \url{http://www.nioz.nl}\\ \\ Thomas Petzoldt\\ Institut f\"ur Hydrobiologie\\ Technische Universit\"at Dresden\\ 01062 Dresden, Germany\\ E-mail: \email{thomas.petzoldt@tu-dresden.de}\\ URL: \url{http://tu-dresden.de/Members/thomas.petzoldt/}\\ \\ R. Woodrow Setzer\\ National Center for Computational Toxicology\\ US Environmental Protection Agency\\ URL: \url{http://www.epa.gov/comptox} } %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% R/Sweave specific LaTeX commands. %% need no \usepackage{Sweave} %\VignetteIndexEntry{R Package deSolve: Solving Initial Value Differential Equations in R} %\VignetteKeywords{differential equations, ordinary differential equations, differential algebraic equations, partial differential equations, initial value problems, R} %\VignettePackage{deSolve} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Begin of the document \begin{document} \SweaveOpts{engine=R,eps=FALSE} \SweaveOpts{keep.source=TRUE} <>= library("deSolve") options(prompt = "> ") options(width=70) @ \maketitle \section{A simple ODE: chaos in the atmosphere} The Lorenz equations (Lorenz, 1963) were the first chaotic dynamic system to be described. They consist of three differential equations that were assumed to represent idealized behavior of the earth's atmosphere. We use this model to demonstrate how to implement and solve differential equations in \proglang{R}. The Lorenz model describes the dynamics of three state variables, $X$, $Y$ and $Z$. The model equations are: \begin{align*} \frac{dX}{dt} &= a \cdot X + Y \cdot Z \\ \frac{dY}{dt} &= b \cdot (Y - Z) \\ \frac{dZ}{dt} &= - X \cdot Y + c \cdot Y - Z \end{align*} with the initial conditions: \[ X(0) = Y(0) = Z(0) = 1 \] Where $a$, $b$ and $c$ are three parameters, with values of -8/3, -10 and 28 respectively. Implementation of an IVP ODE in \R can be separated in two parts: the model specification and the model application. Model specification consists of: \begin{itemize} \item Defining model parameters and their values, \item Defining model state variables and their initial conditions, \item Implementing the model equations that calculate the rate of change (e.g. $dX/dt$) of the state variables. \end{itemize} The model application consists of: \begin{itemize} \item Specification of the time at which model output is wanted, \item Integration of the model equations (uses R-functions from \pkg{deSolve}), \item Plotting of model results. \end{itemize} Below, we discuss the \proglang{R}-code for the Lorenz model. \subsection{Model specification} \subsubsection{Model parameters} There are three model parameters: $a$, $b$, and $c$ that are defined first. Parameters are stored as a vector with assigned names and values: <<>>= parameters <- c(a = -8/3, b = -10, c = 28) @ \subsubsection{State variables} The three state variables are also created as a vector, and their initial values given: <<>>= state <- c(X = 1, Y = 1, Z = 1) @ \subsubsection{Model equations} The model equations are specified in a function (\code{Lorenz}) that calculates the rate of change of the state variables. Input to the function is the model time (\code{t}, not used here, but required by the calling routine), and the values of the state variables (\code{state}) and the parameters, in that order. This function will be called by the \R routine that solves the differential equations (here we use \code{ode}, see below). The code is most readable if we can address the parameters and state variables by their names. As both parameters and state variables are `vectors', they are converted into a list. The statement \code{with(as.list(c(state, parameters)), {...})} then makes available the names of this list. The main part of the model calculates the rate of change of the state variables. At the end of the function, these rates of change are returned, packed as a list. Note that it is necessary \textbf{to return the rate of change in the same ordering as the specification of the state variables. This is very important.} In this case, as state variables are specified $X$ first, then $Y$ and $Z$, the rates of changes are returned as $dX, dY, dZ$. <<>>= Lorenz<-function(t, state, parameters) { with(as.list(c(state, parameters)),{ # rate of change dX <- a*X + Y*Z dY <- b * (Y-Z) dZ <- -X*Y + c*Y - Z # return the rate of change list(c(dX, dY, dZ)) }) # end with(as.list ... } @ \subsection{Model application} \subsubsection{Time specification} We run the model for 100 days, and give output at 0.01 daily intervals. R's function \code{seq()} creates the time sequence: <<>>= times <- seq(0, 100, by = 0.01) @ \subsubsection{Model integration} The model is solved using \ds function \code{ode}, which is the default integration routine. Function \code{ode} takes as input, a.o. the state variable vector (\code{y}), the times at which output is required (\code{times}), the model function that returns the rate of change (\code{func}) and the parameter vector (\code{parms}). Function \code{ode} returns an object of class \code{deSolve} with a matrix that contains the values of the state variables (columns) at the requested output times. <<>>= library(deSolve) out <- ode(y = state, times = times, func = Lorenz, parms = parameters) head(out) @ \subsubsection{Plotting results} Finally, the model output is plotted. We use the plot method designed for objects of class \code{deSolve}, which will neatly arrange the figures in two rows and two columns; before plotting, the size of the outer upper margin (the third margin) is increased (\code{oma}), such as to allow writing a figure heading (\code{mtext}). First all model variables are plotted versus \code{time}, and finally \code{Z} versus \code{X}: <>= par(oma = c(0, 0, 3, 0)) plot(out, xlab = "time", ylab = "-") plot(out[, "X"], out[, "Z"], pch = ".") mtext(outer = TRUE, side = 3, "Lorenz model", cex = 1.5) @ \setkeys{Gin}{width=0.8\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{Solution of the ordinary differential equation - see text for R-code} \label{fig:dae} \end{figure} \clearpage \section{Solvers for initial value problems of ordinary differential equations} Package \ds contains several IVP ordinary differential equation solvers, that belong to the most important classes of solvers. Most functions are based on original (\proglang{FORTRAN}) implementations, e.g. the Backward Differentiation Formulae and Adams methods from \pkg{ODEPACK} \citep{Hindmarsh83}, or from \citep{Brown89,Petzold1983}, the implicit Runge-Kutta method RADAU \citep{Hairer2}. The package contains also a de novo implementation of several Runge-Kutta methods \citep{Butcher1987, Press92, Hairer1}. All integration methods\footnote{except \code{zvode}, the solver used for systems containing complex numbers.} can be triggered from function \code{ode}, by setting \code{ode}'s argument \code{method}), or can be run as stand-alone functions. Moreover, for each integration routine, several options are available to optimise performance. For instance, the next statements will use integration method \code{radau} to solve the model, and set the tolerances to a higher value than the default. Both statements are the same: <<>>= outb <- radau(state, times, Lorenz, parameters, atol = 1e-4, rtol = 1e-4) outc <- ode(state, times, Lorenz, parameters, method = "radau", atol = 1e-4, rtol = 1e-4) @ The default integration method, based on the \proglang{FORTRAN} code LSODA is one that switches automatically between stiff and non-stiff systems \citep{Petzold1983}. This is a very robust method, but not necessarily the most efficient solver for one particular problem. See \citep{deSolve_jss} for more information about when to use which solver in \pkg{deSolve}. For most cases, the default solver, \code{ode} and using the default settings will do. Table \ref{tb:rs} also gives a short overview of the available methods. To show how to trigger the various methods, we solve the model with several integration routines, each time printing the time it took (in seconds) to find the solution: <<>>= print(system.time(out1 <- rk4 (state, times, Lorenz, parameters))) print(system.time(out2 <- lsode (state, times, Lorenz, parameters))) print(system.time(out <- lsoda (state, times, Lorenz, parameters))) print(system.time(out <- lsodes(state, times, Lorenz, parameters))) print(system.time(out <- daspk (state, times, Lorenz, parameters))) print(system.time(out <- vode (state, times, Lorenz, parameters))) @ \subsection{Runge-Kutta methods and Euler} The explicit Runge-Kutta methods are de novo implementations in \proglang{C}, based on the Butcher tables \citep{Butcher1987}. They comprise simple Runge-Kutta formulae (Euler's method \code{euler}, Heun's method \code{rk2}, the classical 4th order Runge-Kutta, \code{rk4}) and several Runge-Kutta pairs of order 3(2) to order 8(7). The embedded, explicit methods are according to \citet{Fehlberg1967} (\code{rk..f}, \code{ode45}), \citet{Dormand1980,Dormand1981} (\code{rk..dp.}), \citet{Bogacki1989} (\code{rk23bs}, \code{ode23}) and \citet{Cash1990} (\code{rk45ck}), where \code{ode23} and \code{ode45} are aliases for the popular methods \code{rk23bs} resp. \code{rk45dp7}. With the following statement all implemented methods are shown: <<>>= rkMethod() @ This list also contains implicit Runge-Kutta's (\code{irk..}), but they are not yet optimally coded. The only well-implemented implicit Runge-Kutta is the \code{radau} method \citep{Hairer2} that will be discussed in the section dealing with differential algebraic equations. The properties of a Runge-Kutta method can be displayed as follows: <<>>= rkMethod("rk23") @ Here \code{varstep} informs whether the method uses a variable time-step; \code{FSAL} whether the first same as last strategy is used, while \code{stage} and \code{Qerr} give the number of function evaluations needed for one step, and the order of the local truncation error. \code{A, b1, b2, c} are the coefficients of the Butcher table. Two formulae (\code{rk45dp7, rk45ck}) support dense output. It is also possible to modify the parameters of a method (be very careful with this) or define and use a new Runge-Kutta method: <<>>= func <- function(t, x, parms) { with(as.list(c(parms, x)),{ dP <- a * P - b * C * P dC <- b * P * C - c * C res <- c(dP, dC) list(res) }) } rKnew <- rkMethod(ID = "midpoint", varstep = FALSE, A = c(0, 1/2), b1 = c(0, 1), c = c(0, 1/2), stage = 2, Qerr = 1 ) out <- ode(y = c(P = 2, C = 1), times = 0:100, func, parms = c(a = 0.1, b = 0.1, c = 0.1), method = rKnew) head(out) @ \subsubsection{Fixed time-step methods} There are two explicit methods that do not adapt the time step: the \code{euler} method and the \code{rk4} method. They are implemented in two ways: \begin{itemize} \item as a \code{rkMethod} of the \textbf{general} \code{rk} solver. In this case the time step used can be specified independently from the \code{times} argument, by setting argument \code{hini}. Function \code{ode} uses this general code. \item as \textbf{special} solver codes \code{euler} and \code{rk4}. These implementations are simplified and with less options to avoid overhead. The timestep used is determined by the time increment in the \code{times} argument. \end{itemize} For example, the next two statements both trigger the Euler method, the first using the ``special'' code with a time step = 1, as imposed by the \code{times} argument, the second using the generalized method with a time step set by \code{hini}. Unsurprisingly, the first solution method completely fails (the time step $= 1$ is much too large for this problem). \begin{verbatim} out <- euler(y = state, times = 0:40, func = Lorenz, parms = parameters) outb <- ode(y = state, times = 0:40, func = Lorenz, parms = parameters, method = "euler", hini = 0.01) \end{verbatim} \subsection{Model diagnostics and summaries} Function \code{diagnostics} prints several diagnostics of the simulation to the screen. For the Runge-Kutta and \code{lsode} routine called above they are: <<>>= diagnostics(out1) diagnostics(out2) @ There is also a \code{summary} method for \code{deSolve} objects. This is especially handy for multi-dimensional problems (see below) <<>>= summary(out1) @ \clearpage \section{Partial differential equations} As package \ds includes integrators that deal efficiently with arbitrarily sparse and banded Jacobians, it is especially well suited to solve initial value problems resulting from 1, 2 or 3-dimensional partial differential equations (PDE), using the method-of-lines approach. The PDEs are first written as ODEs, using finite differences. This can be efficiently done with functions from R-package \rt \citep{ReacTran}. However, here we will create the finite differences in R-code. Several special-purpose solvers are included in \pkg{deSolve}: \begin{itemize} \item \code{ode.band} integrates 1-dimensional problems comprizing one species, \item \code{ode.1D} integrates 1-dimensional problems comprizing one or many species, \item \code{ode.2D} integrates 2-dimensional problems, \item \code{ode.3D} integrates 3-dimensional problems. \end{itemize} As an example, consider the Aphid model described in \citet{Soetaert08}. It is a model where aphids (a pest insect) slowly diffuse and grow on a row of plants. The model equations are: \[ \frac{{\partial N}}{{\partial t}} = - \frac{{\partial Flux}}{{\partial {\kern 1pt} x}} + g \cdot N \] and where the diffusive flux is given by: \[ Flux = - D\frac{{\partial N}}{{\partial {\kern 1pt} x}} \] with boundary conditions \[ N_{x=0}=N_{x=60}=0 \] and initial condition \begin{center} $N_x=0$ for $x \neq 30$ $N_x=1$ for $x = 30$ \end{center} In the method of lines approach, the spatial domain is subdivided in a number of boxes and the equation is discretized as: \[ \frac{{dN_i }}{{dt}} = - \frac{{Flux_{i,i + 1} - Flux_{i - 1,i} }}{{\Delta x_i }} + g \cdot N_i \] with the flux on the interface equal to: \[ Flux_{i - 1,i} = - D_{i - 1,i} \cdot \frac{{N_i - N_{i - 1} }}{{\Delta x_{i - 1,i} }} \] Note that the values of state variables (here densities) are defined in the centre of boxes (i), whereas the fluxes are defined on the box interfaces. We refer to \citet{Soetaert08} for more information about this model and its numerical approximation. Here is its implementation in \proglang{R}. First the model equations are defined: <<>>= Aphid <- function(t, APHIDS, parameters) { deltax <- c (0.5, rep(1, numboxes - 1), 0.5) Flux <- -D * diff(c(0, APHIDS, 0)) / deltax dAPHIDS <- -diff(Flux) / delx + APHIDS * r # the return value list(dAPHIDS ) } # end @ Then the model parameters and spatial grid are defined <<>>= D <- 0.3 # m2/day diffusion rate r <- 0.01 # /day net growth rate delx <- 1 # m thickness of boxes numboxes <- 60 # distance of boxes on plant, m, 1 m intervals Distance <- seq(from = 0.5, by = delx, length.out = numboxes) @ Aphids are initially only present in two central boxes: <<>>= # Initial conditions: # ind/m2 APHIDS <- rep(0, times = numboxes) APHIDS[30:31] <- 1 state <- c(APHIDS = APHIDS) # initialise state variables @ The model is run for 200 days, producing output every day; the time elapsed in seconds to solve this 60 state-variable model is estimated (\code{system.time}): <<>>= times <-seq(0, 200, by = 1) print(system.time( out <- ode.1D(state, times, Aphid, parms = 0, nspec = 1, names = "Aphid") )) @ Matrix \code{out} consist of times (1st column) followed by the densities (next columns). <<>>= head(out[,1:5]) @ The \code{summary} method gives the mean, min, max, ... of the entire 1-D variable: <<>>= summary(out) @ Finally, the output is plotted. It is simplest to do this with \pkg{deSolve}'s \proglang{S3}-method \code{image} %% Do this offline %%<>= \begin{verbatim} image(out, method = "filled.contour", grid = Distance, xlab = "time, days", ylab = "Distance on plant, m", main = "Aphid density on a row of plants") \end{verbatim} %%@ \setkeys{Gin}{width=0.8\textwidth} \begin{figure} \begin{center} %%<>= %%<> %%@ \includegraphics{aphid.png} \end{center} \caption{Solution of the 1-dimensional aphid model - see text for \R-code} \label{fig:aphid} \end{figure} As this is a 1-D model, it is best solved with \ds function \code{ode.1D}. A multi-species IVP example can be found in \citet{Soetaert08}. For 2-D and 3-D problems, we refer to the help-files of functions \code{ode.2D} and \code{ode.3D}. The output of one-dimensional models can also be plotted using S3-method \code{plot.1D} and \code{matplot.1D}. In both cases, we can simply take a \code{subset} of the output, and add observations. <<>>= data <- cbind(dist = c(0,10, 20, 30, 40, 50, 60), Aphid = c(0,0.1,0.25,0.5,0.25,0.1,0)) @ <>= par (mfrow = c(1,2)) matplot.1D(out, grid = Distance, type = "l", mfrow = NULL, subset = time %in% seq(0, 200, by = 10), obs = data, obspar = list(pch = 18, cex = 2, col="red")) plot.1D(out, grid = Distance, type = "l", mfrow = NULL, subset = time == 100, obs = data, obspar = list(pch = 18, cex = 2, col="red")) @ \setkeys{Gin}{width=1.0\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{Solution of the Aphid model - plotted with matplot.1D, plot.1D - see text for R-code} \label{fig:matplot1d} \end{figure} \clearpage \section{Differential algebraic equations} Package \ds contains two functions that solve initial value problems of differential algebraic equations. They are: \begin{itemize} \item \code{radau} which implements the implicit Runge-Kutta RADAU5 \citep{Hairer2}, \item \code{daspk}, based on the backward differentiation code DASPK \citep{Brenan96}. \end{itemize} Function \code{radau} needs the input in the form $M y' = f(t,y,y')$ where $M$ is the mass matrix. Function \code{daspk} also supports this input, but can also solve problems written in the form $F(t, y, y') = 0$. \code{radau} solves problems up to index 3; \code{daspk} solves problems of index $\leq$ 1. \subsection{DAEs of index maximal 1} Function \code{daspk} from package \ds solves (relatively simple) DAEs of index\footnote{note that many -- apparently simple -- DAEs are higher-index DAEs} maximal 1. The DAE has to be specified by the \emph{residual function} instead of the rates of change (as in ODE). Consider the following simple DAE: \begin{eqnarray*} \frac{dy_1}{dt}&=&-y_1+y_2\\ y_1 \cdot y_2 &=& t \end{eqnarray*} where the first equation is a differential, the second an algebraic equation. To solve it, it is first rewritten as residual functions: \begin{eqnarray*} 0&=&\frac{dy_1}{dt}+y_1-y_2\\ 0&=&y_1 \cdot y_2 - t \end{eqnarray*} In \R we write: <<>>= daefun <- function(t, y, dy, parameters) { res1 <- dy[1] + y[1] - y[2] res2 <- y[2] * y[1] - t list(c(res1, res2)) } library(deSolve) yini <- c(1, 0) dyini <- c(1, 0) times <- seq(0, 10, 0.1) ## solver system.time(out <- daspk(y = yini, dy = dyini, times = times, res = daefun, parms = 0)) @ <>= matplot(out[,1], out[,2:3], type = "l", lwd = 2, main = "dae", xlab = "time", ylab = "y") @ \setkeys{Gin}{width=0.4\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{Solution of the differential algebraic equation model - see text for R-code} \label{fig:dae2} \end{figure} \subsection{DAEs of index up to three} Function \code{radau} from package \ds can solve DAEs of index up to three provided that they can be written in the form $M dy/dt = f(t,y)$. Consider the well-known pendulum equation: \begin{eqnarray*} x' &=& u\\ y' &=& v\\ u' &=& -\lambda x\\ v' &=& -\lambda y - 9.8\\ 0 &=& x^2 + y^2 - 1 \end{eqnarray*} where the dependent variables are $x, y, u, v$ and $\lambda$. Implemented in \R to be used with function \code{radau} this becomes: <<>>= pendulum <- function (t, Y, parms) { with (as.list(Y), list(c(u, v, -lam * x, -lam * y - 9.8, x^2 + y^2 -1 )) ) } @ A consistent set of initial conditions are: <<>>= yini <- c(x = 1, y = 0, u = 0, v = 1, lam = 1) @ and the mass matrix $M$: <<>>= M <- diag(nrow = 5) M[5, 5] <- 0 M @ Function \code{radau} requires that the index of each equation is specified; there are 2 equations of index 1, two of index 2, one of index 3: <<>>= index <- c(2, 2, 1) times <- seq(from = 0, to = 10, by = 0.01) out <- radau (y = yini, func = pendulum, parms = NULL, times = times, mass = M, nind = index) @ <>= plot(out, type = "l", lwd = 2) plot(out[, c("x", "y")], type = "l", lwd = 2) @ \setkeys{Gin}{width=0.8\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{Solution of the pendulum problem, an index 3 differential algebraic equation using \code{radau} - see text for \proglang{R}-code} \label{fig:pendulum} \end{figure} \clearpage \section{Integrating systems containing complex numbers, function zvode} Function \code{zvode} solves ODEs that are composed of complex variables. We use \code{zvode} to solve the following system of 2 ODEs: \begin{align*} \frac{dz}{dt} &= i \cdot z\\ \frac{dw}{dt} &= -i \cdot w \cdot w \cdot z\\ \intertext{where} w(0) &= 1/2.1 \\ z(0) &= 1 \end{align*} on the interval $t = [0, 2 \pi]$ <<>>= ZODE2 <- function(Time, State, Pars) { with(as.list(State), { df <- 1i * f dg <- -1i * g * g * f return(list(c(df, dg))) }) } yini <- c(f = 1+0i, g = 1/2.1+0i) times <- seq(0, 2 * pi, length = 100) out <- zvode(func = ZODE2, y = yini, parms = NULL, times = times, atol = 1e-10, rtol = 1e-10) @ The analytical solution is: \begin{align*} f(t) &= \exp (1i \cdot t) \intertext{and} g(t) &= 1/(f(t) + 1.1) \end{align*} The numerical solution, as produced by \code{zvode} matches the analytical solution: <<>>= analytical <- cbind(f = exp(1i*times), g = 1/(exp(1i*times)+1.1)) tail(cbind(out[,2], analytical[,1])) @ \clearpage \section{Making good use of the integration options} The solvers from \pkg{ODEPACK} can be fine-tuned if it is known whether the problem is stiff or non-stiff, or if the structure of the Jacobian is sparse. We repeat the example from \code{lsode} to show how we can make good use of these options. The model describes the time evolution of 5 state variables: <<>>= f1 <- function (t, y, parms) { ydot <- vector(len = 5) ydot[1] <- 0.1*y[1] -0.2*y[2] ydot[2] <- -0.3*y[1] +0.1*y[2] -0.2*y[3] ydot[3] <- -0.3*y[2] +0.1*y[3] -0.2*y[4] ydot[4] <- -0.3*y[3] +0.1*y[4] -0.2*y[5] ydot[5] <- -0.3*y[4] +0.1*y[5] return(list(ydot)) } @ and the initial conditions and output times are: <<>>= yini <- 1:5 times <- 1:20 @ The default solution, using \code{lsode} assumes that the model is stiff, and the integrator generates the Jacobian, which is assummed to be \emph{full}: <<>>= out <- lsode(yini, times, f1, parms = 0, jactype = "fullint") @ It is possible for the user to provide the Jacobian. Especially for large problems this can result in substantial time savings. In a first case, the Jacobian is written as a full matrix: <<>>= fulljac <- function (t, y, parms) { jac <- matrix(nrow = 5, ncol = 5, byrow = TRUE, data = c(0.1, -0.2, 0 , 0 , 0 , -0.3, 0.1, -0.2, 0 , 0 , 0 , -0.3, 0.1, -0.2, 0 , 0 , 0 , -0.3, 0.1, -0.2, 0 , 0 , 0 , -0.3, 0.1)) return(jac) } @ and the model solved as: <<>>= out2 <- lsode(yini, times, f1, parms = 0, jactype = "fullusr", jacfunc = fulljac) @ The Jacobian matrix is banded, with one nonzero band above (up) and one below(down) the diagonal. First we let \code{lsode} estimate the banded Jacobian internally (\code{jactype = "bandint"}): <<>>= out3 <- lsode(yini, times, f1, parms = 0, jactype = "bandint", bandup = 1, banddown = 1) @ It is also possible to provide the nonzero bands of the Jacobian in a function: <<>>= bandjac <- function (t, y, parms) { jac <- matrix(nrow = 3, ncol = 5, byrow = TRUE, data = c( 0 , -0.2, -0.2, -0.2, -0.2, 0.1, 0.1, 0.1, 0.1, 0.1, -0.3, -0.3, -0.3, -0.3, 0)) return(jac) } @ in which case the model is solved as: <<>>= out4 <- lsode(yini, times, f1, parms = 0, jactype = "bandusr", jacfunc = bandjac, bandup = 1, banddown = 1) @ Finally, if the model is specified as ``non-stiff'' (by setting \code{mf=10}), there is no need to specify the Jacobian: <<>>= out5 <- lsode(yini, times, f1, parms = 0, mf = 10) @ \clearpage \section{Events and roots} As from version 1.6, \code{events} are supported. Events occur when the values of state variables are instantaneously changed. They can be specified as a \code{data.frame}, or in a function. Events can also be triggered by a root function. Several integrators (\code{lsoda}, \code{lsodar}, \code{lsode}, \code{lsodes} and \code{radau}) can estimate the root of one or more functions. For the first 4 integration methods, the root finding algorithm is based on the algorithm in solver LSODAR, and implemented in FORTRAN. For \code{radau}, the root solving algorithm is written in C-code, and it works slightly different. Thus, some problems involving roots may be more efficient to solve with either \code{lsoda, lsode}, or \code{lsodes}, while other problems are more efficiently solved with \code{radau}. If a root is found, then the integration will be terminated, unless an event function is defined. A help file with information on roots and events can be opened by typing \code{?events} or \code{?roots}. \subsection{Event specified in a data.frame} In this example, two state variables with constant decay are modeled: <<>>= eventmod <- function(t, var, parms) { list(dvar = -0.1*var) } yini <- c(v1 = 1, v2 = 2) times <- seq(0, 10, by = 0.1) @ At time 1 and 9 a value is added to variable \code{v1}, at time 1 state variable \code{v2} is multiplied with 2, while at time 5 the value of \code{v2} is replaced with 3. These events are specified in a \code{data.frame}, eventdat: <<>>= eventdat <- data.frame(var = c("v1", "v2", "v2", "v1"), time = c(1, 1, 5, 9), value = c(1, 2, 3, 4), method = c("add", "mult", "rep", "add")) eventdat @ The model is solved with \code{ode}: <<>>= out <- ode(func = eventmod, y = yini, times = times, parms = NULL, events = list(data = eventdat)) @ <>= plot(out, type = "l", lwd = 2) @ \setkeys{Gin}{width=0.8\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{A simple model that contains events} \label{fig:event1} \end{figure} \subsection{Event triggered by a root function} This model describes the position (\code{y1}) and velocity (\code{y2}) of a bouncing ball: <<>>= ballode<- function(t, y, parms) { dy1 <- y[2] dy2 <- -9.8 list(c(dy1, dy2)) } @ An event is triggered when the ball hits the ground (height = 0) Then velocity (\code{y2}) is reversed and reduced by 10 percent. The root function, \code{y[1] = 0}, triggers the event: <<>>= root <- function(t, y, parms) y[1] @ The event function imposes the bouncing of the ball <<>>= event <- function(t, y, parms) { y[1]<- 0 y[2]<- -0.9 * y[2] return(y) } @ After specifying the initial values and times, the model is solved, here using \code{lsode}. <<>>= yini <- c(height = 0, v = 20) times <- seq(from = 0, to = 20, by = 0.01) out <- lsode(times = times, y = yini, func = ballode, parms = NULL, events = list(func = event, root = TRUE), rootfun = root) @ <>= plot(out, which = "height", type = "l",lwd = 2, main = "bouncing ball", ylab = "height") @ \setkeys{Gin}{width=0.4\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{A model, with event triggered by a root function} \label{fig:event2} \end{figure} \subsection{Events and time steps} The use of events requires that all event times are contained in the output time steps, otherwise such events would be skipped. This sounds easy but sometimes problems can occur due to the limited accuracy of floating point arithmetics of the computer. To make things work as excpected, two requirements have to be fulfilled: \begin{enumerate} \item all event times have to be contained \textbf{exactly} in times, i.e. with the maximum possible accuracy of floating point arithmetics. \item two time steps should not be too close together, otherwise numerical problems would occur during the integration. \end{enumerate} Starting from version 1.10 of \pkg{deSolve} this is now checked (and if necessary also fixed) automatically by the solver functions. A warning is issued to inform the user about possible problems, especially that the output time steps were now adjusted and therefore different from the ones originally specified by the user. This means that all values of \code{eventtimes} are now contained but only the subset of times that have no exact or ``rather close'' neighbors in \code{eventtimes}. Instead of relying on this automatism, matching times and eventtimes can also be managed by the user, either by appropriate rounding or by using function \code{cleanEventTimes} shown below. Let's assume we have a vector of time steps \code{times} and another vector of event times \code{eventtimes}: <<>>= times <- seq(0, 1, 0.1) eventtimes <- c(0.7, 0.9) @ If we now check whether the \code{eventtimes} are in \code{times}: <<>>= eventtimes %in% times @ we get the surprising answer that this is only partly the case, because \code{seq} made small numerical errors. The easiest method to get rid of this is rounding: <<>>= times2 <- round(times, 1) times - times2 @ The last line shows us that the error was always smaller than, say $10^{-15}$, what is typical for ordinary double precision arithmetics. The accuracy of the machine can be determined with \code{.Machine\$double.eps}. To check if all \code{eventtimes} are now contained in the new times vector \code{times2}, we use: <<>>= eventtimes %in% times2 @ or <<>>= all(eventtimes %in% times2) @ and see that everything is o.k. now. In few cases, rounding may not work properly, for example if a pharmacokinetic model is simulated with a daily time step, but drug injection occurs at precisely fixed times within the day. Then one has to add all additional event times to the ordinary time stepping: <<>>= times <- 1:10 eventtimes <- c(1.3, 3.4, 4, 7.9, 8.5) newtimes <- sort(unique(c(times, eventtimes))) @ If, however, an event and a time step are almost (but not exactly) the same, then it is more safe to use: <<>>= times <- 1:10 eventtimes <- c(1.3, 3.4, 4, 7.9999999999999999, 8.5) newtimes <- sort(c(eventtimes, cleanEventTimes(times, eventtimes))) @ because \code{cleanEventTimes} removes not only the doubled 4 (like \code{unique}, but also the ``almost doubled'' 8, while keeping the exact event time. The tolerance of \code{cleanEventTimes} can be adjusted using an optional argument \code{eps}. As said, this is normally done automatically by the differential equation solvers and in most cases appropriate rounding will be sufficient to get rid of the warnings. \clearpage \section{Delay differential equations} As from \pkg{deSolve} version 1.7, time lags are supported, and a new general solver for delay differential equations, \code{dede} has been added. We implement the lemming model, example 6 from \citep{ST2000}. Function \code{lagvalue} calculates the value of the state variable at \code{t - 0.74}. As long a these lag values are not known, the value 19 is assigned to the state variable. Note that the simulation starts at \code{time = - 0.74}. <<>>= library(deSolve) #----------------------------- # the derivative function #----------------------------- derivs <- function(t, y, parms) { if (t < 0) lag <- 19 else lag <- lagvalue(t - 0.74) dy <- r * y * (1 - lag/m) list(dy, dy = dy) } #----------------------------- # parameters #----------------------------- r <- 3.5; m <- 19 #----------------------------- # initial values and times #----------------------------- yinit <- c(y = 19.001) times <- seq(-0.74, 40, by = 0.01) #----------------------------- # solve the model #----------------------------- yout <- dede(y = yinit, times = times, func = derivs, parms = NULL, atol = 1e-10) @ <>= plot(yout, which = 1, type = "l", lwd = 2, main = "Lemming model", mfrow = c(1,2)) plot(yout[,2], yout[,3], xlab = "y", ylab = "dy", type = "l", lwd = 2) @ \setkeys{Gin}{width=\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{A delay differential equation model} \label{fig:dde} \end{figure} \clearpage \section{Discrete time models, difference equations} There is one special-purpose solver, triggered with \code{method = "iteration"} which can be used in cases where the new values of the state variables are directly estimated by the user, and need not be found by numerical integration. This is for instance useful when the model consists of difference equations, or for 1-D models when transport is implemented by an implicit or a semi-implicit method. We give here an example of a discrete time model, represented by a difference equation: the Teasel model as from \citet[p287]{Soetaert08}. The dynamics of this plant is described by 6 stages and the transition from one stage to another is in a transition matrix: We define the stages and the transition matrix first: <<>>= Stages <- c("DS 1yr", "DS 2yr", "R small", "R medium", "R large", "F") NumStages <- length(Stages) # Population matrix A <- matrix(nrow = NumStages, ncol = NumStages, byrow = TRUE, data = c( 0, 0, 0, 0, 0, 322.38, 0.966, 0, 0, 0, 0, 0 , 0.013, 0.01, 0.125, 0, 0, 3.448 , 0.007, 0, 0.125, 0.238, 0, 30.170, 0.008, 0, 0.038, 0.245, 0.167, 0.862 , 0, 0, 0, 0.023, 0.75, 0 ) ) @ The difference function is defined as usual, but does not return the ``rate of change'' but rather the new relative stage densities are returned. Thus, each time step, the updated values are divided by the summed densities: <<>>= Teasel <- function (t, y, p) { yNew <- A %*% y list (yNew / sum(yNew)) } @ The model is solved using method ``iteration'': <<>>= out <- ode(func = Teasel, y = c(1, rep(0, 5) ), times = 0:50, parms = 0, method = "iteration") @ and plotted using R-function \code{matplot}: <>= matplot(out[,1], out[,-1], main = "Teasel stage distribution", type = "l") legend("topright", legend = Stages, lty = 1:6, col = 1:6) @ \setkeys{Gin}{width=0.6\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{A difference model solved with method = ``iteration''} \label{fig:difference} \end{figure} \section{Plotting deSolve Objects} There are \proglang{S3} \code{plot} and \code{image} methods for plotting 0-D (plot), and 1-D and 2-D model output (image) as generated with \code{ode}, \code{ode.1D}, \code{ode.2D}. How to use it and examples can be found by typing \code{?plot.deSolve}. \subsection{Plotting Multiple Scenario's} The \code{plot} method for \code{deSolve} objects can also be used to compare different scenarios, e.g from the same model but with different sets of parameters or initial values, with one single call to \code{plot}. As an example we implement the simple combustion model, which can be found on \url{http://www.scholarpedia.org/article/Stiff_systems}: \[ y' = y^2 \cdot (1-y) \] The model is run with 4 different values of the initial conditions: $y = 0.01, 0.02, 0.03, 0.04$ and written to \code{deSolve} objects \code{out}, \code{out2}, \code{out3}, \code{out4}. <<>>= library(deSolve) combustion <- function (t, y, parms) list(y^2 * (1-y) ) @ <<>>= yini <- 0.01 times <- 0 : 200 @ <<>>= out <- ode(times = times, y = yini, parms = 0, func = combustion) out2 <- ode(times = times, y = yini*2, parms = 0, func = combustion) out3 <- ode(times = times, y = yini*3, parms = 0, func = combustion) out4 <- ode(times = times, y = yini*4, parms = 0, func = combustion) @ The different scenarios are plotted at once, and a suitable legend is written. <>= plot(out, out2, out3, out4, main = "combustion") legend("bottomright", lty = 1:4, col = 1:4, legend = 1:4, title = "yini*i") @ \setkeys{Gin}{width=\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{Plotting 4 outputs in one figure} \label{fig:plotdeSolve} \end{figure} \subsection{Plotting Output with Observations} With the help of the optional argument \code{obs} it is possible to specify observed data that should be added to a \code{deSolve} plot. We exemplify this using the \code{ccl4model} in package \code{deSolve}. (see \code{?ccl4model} for what this is about). This model example has been implemented in compiled code. An observed data set is also available, called \code{ccl4data}. It contains toxicant concentrations in a chamber where rats were dosed with CCl4. <<>>= head(ccl4data) @ We select the data from animal ``A'': <<>>= obs <- subset (ccl4data, animal == "A", c(time, ChamberConc)) names(obs) <- c("time", "CP") head(obs) @ After assigning values to the parameters and providing initial conditions, the \code{ccl4model} can be run. We run the model three times, each time with a different value for the first parameter. Output is written to matrices \code{out} \code{out2}, and \code{out3}. <<>>= parms <- c(0.182, 4.0, 4.0, 0.08, 0.04, 0.74, 0.05, 0.15, 0.32, 16.17, 281.48, 13.3, 16.17, 5.487, 153.8, 0.04321671, 0.40272550, 951.46, 0.02, 1.0, 3.80000000) yini <- c(AI = 21, AAM = 0, AT = 0, AF = 0, AL = 0, CLT = 0, AM = 0) out <- ccl4model(times = seq(0, 6, by = 0.05), y = yini, parms = parms) par2 <- parms par2[1] <- 0.1 out2 <- ccl4model(times = seq(0, 6, by = 0.05), y = yini, parms = par2) par3 <- parms par3[1] <- 0.05 out3 <- ccl4model(times = seq(0, 6, by = 0.05), y = yini, parms = par3) @ We plot all these scenarios and the observed data at once: <>= plot(out, out2, out3, which = c("AI", "MASS", "CP"), col = c("black", "red", "green"), lwd = 2, obs = obs, obspar = list(pch = 18, col = "blue", cex = 1.2)) legend("topright", lty = c(1,2,3,NA), pch = c(NA, NA, NA, 18), col = c("black", "red", "green", "blue"), lwd = 2, legend = c("par1", "par2", "par3", "obs")) @ \setkeys{Gin}{width=\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{Plotting output and observations in one figure} \label{fig:plotobs} \end{figure} If we do not select specific variables, then only the ones for which there are observed data are plotted. Assume we have measured the total mass at the end of day 6. We put this in a second data set: <<>>= obs2 <- data.frame(time = 6, MASS = 12) obs2 @ then we plot the data together with the three model runs as follows: <>= plot(out, out2, out3, lwd = 2, obs = list(obs, obs2), obspar = list(pch = c(16, 18), col = c("blue", "black"), cex = c(1.2 , 2)) ) @ \setkeys{Gin}{width=1.0\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{Plotting variables in common with observations} \label{fig:plotobs2} \end{figure} \subsection{Plotting Summary Histograms} The \code{hist} function plots the histogram for each variable; all plot parameters can be set individually (here for \code{col}). To generate the next plot, we overrule the default \code{mfrow} setting which would plot the figures in 3 rows and 3 columns (and hence plot one figure in isolation) <>= hist(out, col = grey(seq(0, 1, by = 0.1)), mfrow = c(3, 4)) @ \setkeys{Gin}{width=1.0\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{Plotting histograms of all output variables} \label{fig:plothist} \end{figure} \subsection{Plotting multi-dimensional output} The \code{image} function plots time versus x images for models solved with \code{ode.1D}, or generates x-y plots for models solved with \code{ode.2D}. \subsubsection{1-D model output} We exemplify its use by means of a Lotka-Volterra model, implemented in 1-D. The model describes a predator and its prey diffusing on a flat surface and in concentric circles. This is a 1-D model, solved in the cylindrical coordinate system. Note that it is simpler to implement this model in R-package \code{ReacTran} \citep{ReacTran}. <>= options(prompt = " ") options(continue = " ") @ We start by defining the derivative function <<>>= lvmod <- function (time, state, parms, N, rr, ri, dr, dri) { with (as.list(parms), { PREY <- state[1:N] PRED <- state[(N+1):(2*N)] ## Fluxes due to diffusion ## at internal and external boundaries: zero gradient FluxPrey <- -Da * diff(c(PREY[1], PREY, PREY[N]))/dri FluxPred <- -Da * diff(c(PRED[1], PRED, PRED[N]))/dri ## Biology: Lotka-Volterra model Ingestion <- rIng * PREY * PRED GrowthPrey <- rGrow * PREY * (1-PREY/cap) MortPredator <- rMort * PRED ## Rate of change = Flux gradient + Biology dPREY <- -diff(ri * FluxPrey)/rr/dr + GrowthPrey - Ingestion dPRED <- -diff(ri * FluxPred)/rr/dr + Ingestion * assEff - MortPredator return (list(c(dPREY, dPRED))) }) } @ <>= options(prompt = " ") options(continue = " ") @ Then we define the parameters, which we put in a list <<>>= R <- 20 # total radius of surface, m N <- 100 # 100 concentric circles dr <- R/N # thickness of each layer r <- seq(dr/2,by = dr,len = N) # distance of center to mid-layer ri <- seq(0,by = dr,len = N+1) # distance to layer interface dri <- dr # dispersion distances parms <- c(Da = 0.05, # m2/d, dispersion coefficient rIng = 0.2, # /day, rate of ingestion rGrow = 1.0, # /day, growth rate of prey rMort = 0.2 , # /day, mortality rate of pred assEff = 0.5, # -, assimilation efficiency cap = 10) # density, carrying capacity @ After defining initial conditions, the model is solved with routine \code{ode.1D} <<>>= state <- rep(0, 2 * N) state[1] <- state[N + 1] <- 10 times <- seq(0, 200, by = 1) # output wanted at these time intervals print(system.time( out <- ode.1D(y = state, times = times, func = lvmod, parms = parms, nspec = 2, names = c("PREY", "PRED"), N = N, rr = r, ri = ri, dr = dr, dri = dri) )) @ The \code{summary} method provides summaries for both 1-dimensional state variables: <<>>= summary(out) @ while the S3-method \code{subset} can be used to extract only specific values of the variables: <<>>= p10 <- subset(out, select = "PREY", subset = time == 10) head(p10, n = 5) @ We first plot both 1-dimensional state variables at once; we specify that the figures are arranged in two rows, and 2 columns; when we call \code{image}, we overrule the default mfrow setting (\code{mfrow = NULL}). Next we plot "PREY" again, once with the default xlim and ylim, and next zooming in. Note that xlim and ylim are a list here. When we call \code{image} for the second time, we overrule the default \code{mfrow} setting by specifying (\code{mfrow = NULL}). %% This is done offline. %%<>= \begin{verbatim} image(out, grid = r, mfrow = c(2, 2), method = "persp", border = NA, ticktype = "detailed", legend = TRUE) image(out, grid = r, which = c("PREY", "PREY"), mfrow = NULL, xlim = list(NULL, c(0, 10)), ylim = list(NULL, c(0, 5)), add.contour = c(FALSE, TRUE)) \end{verbatim} %%@ \setkeys{Gin}{width=1.0\textwidth} \begin{figure} \begin{center} %%<>= %%<> %%@ \includegraphics{image1D.png} \end{center} \caption{image plots} \label{fig:plotimg} \end{figure} \subsubsection{2-D model output} When using \code{image} with a 2-D model, then the 2-D values at all output times will be plotted. Sometimes we want only output at a specific time value. We then use \proglang{S3}-method \code{subset} to extract 2-D variables at suitable time-values and use \proglang{R}'s \code{image}, \code{filled.contour} or \code{contour} method to depict them. Consider the very simple 2-D model (100*100), containing just 1-st order consumption, at a rate \code{r_x2y2}, where \code{r_x2y2} depends on the position along the grid. First the derivative function is defined: <<>>= Simple2D <- function(t, Y, par) { y <- matrix(nrow = nx, ncol = ny, data = Y) # vector to 2-D matrix dY <- - r_x2y2 * y # consumption return(list(dY)) } @ Then the grid is created, and the consumption rate made a function of grid position (\code{outer}). <<>>= dy <- dx <- 1 # grid size nx <- ny <- 100 x <- seq (dx/2, by = dx, len = nx) y <- seq (dy/2, by = dy, len = ny) # in each grid cell: consumption depending on position r_x2y2 <- outer(x, y, FUN=function(x,y) ((x-50)^2 + (y-50)^2)*1e-4) @ After defining the initial values, the model is solved using solver \code{ode.2D}. We use Runge-Kutta method \code{ode45}. <<>>= C <- matrix(nrow = nx, ncol = ny, 1) ODE3 <- ode.2D(y = C, times = 1:100, func = Simple2D, parms = NULL, dimens = c(nx, ny), names = "C", method = "ode45") @ We print a summary, and extract the 2-D variable at \code{time = 50} <<>>= summary(ODE3) t50 <- matrix(nrow = nx, ncol = ny, data = subset(ODE3, select = "C", subset = (time == 50))) @ We use function \code{contour} to plot both the consumption rate and the values of the state variables at \code{time = 50}. <>= par(mfrow = c(1, 2)) contour(x, y, r_x2y2, main = "consumption") contour(x, y, t50, main = "Y(t = 50)") @ \setkeys{Gin}{width=1.0\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{Contour plot of 2-D variables} \label{fig:twoD} \end{figure} \clearpage \section{Troubleshooting} \subsection{Avoiding numerical errors} The solvers from \pkg{ODEPACK} should be first choice for any problem and the defaults of the control parameters are reasonable for many practical problems. However, there are cases where they may give dubious results. Consider the following Lotka-Volterra type of model: <<>>= PCmod <- function(t, x, parms) { with(as.list(c(parms, x)), { dP <- c*P - d*C*P # producer dC <- e*P*C - f*C # consumer res <- c(dP, dC) list(res) }) } @ and with the following (biologically not very realistic)% \footnote{they are not realistic because producers grow unlimited with a high rate and consumers with 100 \% efficiency} parameter values: <<>>= parms <- c(c = 10, d = 0.1, e = 0.1, f = 0.1) @ After specification of initial conditions and output times, the model is solved -- using \code{lsoda}: <<>>= xstart <- c(P = 0.5, C = 1) times <- seq(0, 200, 0.1) out <- ode(y = xstart, times = times, func = PCmod, parms = parms) tail(out) @ We see that the simulation was stopped before reaching the final simulation time and both producers and consumer values may have negative values. What has happened? Being an implicit method, \code{lsoda} generates very small negative values for producers, from day 40 on; these negative values, small at first grow in magnitude until they become infinite or even NaNs (not a number). This is because the model equations are not intended to be used with negative numbers, as negative concentrations are not realistic. A quick-and-dirty solution is to reduce the maximum time step to a considerably small value (e.g. \code{hmax = 0.02} which, of course, reduces computational efficiency. However, a much better solution is to think about the reason of the failure, i.e in our case the \textbf{absolute} accuracy because the states can reach very small absolute values. Therefore, it helps here to reduce \code{atol} to a very small number or even to zero: <<>>= out <- ode(y = xstart,times = times, func = PCmod, parms = parms, atol = 0) matplot(out[,1], out[,2:3], type = "l", xlab = "time", ylab = "Producer, Consumer") @ It is, of course, not possible to set both, \code{atol} and \code{rtol} simultaneously to zero. As we see from this example, it is always a good idea to test simulation results for plausibility. This can be done by theoretical considerations or by comparing the outcome of different ODE solvers and parametrizations. \subsection{Checking model specification} If a model outcome is obviously unrealistic or one of the \ds functions complains about numerical problems it is even more likely that the ``numerical problem'' is in fact a result of an unrealistic model or a programming error. In such cases, playing with solver parameters will not help. Here are some common mistakes we observed in our models and the codes of our students: \begin{itemize} \item The function with the model definition must return a list with the derivatives of all state variables in correct order (and optionally some global values). Check if the number and order of your states is identical in the initial states \code{y} passed to the solver, in the assignments within your model equations and in the returned values. Check also whether the return value is the last statement of your model definition. \item The order of function arguments in the model definition is \code{t, y, parms, ...}. This order is strictly fixed, so that the \ds solvers can pass their data, but naming is flexible and can be adapted to your needs, e.g. \code{time, init, params}. Note also that all three arguments must be given, even if \code{t} is not used in your model. \item Mixing of variable names: if you use the \code{with()}-construction explained above, you must ensure to avoid naming conflicts between parameters (\code{parms}) and state variables (\code{y}). \end{itemize} The solvers included in package \ds are thorougly tested, however they come with \textbf{no warranty} and the user is solely responsible for their correct application. If you encounter unexpected behavior, first check your model and read the documentation. If this doesn't help, feel free to ask a question to an appropriate mailing list, e.g. \url{r-help@r-project.org} or, more specific, \url{r-sig-dynamic-models@r-project.org}. \subsection{Making sense of deSolve's error messages} As many of \pkg{deSolve}'s functions are wrappers around existing \proglang{FORTRAN} codes, the warning and error messages are derived from these codes. Whereas these codes are highly robust, well tested, and efficient, they are not always as user-friendly as we would like. Especially some of the warnings/error messages may appear to be difficult to understand. Consider the first example on the \code{ode} function: <<>>= LVmod <- function(Time, State, Pars) { with(as.list(c(State, Pars)), { Ingestion <- rIng * Prey * Predator GrowthPrey <- rGrow * Prey * (1 - Prey/K) MortPredator <- rMort * Predator dPrey <- GrowthPrey - Ingestion dPredator <- Ingestion * assEff - MortPredator return(list(c(dPrey, dPredator))) }) } pars <- c(rIng = 0.2, # /day, rate of ingestion rGrow = 1.0, # /day, growth rate of prey rMort = 0.2 , # /day, mortality rate of predator assEff = 0.5, # -, assimilation efficiency K = 10) # mmol/m3, carrying capacity yini <- c(Prey = 1, Predator = 2) times <- seq(0, 200, by = 1) out <- ode(func = LVmod, y = yini, parms = pars, times = times) @ This model is easily solved by the default integration method, \code{lsoda}. Now we change one of the parameters to an unrealistic value: \code{rIng} is set to $100$. This means that the predator ingests 100 times its own body-weight per day if there are plenty of prey. Needless to say that this is very unhealthy, if not lethal. Also, \code{lsoda} cannot solve the model anymore. Thus, if we try: <>= pars["rIng"] <- 100 out2 <- ode(func = LVmod, y = yini, parms = pars, times = times) @ A lot of seemingly incomprehensible messages will be written to the screen. We repeat the latter part of them: \begin{verbatim} DLSODA- Warning..Internal T (=R1) and H (=R2) are such that in the machine, T + H = T on the next step (H = step size). Solver will continue anyway. In above message, R1 = 53.4272, R2 = 2.44876e-15 DLSODA- Above warning has been issued I1 times. It will not be issued again for this problem. In above message, I1 = 10 DLSODA- At current T (=R1), MXSTEP (=I1) steps taken on this call before reaching TOUT In above message, I1 = 5000 In above message, R1 = 53.4272 Warning messages: 1: In lsoda(y, times, func, parms, ...) : an excessive amount of work (> maxsteps ) was done, but integration was not successful - increase maxsteps 2: In lsoda(y, times, func, parms, ...) : Returning early. Results are accurate, as far as they go \end{verbatim} The first sentence tells us that at T = 53.4272, the solver used a step size H = 2.44876e-15. This step size is so small that it cannot tell the difference between T and T + H. Nevertheless, the solver tried again. The second sentence tells that, as this warning has been occurring 10 times, it will not be outputted again. As expected, this error did not go away, so soon the maximal number of steps (5000) has been exceeded. This is indeed what the next message is about: The third sentence tells that at T = 53.4272, maxstep = 5000 steps have been done. The one before last message tells why the solver returned prematurely, and suggests a solution. Simply increasing maxsteps will not work and it makes more sense to first see if the output tells what happens: <>= plot(out2, type = "l", lwd = 2, main = "corrupt Lotka-Volterra model") @ You may, of course, consider to use another solver: <>= pars["rIng"] <- 100 out3 <- ode(func = LVmod, y = yini, parms = pars, times = times, method = "ode45", atol = 1e-14, rtol = 1e-14) @ but don't forget to think about this too and, for example, increase simulation time to 1000 and try different values of \code{atol} and \code{rtol}. We leave this open as an exercise to the reader. \setkeys{Gin}{width=\textwidth} \begin{figure} \begin{center} <>= <> @ \end{center} \caption{A model that cannot be solved correctly} \label{fig:err} \end{figure} \clearpage %\section{Function overview} \begin{table*}[b] \caption{Summary of the functions that solve differential equations}\label{tb:rs} \centering \begin{tabular}{p{.15\textwidth}p{.75\textwidth}}\hline \rule[-3mm]{0mm}{8mm} Function &Description\\ \hline \hline \code{ode} & integrates systems of ordinary differential equations, assumes a full, banded or arbitrary sparse Jacobian \\ \hline \code{ode.1D} & integrates systems of ODEs resulting from 1-dimensional reaction-transport problems \\ \hline \code{ode.2D} & integrates systems of ODEs resulting from 2-dimensional reaction-transport problems \\ \hline \code{ode.3D} & integrates systems of ODEs resulting from 3-dimensional reaction-transport problems \\ \hline \code{ode.band} & integrates systems of ODEs resulting from unicomponent 1-dimensional reaction-transport problems \\ \hline \code{dede} & integrates systems of delay differential equations \\ \hline \code{daspk} & solves systems of differential algebraic equations, assumes a full or banded Jacobian \\ \hline \code{radau} & solves systems of ordinary or differential algebraic equations, assumes a full or banded Jacobian; includes a root solving procedure \\ \hline \code{lsoda} & integrates ODEs, automatically chooses method for stiff or non-stiff problems, assumes a full or banded Jacobian \\ \hline \code{lsodar} & same as \code{lsoda}, but includes a root-solving procedure \\ \hline \code{lsode} or \code{vode} & integrates ODEs, user must specify if stiff or non-stiff assumes a full or banded Jacobian; Note that, as from version 1.7, \code{lsode} includes a root finding procedure, similar to \code{lsodar}. \\ \hline \code{lsodes} & integrates ODEs, using stiff method and assuming an arbitrary sparse Jacobian. Note that, as from version 1.7, \code{lsodes} includes a root finding procedure, similar to \code{lsodar} \\ \hline \code{rk} & integrates ODEs, using Runge-Kutta methods (includes Runge-Kutta 4 and Euler as special cases) \\ \hline \code{rk4} & integrates ODEs, using the classical Runge-Kutta 4th order method (special code with less options than \code{rk}) \\ \hline \code{euler} & integrates ODEs, using Euler's method (special code with less options than \code{rk}) \\ \hline \code{zvode} & integrates ODEs composed of complex numbers, full, banded, stiff or nonstiff \\ \hline \hline \end{tabular} \end{table*} \begin{table*}[b] \caption{Meaning of the integer return parameters in the different integration routines. If \code{out} is the output matrix, then this vector can be retrieved by function \code{attributes(out)\$istate}; its contents is displayed by function \code{diagnostics(out)}. Note that the number of function evaluations, is without the extra evaluations needed to generate the output for the ordinary variables. } \centering \begin{tabular}{p{.05\textwidth}p{.95\textwidth}}\hline \rule[-3mm]{0mm}{8mm} Nr &Description\\ \hline \hline 1 & the return flag; the conditions under which the last call to the solver returned. For \code{lsoda, lsodar, lsode, lsodes, vode, rk, rk4, euler} these are: 2: the solver was successful, -1: excess work done, -2: excess accuracy requested, -3: illegal input detected, -4: repeated error test failures, -5: repeated convergence failures, -6: error weight became zero \\ \hline 2 & the number of steps taken for the problem so far\\ \hline 3 & the number of function evaluations for the problem so far\\ \hline 4 & the number of Jacobian evaluations so far\\ \hline 5 & the method order last used (successfully)\\ \hline 6 & the order of the method to be attempted on the next step\\ \hline 7 & If return flag = -4,-5: the largest component in the error vector\\ \hline 8 & the length of the real work array actually required. (\proglang{FORTRAN} code)\\ \hline 9 & the length of the integer work array actually required. (\proglang{FORTRAN} code)\\ \hline 10 & the number of matrix LU decompositions so far\\ \hline 11 & the number of nonlinear (Newton) iterations so far\\ \hline 12 & the number of convergence failures of the solver so far\\ \hline 13 & the number of error test failures of the integrator so far\\ \hline 14 & the number of Jacobian evaluations and LU decompositions so far\\ \hline 15 & the method indicator for the last succesful step, 1 = adams (nonstiff), 2 = bdf (stiff)\\ \hline 17 & the number of nonzero elements in the sparse Jacobian\\ \hline 18 & the current method indicator to be attempted on the next step, 1 = adams (nonstiff), 2 = bdf (stiff)\\ \hline 19 & the number of convergence failures of the linear iteration so far\\ \hline \hline \end{tabular} \end{table*} \begin{table*}[b] \caption{Meaning of the double precision return parameters in the different integration routines. If \code{out} is the output matrix, then this vector can be retrieved by function \code{attributes(out)\$rstate}; its contents is displayed by function \code{diagnostics(out)}} \centering \begin{tabular}{p{.05\textwidth}p{.95\textwidth}}\hline \rule[-3mm]{0mm}{8mm} Nr &Description\\ \hline \hline 1 & the step size in t last used (successfully)\\ \hline 2 & the step size to be attempted on the next step\\ \hline 3 & the current value of the independent variable which the solver has actually reached\\ \hline 4 & a tolerance scale factor, greater than 1.0, computed when a request for too much accuracy was detected\\ \hline 5 & the value of t at the time of the last method switch, if any (only \code{lsoda, lsodar}) \\ \hline \hline \end{tabular} \end{table*} %% this adds References to the PDF-Index without adding an obsolete section \phantomsection \addcontentsline{toc}{section}{References} \bibliography{integration} \end{document} deSolve/vignettes/image1D.png0000754000175100001440000010735212352122166015670 0ustar hornikusersPNG  IHDRs?PLTEψ 0ͤ֙GI!EԞVPVDFhΩi(ms L7)п5SI j2eP/Ӧ2n0\u$Y)G$3y 0G)]h̀yԚ dF7K4f 'N x(hy!XX8t$L͸4 x!j-82I2 ݑj!f7h,g(XGW: (.w|NwrKlLʌ0׵"qPYƱj'7uX< ^Py40ؖ0(OKg?U7dؚ4۲׹OX[8*!xX\gtpر|g6#6Y:P k0/Jz0X/E[Nhi.2)!,?*VV/10NG. 06).uӟsqp+'x-ݱkt9ѹX#xDj<Lp\-YjiaJwiɟޣS IDATx|TS5HJMJ1LF&0ɐB84n "﷥u{c^MkEkCfq%`nsB?L&syw3'gf|>$t>Xh6̙~z h2 TӕMAdEL#[cY&_Ja!>r<Th }ih2@ˁE$ ڇPF,7Db*뫪ʡק:%I*K*u߼oT h,Xb@ӫ$Sթ؝dh2 п:& -Lb@PAzӝoſ+$&O|ҡ\J/Q|P!4>T:,r:[^i }*lZZz׿^C P7ܳ{&{ƫ}>1=;i?]R~PUsUzP}UU[A/JUg cWhvlb|ccK2t܃kEB}nu:9+=kkΪ歰$` ND%Xi :1q\)l.9v Os I}@Rֱfջg@>uh '<Kѹ7(ti& @ұ*hr:6 Md"*GO^~z'$tcI`#MƟ.}gͅY+h$Tt(estչ)QЩw!47g}_@#+~uݙ3̀RIn'p"mD :^|6  3x?6wJ"m6woB@PAxMzLܹSuYYce?$&|)g RYccgFp_z :2XB>1VWoлݙo:Uˤ? Lɗ|2ٝ0[ |{l{TYYWG` 6`zrtʌ W6vϘm4)huuII 毺 +s%@#iey,ҡl^.!@AgmAm7$A : [hB-?Rg[.> _^~u wXo+MO%{dP_=3 {cO&27ql :}rt膫Fܵa9wJP=Q 9 $t zs~IԪ^OW?yzzrd[+[;nINLa¡cto@G6]U#  ÕulItp :24&OW nilw5 DGs^3O{"OX F585Zz D~֡ (g O]AЕr 5@LN WOB}s@\81KvV^Y>pt 4CH>ATj1[$Aɉ^s (sYFiZhŖR(h#<h',=?.F`;ApPJ'%oFwOeO Сq+arbv!t_`XЬ;x%{=Ã8ԳuϵkRИ<b.AQTRRRh[ {ZoB|̶O]? :OMʟ.qe3ψ Q8fdd䞃7TS-k~;`L7rGO:7ӐO[Mʟ9G7 ~ mD'`.Yۖ {PyT~ vi~@l2nZ4䳧b5 &W_.`atqzD5XAKnه ϙrއDjh蕇 >|i-;#BFF_\şz l nՃ N VB@Z+ aQjZZD][@c^Z-z'.n0s?<Awԯh=3VO8נ=;e =XF~v-|]@L϶^fմqs-8΅@G~΂ sݿ?#yީ?Vj8 Ax'G'vJg@AetztT6OKRf }u(>Q} ౳*x{?=Aѹ% )% K#t*2an}bweA-ө݅9x0g СCrV;#ÀI0I[磑*~E }IXAA]jN#!@~7y~ :Ӵzptt}FӧѶdUGfT9>;mө :v BB<\kٙm h[[ۻS=x =oN> >aV]?PCu@"] :<|C'=p~/(+IЭh?YmuC}]}yTﳛ>j)0h,T$4Nz^$UjB؁4j h^69]i:;⽷Cn[jE-FxBiih:@E^>iC{>8L в<϶ҩ: p89:b'.d >LGL1䱆ޟ)T ?‘= EjG|@5\@a!yTOڌ1Kt iE Jf1Z(ڝ|:@4BA WVVt&NԿY`vQ|{q61g]] *m 6, yLXOWw:yZd* uh'<񨳳b :gB|56<ռ;ы42H g%s~S2KAKM@k2x<}y$tedd;#X*Wt]c>^񿫓hgBc>q4oGZmjh?lZaOx #w =wgMM4DGO"@#:@F[ӋzƢ)e- s\{*֚lc)HmA h/z+l5X C|m-?) @#G@dShY䂱SFiCD'::BpIvn}ʃE46O< ]:4SQaBJMP?˨7r\uIʤN(\2Wqe?;u$Df'tluD|ĮJW$ł%&~t, {xePp<0h/A (% ntO $ȥK,ə-\?hQ4UK`'wEq PqL++cCPԄZbI+Nu劎tR7!>? 25Z'd<^jX?hZwL@lYwX_ p{y~h (L=M"IJMԾ|퉂&Ol~rH]T|3f79hlZe<*g 4Njtu .t k {KҼRh>DI'䓉&.sh]T|dãl@/{u̩|F\L NX|*x^18Ѥբ++5~l_b5' z𚖤O]k4:9ԍ;?#fWRdѮdvQ&Z<2B :>l(hOZ{ԉfD Zڗ*J όA>Cw&:]!'5;)={AcϳXA;a|gmm- iˆ'uPS/FРNbjA:**3wxtpħx%.ttt2ꂙ#\񧛀sί휉H(6A\E L4 (֯w"4w5#>-!>?f&rZZ>xzbF?c*@4%} OFm:B 1\[R9VNvUWOl9x -1gK:Z?g0Y}-44/ل?ktw2eRK)?Z$x;9h}9'ػT8=`8G٠|7)VG@>jЀUYZ`TŅ j=:I?.x[MtrPb-Hmm'k+LzD ~/n3-{4E$dlJ!܎ԟ4$.ͿƯWd ɦqeZKܒ)7d$hLE"?]`&HRKm>;޼2PwP}dAj(18 I $ef'mqiwjQw&u^i{c5 IDATkFe?cww>T$I1B5kg֚Bk771QjGRmݵIȟ'mqR2Op7gQ]G[{v`=?y8[;L5H ^< ;ܥk~@55AOJ:35V |#;[g%E6VP̨dsvM^<00АҿxxصߓgU OƄlώG(pzԸODG5fYVI u Aܧ)]X'? :[yo9k󀆖!)& `9›S3S{Rt Pl?Dwt̓ چ{7axifdW@Yy+}6})&6>33*1wZ@V/hl8w< ^hM@u(j#欠GVAu|R"oO9 2%P!S: {v*((ܟPA|Rq*yL1NJvi %x>vgY~v^i^v^ⳬ&_d(($VP(x#dR@Vޛ}oAY6|Ggo3KH,LJkx\~_[䠥m `. L`zPD?tymٸ/Yӄ` @xƹty*([1Imp^^/uJ@A@*׶/e|GRj3wJ@Vf>/^ti.47CqQ8ukHEGS{)5<fKl4K첼|ZL'(P]JoؒgeҶZ8{]S>< :gpR)NrOCYչ C5QqNAM@oiKK/@ܨ7 |t;tPH/5Ch(!MD˟不 ZF&ж_&0+F~i(7/ hF t3B |Iӭ9G]WT)h1z>wsgOAhgKz'D (,o J跀 ]j{>7PXg,O}6켦KmyL5N/l|ІB{)%wK {/-Bx'4#wbPg $l1VƵd./!eеe`9=q{bFV!Rjj{qӓ{G:P[iɞ?]xh>TP~QkƛRSR['!'Л/<. a}D@1 fǀ])?#5њ( KAS?L#͓PB p$>l(|W{&l@Kw.e@#_<"rQs|xDi%H3ߕ vD@.=Yc:sA9.t[t[A6roqQCV-@utA!O}_PiBq%ؽb(%X?V`07a@ŧy.=hGx"&\uRG<>OG.[)1;>4^$ b@#PXl/#GqOtb }#hK\&y)Gb,@zRcȒU'!Q$F =Q"R]((wħYwHzj{B`  & h/PۏQO;[*E¢ގ2Od"{m50{В+';t9 O&B{JbnxtO L@CgOŖ?]2ѢA 5M|0gNn{AMwpWR$_xzٽrџnƴh2??Ur0o^Q9Xz n!nO7|L玽 (CWbu$>_01xkjaOLğ.J厽(DϹOL҄1 n~4ϵ'#ŸyLh6U4p1MޡFCqey۾yԷ2wEOjd,MhCC 2SPvG_Bڎ!OsMv_ǀ!)w6)47Xz"Kcf$sP"gZ#1>??n/Q,s EԨ}/~[lpR9vNc1>;ɜl3nxȔ PA 8?=4Isq㒜4,- q 89-m֬@77#ʱO. @a0Ù&P TFXX.Z$I ez'pS/&O/ K?rh8g i|pKD`Hd|CC+Ȥ\.  i2H?=duY|-dEG"&I/B&Sh@<,AKءaOBG˟4-}] P]'=  hZ%a82iBGΟiRi pX@?tNl;t ÖqΡlS?]4OHl7< LOh,۱Xޱ/P&ySvv4KƟ L{p~8MbS|4#e^Z[x;MTAck?/&<c4&SKYHUơsT8ԗ+}7ilooC?}qbn9 &vn@?lP|#>ۥ%Gџ~jl*.}Q4SN !)->t`r-0 SoX>^ e9Ppz4ܻ+M?{޻gПRً63qkl26)nftL׌˾R4{e>ڡ&mП4C&7wmZ4e'lR6 )^3$ɽR4{eɏHڐ$MCJ[ʔaS*ʤ62MLjS*ʤ62MLjS*ʤ62MLjS*ʤ62MLjS*ʤ62MLjS*ʤ62MLjS*ʤ62MLjS*ʤ62MLjS*ʤ62MLjS*ʤ62MLjS*ʤ62MLjS*ʤ62MLjS*ʤ62MLjS*ʤ62MLjS*ʤ62MLjS*ʤ62MLjS*ʤ62MLjS*ʤ62MLjS*ʤ62MLjS*ʤ62MLjS*ʤ62MLja#4sCvr / mĦ?e؇8FpLnM?^b'bq*c+a˟rELPmzSiqs&㉿{9}lzS݈e|I&lzSaln9a#emzSa2m\Zo˟G :.COY#&m$M/ʲ1w!COYC2)@Im PeRTԦU&)@Im PeRTԦU&)@Im PeRTԦU&)@Im PeRTԦU&)@Im PeR[R'(S%H\LU&f_43dSIlI͛7w E"#-U6nBZ2ݱcQ.3 \w{<n{z曟#]]G]Ў#]`%^s2נߣ*QrkQUgG~G :%NW(xE$,tΚzj3kVſӳs2m`@FkѠu ӃJ7ҍ:ZgQ݈|f].:%NW[tUơZ8_6i=  pf4}"Z׃k@h 909ހ^)VhNldlE|&#eɐi:t\&ί$F<&^LE =5Yfˏn8UeZX_Wo0@A1QJs,Hu;B.d{ qsJ9~=OMTs^;-&$̲:u}o·"U>?0 6#WA:-\J{]KZF ;e!>O$e"CC]cWGWZoYӗòybGsP* 2YXjd{1ګ`RAG-98>&3_9AB{ʽ$!&TP5c5~wg!Wo[^hW\0t`8 JhEjogx^T׃f,anh4¥qt4u˨agN=ˡ10BWY_.4Y^Y) zRBZBUFVgՒRUR WJ1|k=rNvGỒx2o 3NlsCAc99䮇BO}k Mo^qյt+RA( 5TsP" uB ^AE z^MћXf m*(QkX}kUFRЬ{.؀2!h MC^ *A{!蓂:A>c. >|m,f^t칂 <Y-ﾻjd:tf׾ ,@ћQs*y5ӹxξ=f~Hqs YNA4}|PPj3S'C 54kt3jj&zL(U㈁Ȩo[{e#6OM9s'$?:nO$AAjG>êB~ k(!AgmF< td/cw;(/c|"/&`tZ~.S_?'uϵ|wEY_qA-ᣘ(D gQa*j,aG $>bs(/Dԟ:Ǿބ,&~*(*_ͨ[At`m{SbVu*(m$ݣzG _`c\^u6(;urQS R#L;oڼ Q AH1#K=$O0MAxNœMcgAB#Gn{OUu->GxhU>x^PP!vS GaZ\ԇ?vOl&:"hx91YWo;x1>ݍ6(c |-J.uF͢,E2k;F)rN25o.b2>@潂"5Zo6ML^X|&HDcAL:h9"ɡ!g-huCOL&<?i"ײY^l}RPz#\ ]?m oW4jQ'J.b'JZbފߗ$qxR7j,Bo;L"Po(p[Nݺݓ+ %RiuliisP5ߤOhuc;(Tj2?/OefD =IVA9Fm˭~ۖ_c AQ!U/Ȭ&tjUix=Qe$O4F)^i"|I|I-ttuLA t_ ZFyD9*!jLwExЄb< /&Q 9(=0O^)(U($-tΛnXJxt9f7yF:UfD/o}PP freT 9(7g:tw3\9(ص?G mEF dZ&@R9Sk\Je0bZ}U\=$*[K4~2ShIh} }; IDAT_hk)%qōl " Z:eatKc{gR &qQ Hk|H2M\8-M&9e5E͝_XuۏˏZD @FPfzVUҲxS$E[ ÿ}G^VVŖg4p~h,=ӯ~ N j* Ruج/e1d]+ 2M8r(\41!/l[l0,?U&g \{Z>߬᫖Tq8?.@ @ڜ6%f *LoQKFt"%X/1Lj&Eb%¢P7xg ՞$ݎ/F.Ћ9Fz.F./uP( _jtm$-Ք?d9^|&k3um;hXeF7Eky&PhJE4`fQ429|S}'Ye#0PD=^KôF4vE›̾qݑҳ:7[H/޸Ѧt#(mu?n>""1j 1A"lTiN1@,=?#<P=aԐ{uċ}ǂܚ'[̡/^\bR@mFhW*Ӥd}2[K~f"ɳG>ˡn?%ILz(2~!}0L:o)/ZcKNX)э֔ɑv$(7(YXسOԎܢQ,ɢo_ѵ|mG@GQvzAYQ!T}} !1=}ֿjqxv>Y.gk0èXQ}K\Il]D/;1b[e~|/cq|!|!yWnѸHqʻ|s/uS*l>Qf5'(/17UPV.(Ư*:ܙme?j ݽcGM[>ޢH"u U<{oٗΔ|~r(DQ;s͠ru9)ò0F:|;ԩ6 SLmiyEXdx)z^*(PKA@_rs+f@D*JޔUZ"l^)z3=\RHFoo=Ьy4+4C<bO=kxS222<ѯ6F}aD OURgAm(h=Nb%>/t Yh^MzKD~.  Wft5B<9 O_-|,NA?`Mٜl/QR˧ƎT-e7[ tAD1y4o`ư%0&'zved}\wWœ29E`!|~ d# F&RHeR97c9x/?#~B0E^vN͹l6ykP54d ?3o-:ݴ ,x\(o.7YޘS8%ړ(,a3O9HD 7bSV?E2 S'^nZab S~ӻǎ ,-mz@٣ȁ_݉NV~c j5aF0e9"$ƖPKg5W (v1#$m 55 4삥Zg@ G ZxqK9[s$]Vj9nX盤Q_t]Nz%RTW6sNu7&_nC3ژL(gB #Zp' %|cgfppMPOK^JnpH i M`%LoW \Vc"wFX jrPThhB:׭{pʡܟq|#ybzZz{NPFӢ\ڍO'պJA Q.QzcKZ%珌5QxLryXwis޼u_z^l9.5bzD9 1TKDbZKɰo+Mltg%E`2nI5|'KzKiL{\0Bh.(hoo7ٟqKY7/_OdJ$/xZ|ܲ Ow8R,1ľ0;4{< )pgKKl-m^|k{֟ r M@uc]+f*'I#<,&Dd*(:&&#quJHclHq:dRN3Zd{g߸pA G?z#:ye՜&{Zb=JNZK6L |S蜧/-&lDN*:?(Uv%܆zl>i-d[Ö0|xWϾ1Bmmgr9(}jZcΉ7س}uxsZr>;UDoU&zJIPKy*|.qƽu0dhthc DtֶOyP[ Wn2s'9O,ٲLLZZk"!}tJ%KxfljF*ԞCUͬ"aFxkH56}pffM>ӧ73f-[Er*쇂r!ᥥFtq ks=H&RčTHHN¾NQT((#x!;4YDBɖ Z񞟿{+) 'gkzwKGNNQQΪUOSS3;@;TcNɶ#1 )h6E9U2ӯ0 0R,MiɍEiJH6;Ex%fcw{z lݺcv?xsUWC {*i]ŃnneH;_Xrm&ݘ]4F-b<&%(Դ뱳o & j/ΙpHgnx^ 6ON3`WK 4eζGAzZkH7uAC,E :)(M$,؏|P. :bL+sA!UpS@[1uG3%d,\{ZoGOB 7;Dt\aO-Ax^o5 4>閬ɸ^2xۛP7cU-[V:rrڀ+?iOyLPO߶\&pE814ʭ D GCYy|~1S;cP{ cq*:cP4x- ctDws쬓>CGwF#o#ƺYbrGrՠUד5ۣlurlVϋ-L 4Vf7A!P-Pf?*Պ?/]7t^Ӻgݺyֽu𞢜7 Pvo {BI opÍNBνjrXLо~Ḿ[jYHI"nd"U&+%$v>WO9@D*HEY5C\8_(BraQn8(={=;;={~v}%%%{,ڳXVqp㌱c˗;ul; 1.~mˍz 4@Ufx,үP[#t$~WP rJLΕ26leŐk΢\ԭch;Rv]W5X].3Ʋn]uXV*Pch[ZszXqIfZ`PPRd':Iů?9dkEۈ *{@50D^t([4 3C(xN4, govݶqW]vn=;W 0Pɦ$?tg[/S滱`Vg4HiڀJkGsSgoK|wO!4x9:!iw@>\<.cwÄ́|%}zmxPO8~ ,>@>_|zCC}Nik u=.F=, l6BjiJZ=Iu$B"T wB/lo{ Pb(Onyc3 |B%>v=jDx؉bkr1GB}3pov&{F&8!SJO( mU+$dJF e1eTMAۈ Rd{;b hƅ Es--׿>gN8…Gι?P1OX<صĹsiٜKj<23~ťU@=A/ue"132 HFd%qTDHtVjJ3 (z^:c3)(D &#Iin5Mڲe59[e˖5kٜ;if{|q/\sǹ7Wy6EY^]5),.\s`:ƴPPYe2EYJW)(Ϭ }bpmtQu: P?aZsū./Fxv,;[ -.ԋ _AB)ZbϭNPQe'Q4k~֊=׋J %QZ1L&䥶/鿙YWPsXC"x O l#35~2QKnGog@>;Z[A [%3SoEc PPW@ꥂRY}(c|T_\~ͺG1q] EnCcQG]_O j}Β Vvv;kF?Fn^\5BlɺQQ| uM5޽t?`Mnnlh۷?e` ,lZ IDATdޕ{6N@Dnz1Ҳ_[z`yh_Wߺ6zRe[A-x!dyZOK3 dMNkŅ8d$U}1 jkiin%`2 ˲g>HnX2X=8dOobsV1kOA,_lsE(l ))lt7>($pPld)SNEԟ!z&>~o.&'iFgc<۷Å'۳wƒ]ϒpypz]ǗWQiXA7{59bC-HAcm{yFsj':f- Lɶ[)h*SICXjOVG ʧɧ=&]vgx"KOK2TЗY[;(Z]JZߥo>K_8ޚO$OfkȢ9Ydhm4JENI}?9SRQ&!Ƨ|>j,nxѭ'J%7nq]'fs+˫W|Oܑ$8n^׌Vлc`2%i`NmH^o"`xҧPO9$߄pBB,ɳ96MFigfnoBI&iۗX}UP9Q.Č[B h m‹7.Y۹s;O-zg͚5O9{oll{{Ͻs'^nn-]t܁ߟz;[oT94(q͝ vAVurK[i)u{o3hKMȜ'Dxqnwt{oM[SQQQlqQ dU,XmK^|`gA.ͻ_zjgz:"@oVPl?+x3-(%GݜĨyQ,g,_5}9!xT߼ fg$E՗9GTD-N3zQK!cX,ĸ ر3k6gf銎[B:W.Y82rsFFC }Y:+xVœ¿5|a}osz8`R[S>wWP3ZOl3=+22AKĨ4s x-[.eKn==7xz_j ^jNo6>HKM:WP{?,.}b{MPk K$3%-z3Jg  ]]\s1 ԣ@,m>>btSQIӫPC'o3ϜTl4Ѳ&jdmK2MecՉsg qѩ: k43!Z߬=]$.{uMMiђ%XV闬Z[A<8ru/^wG+ /0VA єaem|0(zI J[-6)J+dE%$z;oxa-R@nn֟>; Xr>]Ttپ}g,?ԛ(':y9hʫz I5Żꡀ¡ؗMrÓ>|1DvDf_ϑL"ӸEG~;4U:ӻDNM(5(ڛkBP{%8p=?Cݏ=dnXyh0Ϧne 5go‹xÑZ뫿Z:sn@]6![nDɸO*Z%ܦkv_*([œXUlӝvZA-JL{s`XD'`xT]YC{+{WoLB,Ϭ>wnD#~яYh&MK !U'X)PdNnIm&A`#2LOӮ47%ŒU)631S-BP;UWA(ozge?jxd +z|[a/4wX5!U$U*(<p^zg{*xNШh5&ޑeDoJX&$F9( 砬dr=l AށO-׀⽾J~'|g?_VDG+{|E|&1fG jq385LfѨc"bxý --8#>|l& gfmn,%oċ @ϜY3Fh7oLfd84rPOIYPf O,Ys-1ru=N Yx9$W qdj堺!~T^A 8RnK/!Sɖo.v֮]P|Kh%d˳v;gηd[9rꍟ*=<HA"n?@m8 $H: .apT7C2 $ ""ij_@ws[d6ɖ6m ~ܜkҥyΖk{zlYs򚞵=ɚEEɹgEo \tb՟݉?^u1 'B4s=PQz ~S)(|&T jILH%bUSP2ߴ;zZ?wI7*$]ȺL {7/2ݡ|S@Yslќ-ϵ[WVN $'Vp, K)Xh>dgqoުoR(>;ՎdIvK|n:}Mkl)|f s%{s׃D8|-bj'XA!q& *>{x:'C[m#GZ2$2 B:"ыd} ([ J["*@m}exR!SPF %\@Ao iv䜳Ek"<ٳ眈̹rKˡbb<-!ݹsYYA ( (=р/G^yb]u6cq.2gQy%(ZI%h>Щ?}QQ!^P'ĸPLG 4lh0W ]:Sz\<@A+.\mm@KPR=N'Nx` i3 s_XuVzBA0EZ޺K_X 0e)JA۲$z9LVYu[*%DӪ T'V4t +"82WL+s-i^5ӦNϞ G>O *఺ˋ.dωsiV6A)=ٸCVl.w0S==(뼯[I 4,V5$"UX(EZTk!E&ӌ۩;LfqGc%# #$C5bQ]Q$4菞νwEp߽{r_~＾/.n/bsF[Υ ZU'&չ+myİ{\3$*Yj' TPZ|L*1 1-P!ϟgch4Wjk7R5ξw'~=\PPpNKo\0LJҟCUrIUDPΦUL i6<$W2.z@Oއ,y/`P)C\Fvprƍ'sֶ]{eh/7|Ko^7^z1E2m^ꟺn\)ʹGuO;' {,X:I']]Rp773ƬUgƮS[IvL/-j3jD"eRĸsĪxd.=h*h"h ---C--廱|l0Ī_<5%(hĦwE?n!Y OG:CPQ~ nO+'J.s~r Ƥ^T-m$I+T *RvXU4$v})'QS ! zb툐#GƗAN6}$(mb VFPj ?)_ढ़U7O( S_DCAdP(ERPj6jVPV_壅*<$Y Fa0!CBpSM6aщG8E}to_:>޶mՅM:f>'7H̓gѷ _=ES$ަ9toLRʖԨT5J~VcNVXM AM~sgɀOyۤ7 y2p7!CVnJ*I5smgFʶ;斯4EU7!'iihX ScW%JGUF:.5L"/1p'?KRvdDe5<]Z!A`RfldB- ZwFκc%ٛ JEfe|p&HPmD;JRM *24] 'fO3E?UP/~Mz[Uo3:9:tHM'[3+o!$,Dm,eÁK]B?Sa 1 -<&"'ORAә:@JYYEWϮ=ک!+"Y[LǪ|?Y ~lONASou!iOL,e :trqF-8comh*mO%+fT?2Ctb91o(F7ꀨRe&>qu'"W^Fϝg 2:!Kx:J"$d;k9tLH>G_(Mo`BDT0yJX =׳_-|@˙I5fy2''MsₚnMT73Ѵ +t-^Nm'GͻG!AO^  Ha2 rD5d5|Ъ<"J'dPBb_wPAoZ]} Ĝ鎬kZiv\}0#շ1,S'__Q$'9AC-J{<PS &GHSj@R6JūJWd)!ūг**$z@жr8+v4W\6U~4˶M34AcNT3R첱mA=TReeZs\YxaJdXuV_Ԙ-ï| usjOR>nY`DdÑ[nZdF%5G]jI*9[Amkni|3|@oRPZsrQ aJA[jP[*UkJU(fW}P(+ f&'gG'Ugye\: H?oP~qyhF.KF FM ZGSA6;do{ mgeRIT>Ў4Ӣ!>A ]P6z$h) $n(SS2`7P/o~J)(q>|b3=~#{<6TtD.XҸ9B{SaNK.p/=gLޖTYoQ(3 ٴ ORmR2 geRIN\W:ŋO޺a`v μLN>G86:?#?&4N1$uD2^" ;?[\~b46((*Д]$"D_A^ ETo ]& vRrFS8bqdQU)H:3dv7`CG;s@|CCxr Ɂڬj,y˪PC+2V$ TTXDcm[la3v@~yt uIDATsiN3&@NSߪ_%,!k)U=xIANgܹ\ٶg`-LJw}g}~GN]2F` )) ]Þqk&ϺH3FAˑلy }tI1ud{k@N@Jv'w`T7ʢ$L_J2P MRAye&\PAi ϳ~ى)Coud!Cvэ26w b`I7oI1J,b:|?KAAzFb;_+ֈ0k\tBA=̏/4o NL;<#V.(UU4G&UDN!H D-^mhgMQ^HnMNI)C>%Vэ}  &^HA{0~wLP jZ0ȋH?Vlk($/c]-kK3CtSШa16GDx^dzHWIe2JYjQh ɼ1+=sڏ7sS?^'fዑO$ MXQ2 %":R1\GbzJstx #Ak#>hJvU#n+Jd((L/L<3OO|MPGi'h>:'{1<A+LN[Ë(:~b$7vu A1^)(QMXQTb ̬v˘W[#g̣D ڴUBACLA礋(j&4J#)*U1ʏTzr|w!͟Y;?~clޟIdXzס ڸYwZp W4 jߒb)h1Śa;pgJDz!ێsNG{Fw Qޑɸk{]9]]afy<1? LPRLT <O?}[;ΜY5zfzзuy GX-v{J?'ɦ@+QY$l"ef`h$ݐ>|dDbc(6_ذ'BecT_Sc\3GJk:tj icW*n 3h/EpTqAΠ&C.=A |yMPN]{,:PXt-5A:u Z;Qs& jhj& jhj& jhj}tVbp8{cvsNNYw> endobj 2 0 obj << /CreationDate (D:20091121151502) /Creator (R) /ModDate (D:20091121151502) /Producer (R 2.7.2) /Title (R Graphics Output) >> endobj 3 0 obj << /Count 1 /Kids [ 4 0 R ] /MediaBox [ 0 0 503 503 ] /Type /Pages >> endobj 4 0 obj << /Contents 5 0 R /Parent 3 0 R /Resources 6 0 R /Type /Page >> endobj 5 0 obj << /Length 18042 /Filter /FlateDecode >> stream x}K.9wռ;/o{ $$$ 1# 4R"$>^]NBNwAsVUO^w/믾.}W>嫎]_?٫|_׿/_9}+`,ھ j{5k>^C>`]^ [*8}༝]d]q:[#{F~G30ݖྜྷW\xh=Ksi>:y;[?;"=`G%y wo~y>مQT} {;=WݷvsGX럪^ֱ-&\[^QsNX7ot_$ otܝoo[ M]oޢ .}!(o;Fo48, h]xGe%YV.NE3waG#Ň|~af Y|_sTkpw ~¹f԰%9 6&GAX|8VOƒ!ޱ uTÝA}F!;"KR A}{c.UԇPA}VխsfBpT~߄S_Tpat`<˥ ԇYgn>>®^8؆`wW BP]Gխ[A}SpoP "( RAq+oO A}F8.ݏIV}P=$} x\38>|.[[KBP(gKwa`g.\ @M \nBwW5BP}nӴp0 O/܍b+ppl\Aa;2ܕqK}A X/fbg>ʭR7ps7Pp¦}? ̡΃q9k AU_Z_/x2ÅKBBFpD \X|/X`SܺpH!1^b.)껃=eE`ot!oy[.92ugPI呤>:.Ǭ_&̹0g'΋$6.oMMo/A}J ) )5!oBR A}I_hRB!OԷ]"m1& kl9HcNqBȓkOId I}Er!oԷGR';v|HЧ踵k$@|VPY[jj3b}Pdҭ*^tԮ׿pAHᆐC ͨwnX"(8/D=5)LR LBJ}pKᬻR_޹S+.GBb&^4=;^v᥾ъ݅vnCkG'{V)3z pץq)G^3; p-K}hRkSkѺ׬\FŝW7c,I}Kr(1f†_К!]mQC'Sy!ɫF!{ѵ/P_ƨR. ^x?K-Ƙ=?39V-55;Ξ͋]1ܘxh3 ;s\ lU;80سـR<ndj<>`fښ_ɏ}h 4Q kb "2OLx]H L zz^ 9xkm0T4#L-z{]S8 >M 0p^ >֖' ^ AR0\!Ubv[ZA͸vqmd;DKȮ˘e L!rzʳs<||*ދ;}7V٤D27uOǗƿӻ ?T;ԲvT1+=Sд!u$i ]lﷰr˄Q>-!9 x{<C~olh\ V޿_O3S+WQpl֦14d`4Wzk]&!Q|ZR^xh}_!4 aCrq#y$%Q|)O/K~|z|uG"1tzL>S|Zs|~Qɧіtx=ŧF? Ol`i=N{|\ 0pړ?1jFbi&g>pп~ߒOK&6ی7gCNi.|Z-NG~|ziC S!6ÀO-z|Z~H>N ɋC> O$<Ыzߣҁܘu x?xi|z,wo6Hb靏%C'R-i?oI>|ηN+q.|ziߋ{}i!{o˟sN4_^L>ԷS+4*}l7鷒o:|:i/6p|zߠ/aOyToY h /Ǩ"$_xz0 H߉l'2, %ۛi8hOSMͧZShSc鳞=>ԧ'?MV.SgA7#CL7Y˴^]?XoI>#Ǜ-Qȧ_Sӫ/"ӑɧ⃋'OKOGo.^? ~&>2n 7]6IԆx%EibynYS g=\[B1)Nha0xH_>[C,ӖU~S!Z#':->q>J/aL|Z%Ӌ|y?iIr=b)bL{zxi??i=.>uCC|,]ܴ=S[~wJT|hOGO"yVwRoci8Ⱦ2i2{w,$F~b<4cg<7C<=Bzɉ>[lnis| bqOA!y| V<0Z_-E|'/ퟓ7xi>*^LEO~ ylѯyC*φߒgzGOmɷjjb˧5>KS_J/TG̈́ hxf;ԧ庥}O{ߓIb%wSw𲾓O{'>ŧ|W7&?aTךL>/iMilևsɭe0ӕOO>OpR~,@}R/>[A5ڲ'[|swʿ3ۧS_EGL|䊪-OL>}OewT5_?()J@%ߐ?" i/ {OjӞ ":W~>s'!TK¨cL>MTwUB4Zo=+y0hH27=o$=ay"JBál'HBEf/4>~z>~Ň?UCO(uq~{w~%{´G|+ %}GA>i@+oCo-א?3XQެC n%CgU/b+"t{QpcwnAWc}|#v4aߕWD^Mc'n'l5?*>mGQUɧ^&ywUa7sC ?jy} KWb"GM{B̿x?L6c=-"qS=R2pA1EK'T.. f@ 7#'[ް[駈2)xphz+}'Dh7H^r4-T(-wxӒ}E参֋c[ ADkiGm{bl/)[3O|#ԣ 洿PUI}#T銸\5&yfx.G!778~GՑ;ŧ)j?̐{+d|),ɧOGreܴF!{mDk:!{Cڀ1?3>UL>-9G?-_j ܯq}_w< Ob7`OmogP+%?$il/]KI<5?Gy<|Z/*}oOp/;\{|ҶqQøk<|^ci_V쏲:1D`ʧkd[򬿯Qim}vqxe<,x#Tʒ=A.Ɣ5dxw>Rf6Wȗi?m!M㧍[ttb&pSBWCl6݈Dzo~_(<;$aA?xպyov˧=24vA~j I>-3wRMQS`\m/.K*}nvY|]j]ДL&gLL?V_Yv0tmwI${:$!W~ __m_O㫾?'К_Y_O]K׍yvퟺdբ ͟~q p=1%7v~*2OG{p?퇁~z =݆#3݈LE/}"L3 pbz6#A3y`WӸ0~|e?ҭ |ԟa/ #MiFh3FhQ5Iz%oG7nB30RA3LnR`afG~2#9l;e2Cuœf3phʬHoN</|1FZhqt{Z`$giOdb^dFFr[j^W<70h`v'߁JͰO[WGchm ~La}KF|?RzeT6S#liOA=`lG=)1%4(䯏n 9gD/NrtŻ#{%F!Å"3x(~%f|Hlf~ԻaeM{ׯs(>1xؾpMn| ǐM30rj40az,KTTà#}>t6W>8:PF= c[5jBc >]jqW%r>TC$XlӚ?HwsbH9 *9 j6>(R2xwƣ8q!nE1v9g#ݔUJz2t * ZMsnJ[m[gɌ6=ei-q_v?f Oì~ޛҠ͐]A ҠF}c-YSԘ2v#H iu34(iL+u*tW|˓kb=@HS-jڎjp7FL3Puvg,V=WW}\Օ5WWpbӕ5r?r;TH~?4av|w1dP~4ۘn!qFaQx(LdopěٕO@7ڕU/{ SyCKv.FL>2T%_סum+isY`ȧ-U.6KCUZ4(oW^<\ve!kKʧ=X!f0"OӘuOt1|fu2vq+!I mC8LOl!1WCv]wZ0SElzr"1`ȧp+C`|c`o3}I]*pS:7g]O*raL#QU T;т0t8xxE.J< F؀5gx|ݨ41p$Y|*>z7`}I|:f >#CFΧw#T1s<EqO o'nߌn(SS5*>*^:xU}Ui*7r=LeI3`9*7S_L4fc2 !1t>G6{El=a-lޏujsUR[Cw6J|8Jg:J}uT!/\F|Nku[ǜ?iPЏ0nÞSZ]6oחJ!O,R4 ZpY`v0tϯyiSKEN}?*Sټc<0 e l*j6>-a}_RG^^*wꚃO `qY$^[hAi@,9b445Oi XhtO|aj+Er_OzR*A˘uEUכN{N5i >mΖS0 bDZ?J$N~*:M{d ɧ. %_~C2Đ|C˲)yL5((LSnz?ɳxO`YLɧ>d~S˼abW2Eylc;O.CߏiPVYjO3}oB|hy=B1?U4噐?j\[5NS^Aa>b bq$L76#4!c#t[ |ɧN#|XU!~әӖ?j럛=f >͢܈Ue;+Wc"Nj >t|g&6$/o*^=쟨[_Ge^`VOya5Ua9=6)b=Qmfc%דO4(<=ŧ.GAE'>S|0J`Oӿ叚ioK|mTC:[ K^Q''Y_sBOlC.-Z/'vߵvo5\6f %>>5v3 s5f <mFclҌԍ?_4TU?x82>ٟQ#IOQ#ՇũOQl?^_QY_9LZZ@Gi{ˑ?j:igY7Z>{*G7e?^]ϩ5A!ylg;<0 b_7vg?TϟZ)AQJmO2 nkcgKI{,_^全|||?ai=L|?:Kd|?bJ5׃O#g~Ek:ӂb4x~~e(oXri14h T2gyJ|M/ۇ*s}/R&=g~#5b-:8g=?`|:]ևe/ES33}_%d;S+XF|zHhY-lg6^iLao씧GnJØS1.{_2,u.~ (M}tcO0~Z|?;go*Ğ[vб/(OQqqjO9Kg懾W?j[|>ǫ:[[>iZS>oi`o.t0cuDZƔO͗̿hivy}䏚N+g}H)|.{m7Q%z^f:dOIm˜SۗXRpt:Sw/G3^=Z e/~#Դ?qTx{OQ!>zsOwQe XL֌oO OTyȐ[1}H\%|`cʫOa($/[MJ&}$oH"}?_?jiwP=Gg~c}+̧Fe?*5i?&_Q0p=>]|ZyzğO[>zj]|K'y1%G??l_|S.꿌ۏWa}6eOhG>mK +ϳħ.z]v=?ֳ<`*9|:S TZ.5H@/; 'i1 F02ۗrm[_WB3q6?O6z0w{Gv0Q3;14\iKH^GLéyQ_~bioVVCz~z߫qxDhK9`o?o7aw8&V30fGzePM'CJԀ5F0=ao} N;e=g/)PO70Ng1U_otcG7GW@OS?"%}@Os?G͙gH>Y 4| fɧo|*>3SQXxIT - ߕ~+OK|s@>$aF?/H7n#!zWO]=%U=G-2sccNQQ8:x|Mk2ǵw岋cSK|Z~0j9K>i>ϐ+3ocwl-%>[W'eO(֜GMǟj?%yWĶJG|cg}XG=UdM~^GM n_qH_MlWVM>*7yU=O[j)Q+<,&_߭&>]oѹ qS~!}gTxu>~(kOOLMu(>r!pSQKqQmO?ju`r>.qbL¿DK')Sƭ~KCyԜy}*t}>Q3k>'>ij5zd>3~ aY WŋhߢOG SwTiڣCx/`ci}Q ~Gushr| 0*{乻^H[=E2WadOG{0aag\G0T? ''LOW, (dcvr =m'oA3Cǡ!éOL g{P#*S %S %\4Vr(y!z((yTTDǯwJ?5Po#MQ?JYfP?).J/;V!W$~EwKL=t%4~y?X]1M: >YGO>P럨I?PBh'D0LvLzS&Ir¡ A + bS3f1g4\uqwElQŬun|{~I>IJpE|8\b1 :\FV|nTٓBb ɰv.#WNx[nO̵ۙ&IT#_: Bk0觪,Tsk1 ţCps15OmxɪV uoj= 7:;&]͸զ'wȕ̈́`C}^4)Dt0aU Lxrfԅ&;_9SALXԛnkGxN GޙҸot ʚMO:prڂζv-76xRPS ;f<'3.?ΫͬIqR#-xplwt+&L .5QLUjx;_fG@oJ 7]$87[fwlfkOcI@87],?/DZ~0(lc6<ܝ˰jn GA<} ajӅXfDATf~al֮gD6Aȝ0#˭][gKDr I=*,\ XD X`!QM ULkA}a^Ӏr9$('AP_}giHs<I}\g=;-@3gf̾A}͞ ̚?=#k>3 kS;衊ZC[. Wa#O߂>ŁMAP_V?З\ 1l8(%׌~[*t*(qKۋ sq2w̓41Fn 5o+syrd5` Of-wyBPT*j A{ O H ;m;` EGJ;gϑ2hi v;'Al_ J>r1 I9rLgQs:"Lg pZOCtYS)ڨ[1$42|Zmbf{Hy?cEp$&))C|HކԱ w{hnSkPܦ❱Mɧ|*YT1YT$KUg`ʣSjH \ۻ]*@K~I*WEw_tzS 쇒g:=*5sAY+.$Og+OV"5s7b 閊ە*(әlo:jOWaDYC`9(hdfd<T3wq?u2Znu*rN"FbEU4հeL7WReT. *yI=,}mciq a{v3J^ZR}Q:e >hR,viMZE1)6sb p|m~) kG߃&x8vv6T,>_L@˞PӞKErj֢*fh= 2z O{=88>!>-FO&b&> "O~^ӌ r3[|fTL>ɧqO{'{ħydhv04cQ`U%{aeC]eXdVWΧ)gPW%BrO*2UsQ~UDMdiUAr Ew T14&'},|DgO:0H{d.OG|D3~l\F9qV;0qbQ-UIX3ͧ;'v7v)_QuI?r%>#'] ɧL>E"#1t44+GAj0pqC}7/&4H)Þm=H>MHY/xJi|?.g'UZCD1]HK >m^$H>YeZ_$0,>xUEhӬ >vV%SL,T#*kעK*eXx%CKiO^r*^d_* v{?}ɱSZe>o/2ʰCKyF͒{i>5kЫ\]r1fF`:O?/|| @:`i zX5M6U%qיޒiN%.0 ywK~&yv1֖+姽um98 >]#Ö;.yM_ΧMGMBȨ߶QsXT)6.c\/=a{=t,!.>M{bG)fd;gMq0-O}V m/ۇ/_7 f1Tۄ0tRizO3KmԫlI[7 FF{9_eMŦ04"ߗR\F|:)\a >->;*c >-i$vuOK˛Q03_(%C>Swك}CG<|g#|ڗÍfcaiO"Bj{-H͑?jy?ſ'T}V$T[-9jۍq}UE_~G5k(~gs;^Jע[6)tgCX{^OZFA72n L|GWl!L|_5?f0<8_P`V%ǣg<>]qhx,׮kU|ŷ51 >'Qq`c9թx,Miu*˵^Mod>2t=kk֬\o&Z.o y*r-φ@&6Ye+0taZ۲PԬ\e?Z͸~tڔ|@doُfښb >KGo^DxG<.OUkC J˿*?6 |mU:I !fÏv6OGT]mag`a DLеUVCG\Q {~FU+A_\E 2w|\QPC)Nw?-]O~l.lNީ> ~&C =2ڿ2e@,XˋˁPvRev οe̢UֳĿ٪S?endstream endobj 6 0 obj << /ExtGState << >> /Font << /F1 7 0 R /F2 8 0 R /F3 9 0 R >> /ProcSet [ /PDF /Text ] >> endobj 7 0 obj << /BaseFont /ZapfDingbats /Name /F1 /Subtype /Type1 /Type /Font >> endobj 8 0 obj << /BaseFont /Helvetica /Encoding 10 0 R /Name /F2 /Subtype /Type1 /Type /Font >> endobj 9 0 obj << /BaseFont /Helvetica-Bold /Encoding 10 0 R /Name /F3 /Subtype /Type1 /Type /Font >> endobj 10 0 obj << /BaseEncoding /WinAnsiEncoding /Differences [ 45 /minus 96 /quoteleft 144 /dotlessi /grave /acute /circumflex /tilde /macron /breve /dotaccent /dieresis /.notdef /ring /cedilla /.notdef /hungarumlaut /ogonek /caron /space ] /Type /Encoding >> endobj xref 0 11 0000000000 65535 f 0000000015 00000 n 0000000064 00000 n 0000000206 00000 n 0000000291 00000 n 0000000371 00000 n 0000018486 00000 n 0000018590 00000 n 0000018673 00000 n 0000018770 00000 n 0000018872 00000 n trailer << /Info 2 0 R /Root 1 0 R /Size 11 /ID [<49a3146a7b3decb7d7e60691fd6bd377><49a3146a7b3decb7d7e60691fd6bd377>] >> startxref 19134 %%EOF deSolve/vignettes/aphid.png0000754000175100001440000010157012352122166015502 0ustar hornikusersPNG  IHDRs?PLTE$qR\0RH9!H1OHȬP*FVDړ= &eTW,~el N|+/ x|!T#f-/*:JLȗ5@h_<~Ihm$@ |t.:,&#V*"YU N (b$l=L .|Td-V5 i l>,Vڬ^"-D t~H4 g {Z*& % 8Zޒ4!순Zd VdIn%ԒL|VVdq$ D $~$$L'$ܳnDt$ZyT4|ww:$* D  &$&T ,ҜD IDATx fY]'V䶐h(\Ɔ wh{T N1k3ZtcݴX0ҪnߐDWt}eCP$% K>3:JV423aF+J?~o9z}ǹ~q܅,Y>,YB%i͒dfIZ2@$-Y ,IKh%4KҒ%i͒dfIZ2@$-Y ,IKh%4KҒ%i͒dfIZ2@$-Y ,IKh%4KҒ%i͒dfIZ2@$-Y ,IKh%4KҒ%i͒dfIZ2@$-Y ,IKh%4KҒ%i͒dfIZ2@$-Y ,IKh%4KҒ%i͒dfIZ2@$-Y ,IKh%4KҒ%i͒dfIZ2@$-Y ,IKh%4KҒ%i͒dfIZ2@$-Y ,IKh%4KҒ%i͒dfIZ2@$-Y ,IKh%4KҒ%i͒dfIZ2@$-Y ,IKh%4KҒ%iI HK[^꟩qVi?Ea'MI и}ݙ#IIݽiڹl6t4;t;)pu+m&g_ moǁķU ~J!*Em"?{RR=MrѝdɦRuhUvV8@JǬ9IWw @ q6I-Iwm,\6tVZ)8M#}3Mb߽ر[wfnwo`.0s{;63@Uf~}ԮS|a$-Y ,IKh%4KҒ%i͒dfIZ2@$-Y ,IKh%4KҒ%i͒dfIZ2@$-Y ,IKh%4KҒ%i2TMY, j2@C<w̆uW}쏝6x5@w wRUu %HM еSDರ@d$ .qǍY/q Xx4J`4zs?LEZROu?1^5>!W0yڧ~ݭ*'sF_r6~&~"/+ߞ2@o:7YvD_~z|9iV :*Y܂} ?ψ*epGh4EY-$WI6i;MkߘM zcԽ-%G>]T)b=PĪ5[tG% X-^CǠz&3 ,H*QhODJߦ(7 UIҿ7tL4('B?3vN7? )uAk }ݚRA &䖑5bURLv aRH>N VVբ\0׹~i%^|zA!lPtCoFʽt*7ovSgnvTx^ V]àZ)%{_>VMO|0#aG.r64ЈR[a4 ̜>UȄ Na#x-[QƷgiK),=z2mmV)mнˠ", [o! +$Tr#.}oah?v6tw0rZѻ=SKS.TG`,Leuɻ+x~ YdmbvO+$BD ҆l/j!] eŽl>0ٙXFd>SJ^<]`[" ېbUiZm zw#M#9X0Vۿ#U+^U-I#֘@! $XrWi!V:y(O>>M'Bx'__AEf ZAdY pٝ>pB$z#L`?|Y:w8eNݒbt{ $iCVH;NʦT\zhd;qٴSp|2@g`P\]ir3B !G )$>ʡ"-YV;Y2K6wY/^JU ")~VH=N~pS!26#$Y6iNݒ Iѣ7.BS$,;mÅz'|)tZlӒt{Y@x ^X!*PŧGx!wYOEڠ{AGMU/#OE5 BP4Yeuɻz Ztq=Ƞ.$޿]TCLpi )xv!n!JGݘV%9?zOE u7Hk&T$- 9Zx! (WOٞZ:Vvh*@Ne&m&onTUV"hʥC2SSЋ Zfw4fRP-UܟB\mj <#mU@yc#T+-0I0D@Ԁ87Tq X΀G)>uc[Y9DmC=ZI6(iwTTJg#m,̓HT:֘BDh3yC28N~ʹI_TƶI.ξJDà>ml{Nd3%t$g^ya^~< zdtonA1HTh*QxiZ[iCDS<-"_reg N }D{`P zw%iD{ϡFrZ?dwafz2(BnP;.<(v/ F<O o8hMldfBĈ.b)-I#_ RyHv Ͳ^I$1 ~; QeH2>95Z[AjA%F̨7s},7or. $l?Br E2i~.ɨo5C.A·J}#wjz{zQҁX'ïo}[:S$2f*Fn!nn9."$tQķ+ϋKW{ `)'O֔:'il\7]U2@ޝ|RcgH>/Vy[U}~J%i$Z A<*]M'J(R:a%r,S3WX$(0hwQ@Dh3yCi/L;}txN|AAvAiZ<(iF)"Iy .UxLG VJ8Kq`7fAJŷh]àW n{J8RAJUvzJ CEO86;ą84}4pו Ep (JQVQ'ͮ#|8UxԨs hnaM - !B@\\:,{=Vڳ1{pQē d~63 *p qCMJM٠P!tf1:(]TYp(- nx<ܨT BTpгD!*U=FC GEՆbٍA)T=6*9T!O iR m"33h_ uTTJPD[QĹJ;N~ ]q 7S†v4jrMEP9򿻃A!oSAn5"@RʍTmHpd^DU!T(^-"tAś%.}1X Z! 3qIgHSQX~,l EƓ3)*BD7+DJBv kIHt6 `So% CKuT 7̠.j *, z)N o,ɠnĠnŠq#cPo /*p c t%(fA`PRR# =T^Ue' GfQUk2fR)%&!= Vmq }poF"*n{dP \MD&EtvhI:RʠhZ̔\d>Ib_ A$RWgG%o2µZm\dE6G0J_;T @QiB)TXc %{HD%U u|tH *( KFt Yd{Ơx+ Y.uQ"En=Eε0( xH bS3(/ isp)جS努fW} }^*AQc!Rݴ'%EfgP%ՈO߳Թ q4݂U$}W_MS$1AO͠p@i1Ǐqft xE09s>A=J?)`Q$ :UKn JJ ^}p.LʂTBe{wWay2:Iӷ$1A* A!XFzp+(-.;\%~إqyC"Rb]o[,,)R<)u݉U x<~n@~ kLffP(-pIP+`l.Aٝ9>D"NQ bKt4A ,2 {Π+a*t22sQk^@A)Щ$1)H-0$ɜ8"E0()) ?Jž2Ʀ'  /z *۠꧷AmiٙS'Ǥa+ yCf19TkͱfmPAK0d H]M)ǹ!/f7:3D6n t*~I% ~0`Pn jTmI"OP%D@<ӑ't/WgP S1(=T4s1(u"FfA4ZD7^귍A)UHingfC(X<$ t8 4lY Rt *QASA>*%v{hLirfiSk;gbPyXfPx@3.OЪx Ož i$1hʠl-I!)opU ֕p'xBI&e@OE3JY@jAAvUV(a}s"m7TJ2*2!'*ۣ(1]l<&b*lyK)[<'A+ӁK1LKA\Z8 ej#AږNh D\MIcyDc γ56&_n>|ox)+P\ip66 (XyUJ$ H)h]!/is2t`GW:[wuJ wOˬT\q(x0%fg]uGbvٷ y6?2}M|ߦ ؖ2\sH E)(bgվ&mCZ1ndRg֟O5Ϡo:՝k*JA7[q%J|EFT:uE/E ]4Z(SA%JRB?bÑ]-컷E#Us'v}$ OTs@edyˠAlP$AR-Ak1"9@gP3ܪht'scTD],j*r'uJtTruq hO7Ƞ22)QQ텟 ah^߶hߡ%SOʒ"ݱ_ IDAT" >4V.Q6R4AGKvOìbr({VL%osc y-̝AZ=Kp=ŠElAljkvsD¢`~L8AS km9:K&_ĩFbU| Z2^bPƋ\3 e.P1IJ c#.ϛ5Nuץh,sp-4 (ԢB/ d(KTV *c|@teVճ>DNl34$`SqUUpRݶ'o >Ih*Ƞ(6`ݤ#TX ڕ}L|wFۆ:@HX8jvOfO?;A|aX 6bfO\= NG7yEc:S{oxM0{\tFS#$C-IʠŨD6C-5$D+yg7DuRArB|6"(Gb㠯V=mP:Ab):)g y α"E6& v{E ] +A{@GySR'OO Π*#&Yls SmuVZvkv((Tu5)YS;0h F4}u!C|3`z7 qg_f:VqIHc讫%X1(HlY~h/~o0(e8J Ĕ9nu/!X*"*v{{fw6unkwZ1E  Tӎm#;N=2@ >D0W.pMVf56hLA]nLcbxƦ28%{Nω$G"'rڙ|nؠ – !Muc:렎l@q6u#SNAJ| %"G[6䛈nMkX :Ksw.lZ{d LR*]/U`jsѥuJZb~"\;6h@ wA)roxgt*w9C;ƬOdN1?B@ٗ<جy tʍ0NPIh 6^WK6BSrO:jIuf# W5p^=r3_sӷA$nY{L'K ȓ0F=?GcX+4]_m8pOW$qgxՋ'ֺ4m ڋ/= b-0j+ˮY7L=ם>f2 6 &,1X'S&$OAϫ+xWZ.V%[!@@ ,IT9RT(J6ntUĖ-޺H$duMNFҔ4g~#)?ORI-M%F۔K:"i O=V?1ҋ_[^Z1hN5Q(V~lYCHraDc\?k;dh%M&wJ9$C;"G`_yQ7LJ$9/8%J8C)4[ ]:<{줪F@Z'^$ =z_v^w OɠIw;uagIaCJRNڳ`T}%ʏ 6 ݄DV(욋<=ʕKK݌fЗܫ# ͞D=,5fdNgó$05ySJE'۾ϕƥK"g6xQ#-wi#^KöL[Hѡ܀sox;m]%]x>]˦'%x%Pb僂Ƞ5{ƠZ` S,Ė$iȎx9+&Mj̞Z@>F76f",u+V{^:~FdnzKAlgth>DH2qZQ@hbL2:o7)6"DXqq'!ϒ=+&${腑-I6PQ=0 x(ݣ4C+v{s},nL}# HJ@<ӏTC0)5/2Ⱦ4h3j??~c=#]Q" ^;͉-IM=u9ˆk޴M^:HwҜ$ (lTO! +m{sKx>tgnV6ʯ ;j`=a% ?EO1&ĥOrc_ڂӿl0~'f'TsA⣗#0 ->76^~/]rx-ٳDCz腑 z]7]wI66 }o-F'T8wIfƛ`-D J؞R'S EF=VWgJW w~Lg]6OShB1m&Mb8=q'!6w8mM9cV][o/Tɠ,BZ碐4'u\c#M0""ALʊLyL$/:R2Ȁ76)!.-|?C|v`[Oe?S[n1)PJ Jԓ@ &~#H4-эٛxƠ;V_>.Ӓ5<:u?M`nRxxc|6}__1hŘbeANirB6 fP˥'h]W! :e 4wlҕNs -~0BLsSBa/DŶxLž{ѸQ4fY*˷-ҁ8=EOq]u#+Qût ܤZج$Aشz{=(10BNDbP>k!M -YZ˥'} v }8yDyFWAw;KPg#KgmF/QcvZNZ.D:"aV>œ3t2Կ@;ZGv4Þ&NY;RL͚Xuco5w۠ DA Ɵpdd{pL[pLMaPX쨇lěM>dĭQh|JJFCo~kNˤK3:۠I (" sj'g5ܖjàWuESC*Tϯ{tG_hw׸{d'۔:ǝK.iɶl tcPeЙPВDb2ksM8R#n-CMinb| ԍ-d~wf$84Akg-aoh>M{gl6hPe8% 稩3O:;gK&Hg΂>,MNa-QQbddq:G$d 6wCHEm @oeY0( F3y +4#\%ePwyLQ}!E4:Ӥ-'[f}oKПZɨ=%lHӡ9 N WOe7.F#$5yr :K=svb_6. JF+ <*lÚ1=&`CD$˗'1q!mCZq݁эе=ڀNKDǗ{"U[俁muS$N$TiM̆1]; l1qhmcÓw@hRK+"Onq`6?o;fQk~V7#U𡓤TƧ $EլX63-@O )ԪecJh[ '.#UR@՛ɛp^2Aj͟D2¿~꿞ÛfhI@-"hno.\S +B ۄ0H 9a7 N%H4dF.U1vw;Bh͟6]7?D{6{nӒg̚δ tx1Lv%/{9IfM6zORh hӁoֈqß y??&f:Ico=^1吆`'CP.Qy|W7 5$AO4a$h}si3P[t=0jiyh-IQфD1(֛Շƣd9/'Lb1]r s|P( p?C2謱AON)Bz>0Ĩ!JHhAAij[pk;G듵Or͘K8% Tڟ(K柽B' _8qډXL'kH2 9#(xSSAzC8?Syz6hlzkW|VhQigOnV SIJ\Q?+D/_q/wU!Cl=Um;·nƵO*AhE߫WO 42A'9+}z JPTWO+YǍv7IM=jⳙi]Zm-YBE ъERtّ(W_ L Ф螃y/AOϚ@iie:o8IM7 zT٠C3ҨO_/ǎ=o nGn D'1bdw"?H\Y.O4];oS@z u?ڇ} PhAxȶLJ-s[[/] kޥLQOP&ƯoQDAjЩE,Ic}"]4.<m\n Ze3}3hD4_ow={] GR&BgeP23:s-@V.^- IDATTR\MC z MG6hݏ=aHR2N`SYBk-6Nx-oH aO%|a-!-9-^ʼn{s>]mL?^ 鸵A!@ _hU| ԑ3eC~ ‘CmPT ORo`hC| ~oY zfA]}=p3A!Yك :1mHxGctEC,Xm__U~ya7w{6KYc8Pc5HgԴ$ Lw?I8! ځAhˠm[:qcw<ʮ?JOMb(ߤ?.`Hb,w:3*6Nڌf njx<czuN^+;Ag'Vb6MFȲǧH7A A'~|чWZt@:(hwGvf5H̐ (e3uaPx"Nso|?С %}^5OK.Qoj[LڄC1E6/AI"=L%7mIg@qo~q}%7~ib #!k`6kA!`JDI\ (]iՋ6J=xd6YMq]04 fӶA7lmW^IHʠ"Y^Ǡ FWT$Y3 ^=k ԉ7ЕF!n^R4@_xgSm-ދE^NC,o!˶&м}P4]8)Ah{F2F+W(R)_pbm )wRi5K = B]g`גAN0/p_GGTgPZȠ[?*r3PWcEC7Z6&%tȠaI%~Aؽ$yݫ}k4`!FJJB#ZeP mcrTK]^E^Ȍ5gB(dpn -6(]QN;PȫzOҺ{a8СXzaA͈ 6cNPpcq*y>h08`P DC}`HtF ?qP4 Z4oBT_I_eX p 'nFO9d cEV*)|EC4NtB=T" 5 7)`'roΆA%_!iC; /Uɕۮ]ؾ΅o Z8Hz׻f8V5 Q8Vc7$*7D ڼ{ѾNvռPv 7XDm Y>ZJn̩ :Au2Y%xMx Eg8ڠti||˾5ft ZRhBU=FrQ!:^;kZmX5`vePt_Ư (xbܥ$ yM*yowq(`r AQ_/{3GZ=V;!cܲ5"6/lM wF1(YgV%O ZSk zѳ(h#Dm%9lΨ?U4Bgk=J̈GQi6Ckճ8VARg:uQfwOٿ\Z $bHC.՝pCmu>AxPlK_Z1聆B-B+:m~)]5f:.e 8sBB4YBnH'6(U?UYGftg%BV ګ BO6j.f嘨1%W@*"eo0GF$RwMsc8qczq%foۢm7P;T_gS|cyC2쯡ixxR+: FSJA]Ԅf=]hpzcՋhP5;r5ƻpjUG+ Zs'KoA{`ƋwZCқe CNcj[L5ݒf=IBMRW.]?`KPTZLjCo7 t^}OGEP]]>*gƃER5"'LՀhDj.G!}2kNveQ&ؠ}ycD@3ӒiV^<@M΋w= ZT$c:kB%UlB_7DM N0qzbIB$R 贚ז(eQ=MQDk(Wr#}ao%Ag{N͟`۔ӧD:@U>q'fP@(< T[BWLQ"%`~bm2( sh[tH/54r:I3@ <>I%sYY )L[֯_aQDܬ۰hcFUnϞ;ͨyQ{wtTdЛߴD[kbP/~V6(PZ#"%0=92F)nDԔL4鉷}z]h5aQJY.9o%wMMf#KjU^|L?7ʢ V)PJxvRIͣ9QWR(︌m3G2^ͷgyMiu~kr3bmPG"8qPǞ H7z>P<#MQ5J%mriA mO;. ١ķ0]L}ޫ]Kb4[j-JeiXtnƋЄg$W l1}JAUcveF1eQ [iX٢9^Norjؠt|#M3QBAFmM DSUdEN+hC([(jgkh4xO#Iyf鲄%Sˠ6_oU<yd;d:S(C(jG'V)Hǔ1%O It!'W7Aizh4Zcƚ@%4.JA~@=UL ".}{JxX) )턊ƇMQw`QcŚTqaR z^vg~g~fiie˖< 4"3I$lR͹W"2U*q1.RC3(NL|f,]Y% }< +MQA v.]a,qzQ/rT=OԽP X%mR RԩGiO-LW@$82kj7 ]B{OoYc=#9 Vq^o"rO{GMtƠ"E}eóJf^x]†hC6p :^:Kw`W*oWNZ^zڹ?#tR9rzXp.,tP?R6GQd,fOlCN ډC'ւ{([3;PQH Tr* ;Q'N-㐖wٳ"E}y'&TG12AturK1fDM?p,)л_laЎ]g0sAC tb *M#tp)4mQ8`:«7}9 P<~cȽږ4.(A!m2UAkL֔Oq Z( L 47e>et #zl8R[% Ц8}]w0LE ((I('#.ĝnNfmVׯ9%BItC}E Οo^| tZr`,`Y2rh8LaMiA[IP@Eм!RщZoHO(H:]oGEL66_ . M/2ӌ>ֿ'((5<[h4M}>Zp_RgkX=QB9mzLq$_5h0蚤݁VA_D{u1(n=.uR"i8 or&1 =E]J_KZB zzw0h $0hZEƫ\ۤ0*-`J^l :`␔ "R9ѣ17xoCh6)7og|DJdI(kTe;c{tB`xxPC :L]x-G'ۣ4B#b 4*MN{aQSoҝhLc4ֶBt-*ؠr )A .hHPC{tw*g*U_x=> =Pk]̸7Ǽw:tС{`YA j:D8}Gʵkizpi}D%>X}/OHy2=А $?/||OPNݥavŘ-%yDLwQHŏ= hHi6[ '/Cј FqH9-zdOqP*ԍGuB<ji{5,WJ䃉Ư_^/ܦ Fѵӱ?|Sh:{HE˙̊^RDYB>wt>"m0Ͼ'ꏼo= ً/p ڣ'&<)\q<'8ãح'L9@=zih'fp#G? Eh q.:,Sأ[WyN¢z~ OĿĖ{%I:Fal4IA[; P'10(̂s0<:}hQJxO-! Fh:`GwC)6A3mәG1yzcmQ%!zefM0٢N %Y`-}Q  :UTfРIW :cpN`$Re">G%UO4ǟ^N:I(!Oeоl } 99Ǿ%F*[(B*&@хUQ+tzU+z)Ac:k'WPԗ6meP*zihe ȍ'A{Z.FK|h/ E; W}1(⠑ Z͌-}h{配: &~'!yyADA_/8*Ot!?:("r^lYauO|U!K:T,ik~ DT{1}ΣNRaO+čf`b̈F$-&@ެ 4#i3S[Z>׽ӯ|z?_WKe+e݋g%Вy&0AcP9W BDKzS(*>/K6B*(Hݍw'_[Sw]WؠƟPiRm2feaT4G `ׅ7ړJ9*wc*AK~w'eH :W/ e2mtOLW H= Q.lk@V'AKGئS}}:e]I4WK!jGfBG_ne>d/;؋oldO|ZBm B'RT~cPXgߑ@V2zsh-;4xf),4A_z+Ԛ|:ZϠl7^`2z$RãzkSOW9D = g];8j^ThMIؠ"TvA ,칶F58&8'g[Ftj}';N j4w6h \VkRH{6Hle%ãBPoN` h@ ̠xE䥾08(m(CNb]a~ .Fŗ ů A%Eo;ߌwg &ҒH&ՒHԽ* .r_q]VM;3(ma-0z='NCeVi3Q-yI眊 n`PVXve}bw!r]J]GMR?xH|=hxWw"'{Z,YhϹOg0z-)Wm=v@z96wi]aZ/ Zx j;m/z},әG10vf0g6 mT+*`R#[%Gϰ4R![Hm"vaR{o,~:ԣy٠ N(4yxD2(SgE~F'xqKtK_|hpgwaPš Š]R"_,HA*& c"` {]äQ z=N Q̠(" t+ȏzNՊ$&@"Pr] 4c?JHm|[ӧ(%0p,V(fvNA Rp6)~2&NKvŠw:!R42EԗDU2@AщyɾUF!Km\;pAS$~]~ݸ;s`AexQO Π# &)D{eba}KyGonrސ0@2(FS ^09mw;U&9]T:fF12K؋DU`,vmE,^$2'^DP*ĭOB(:Gv$@, t70`wIf$S/ 3(<^ ꈔ5RnNK>S[6@AAEB ꎻH8>I@ġsc}5Iy ^D ϠQ5Tc:/Y+7 $% Pʠ )(ƈJNy3(|+ga '6L}P3 F3h 8@77:EUYNGʠ ʁ]kQ=B݀%b |(eH4I$ob njQ#/·AcEFGqĝiد=0|s9GPjZ؁A9#o ZGH0H5՚,Bڠ ~#ЊAi6,z=̠9$ĝ6hIGYJRǰ7UMaH>T[U2 $T]:|´4Ec/%^ P̣ ZڠmN|6(>,"`BĕďHA(h"1U´OZ )D*6HS^ɤ|$ *xB5q%mzYT>an/ޡr c$ݰUN-X(y>Id0 Ǡfȧ3;sTj/"Ǡ;g ΂OcR, ڊXt$}=a|=󐖇 ad^{ VMewuCh3@=Tڄ ѓ&&A3vb> ^s^ ȋ/Fn ja4~&A59^j4Ĩ\|XKĤR4Hݎ)@;n /.B Jj(#C Z#ɠB k+DY )èQQ^| Vys#ty2` BE z8k2(=vC0<*ǝtiX%_2@} Ń0MTuTiA#DWA=X|54495 fDdPԹ4tƷu4-xA;veP-Ǹ MbTй:%"Agx{G!bQ5-bjUQC;' gQ#*Ï C'hc\Co4 :%ɖ)S3()k 0b zߐ : lW'/PLUfQucPhO eSؠČnn(%1 ڊX OG%O)u!Ay4AHߵSvFu7 2`,JAc,Ih /j c↵_ o'kr 6>| ]WJz M@))HAB9X!WzdP0MǠy`NIԷg3: jލ{xSKV0@uװA̬ Z8ŏ*E{Q|7J"Vſ?+Ns @]*aw8[(TePʠA VMN⿩*KCH+F۠jv8Π2573A; r8 f@!Wqo>≕IP0²eHiZo o^P^wn9<@=S?,T}c6N7uvePw1JD ($@T3eg-?ڲ_O)dKe6$}B"͉A1r&Z3&2g(K"_O>?.y>}WgO@nOo ڊX  <9dP0̭glhdj`VK!|K #Ƞh *ʈU͠!8r2%S` Zۏ_IpJB#  HlcPKU~*A|j|vC6̫A1t*B0(8gA DXṷ=ǧB3烂p]j) ApZÓA<)fyf_Vgn) .aVMS`7[fБ(ON-p1~,NePL{3I,iMi IAQX`H V7$ H ܵg6/JS$ݽaP~Ul#P̠yHp%fy*dr MNұ8dcASAU=2Pno~ U;s0jePkP%0Vf *vO=X~ې&*!/v< &)Hx}mPz8s)|!QKdI R!}N;> BpLyr=hG/uGޫ> !wzZe!01 ʋ'̏%< u5M8IuҵA:p m|(݉gPn VZVT|,o ;%6T7 ~ D;1TaPpvxFXwu@ ݴ;/@S:IL"T-B W&\PbN-v`(]yp7խө@2a%%wZ .\v c!Q g\*/*g"mz_|AI1BW2~pjdm$0 ܶWiNGxQ!oOezT҃Nҟ&[e'PjFY$mJoCW<IeX[$|J0>x0,Jipi9I-rrG 9 A DFRm1ErSn*M]Ƞ梤3b# n9{1+ml&9弌Oy{i_q<@GI39" sʴT"t%"9dw drx /tiPEx V{xFۢ۴6ږj.ZD,; 3bT|ҁzMs"Gp[l˖2lc { )lUǗB)a,,~n_ =Ż%r}aX\ ~@b-x$&Dw8xݖ$n\x@Qx*m7\5¦T hp(PNc#ΠMsKV_qy1U 텔F d8zyKV̲-IhMAL$5Qr_m7By]=+=.fY ]cUBS箴Am<{S(dKin0PvOF4$$F\vd]wdԗE-ZeQhߌ8'O&oV }P6FA詈[axߓJeq|,11N~,׋>|otsS7ߩ*zY+:3^HAs79k'5̨6h踓gƋ#ۘGw.Iɋo@Aw'm_K7)溷X4A.@6eYvt[tb ʹJ*~뙥g3NsUǕOw!OPO wqǍWq 6\ N(ʒhե|j tlZ^; н=vj{mg{ 绸;6Y~Dmq[]J{˧#u $wO|lYdfI[2@$-Y ,IKh%4KҒ%i͒dfIZ2@$-Y ,IKh%4K+@Ϻ#wi{z-Љ6sC+Ԧ>Sg4]4 vxowHGԭ;i.3" xb@Fۜ'@6e!D~dP+wN:i~co|.Mffet6detg m<% Li]6oo pbNrV69y4uao Bso̒w͒dfIZ2@$-Y ,IKh%4KҒ%i͒dfIZ2@$-Y ,IKh%4KҒ%i͒dfIZ2@$-Y ,IKh%4KҒ%i͒d:Sծeȗlv-Jڕ5Cw\ n 0f#ɗ;6P;_WGfY|ik !%_ZdQ})2|H"ܺKK9Z˔6hj-"@u/D6-@?Z/w[D|%|Yc$pV |}g؇|$-Y ,IKh%4KҒ%i͒dfIZ2@$-Y ,IKh%4KҒ%i͒dfIZ2@$-Y ,IKhЙIDATj*폻IENDB`deSolve/vignettes/integration.bib0000754000175100001440000002033512675173174016724 0ustar hornikusers% Encoding: UTF-8 @ARTICLE{Bogacki1989, author = {Bogacki, P and Shampine, L F}, title = {A 3(2) Pair of Runge-Kutta Formulas}, journal = {Applied Mathematics Letters}, year = {1989}, volume = {2}, pages = {1--9} } @BOOK{Brenan96, title = {Numerical Solution of Initial-Value Problems in Differential-Algebraic Equations}, publisher = {SIAM Classics in Applied Mathematics}, year = {1996}, author = {Brenan, K E and Campbell, S L and Petzold, L R} } @ARTICLE{Brown89, author = {Brown, P N and Byrne, G D and Hindmarsh, A C}, title = {\pkg{VODE}, A Variable-Coefficient ODE Solver}, journal = {SIAM Journal on Scientific and Statistical Computing}, year = {1989}, volume = {10}, pages = {1038--1051} } @BOOK{Butcher1987, title = {The Numerical Analysis of Ordinary Differential Equations, Runge-Kutta and General Linear Methods}, publisher = {John Wiley \& Sons}, year = {1987}, author = {Butcher, J C}, volume = {2}, pages = {1--9}, address = {Chichester and New York.} } @MANUAL{bvpSolve, title = {\pkg{bvpSolve}: Solvers for Boundary Value Problems of Ordinary Differential Equations}, author = {Karline Soetaert and Jeff R. Cash and Francesca Mazzia}, year = {2010}, note = {\proglang{R} package version 1.2}, url = {http://CRAN.R-project.org/package=bvpSolve} } @ARTICLE{Cash1990, author = {Cash, J R and Karp, A H}, title = {A Variable Order Runge-Kutta Method for Initial Value Problems With Rapidly Varying Right-Hand Sides}, journal = {ACM Transactions on Mathematical Software}, year = {1990}, volume = {16}, pages = {201--222} } @MANUAL{compiledCode, title = {\proglang{R} package \pkg{deSolve}: Writing Code in Compiled Languages}, author = {Karline Soetaert and Thomas Petzoldt and R. Woodrow Setzer}, year = {2008}, note = {\pkg{deSolve} vignette - \proglang{R} package version 1.8} } @MANUAL{deSolve, title = {deSolve: General solvers for initial value problems of ordinary differential equations (ODE), partial differential equations (PDE), differential algebraic equations (DAE) and delay differential equations (DDE)}, author = {Karline Soetaert and Thomas Petzoldt and R. Woodrow Setzer}, year = {2010}, note = {R package version 1.8} } @ARTICLE{deSolve_jss, author = {Soetaert, K and Petzoldt, T and Setzer, RW}, title = {Solving Differential Equations in \proglang{R}: Package \pkg{deSolve}}, journal = {Journal of Statistical Software}, year = {2010}, volume = {33}, pages = {1--25}, number = {9}, coden = {JSSOBK}, issn = {1548-7660}, url = {http://www.jstatsoft.org/v33/i09} } @ARTICLE{Dormand1980, author = {Dormand, J R and Prince, P J}, title = {A family of embedded Runge-Kutta formulae}, journal = {Journal of Computational and Applied Mathematics}, year = {1980}, volume = {6}, pages = {19--26}, issue = {1} } @ARTICLE{Dormand1981, author = {Dormand, J R and Prince, P J}, title = {High Order Embedded Runge-Kutta Formulae}, journal = {Journal of Computational and Applied Mathematics}, year = {1981}, volume = {7}, pages = {67--75}, issue = {1} } @ARTICLE{Fehlberg1967, author = {Fehlberg, E}, title = {Klassische Runge-Kutta-Formeln fuenfter and siebenter Ordnung mit Schrittweiten-Kontrolle}, journal = {Computing (Arch. Elektron. Rechnen)}, year = {1967}, volume = {4}, pages = {93--106} } @BOOK{Hairer1, title = {Solving Ordinary Differential Equations I: Nonstiff Problems. Second Revised Edition}, publisher = {Springer-Verlag}, year = {2009}, author = {Hairer, E and Norsett, S. P. and Wanner, G}, address = {Heidelberg} } @BOOK{Hairer2, title = {Solving Ordinary Differential Equations II: Stiff and Differential-Algebraic Problems. Second Revised Edition}, publisher = {Springer-Verlag}, year = {2010}, author = {Hairer, E and Wanner, G}, address = {Heidelberg} } @INCOLLECTION{Hindmarsh83, author = {Hindmarsh, A. C.}, title = {\pkg{ODEPACK}, a Systematized Collection of {ODE} Solvers}, booktitle = {Scientific Computing, Vol. 1 of IMACS Transactions on Scientific Computation}, publisher = {IMACS / North-Holland}, year = {1983}, editor = {Stepleman, R.}, pages = {55-64}, address = {Amsterdam} } @ARTICLE{Petzold1983, author = {Linda R. Petzold}, title = {Automatic Selection of Methods for Solving Stiff and Nonstiff Systems of Ordinary Differential Equations}, journal = {SIAM Journal on Scientific and Statistical Computing}, year = {1983}, volume = {4}, pages = {136--148} } @Conference{Petzoldt-Rennes, author = {Petzoldt, Thomas}, title = {Dynamic simulation models - is R powerful enough?}, booktitle = {UseR!2009, July 8-10, Rennes, France}, year = {2009} } @Conference{Petzoldt-UCLA, author = {Petzoldt, Thomas}, title = {Swimming in clear lakes: How model coupling with R helps to improve water quality}, booktitle = {user!2014}, year = {2014} } @Conference{Petzoldt-Warwick, author = {Petzoldt, T. and Soetaert, K.}, title = {Using R for Systems Understanding - A Dynamic Approach}, booktitle = {UseR!2011, August 16-18, University of Warwick, Coventry, UK}, year = {2011} } @BOOK{Press92, title = {Numerical Recipes in FORTRAN. The Art of Scientific Computing}, publisher = {Cambridge University Press}, year = {1992}, author = {Press, W H and Teukolsky, S A and Vetterling, W T and Flannery, B P}, edition = {2nd} } @MANUAL{Rcore, title = {\proglang{R}: A Language and Environment for Statistical Computing}, author = {{\proglang{R} Development Core Team}}, organization = {\proglang{R} Foundation for Statistical Computing}, address = {Vienna, Austria}, year = {2008}, note = {{ISBN} 3-900051-07-0}, url = {http://www.R-project.org} } @Manual{ReacTran, title = {ReacTran: Reactive transport modelling in 1D, 2D and 3D}, author = {Karline Soetaert and Filip Meysman}, year = {2010}, note = {R package version 1.3}, }@MANUAL{Rexts2009, title = {Writing \proglang{R} Extensions}, author = {{\proglang{R} Development Core Team}}, organization = {R Foundation for Statistical Computing}, address = {Vienna, Austria}, year = {2009}, note = {{ISBN} 3-900051-11-9}, url = {http://www.R-project.org} } @MANUAL{Setzer01, title = {The \pkg{odesolve} Package: Solvers for Ordinary Differential Equations}, author = {R. Woodrow Setzer}, year = {2001}, note = {R package version 0.1-1} } @BOOK{Soetaert08, title = {A Practical Guide to Ecological Modelling. Using \proglang{R} as a Simulation Platform}, publisher = {Springer}, year = {2009}, author = {Soetaert, K and Herman, P M J}, pages = {372}, note = {ISBN 978-1-4020-8623-6} } @Conference{Soetaert-ICNAAM, author = {Soetaert, K., Meysman, F. and Petzoldt, T.}, title = {Solving Differential Equations in R}, booktitle = {ICNAAM 2010: International Conference of Numerical Analysis and Applied Mathematics, September 19-25, Rhodos, Greece}, year = {2010}, doi = {doi:10.1063/1.3498463} } @Conference{Soetaert-Rennes, author = {Soetaert, Karline}, title = {Mathematical modelling of the environment - are there enough data?}, booktitle = {UseR!2009, July 8-10, Rennes, France}, year = {2009} } @Manual{ST2000, author = {Shampine, L.F and Thompson, S.}, year = {2000}, title = {Solving Delay Differential Equations with dde23}, url = {http://www.runet.edu/~thompson/webddes/tutorial.pdf} } @MANUAL{testset, title = {Test Set for Initial Value Problem Solvers, release 2.4}, author = {Francesca Mazzia and Cecilia Magherini}, note = {Report 4/2008}, address = {Department of Mathematics, University of Bari, Italy}, year = {2008}, url = {http://pitagora.dm.uniba.it/~testset} } @Conference{Tutorial-UCLA, author = {Soetaert, Karline and Petzoldt, Thomas}, title = {Simulating differential equation models in R}, booktitle = {Pre-conference tutorial at the useR!2014 conference, UCLA, Los Angeles, June 30 - July 3 2014}, year = {2014}, url = {http://user2014.stat.ucla.edu/} } @Conference{, author = {Soetaert, Karline}, title = {Solving differential equations in R (plenary talk)}, booktitle = {useR!2014 conference, UCLA, Los Angeles, June 30 - July 3 2014}, year = {2014} } deSolve/MD50000644000175100001440000002347413132171175012214 0ustar hornikusers1f4c639816042792d519cf46e0f7469d *DESCRIPTION 316262d3be55a7fcb10ac5ceebfd7658 *NAMESPACE 5bef0bfe4f32e4dbaaa5a296dfa50203 *NEWS 4df6c896706646b5793cc6357b15574a *R/Aquaphy.R 6fe538f8f31e8a207a38958e02e2e70a *R/DLLfunc.R 31be22a79645487f5441d15c21de881d *R/SCOC.R 4a1d5aa97330fab3a064dceeca668c53 *R/Utilities.R 0b7bc04c247655f2319113eb0670bbf1 *R/ccl4model.R 4818e98a5d3da2ce8e817a211e072f27 *R/checkevents.R 346a5f56c99a21de4428c976fb38cbc6 *R/cleanEventTimes.R 836c97b9bcdbdb82d00e6c4692b5804e *R/daspk.R b2f54ca36a32a9fe245d2a736205f600 *R/dede.R 947bcfadb19abe4513e2ae3b04e74a44 *R/diagnostics.R bca4ea464985302cfcf8a7f8deea954d *R/euler.R a03c323104b2935bee848463a22b9744 *R/forcings.R 4b14898e5d89cb2afdf3ae15f8bd6af7 *R/functions.R 9e86ca30ff1679cb5449ce0038537d4b *R/iteration.R 91f2dd21ba5e6fd2a20bfb92bad1c261 *R/lsoda.R eb5bd3274ba1c488dfe294e646d46973 *R/lsodar.R 6d4a63564c70b7a661684372b69f5db1 *R/lsode.R e28be595d3115525bdb1d95591a3b778 *R/lsodes.R b535060b2fa973c5bd6a65cdac9236d5 *R/matplot.R 3a5678b1d2b3a0832dcf54d3f64522ff *R/ode.R 6b16f3c6ea8b7944df6a389398e5443f *R/printmessage.R be18d5d3d390d6051b19b2f65227ef2b *R/radau.R 5401f812ef1edb3c6fad25d24b8a1fcb *R/rk.R c8e0d4227ef5f0069ad28bceb1c5254c *R/rk4.R f028e09ca69643fa97557dfd995a9152 *R/rkMethod.R 6d27977394a413859fa0114865e986cc *R/vode.R d9f4bbd9c942f597b552b2390e172a9b *R/zvode.R 8d78b959cf08314c68b2e716c1f5ca0e *build/vignette.rds 85c07190ebe866c60681d323498606b4 *data/ccl4data.rda be157a942988018a45e577923b2b66e6 *demo/00Index c0c0293b16490375a893937ef11f398b *demo/CCL4model.R 5b936a490bc9ea9aebc3f80cb6ce1fa5 *demo/odedim.R 88e241464aebb08e7d4a2d10e6f4525d *inst/CITATION 6b1aa98cdc839c1e59c40c9c6bcdc78c *inst/doc/compiledCode.R a7f37878e8888219d66d4f40a700279c *inst/doc/compiledCode.Rnw 8da1cdaec8f4896c52f702f3d55d624e *inst/doc/compiledCode.pdf 58f4029a95b765dd4d84456b0fc16acd *inst/doc/deSolve.R 86ed9ab9c5415bb141eb2cc78b03db66 *inst/doc/deSolve.Rnw 40ff643e519aa149e8c24c4b77059957 *inst/doc/deSolve.pdf 90cff72b5d4f433507d4a3194ac2b4c5 *inst/doc/dynload-dede/dedeUtils.c 32adc37ff9cfdae64133e2f0905ca68c *inst/doc/dynload-dede/dede_lv.R 0554dd66581cbd412e50455977167143 *inst/doc/dynload-dede/dede_lv.c 89bbf4e7bd58ec8521eca8525aed7050 *inst/doc/dynload-dede/dede_lv2.R f4e78a288c93aebcfc376833f39c800f *inst/doc/dynload-dede/dede_lv2.c affb61cc1870a00a1d0ddc56f766d78b *inst/doc/dynload-dede/dede_lv2F.f a0b51ca0d9b0fac4f7355bd042f3d429 *inst/doc/dynload-dede/dede_lvF.f d668bba347fcaa35b995880b0db64da3 *inst/doc/dynload-dede/dedesimple.R d092893bb9fe7ca3b808bec33ac43529 *inst/doc/dynload-dede/dedesimple.c 1e029ca10ea268a0b1ca1d4c48139dfe *inst/doc/dynload-dede/dedesimpleF.f aeb199875bb906ce80643d6acf778ff1 *inst/doc/dynload/Aquaphy.f b632619a9e6d2b730166eb52790c764a *inst/doc/dynload/AquaphyEvent.R d80a2a93e0f374238d7f45dc1bb69e6d *inst/doc/dynload/AquaphyForcing.R e4932f80fc03ab8cb99d033fb5587e2d *inst/doc/dynload/AquaphyForcing.f 426a4eca780fd364caac828ae81a6271 *inst/doc/dynload/CCL4model.f 9ffdf0d254e2caaf4376a5d01b3e35eb *inst/doc/dynload/ChemicalDAE.f 44cdb71dbf64ae9a354a5763cac53b3b *inst/doc/dynload/Forcing_lv.R a901f436c5cde25ac2f98748ae82551d *inst/doc/dynload/Forcing_lv.c 6156420e54af94bcf492794ed0231a29 *inst/doc/dynload/SCOC.f 0ec7c970e20e2ec5d915c8c065b64b8d *inst/doc/dynload/daspkdll.R a0e55bab3e7204f12aff54721da68c64 *inst/doc/dynload/daspkfor.f 10a5fda2ed498a58743c1886a13d61da *inst/doc/dynload/ex_Aquaphy.c 2d7ed3de13a976a1ebe75b226c73caa5 *inst/doc/dynload/ex_Aquaphy.f 586850d15e2be94fbe27eb7df0898ce8 *inst/doc/dynload/ex_CCL4model.c 2f532562e77cb2f88f36eedb9b82b5c4 *inst/doc/dynload/ex_CCL4model.f 71834ca5cfe3ee50638bf7164762e5aa *inst/doc/dynload/ex_SCOC.c 6156420e54af94bcf492794ed0231a29 *inst/doc/dynload/ex_SCOC.f dc0d6dc950a608126a445bc0a1988ba5 *inst/doc/dynload/intakes.RData 160b990493dd04c26f6b21e5e5f47d21 *inst/doc/dynload/lsodardll.R 038f0e37a271b702a268535f31c942c7 *inst/doc/dynload/lsodarfor.f 13a693adb572d5cb5ca2f51595bcb960 *inst/doc/dynload/odeband.R c29aa9f32b22e1a0879f05bff7a18c0a *inst/doc/dynload/odeband.f 6542f040003a093e51246e97e12f2190 *inst/doc/dynload/odec.c d9e3836229433daa8c0163fd3f3a18ea *inst/doc/dynload/odedll.R 250379b382326971010171cbfd9a92f8 *inst/doc/dynload/odefor.f bb4065405df9826a5919a7cbcb747f13 *inst/doc/dynload/odefor2.f 051973c89ab6f678e344cdbc3c5899c2 *inst/doc/dynload/radaudae.f 8e62923bc1506ec6fba0a25857fbbb99 *inst/doc/dynload/radaudaedll.R ae2afb02d57ea57ba6b8f42c5704f692 *inst/doc/dynload/satres.R eee7aca79ecb69f57ee392eebf4f0a38 *inst/doc/dynload/satres.f 4c102965c6d6a5355820c815683007f4 *inst/doc/dynload/satresC.c 82b67b1d71f66383bf1a02acdcc150e9 *inst/doc/dynload/zvodedll.R a81a79508e8cb535304b2b6c6d5fac77 *inst/doc/dynload/zvodedll.f 7718208c0fbdd96910c3a50c27f9cdd3 *inst/doc/examples/Arenstorf.R f0d26285a7e36f4ef674de9b66aa0d35 *inst/doc/examples/Daphnia_event.R 1e5f4cec90318c21a6db9efd822f5f5e *inst/doc/examples/Nand.R 6e933b690074cbe308a4905b5794fbd2 *inst/doc/examples/Pollution.R 92a131ab774a97d56c67bc5072c29260 *inst/doc/examples/Schelde_DSA.R b7c081a867ece141eb6d68fb1508b947 *inst/doc/examples/Schelde_FKA.R c80a3fa263db0324b3dc52209c4bf74a *inst/doc/examples/Schelde_FNA.R efd81b32bba7723155958e8574af3ff1 *inst/doc/examples/Schelde_OSA.R 6f1a3c93875c210cc5c2a7b672fab8b3 *inst/doc/examples/Schelde_pars.R d27eba5367c556dd9ea5c90cb10e30d0 *inst/doc/examples/ballode.R b77c6dc0186bc97451484713ed33a678 *inst/doc/examples/examples_paper.R fb0b7672fcb11c004b740aed5fd3781a *inst/doc/mymod.c 49500c40ef108d5529ed7c8755689b18 *inst/doc/mymod.f 423cbcdb18179550331254b13cdd5bd0 *inst/doc/source/ddaspkcomments.txt.gz dced93270fdf192134620a73a6bcf075 *inst/doc/source/opkdmain.f.gz 7bec5627ba9d5af8d93c9129f73e31c4 *inst/doc/source/opkdmaincomments.txt.gz 279975bba4f882e38557aaf07f89036a *inst/doc/source/vodecomments.txt.gz 1f0b35342f6f2d9f7c4b567bb56f6644 *man/DLLfunc.Rd 625c20713467f4686365ee9fcb72221a *man/DLLres.Rd 45853fbddcafe6a39c7f9943dc1e652b *man/SCOC.Rd 42cf2317d8e450688ac73db803e6709e *man/aquaphy.Rd a079d71b38857de60b0b33c87b5ba5d3 *man/ccl4data.Rd 6040dc07121c92d3fa1bc86332b07d55 *man/ccl4model.Rd 6ea0ea45545acf07498f337fcdef75b3 *man/cleanEventTimes.Rd 2463ffe7896a04edb4639a867e00b83a *man/daspk.Rd 9f4d51956e88cadb78088e438eaa3ba7 *man/deSolve-internal.Rd a459d7ab3bf02f9a5dc4a3c98098f203 *man/deSolve.Rd 7efa38b374dd3bc47661ad9e34aed899 *man/dede.Rd 96ce499ae3f2afa326764086c3cf4919 *man/diagnostics.Rd c9cbad59d0970aeb3fbdd0ee5b02d5d6 *man/diagnostics.deSolve.Rd c1a2635c37d832b339c67ffbff33f1ed *man/events.Rd e41906e4c2bcc40fcebab691945e5922 *man/forcings.Rd e775338c94905c15439b013493c899b6 *man/lsoda.Rd f93dd817a69ae3c2b119aebf770c4e3c *man/lsodar.Rd 82bfa9ee34e0dbd063542a22b7d34a87 *man/lsode.Rd 8ac5d007d816f7acbf70b1cca65a33b9 *man/lsodes.Rd 8d4d38aeb64a534a58c7704c35b95574 *man/ode.1D.Rd c2ccea13dd2e55b4d27ab39b2ffe7343 *man/ode.2D.Rd b46540d7d6cb410f7697f99af40ae14f *man/ode.3D.Rd f863cf063f6f70a2d09063bfe7cb9d6b *man/ode.Rd 55cc4bab9e1004c2fcebbb00ef164dda *man/ode.band.Rd 5eae6ef336516d684b13b82dd8376a3a *man/plot.deSolve.Rd ea0ab68f69725505316965b6924865b9 *man/radau.Rd 22be16f0f36f7ba20bebc3826caefcf8 *man/rk.Rd 4be167bbf27a629c53e7b9b224672e5e *man/rk4.Rd e091183180f361a5b3ffa97b46cfad95 *man/rkMethod.Rd 6418431865799b3674dd0730affa8818 *man/timelags.Rd 66651449cbde8908e758e4aa061be702 *man/vode.Rd 88ecf456ed7f62f4d09e5afd5489d5a2 *man/zvode.Rd 2e5ed5cd1f6cb1eb48c3bc7bfcc4934f *src/DLLutil.c 8290d2e9740414e315237f0d5d4024bb *src/Makevars c7fc123246514962537f2b3f31fbec96 *src/R_init_deSolve.c cf4b58246d69335dd7eb21173b338752 *src/brent.c ef0a495ea88dd7c67ff3a3095f1d82e7 *src/call_daspk.c f0de9c69746d891eac5785fd2472077e *src/call_euler.c c46f3a88e4458b596c7c8818e97da85b *src/call_iteration.c 950598b245ac1df0e71f8c8a757bb354 *src/call_lsoda.c db2a7c581dd8b55a70c4d8e4d6dd117f *src/call_radau.c f2a32e9ee386aae1651e6f795e7274cb *src/call_rk4.c 17a7cfe4ee8451ce23927d8ca2412acf *src/call_rkAuto.c 78820c0715bc97e5790c325ca62b4974 *src/call_rkFixed.c dcb45e43002ab1267dcc2a78e47bf222 *src/call_rkImplicit.c 426823ac9cf258e445d2b3b036f223ee *src/call_zvode.c 39445cfb088cca51104f28ea6c989193 *src/daux.f 705ce390418bdd05c67abfe377eee68b *src/ddaspk.f 7a0c500714ba1ada11339203497908d8 *src/deSolve.h e57f97287b075fcb1a203a69c38cc106 *src/deSolve_utils.c 18ad8ad090a8fce19a72c3263ba91e9d *src/dintdy2.f 336b1f06200a19859d3e7ee8aa6687c8 *src/dlinpk.f f328f3993e23e50c83b49658d1c02682 *src/dlsoder.f 945e7b16f2102ec497a4844d1c917010 *src/dsparsk.f 6f65d1e45c46324e730d9003a6fef4cb *src/dvode.f dd31e35fb672636b57b3e5e2627c014a *src/errmsg.f 10a5fda2ed498a58743c1886a13d61da *src/ex_Aquaphy.c 586850d15e2be94fbe27eb7df0898ce8 *src/ex_CCL4model.c ce974c6cfe3334a319ff9ff519d599dd *src/ex_ChemicalDAE.c 1815d64fc1a6e9032baeadcfc0d4da01 *src/ex_SCOC.c 5841fc95b46e14b4b8f6ef69f255d496 *src/externalptr.h fc2d83a9626ce5c049cae5a43740d556 *src/forcings.c 9f957cabb904a0082098e442c67ce73c *src/lags.c 46dd26c35b1ae3afc60d57c08d26c68d *src/opkda1.f 688651a524ec1be8c66183dff137baef *src/opkdmain.f b26047feef75fadeb4a959a205037844 *src/radau5.f b1da04fe446018e43a44b0351a82ef04 *src/radau5a.f 0b5fb5a8a8673f23a7733f8be222a729 *src/rk_auto.c 08b6c0746edb392937ff797c2f87a504 *src/rk_fixed.c 9f058aa8acd4b3b63577ef33410b1735 *src/rk_implicit.c 95ec8dbabf477464377218997d3f81d8 *src/rk_util.c 06245a83dd68eb332301f756f9afd420 *src/rk_util.h e0593ab7bbcf13bbd3c3584f00313981 *src/rprintf.c fa1db7b8006e5a4a0c397af62d5b80d0 *src/twoDmap.c f07d19e2b7815c42e1f912402e7630e9 *src/zvode.f d0f36e39e8f68d89df2a00cd0e0a144d *src/zvode.h 0b5c5eb86441a7b7a33c354493935d8d *vignettes/aphid.png 7c57b9128fc34e219eab6021eeda8a6b *vignettes/comp-event.pdf a7f37878e8888219d66d4f40a700279c *vignettes/compiledCode.Rnw 86ed9ab9c5415bb141eb2cc78b03db66 *vignettes/deSolve.Rnw bca3923230381ce0300918005f438b52 *vignettes/image1D.png 21b31a8ef56f0caba294e8feb3a72ebc *vignettes/integration.bib fb0b7672fcb11c004b740aed5fd3781a *vignettes/mymod.c 49500c40ef108d5529ed7c8755689b18 *vignettes/mymod.f deSolve/build/0000755000175100001440000000000013131751000012757 5ustar hornikusersdeSolve/build/vignette.rds0000644000175100001440000000051313131751000015315 0ustar hornikusers}QAO0P0_͋W'F>ַnruk!}}g? RhwSgDs!?jX~q岆M #=#J2f]P׮T jݬY Hr,iU=}/Z<>!a 5%BaPkYû`Fߴӆ fNҚ 3?mt 7e5ĹmQҶMr@G~V3V{L7Q$9y9*_x^cWv?laGw>F!=6vdeSolve/DESCRIPTION0000754000175100001440000000345013132171175013404 0ustar hornikusersPackage: deSolve Version: 1.20 Title: Solvers for Initial Value Problems of Differential Equations ('ODE', 'DAE', 'DDE') Authors@R: c(person("Karline","Soetaert", role = c("aut"), email = "karline.soetaert@nioz.nl"), person("Thomas","Petzoldt", role = c("aut", "cre"), email = "thomas.petzoldt@tu-dresden.de"), person("R. Woodrow","Setzer", role = c("aut"), email = "setzer.woodrow@epa.gov"), person("odepack authors", role = "cph")) Author: Karline Soetaert [aut], Thomas Petzoldt [aut, cre], R. Woodrow Setzer [aut], odepack authors [cph] Maintainer: Thomas Petzoldt Depends: R (>= 2.15.0) Imports: methods, graphics, grDevices, stats Suggests: scatterplot3d Description: Functions that solve initial value problems of a system of first-order ordinary differential equations ('ODE'), of partial differential equations ('PDE'), of differential algebraic equations ('DAE'), and of delay differential equations. The functions provide an interface to the FORTRAN functions 'lsoda', 'lsodar', 'lsode', 'lsodes' of the 'ODEPACK' collection, to the FORTRAN functions 'dvode', 'zvode' and 'daspk' and a C-implementation of solvers of the 'Runge-Kutta' family with fixed or variable time steps. The package contains routines designed for solving 'ODEs' resulting from 1-D, 2-D and 3-D partial differential equations ('PDE') that have been converted to 'ODEs' by numerical differencing. License: GPL (>= 2) URL: http://desolve.r-forge.r-project.org/ LazyData: yes NeedsCompilation: yes Packaged: 2017-07-13 20:03:15 UTC; user Repository: CRAN Date/Publication: 2017-07-14 16:34:05 UTC deSolve/man/0000755000175100001440000000000013131750050012437 5ustar hornikusersdeSolve/man/timelags.Rd0000754000175100001440000001152412352122172014542 0ustar hornikusers\name{timelags} \alias{timelags} \alias{lagvalue} \alias{lagderiv} \title{ Time Lagged Values of State Variables and Derivatives. } \description{ Functions \code{lagvalue} and \code{lagderiv} provide access to past (lagged) values of state variables and derivatives. They are to be used with function \code{dede}, to solve delay differential equations. } \usage{ lagvalue(t, nr) lagderiv(t, nr) } \arguments{ \item{t }{the time for which the lagged value is wanted; this should be no larger than the current simulation time and no smaller than the initial simulation time. } \item{nr }{the number of the lagged value; if \code{NULL} then all state variables or derivatives are returned. } } \value{ a scalar (or vector) with the lagged value(s). } \author{Karline Soetaert } \details{ The \code{lagvalue} and \code{lagderiv} can only be called during the integration, the lagged time should not be smaller than the initial simulation time, nor should it be larger than the current simulation time. Cubic Hermite interpolation is used to obtain an accurate interpolant at the requested lagged time. } \seealso{ \link{dede}, for how to implement delay differential equations. } \examples{ ## ============================================================================= ## exercise 6 from Shampine and Thompson, 2000 ## solving delay differential equations with dde23 ## ## two lag values ## ============================================================================= ##----------------------------- ## the derivative function ##----------------------------- derivs <- function(t, y, parms) { History <- function(t) c(cos(t), sin(t)) if (t < 1) lag1 <- History(t - 1)[1] else lag1 <- lagvalue(t - 1)[1] # returns a vector; select first element if (t < 2) lag2 <- History(t - 2)[2] else lag2 <- lagvalue(t - 2,2) # faster than lagvalue(t - 2)[2] dy1 <- lag1 * lag2 dy2 <- -y[1] * lag2 list(c(dy1, dy2), lag1 = lag1, lag2 = lag2) } ##----------------------------- ## parameters ##----------------------------- r <- 3.5; m <- 19 ##----------------------------- ## initial values and times ##----------------------------- yinit <- c(y1 = 0, y2 = 0) times <- seq(0, 20, by = 0.01) ##----------------------------- ## solve the model ##----------------------------- yout <- dede(y = yinit, times = times, func = derivs, parms = NULL, atol = 1e-9) ##----------------------------- ## plot results ##----------------------------- plot(yout, type = "l", lwd = 2) ## ============================================================================= ## The predator-prey model with time lags, from Hale ## problem 1 from Shampine and Thompson, 2000 ## solving delay differential equations with dde23 ## ## a vector with lag valuess ## ============================================================================= ##----------------------------- ## the derivative function ##----------------------------- predprey <- function(t, y, parms) { tlag <- t - 1 if (tlag < 0) ylag <- c(80, 30) else ylag <- lagvalue(tlag) # returns a vector dy1 <- a * y[1] * (1 - y[1]/m) + b * y[1] * y[2] dy2 <- c * y[2] + d * ylag[1] * ylag[2] list(c(dy1, dy2)) } ##----------------------------- ## parameters ##----------------------------- a <- 0.25; b <- -0.01; c <- -1 ; d <- 0.01; m <- 200 ##----------------------------- ## initial values and times ##----------------------------- yinit <- c(y1 = 80, y2 = 30) times <- seq(0, 100, by = 0.01) #----------------------------- # solve the model #----------------------------- yout <- dede(y = yinit, times = times, func = predprey, parms = NULL) ##----------------------------- ## display, plot results ##----------------------------- plot(yout, type = "l", lwd = 2, main = "Predator-prey model", mfrow = c(2, 2)) plot(yout[,2], yout[,3], xlab = "y1", ylab = "y2", type = "l", lwd = 2) diagnostics(yout) ## ============================================================================= ## ## A neutral delay differential equation (lagged derivative) ## y't = -y'(t-1), y(t) t < 0 = 1/t ## ## ============================================================================= ##----------------------------- ## the derivative function ##----------------------------- derivs <- function(t, y, parms) { tlag <- t - 1 if (tlag < 0) dylag <- -1 else dylag <- lagderiv(tlag) list(c(dy = -dylag), dylag = dylag) } ##----------------------------- ## initial values and times ##----------------------------- yinit <- 0 times <- seq(0, 4, 0.001) ##----------------------------- ## solve the model ##----------------------------- yout <- dede(y = yinit, times = times, func = derivs, parms = NULL) ##----------------------------- ## display, plot results ##----------------------------- plot(yout, type = "l", lwd = 2) } \keyword{utilities}deSolve/man/daspk.Rd0000754000175100001440000006361613071630263014054 0ustar hornikusers\name{daspk} \alias{daspk} \title{Solver for Differential Algebraic Equations (DAE)} \description{ Solves either: \itemize{ \item a system of ordinary differential equations (ODE) of the form \deqn{y' = f(t, y, ...)} or \item a system of differential algebraic equations (DAE) of the form \deqn{F(t,y,y') = 0} or \item a system of linearly implicit DAES in the form \deqn{M y' = f(t, y)} } using a combination of backward differentiation formula (BDF) and a direct linear system solution method (dense or banded). The \R function \code{daspk} provides an interface to the FORTRAN DAE solver of the same name, written by Linda R. Petzold, Peter N. Brown, Alan C. Hindmarsh and Clement W. Ulrich. The system of DE's is written as an \R function (which may, of course, use \code{\link{.C}}, \code{.Fortran}, \code{\link{.Call}}, etc., to call foreign code) or be defined in compiled code that has been dynamically loaded. } \usage{ daspk(y, times, func = NULL, parms, nind = c(length(y), 0, 0), dy = NULL, res = NULL, nalg = 0, rtol = 1e-6, atol = 1e-6, jacfunc = NULL, jacres = NULL, jactype = "fullint", mass = NULL, estini = NULL, verbose = FALSE, tcrit = NULL, hmin = 0, hmax = NULL, hini = 0, ynames = TRUE, maxord = 5, bandup = NULL, banddown = NULL, maxsteps = 5000, dllname = NULL, initfunc = dllname, initpar = parms, rpar = NULL, ipar = NULL, nout = 0, outnames = NULL, forcings=NULL, initforc = NULL, fcontrol=NULL, events = NULL, lags = NULL, ...) } \arguments{ \item{y }{the initial (state) values for the DE system. If \code{y} has a name attribute, the names will be used to label the output matrix. } \item{times }{time sequence for which output is wanted; the first value of \code{times} must be the initial time; if only one step is to be taken; set \code{times} = \code{NULL}. } \item{func }{to be used if the model is an ODE, or a DAE written in linearly implicit form (M y' = f(t, y)). \code{func} should be an \R-function that computes the values of the derivatives in the ODE system (the \emph{model definition}) at time t. \code{func} must be defined as: \code{func <- function(t, y, parms,...)}. \cr \code{t} is the current time point in the integration, \code{y} is the current estimate of the variables in the ODE system. If the initial values \code{y} has a \code{names} attribute, the names will be available inside \code{func}, unless \code{ynames} is FALSE. \code{parms} is a vector or list of parameters. \code{...} (optional) are any other arguments passed to the function. The return value of \code{func} should be a list, whose first element is a vector containing the derivatives of \code{y} with respect to \code{time}, and whose next elements are global values that are required at each point in \code{times}. The derivatives should be specified in the same order as the specification of the state variables \code{y}. Note that it is not possible to define \code{func} as a compiled function in a dynamically loaded shared library. Use \code{res} instead. } \item{parms }{vector or list of parameters used in \code{func}, \code{jacfunc}, or \code{res} } \item{nind }{if a DAE system: a three-valued vector with the number of variables of index 1, 2, 3 respectively. The equations must be defined such that the index 1 variables precede the index 2 variables which in turn precede the index 3 variables. The sum of the variables of different index should equal N, the total number of variables. Note that this has been added for consistency with \link{radau}. If used, then the variables are weighed differently than in the original daspk code, i.e. index 2 variables are scaled with 1/h, index 3 variables are scaled with 1/h^2. In some cases this allows daspk to solve index 2 or index 3 problems. } \item{dy }{the initial derivatives of the state variables of the DE system. Ignored if an ODE. } \item{res }{if a DAE system: either an \R-function that computes the residual function \eqn{F(t,y,y')} of the DAE system (the model defininition) at time \code{t}, or a character string giving the name of a compiled function in a dynamically loaded shared library. If \code{res} is a user-supplied \R-function, it must be defined as: \code{res <- function(t, y, dy, parms, ...)}. Here \code{t} is the current time point in the integration, \code{y} is the current estimate of the variables in the ODE system, \code{dy} are the corresponding derivatives. If the initial \code{y} or \code{dy} have a \code{names} attribute, the names will be available inside \code{res}, unless \code{ynames} is \code{FALSE}. \code{parms} is a vector of parameters. The return value of \code{res} should be a list, whose first element is a vector containing the residuals of the DAE system, i.e. \eqn{\delta = F(t,y,y')}{delta = F(t,y,y')}, and whose next elements contain output variables that are required at each point in \code{times}. If \code{res} is a string, then \code{dllname} must give the name of the shared library (without extension) which must be loaded before \code{daspk()} is called (see package vignette \code{"compiledCode"} for more information). } \item{nalg }{if a DAE system: the number of algebraic equations (equations not involving derivatives). Algebraic equations should always be the last, i.e. preceeded by the differential equations. Only used if \code{estini} = 1. } \item{rtol }{relative error tolerance, either a scalar or a vector, one value for each y, } \item{atol }{absolute error tolerance, either a scalar or a vector, one value for each y. } \item{jacfunc }{if not \code{NULL}, an \R function that computes the Jacobian of the system of differential equations. Only used in case the system is an ODE (\eqn{y' = f(t, y)}), specified by \code{func}. The \R calling sequence for \code{jacfunc} is identical to that of \code{func}. If the Jacobian is a full matrix, \code{jacfunc} should return a matrix \eqn{\partial\dot{y}/\partial y}{dydot/dy}, where the ith row contains the derivative of \eqn{dy_i/dt} with respect to \eqn{y_j}, or a vector containing the matrix elements by columns (the way \R and FORTRAN store matrices). If the Jacobian is banded, \code{jacfunc} should return a matrix containing only the nonzero bands of the Jacobian, rotated row-wise. See first example of lsode. } \item{jacres }{ \code{jacres} and not \code{jacfunc} should be used if the system is specified by the residual function \eqn{F(t, y, y')}, i.e. \code{jacres} is used in conjunction with \code{res}. If \code{jacres} is an \R-function, the calling sequence for \code{jacres} is identical to that of \code{res}, but with extra parameter \code{cj}. Thus it should be called as: \code{jacres = func(t, y, dy, parms, cj, ...)}. Here \code{t} is the current time point in the integration, \code{y} is the current estimate of the variables in the ODE system, \eqn{y'} are the corresponding derivatives and \code{cj} is a scalar, which is normally proportional to the inverse of the stepsize. If the initial \code{y} or \code{dy} have a \code{names} attribute, the names will be available inside \code{jacres}, unless \code{ynames} is \code{FALSE}. \code{parms} is a vector of parameters (which may have a names attribute). If the Jacobian is a full matrix, \code{jacres} should return the matrix \eqn{dG/dy + c_j\cdot dG/dy'}{dG/d y + cj*dG/d y'}, where the \eqn{i}th row is the sum of the derivatives of \eqn{G_i} with respect to \eqn{y_j} and the scaled derivatives of \eqn{G_i} with respect to \eqn{y'_j}. If the Jacobian is banded, \code{jacres} should return only the nonzero bands of the Jacobian, rotated rowwise. See details for the calling sequence when \code{jacres} is a string. } \item{jactype }{the structure of the Jacobian, one of \code{"fullint"}, \code{"fullusr"}, \code{"bandusr"} or \code{"bandint"} - either full or banded and estimated internally or by the user. } \item{mass }{the mass matrix. If not \code{NULL}, the problem is a linearly implicit DAE and defined as \eqn{M\, dy/dt = f(t,y)}{M dy/dt = f(t,y)}. The mass-matrix \eqn{M} should be of dimension \eqn{n*n} where \eqn{n} is the number of \eqn{y}-values. If \code{mass=NULL} then the model is either an ODE or a DAE, specified with \code{res} } \item{estini }{only if a DAE system, and if initial values of \code{y} and \code{dy} are not consistent (i.e. \eqn{F(t,y,dy) \neq 0}{F(t, y, dy) != 0}), setting \code{estini} = 1 or 2, will solve for them. If \code{estini} = 1: dy and the algebraic variables are estimated from \code{y}; in this case, the number of algebraic equations must be given (\code{nalg}). If \code{estini} = 2: \code{y} will be estimated from \code{dy}. } \item{verbose }{if TRUE: full output to the screen, e.g. will print the \code{diagnostiscs} of the integration - see details. } \item{tcrit }{the FORTRAN routine \code{daspk} overshoots its targets (times points in the vector \code{times}), and interpolates values for the desired time points. If there is a time beyond which integration should not proceed (perhaps because of a singularity), that should be provided in \code{tcrit}. } \item{hmin }{an optional minimum value of the integration stepsize. In special situations this parameter may speed up computations with the cost of precision. Don't use \code{hmin} if you don't know why! } \item{hmax }{an optional maximum value of the integration stepsize. If not specified, \code{hmax} is set to the largest difference in \code{times}, to avoid that the simulation possibly ignores short-term events. If 0, no maximal size is specified. } \item{hini }{initial step size to be attempted; if 0, the initial step size is determined by the solver } \item{ynames }{logical, if \code{FALSE}, names of state variables are not passed to function \code{func}; this may speed up the simulation especially for large models. } \item{maxord }{the maximum order to be allowed. Reduce \code{maxord} to save storage space ( <= 5) } \item{bandup }{number of non-zero bands above the diagonal, in case the Jacobian is banded (and \code{jactype} one of "bandint", "bandusr") } \item{banddown }{number of non-zero bands below the diagonal, in case the Jacobian is banded (and \code{jactype} one of "bandint", "bandusr") } \item{maxsteps }{maximal number of steps per output interval taken by the solver; will be recalculated to be at least 500 and a multiple of 500; if \code{verbose} is \code{TRUE} the solver will give a warning if more than 500 steps are taken, but it will continue till \code{maxsteps} steps. (Note this warning was always given in deSolve versions < 1.10.3). } \item{dllname }{a string giving the name of the shared library (without extension) that contains all the compiled function or subroutine definitions referred to in \code{res} and \code{jacres}. See package vignette \code{"compiledCode"}. } \item{initfunc }{if not \code{NULL}, the name of the initialisation function (which initialises values of parameters), as provided in \file{dllname}. See package vignette \code{"compiledCode"}. } \item{initpar }{only when \file{dllname} is specified and an initialisation function \code{initfunc} is in the dll: the parameters passed to the initialiser, to initialise the common blocks (FORTRAN) or global variables (C, C++). } \item{rpar }{only when \file{dllname} is specified: a vector with double precision values passed to the dll-functions whose names are specified by \code{res} and \code{jacres}. } \item{ipar }{only when \file{dllname} is specified: a vector with integer values passed to the dll-functions whose names are specified by \code{res} and \code{jacres}. } \item{nout }{only used if \file{dllname} is specified and the model is defined in compiled code: the number of output variables calculated in the compiled function \code{res}, present in the shared library. Note: it is not automatically checked whether this is indeed the number of output variables calculated in the dll - you have to perform this check in the code - See package vignette \code{"compiledCode"}. } \item{outnames }{only used if \file{dllname} is specified and \code{nout} > 0: the names of output variables calculated in the compiled function \code{res}, present in the shared library. These names will be used to label the output matrix. } \item{forcings }{only used if \file{dllname} is specified: a list with the forcing function data sets, each present as a two-columned matrix, with (time,value); interpolation outside the interval [min(\code{times}), max(\code{times})] is done by taking the value at the closest data extreme. See \link{forcings} or package vignette \code{"compiledCode"}. } \item{initforc }{if not \code{NULL}, the name of the forcing function initialisation function, as provided in \file{dllname}. It MUST be present if \code{forcings} has been given a value. See \link{forcings} or package vignette \code{"compiledCode"}. } \item{fcontrol }{A list of control parameters for the forcing functions. See \link{forcings} or vignette \code{compiledCode}. } \item{events }{A matrix or data frame that specifies events, i.e. when the value of a state variable is suddenly changed. See \link{events} for more information. } \item{lags }{A list that specifies timelags, i.e. the number of steps that has to be kept. To be used for delay differential equations. See \link{timelags}, \link{dede} for more information. } \item{... }{additional arguments passed to \code{func}, \code{jacfunc}, \code{res} and \code{jacres}, allowing this to be a generic function. } } \value{ A matrix of class \code{deSolve} with up to as many rows as elements in \code{times} and as many columns as elements in \code{y} plus the number of "global" values returned in the next elements of the return from \code{func} or \code{res}, plus an additional column (the first) for the time value. There will be one row for each element in \code{times} unless the FORTRAN routine `daspk' returns with an unrecoverable error. If \code{y} has a names attribute, it will be used to label the columns of the output value. } \author{Karline Soetaert } \examples{ ## ======================================================================= ## Coupled chemical reactions including an equilibrium ## modeled as (1) an ODE and (2) as a DAE ## ## The model describes three chemical species A,B,D: ## subjected to equilibrium reaction D <- > A + B ## D is produced at a constant rate, prod ## B is consumed at 1s-t order rate, r ## Chemical problem formulation 1: ODE ## ======================================================================= ## Dissociation constant K <- 1 ## parameters pars <- c( ka = 1e6, # forward rate r = 1, prod = 0.1) Fun_ODE <- function (t, y, pars) { with (as.list(c(y, pars)), { ra <- ka*D # forward rate rb <- ka/K *A*B # backward rate ## rates of changes dD <- -ra + rb + prod dA <- ra - rb dB <- ra - rb - r*B return(list(dy = c(dA, dB, dD), CONC = A+B+D)) }) } ## ======================================================================= ## Chemical problem formulation 2: DAE ## 1. get rid of the fast reactions ra and rb by taking ## linear combinations : dD+dA = prod (res1) and ## dB-dA = -r*B (res2) ## 2. In addition, the equilibrium condition (eq) reads: ## as ra = rb : ka*D = ka/K*A*B = > K*D = A*B ## ======================================================================= Res_DAE <- function (t, y, yprime, pars) { with (as.list(c(y, yprime, pars)), { ## residuals of lumped rates of changes res1 <- -dD - dA + prod res2 <- -dB + dA - r*B ## and the equilibrium equation eq <- K*D - A*B return(list(c(res1, res2, eq), CONC = A+B+D)) }) } ## ======================================================================= ## Chemical problem formulation 3: Mass * Func ## Based on the DAE formulation ## ======================================================================= Mass_FUN <- function (t, y, pars) { with (as.list(c(y, pars)), { ## as above, but without the f1 <- prod f2 <- - r*B ## and the equilibrium equation f3 <- K*D - A*B return(list(c(f1, f2, f3), CONC = A+B+D)) }) } Mass <- matrix(nrow = 3, ncol = 3, byrow = TRUE, data=c(1, 0, 1, # dA + 0 + dB -1, 1, 0, # -dA + dB +0 0, 0, 0)) # algebraic times <- seq(0, 100, by = 2) ## Initial conc; D is in equilibrium with A,B y <- c(A = 2, B = 3, D = 2*3/K) ## ODE model solved with daspk ODE <- daspk(y = y, times = times, func = Fun_ODE, parms = pars, atol = 1e-10, rtol = 1e-10) ## Initial rate of change dy <- c(dA = 0, dB = 0, dD = 0) ## DAE model solved with daspk DAE <- daspk(y = y, dy = dy, times = times, res = Res_DAE, parms = pars, atol = 1e-10, rtol = 1e-10) MASS<- daspk(y=y, times=times, func = Mass_FUN, parms = pars, mass = Mass) ## ================ ## plotting output ## ================ plot(ODE, DAE, xlab = "time", ylab = "conc", type = c("l", "p"), pch = c(NA, 1)) legend("bottomright", lty = c(1, NA), pch = c(NA, 1), col = c("black", "red"), legend = c("ODE", "DAE")) # difference between both implementations: max(abs(ODE-DAE)) ## ======================================================================= ## same DAE model, now with the Jacobian ## ======================================================================= jacres_DAE <- function (t, y, yprime, pars, cj) { with (as.list(c(y, yprime, pars)), { ## res1 = -dD - dA + prod PD[1,1] <- -1*cj # d(res1)/d(A)-cj*d(res1)/d(dA) PD[1,2] <- 0 # d(res1)/d(B)-cj*d(res1)/d(dB) PD[1,3] <- -1*cj # d(res1)/d(D)-cj*d(res1)/d(dD) ## res2 = -dB + dA - r*B PD[2,1] <- 1*cj PD[2,2] <- -r -1*cj PD[2,3] <- 0 ## eq = K*D - A*B PD[3,1] <- -B PD[3,2] <- -A PD[3,3] <- K return(PD) }) } PD <- matrix(ncol = 3, nrow = 3, 0) DAE2 <- daspk(y = y, dy = dy, times = times, res = Res_DAE, jacres = jacres_DAE, jactype = "fullusr", parms = pars, atol = 1e-10, rtol = 1e-10) max(abs(DAE-DAE2)) ## See \dynload subdirectory for a FORTRAN implementation of this model ## ======================================================================= ## The chemical model as a DLL, with production a forcing function ## ======================================================================= times <- seq(0, 100, by = 2) pars <- c(K = 1, ka = 1e6, r = 1) ## Initial conc; D is in equilibrium with A,B y <- c(A = 2, B = 3, D = as.double(2*3/pars["K"])) ## Initial rate of change dy <- c(dA = 0, dB = 0, dD = 0) # production increases with time prod <- matrix(ncol = 2, data = c(seq(0, 100, by = 10), 0.1*(1+runif(11)*1))) ODE_dll <- daspk(y = y, dy = dy, times = times, res = "chemres", dllname = "deSolve", initfunc = "initparms", initforc = "initforcs", parms = pars, forcings = prod, atol = 1e-10, rtol = 1e-10, nout = 2, outnames = c("CONC","Prod")) plot(ODE_dll, which = c("Prod", "D"), xlab = "time", ylab = c("/day", "conc"), main = c("production rate","D")) } \references{ L. R. Petzold, A Description of DASSL: A Differential/Algebraic System Solver, in Scientific Computing, R. S. Stepleman et al. (Eds.), North-Holland, Amsterdam, 1983, pp. 65-68. K. E. Brenan, S. L. Campbell, and L. R. Petzold, Numerical Solution of Initial-Value Problems in Differential-Algebraic Equations, Elsevier, New York, 1989. P. N. Brown and A. C. Hindmarsh, Reduced Storage Matrix Methods in Stiff ODE Systems, J. Applied Mathematics and Computation, 31 (1989), pp. 40-91. P. N. Brown, A. C. Hindmarsh, and L. R. Petzold, Using Krylov Methods in the Solution of Large-Scale Differential-Algebraic Systems, SIAM J. Sci. Comp., 15 (1994), pp. 1467-1488. P. N. Brown, A. C. Hindmarsh, and L. R. Petzold, Consistent Initial Condition Calculation for Differential-Algebraic Systems, LLNL Report UCRL-JC-122175, August 1995; submitted to SIAM J. Sci. Comp. Netlib: \url{http://www.netlib.org} } \details{ The daspk solver uses the backward differentiation formulas of orders one through five (specified with \code{maxord}) to solve either: \itemize{ \item an ODE system of the form \deqn{y' = f(t,y,...)} or \item a DAE system of the form \deqn{y' = M f(t,y,...)} or \item a DAE system of the form \deqn{F(t,y,y') = 0}. The index of the DAE should be preferable <= 1. } ODEs are specified using argument \code{func}, DAEs are specified using argument \code{res}. If a DAE system, Values for y \emph{and} y' (argument \code{dy}) at the initial time must be given as input. Ideally, these values should be consistent, that is, if t, y, y' are the given initial values, they should satisfy F(t,y,y') = 0. \cr However, if consistent values are not known, in many cases daspk can solve for them: when \code{estini} = 1, y' and algebraic variables (their number specified with \code{nalg}) will be estimated, when \code{estini} = 2, y will be estimated. The form of the \bold{Jacobian} can be specified by \code{jactype}. This is one of: \describe{ \item{jactype = "fullint":}{a full Jacobian, calculated internally by \code{daspk}, the default, } \item{jactype = "fullusr":}{a full Jacobian, specified by user function \code{jacfunc} or \code{jacres}, } \item{jactype = "bandusr":}{a banded Jacobian, specified by user function \code{jacfunc} or \code{jacres}; the size of the bands specified by \code{bandup} and \code{banddown}, } \item{jactype = "bandint":}{a banded Jacobian, calculated by \code{daspk}; the size of the bands specified by \code{bandup} and \code{banddown}. } } If \code{jactype} = "fullusr" or "bandusr" then the user must supply a subroutine \code{jacfunc}. If jactype = "fullusr" or "bandusr" then the user must supply a subroutine \code{jacfunc} or \code{jacres}. The input parameters \code{rtol}, and \code{atol} determine the \bold{error control} performed by the solver. If the request for precision exceeds the capabilities of the machine, \code{daspk} will return an error code. See \code{\link{lsoda}} for details. When the index of the variables is specified (argument \code{nind}), and higher index variables are present, then the equations are scaled such that equations corresponding to index 2 variables are multiplied with 1/h, for index 3 they are multiplied with 1/h^2, where h is the time step. This is not in the standard DASPK code, but has been added for consistency with solver \link{radau}. Because of this, daspk can solve certain index 2 or index 3 problems. \bold{res and jacres} may be defined in compiled C or FORTRAN code, as well as in an R-function. See package vignette \code{"compiledCode"} for details. Examples in FORTRAN are in the \file{dynload} subdirectory of the \code{deSolve} package directory. The diagnostics of the integration can be printed to screen by calling \code{\link{diagnostics}}. If \code{verbose} = \code{TRUE}, the diagnostics will written to the screen at the end of the integration. See vignette("deSolve") for an explanation of each element in the vectors containing the diagnostic properties and how to directly access them. \bold{Models} may be defined in compiled C or FORTRAN code, as well as in an R-function. See package vignette \code{"compiledCode"} for details. More information about models defined in compiled code is in the package vignette ("compiledCode"); information about linking forcing functions to compiled code is in \link{forcings}. Examples in both C and FORTRAN are in the \file{dynload} subdirectory of the \code{deSolve} package directory. } \seealso{ \itemize{ \item \code{\link{radau}} for integrating DAEs up to index 3, \item \code{\link{rk}}, \item \code{\link{rk4}} and \code{\link{euler}} for Runge-Kutta integrators. \item \code{\link{lsoda}}, \code{\link{lsode}}, \code{\link{lsodes}}, \code{\link{lsodar}}, \code{\link{vode}}, for other solvers of the Livermore family, \item \code{\link{ode}} for a general interface to most of the ODE solvers, \item \code{\link{ode.band}} for solving models with a banded Jacobian, \item \code{\link{ode.1D}} for integrating 1-D models, \item \code{\link{ode.2D}} for integrating 2-D models, \item \code{\link{ode.3D}} for integrating 3-D models, } \code{\link{diagnostics}} to print diagnostic messages. } \note{ In this version, the Krylov method is not (yet) supported. From \code{deSolve} version 1.10.4 and above, the following changes were made \enumerate{ \item the argument list to \code{daspk} now also includes \code{nind}, the index of each variable. This is used to scale the variables, such that \code{daspk} in R can also solve certain index 2 or index 3 problems, which the original Fortran version may not be able to solve. \item the default of \code{atol} was changed from 1e-8 to 1e-6, to be consistent with the other solvers. \item the multiple warnings from daspk when the number of steps exceed 500 were toggled off unless \code{verbose} is \code{TRUE} } } \keyword{math} deSolve/man/deSolve-internal.Rd0000754000175100001440000000313612352122172016150 0ustar hornikusers\name{deSolve-internal} \alias{timestep} \title{Internal deSolve Functions} \description{ Internal deSolve functions, these are not to be called by the user. } \usage{ timestep(prev = TRUE) } \arguments{ \item{prev }{if \code{TRUE} will return the timestep previously used; when \code{FALSE} will return the time step to be currently tried by the integrator. } } \details{ Function \code{timestep} is intended to return the current or next timestep of the integration. It works only under specific circumstances and should not be used by the end user. Instead of this, please see the example below for a pure \R solution. } \seealso{ \code{\link{diagnostics}} for information about the time steps used,\cr \code{\link{lagvalue}} and \code{\link{lagderiv}} that can be used for DDEs. } \examples{ ################################################### ### This example shows how to retrieve information ### about the used time steps. ################################################### ## a function closure ('lexical scoping') modelClosure <- function(t0) { t.old <- t.act <- t0 function(t, y, parms) { t.old <<- t.act t.act <<- t cat(t, "\t", t - t.old, "\n") with (as.list(c(y, parms)), { dP <- a * P - b * P * K dK <- b * P * K - c * K list(c(dP, dK)) }) } } model <- modelClosure(0) # initialization parms <- c(a = 0.1, b = 0.1, c = 0.1) y <- c(P = 1, K = 2) out <- ode(y = y, func = model, times = c(0, 2), parms = parms, method = "lsoda") ls() # prove that t.old and t.new are local within 'model' } \keyword{ internal }deSolve/man/SCOC.Rd0000754000175100001440000000465412352122172013472 0ustar hornikusers\name{SCOC} \alias{SCOC} \title{A Sediment Model of Oxygen Consumption} \description{A model that describes oxygen consumption in a marine sediment. One state variable: \itemize{ \item sedimentary organic carbon, } Organic carbon settles on the sediment surface (forcing function Flux) and decays at a constant rate. The equation is simple: \deqn{\frac{dC}{dt} = Flux - k C} This model is written in \code{FORTRAN}. } \usage{SCOC(times, y = NULL, parms, Flux, ...)} \arguments{ \item{times}{time sequence for which output is wanted; the first value of times must be the initial time,} \item{y}{the initial value of the state variable; if \code{NULL} it will be estimated based on \code{Flux} and \code{parms},} \item{parms }{the model parameter, \code{k},} \item{Flux }{a data set with the organic carbon deposition rates, } \item{...}{any other parameters passed to the integrator \code{ode} (which solves the model).} } \author{Karline Soetaert } \examples{ ## Forcing function data Flux <- matrix(ncol = 2, byrow = TRUE, data = c( 1, 0.654, 11, 0.167, 21, 0.060, 41, 0.070, 73,0.277, 83,0.186, 93,0.140,103, 0.255, 113, 0.231,123, 0.309,133,1.127,143,1.923, 153,1.091,163,1.001, 173, 1.691,183, 1.404,194,1.226,204,0.767, 214, 0.893,224,0.737, 234,0.772,244, 0.726,254,0.624,264,0.439, 274,0.168,284 ,0.280, 294,0.202,304, 0.193,315,0.286,325,0.599, 335, 1.889,345, 0.996,355,0.681,365,1.135)) parms <- c(k = 0.01) times <- 1:365 out <- SCOC(times, parms = parms, Flux = Flux) plot(out[,"time"], out[,"Depo"], type = "l", col = "red") lines(out[,"time"], out[,"Mineralisation"], col = "blue") ## Constant interpolation of forcing function - left side of interval fcontrol <- list(method = "constant") out2 <- SCOC(times, parms = parms, Flux = Flux, fcontrol = fcontrol) plot(out2[,"time"], out2[,"Depo"], type = "l",col = "red") lines(out2[,"time"], out2[,"Mineralisation"], col = "blue") } \references{ Soetaert, K. and P.M.J. Herman, 2009. A Practical Guide to Ecological Modelling. Using \R as a Simulation Platform. Springer, 372 pp. } \details{ The model is implemented primarily to demonstrate the linking of FORTRAN with \R-code. The source can be found in the \file{doc/examples/dynload} subdirectory of the package. } \seealso{ \code{\link{ccl4model}}, the CCl4 inhalation model. \code{\link{aquaphy}}, the algal growth model. } \keyword{models} deSolve/man/zvode.Rd0000754000175100001440000003241412352122172014065 0ustar hornikusers\name{zvode} \alias{zvode} \title{Solver for Ordinary Differential Equations (ODE) for COMPLEX variables} \description{ Solves the initial value problem for stiff or nonstiff systems of ordinary differential equations (ODE) in the form: \deqn{dy/dt = f(t,y)} where \eqn{dy} and \eqn{y} are complex variables. The \R function \code{zvode} provides an interface to the FORTRAN ODE solver of the same name, written by Peter N. Brown, Alan C. Hindmarsh and George D. Byrne. } \usage{zvode(y, times, func, parms, rtol = 1e-6, atol = 1e-6, jacfunc = NULL, jactype = "fullint", mf = NULL, verbose = FALSE, tcrit = NULL, hmin = 0, hmax = NULL, hini = 0, ynames = TRUE, maxord = NULL, bandup = NULL, banddown = NULL, maxsteps = 5000, dllname = NULL, initfunc = dllname, initpar = parms, rpar = NULL, ipar = NULL, nout = 0, outnames = NULL, forcings = NULL, initforc = NULL, fcontrol = NULL, ...) } \arguments{ \item{y }{the initial (state) values for the ODE system. If \code{y} has a name attribute, the names will be used to label the output matrix. \emph{y has to be complex} } \item{times }{time sequence for which output is wanted; the first value of \code{times} must be the initial time; if only one step is to be taken; set \code{times = NULL}. } \item{func }{either an \R-function that computes the values of the derivatives in the ODE system (the \emph{model definition}) at time \code{t}, or a character string giving the name of a compiled function in a dynamically loaded shared library. If \code{func} is an \R-function, it must be defined as: \code{func <- function(t, y, parms, ...)}. \code{t} is the current time point in the integration, \code{y} is the current estimate of the variables in the ODE system. If the initial values \code{y} has a \code{names} attribute, the names will be available inside \code{func}. \code{parms} is a vector or list of parameters; ... (optional) are any other arguments passed to the function. The return value of \code{func} should be a list, whose first element is a vector containing the derivatives of \code{y} with respect to \code{time}, and whose next elements are global values that are required at each point in \code{times}. The derivatives must be specified in the \bold{same order} as the state variables \code{y}. They should be \emph{complex numbers}. If \code{func} is a string, then \code{dllname} must give the name of the shared library (without extension) which must be loaded before \code{zvode()} is called. See package vignette \code{"compiledCode"} for more details. } \item{parms }{vector or list of parameters used in \code{func} or \code{jacfunc}. } \item{rtol }{relative error tolerance, either a scalar or an array as long as \code{y}. See details. } \item{atol }{absolute error tolerance, either a scalar or an array as long as \code{y}. See details. } \item{jacfunc }{if not \code{NULL}, an \R function that computes the Jacobian of the system of differential equations \eqn{\partial\dot{y}_i/\partial y_j}{dydot(i)/dy(j)}, or a string giving the name of a function or subroutine in \file{dllname} that computes the Jacobian (see vignette \code{"compiledCode"} for more about this option). In some circumstances, supplying \code{jacfunc} can speed up the computations, if the system is stiff. The \R calling sequence for \code{jacfunc} is identical to that of \code{func}. If the Jacobian is a full matrix, \code{jacfunc} should return a matrix \eqn{\dot{dy}/dy}{dydot/dy}, where the ith row contains the derivative of \eqn{dy_i/dt} with respect to \eqn{y_j}, or a vector containing the matrix elements by columns (the way \R and FORTRAN store matrices). Its elements should be \emph{complex numbers}. If the Jacobian is banded, \code{jacfunc} should return a matrix containing only the nonzero bands of the Jacobian, rotated row-wise. See first example of \code{lsode}. } \item{jactype }{the structure of the Jacobian, one of \code{"fullint"}, \code{"fullusr"}, \code{"bandusr"} or \code{"bandint"} - either full or banded and estimated internally or by user; overruled if \code{mf} is not \code{NULL}. } \item{mf }{the "method flag" passed to function \code{zvode} - overrules \code{jactype} - provides more options than \code{jactype} - see details. } \item{verbose }{if TRUE: full output to the screen, e.g. will print the \code{diagnostiscs} of the integration - see details. } \item{tcrit }{if not \code{NULL}, then \code{zvode} cannot integrate past \code{tcrit}. The FORTRAN routine \code{dvode} overshoots its targets (times points in the vector \code{times}), and interpolates values for the desired time points. If there is a time beyond which integration should not proceed (perhaps because of a singularity), that should be provided in \code{tcrit}. } \item{hmin }{an optional minimum value of the integration stepsize. In special situations this parameter may speed up computations with the cost of precision. Don't use hmin if you don't know why! } \item{hmax }{an optional maximum value of the integration stepsize. If not specified, hmax is set to the largest difference in \code{times}, to avoid that the simulation possibly ignores short-term events. If 0, no maximal size is specified. } \item{hini }{initial step size to be attempted; if 0, the initial step size is determined by the solver. } \item{ynames }{logical; if \code{FALSE}: names of state variables are not passed to function \code{func} ; this may speed up the simulation especially for multi-D models. } \item{maxord }{the maximum order to be allowed. \code{NULL} uses the default, i.e. order 12 if implicit Adams method (\code{meth = 1}), order 5 if BDF method (\code{meth = 2}). Reduce maxord to save storage space. } \item{bandup }{number of non-zero bands above the diagonal, in case the Jacobian is banded. } \item{banddown }{number of non-zero bands below the diagonal, in case the Jacobian is banded. } \item{maxsteps }{maximal number of steps per output interval taken by the solver. } \item{dllname }{a string giving the name of the shared library (without extension) that contains all the compiled function or subroutine definitions refered to in \code{func} and \code{jacfunc}. See package vignette \code{"compiledCode"}. } \item{initfunc }{if not \code{NULL}, the name of the initialisation function (which initialises values of parameters), as provided in \file{dllname}. See package vignette \code{"compiledCode"}. } \item{initpar }{only when \file{dllname} is specified and an initialisation function \code{initfunc} is in the dll: the parameters passed to the initialiser, to initialise the common blocks (FORTRAN) or global variables (C, C++). } \item{rpar }{only when \file{dllname} is specified: a vector with double precision values passed to the DLL-functions whose names are specified by \code{func} and \code{jacfunc}. } \item{ipar }{only when \file{dllname} is specified: a vector with integer values passed to the dll-functions whose names are specified by \code{func} and \code{jacfunc}. } \item{nout }{only used if \code{dllname} is specified and the model is defined in compiled code: the number of output variables calculated in the compiled function \code{func}, present in the shared library. Note: it is not automatically checked whether this is indeed the number of output variables calculated in the DLL - you have to perform this check in the code - See package vignette \code{"compiledCode"}. } \item{outnames }{only used if \file{dllname} is specified and \code{nout} > 0: the names of output variables calculated in the compiled function \code{func}, present in the shared library. These names will be used to label the output matrix. } \item{forcings }{only used if \file{dllname} is specified: a list with the forcing function data sets, each present as a two-columned matrix, with (time,value); interpolation outside the interval [min(\code{times}), max(\code{times})] is done by taking the value at the closest data extreme. See \link{forcings} or package vignette \code{"compiledCode"}. } \item{initforc }{if not \code{NULL}, the name of the forcing function initialisation function, as provided in \file{dllname}. It MUST be present if \code{forcings} has been given a value. See \link{forcings} or package vignette \code{"compiledCode"}. } \item{fcontrol }{A list of control parameters for the forcing functions. \link{forcings} or package vignette \code{"compiledCode"} } \item{... }{additional arguments passed to \code{func} and \code{jacfunc} allowing this to be a generic function. } } \value{ A matrix of class \code{deSolve} with up to as many rows as elements in \code{times} and as many columns as elements in \code{y} plus the number of "global" values returned in the next elements of the return from \code{func}, plus and additional column for the time value. There will be a row for each element in \code{times} unless the FORTRAN routine `zvode' returns with an unrecoverable error. If \code{y} has a names attribute, it will be used to label the columns of the output value. } \author{Karline Soetaert } \examples{ ## ======================================================================= ## Example 1 - very simple example ## df/dt = 1i*f, where 1i is the imaginary unit ## The initial value is f(0) = 1 = 1+0i ## ======================================================================= ZODE <- function(Time, f, Pars) { df <- 1i*f return(list(df)) } pars <- NULL yini <- c(f = 1+0i) times <- seq(0, 2*pi, length = 100) out <- zvode(func = ZODE, y = yini, parms = pars, times = times, atol = 1e-10, rtol = 1e-10) # The analytical solution to this ODE is the exp-function: # f(t) = exp(1i*t) # = cos(t)+1i*sin(t) (due to Euler's equation) analytical.solution <- exp(1i * times) ## compare numerical and analytical solution tail(cbind(out[,2], analytical.solution)) ## ======================================================================= ## Example 2 - example in "zvode.f", ## df/dt = 1i*f (same as above ODE) ## dg/dt = -1i*g*g*f (an additional ODE depending on f) ## ## Initial values are ## g(0) = 1/2.1 and ## z(0) = 1 ## ======================================================================= ZODE2<-function(Time,State,Pars) { with(as.list(State), { df <- 1i * f dg <- -1i * g*g * f return(list(c(df, dg))) }) } yini <- c(f = 1 + 0i, g = 1/2.1 + 0i) times <- seq(0, 2*pi, length = 100) out <- zvode(func = ZODE2, y = yini, parms = NULL, times = times, atol = 1e-10, rtol = 1e-10) ## The analytical solution is ## f(t) = exp(1i*t) (same as above) ## g(t) = 1/(f(t) + 1.1) analytical <- cbind(f = exp(1i * times), g = 1/(exp(1i * times) + 1.1)) ## compare numerical solution and the two analytical ones: tail(cbind(out[,2], analytical[,1])) } \references{ P. N. Brown, G. D. Byrne, and A. C. Hindmarsh, 1989. VODE: A Variable Coefficient ODE Solver, SIAM J. Sci. Stat. Comput., 10, pp. 1038-1051. \cr Also, LLNL Report UCRL-98412, June 1988. G. D. Byrne and A. C. Hindmarsh, 1975. A Polyalgorithm for the Numerical Solution of Ordinary Differential Equations. ACM Trans. Math. Software, 1, pp. 71-96. A. C. Hindmarsh and G. D. Byrne, 1977. EPISODE: An Effective Package for the Integration of Systems of Ordinary Differential Equations. LLNL Report UCID-30112, Rev. 1. G. D. Byrne and A. C. Hindmarsh, 1976. EPISODEB: An Experimental Package for the Integration of Systems of Ordinary Differential Equations with Banded Jacobians. LLNL Report UCID-30132, April 1976. A. C. Hindmarsh, 1983. ODEPACK, a Systematized Collection of ODE Solvers. in Scientific Computing, R. S. Stepleman et al., eds., North-Holland, Amsterdam, pp. 55-64. K. R. Jackson and R. Sacks-Davis, 1980. An Alternative Implementation of Variable Step-Size Multistep Formulas for Stiff ODEs. ACM Trans. Math. Software, 6, pp. 295-318. Netlib: \url{http://www.netlib.org} } \details{ see \code{\link{vode}}, the double precision version, for details. } \note{ From version 1.10.4, the default of atol was changed from 1e-8 to 1e-6, to be consistent with the other solvers. The following text is adapted from the zvode.f source code: When using \code{zvode} for a stiff system, it should only be used for the case in which the function f is analytic, that is, when each f(i) is an analytic function of each y(j). Analyticity means that the partial derivative df(i)/dy(j) is a unique complex number, and this fact is critical in the way \code{zvode} solves the dense or banded linear systems that arise in the stiff case. For a complex stiff ODE system in which f is not analytic, \code{zvode} is likely to have convergence failures, and for this problem one should instead use \code{ode} on the equivalent real system (in the real and imaginary parts of y). } \seealso{ \code{\link{vode}} for the double precision version } \keyword{math} deSolve/man/rk.Rd0000754000175100001440000003616713071630263013367 0ustar hornikusers\name{rk} \alias{rk} \title{Explicit One-Step Solvers for Ordinary Differential Equations (ODE)} \description{Solving initial value problems for non-stiff systems of first-order ordinary differential equations (ODEs). The \R function \code{rk} is a top-level function that provides interfaces to a collection of common explicit one-step solvers of the Runge-Kutta family with fixed or variable time steps. The system of ODE's is written as an \R function (which may, of course, use \code{\link{.C}}, \code{\link{.Fortran}}, \code{\link{.Call}}, etc., to call foreign code) or be defined in compiled code that has been dynamically loaded. A vector of parameters is passed to the ODEs, so the solver may be used as part of a modeling package for ODEs, or for parameter estimation using any appropriate modeling tool for non-linear models in \R such as \code{\link{optim}}, \code{\link{nls}}, \code{\link{nlm}} or \code{\link[nlme]{nlme}} } \usage{ rk(y, times, func, parms, rtol = 1e-6, atol = 1e-6, verbose = FALSE, tcrit = NULL, hmin = 0, hmax = NULL, hini = hmax, ynames = TRUE, method = rkMethod("rk45dp7", ... ), maxsteps = 5000, dllname = NULL, initfunc = dllname, initpar = parms, rpar = NULL, ipar = NULL, nout = 0, outnames = NULL, forcings = NULL, initforc = NULL, fcontrol = NULL, events = NULL, ...) } \arguments{ \item{y }{the initial (state) values for the ODE system. If \code{y} has a name attribute, the names will be used to label the output matrix. } \item{times }{times at which explicit estimates for \code{y} are desired. The first value in \code{times} must be the initial time. } \item{func }{either an \R-function that computes the values of the derivatives in the ODE system (the \emph{model definition}) at time t, or a character string giving the name of a compiled function in a dynamically loaded shared library. If \code{func} is an \R-function, it must be defined as: \code{func <- function(t, y, parms,...)}. \code{t} is the current time point in the integration, \code{y} is the current estimate of the variables in the ODE system. If the initial values \code{y} has a \code{names} attribute, the names will be available inside \code{func}. \code{parms} is a vector or list of parameters; ... (optional) are any other arguments passed to the function. The return value of \code{func} should be a list, whose first element is a vector containing the derivatives of \code{y} with respect to \code{time}, and whose next elements are global values that are required at each point in \code{times}. The derivatives must be specified in the \bold{same order} as the state variables \code{y}. If \code{func} is a string, then \code{dllname} must give the name of the shared library (without extension) which must be loaded before \code{rk} is called. See package vignette \code{"compiledCode"} for more details. } \item{parms }{vector or list of parameters used in \code{func}. } \item{rtol }{relative error tolerance, either a scalar or an array as long as \code{y}. Only applicable to methods with variable time step, see details. } \item{atol }{absolute error tolerance, either a scalar or an array as long as \code{y}. Only applicable to methods with variable time step, see details. } \item{tcrit }{if not \code{NULL}, then \code{rk} cannot integrate past \code{tcrit}. This parameter is for compatibility with other solvers. } \item{verbose }{a logical value that, when TRUE, triggers more verbose output from the ODE solver. } \item{hmin }{an optional minimum value of the integration stepsize. In special situations this parameter may speed up computations with the cost of precision. Don't use \code{hmin} if you don't know why! } \item{hmax }{an optional maximum value of the integration stepsize. If not specified, \code{hmax} is set to the maximum of \code{hini} and the largest difference in \code{times}, to avoid that the simulation possibly ignores short-term events. If 0, no maximal size is specified. Note that \code{hmin} and \code{hmax} are ignored by fixed step methods like \code{"rk4"} or \code{"euler"}. } \item{hini }{initial step size to be attempted; if 0, the initial step size is determined automatically by solvers with flexible time step. For fixed step methods, setting \code{hini = 0} forces internal time steps identically to external time steps provided by \code{times}. Similarly, internal time steps of non-interpolating solvers cannot be bigger than external time steps specified in \code{times}. } \item{ynames }{if \code{FALSE}: names of state variables are not passed to function \code{func} ; this may speed up the simulation especially for large models. } \item{method }{the integrator to use. This can either be a string constant naming one of the pre-defined methods or a call to function \code{\link{rkMethod}} specifying a user-defined method. The most common methods are the fixed-step methods \code{"euler"}, second and fourth-order Runge Kutta (\code{"rk2"}, \code{"rk4"}), or the variable step methods Bogacki-Shampine \code{"rk23bs"}, Runge-Kutta-Fehlberg \code{"rk34f"}, the fifth-order Cash-Karp method \code{"rk45ck"} or the fifth-order Dormand-Prince method with seven stages \code{"rk45dp7"}. As a suggestion, one may use \code{"rk23bs"} (alias \code{"ode23"}) for simple problems and \code{"rk45dp7"} (alias \code{"ode45"}) for rough problems. } \item{maxsteps }{average maximal number of steps per output interval taken by the solver. This argument is defined such as to ensure compatibility with the Livermore-solvers. \code{rk} only accepts the maximal number of steps for the entire integration. It is calculated as \code{max(length(times) * maxsteps, max(diff(times)/hini + 1)}. } \item{dllname }{a string giving the name of the shared library (without extension) that contains all the compiled function or subroutine definitions refered to in \code{func} and \code{jacfunc}. See package vignette \code{"compiledCode"}. } \item{initfunc }{if not \code{NULL}, the name of the initialisation function (which initialises values of parameters), as provided in \file{dllname}. See package vignette \code{"compiledCode"}. } \item{initpar }{only when \file{dllname} is specified and an initialisation function \code{initfunc} is in the dll: the parameters passed to the initialiser, to initialise the common blocks (FORTRAN) or global variables (C, C++). } \item{rpar }{only when \file{dllname} is specified: a vector with double precision values passed to the dll-functions whose names are specified by \code{func} and \code{jacfunc}. } \item{ipar }{only when \file{dllname} is specified: a vector with integer values passed to the dll-functions whose names are specified by \code{func} and \code{jacfunc}. } \item{nout }{only used if \code{dllname} is specified and the model is defined in compiled code: the number of output variables calculated in the compiled function \code{func}, present in the shared library. Note: it is not automatically checked whether this is indeed the number of output variables calculated in the dll - you have to perform this check in the code. See package vignette \code{"compiledCode"}. } \item{outnames }{only used if \file{dllname} is specified and \code{nout} > 0: the names of output variables calculated in the compiled function \code{func}, present in the shared library. } \item{forcings }{only used if \file{dllname} is specified: a list with the forcing function data sets, each present as a two-columned matrix, with (time,value); interpolation outside the interval [min(\code{times}), max(\code{times})] is done by taking the value at the closest data extreme. See \link{forcings} or package vignette \code{"compiledCode"}. } \item{initforc }{if not \code{NULL}, the name of the forcing function initialisation function, as provided in \file{dllname}. It MUST be present if \code{forcings} has been given a value. See \link{forcings} or package vignette \code{"compiledCode"}. } \item{fcontrol }{A list of control parameters for the forcing functions. See \link{forcings} or vignette \code{compiledCode}. } \item{events }{A matrix or data frame that specifies events, i.e. when the value of a state variable is suddenly changed. See \link{events} for more information. Not also that if events are specified, then polynomial interpolation is switched off and integration takes place from one external time step to the next, with an internal step size less than or equal the difference of two adjacent points of \code{times}. } \item{... }{additional arguments passed to \code{func} allowing this to be a generic function. } } \details{ Function \code{rk} is a generalized implementation that can be used to evaluate different solvers of the Runge-Kutta family of explicit ODE solvers. A pre-defined set of common method parameters is in function \code{\link{rkMethod}} which also allows to supply user-defined Butcher tables. The input parameters \code{rtol}, and \code{atol} determine the error control performed by the solver. The solver will control the vector of estimated local errors in \bold{y}, according to an inequality of the form max-norm of ( \bold{e}/\bold{ewt} ) \eqn{\leq}{ <= } 1, where \bold{ewt} is a vector of positive error weights. The values of \code{rtol} and \code{atol} should all be non-negative. The form of \bold{ewt} is: \deqn{\mathbf{rtol} \times \mathrm{abs}(\mathbf{y}) + \mathbf{atol}}{\bold{rtol} * abs(\bold{y}) + \bold{atol}} where multiplication of two vectors is element-by-element. \bold{Models} can be defined in \R as a user-supplied \bold{R-function}, that must be called as: \code{yprime = func(t, y, parms)}. \code{t} is the current time point in the integration, \code{y} is the current estimate of the variables in the ODE system. The return value of \code{func} should be a list, whose first element is a vector containing the derivatives of \code{y} with respect to time, and whose second element contains output variables that are required at each point in time. Examples are given below. } \value{ A matrix of class \code{deSolve} with up to as many rows as elements in \code{times} and as many columns as elements in \code{y} plus the number of "global" values returned in the next elements of the return from \code{func}, plus and additional column for the time value. There will be a row for each element in \code{times} unless the integration routine returns with an unrecoverable error. If \code{y} has a names attribute, it will be used to label the columns of the output value. } \note{ Arguments \code{rpar} and \code{ipar} are provided for compatibility with \code{lsoda}. Starting with version 1.8 implicit Runge-Kutta methods are also supported by this general \code{rk} interface, however their implementation is still experimental. Instead of this you may consider \code{\link{radau}} for a specific full implementation of an implicit Runge-Kutta method. } \references{ Butcher, J. C. (1987) The numerical analysis of ordinary differential equations, Runge-Kutta and general linear methods, Wiley, Chichester and New York. Engeln-Muellges, G. and Reutter, F. (1996) Numerik Algorithmen: Entscheidungshilfe zur Auswahl und Nutzung. VDI Verlag, Duesseldorf. Hindmarsh, Alan C. (1983) ODEPACK, A Systematized Collection of ODE Solvers; in p.55--64 of Stepleman, R.W. et al.[ed.] (1983) \emph{Scientific Computing}, North-Holland, Amsterdam. Press, W. H., Teukolsky, S. A., Vetterling, W. T. and Flannery, B. P. (2007) Numerical Recipes in C. Cambridge University Press. } \author{Thomas Petzoldt \email{thomas.petzoldt@tu-dresden.de}} \seealso{ For most practical cases, solvers of the Livermore family (i.e. the ODEPACK solvers, see below) are superior. Some of them are also suitable for stiff ODEs, differential algebraic equations (DAEs), or partial differential equations (PDEs). \itemize{ \item \code{\link{rkMethod}} for a list of available Runge-Kutta parameter sets, \item \code{\link{rk4}} and \code{\link{euler}} for special versions without interpolation (and less overhead), \item \code{\link{lsoda}}, \code{\link{lsode}}, \code{\link{lsodes}}, \code{\link{lsodar}}, \code{\link{vode}}, \code{\link{daspk}} for solvers of the Livermore family, \item \code{\link{ode}} for a general interface to most of the ODE solvers, \item \code{\link{ode.band}} for solving models with a banded Jacobian, \item \code{\link{ode.1D}} for integrating 1-D models, \item \code{\link{ode.2D}} for integrating 2-D models, \item \code{\link{ode.3D}} for integrating 3-D models, \item \code{\link{diagnostics}} to print diagnostic messages. } } \examples{ ## ======================================================================= ## Example: Resource-producer-consumer Lotka-Volterra model ## ======================================================================= ## Notes: ## - Parameters are a list, names accessible via "with" function ## - Function sigimp passed as an argument (input) to model ## (see also ode and lsoda examples) SPCmod <- function(t, x, parms, input) { with(as.list(c(parms, x)), { import <- input(t) dS <- import - b*S*P + g*C # substrate dP <- c*S*P - d*C*P # producer dC <- e*P*C - f*C # consumer res <- c(dS, dP, dC) list(res) }) } ## The parameters parms <- c(b = 0.001, c = 0.1, d = 0.1, e = 0.1, f = 0.1, g = 0.0) ## vector of timesteps times <- seq(0, 200, length = 101) ## external signal with rectangle impulse signal <- data.frame(times = times, import = rep(0, length(times))) signal$import[signal$times >= 10 & signal$times <= 11] <- 0.2 sigimp <- approxfun(signal$times, signal$import, rule = 2) ## Start values for steady state xstart <- c(S = 1, P = 1, C = 1) ## Euler method out1 <- rk(xstart, times, SPCmod, parms, hini = 0.1, input = sigimp, method = "euler") ## classical Runge-Kutta 4th order out2 <- rk(xstart, times, SPCmod, parms, hini = 1, input = sigimp, method = "rk4") ## Dormand-Prince method of order 5(4) out3 <- rk(xstart, times, SPCmod, parms, hmax = 1, input = sigimp, method = "rk45dp7") mf <- par("mfrow") ## deSolve plot method for comparing scenarios plot(out1, out2, out3, which = c("S", "P", "C"), main = c ("Substrate", "Producer", "Consumer"), col =c("black", "red", "green"), lty = c("solid", "dotted", "dotted"), lwd = c(1, 2, 1)) ## user-specified plot function plot (out1[,"P"], out1[,"C"], type = "l", xlab = "Producer", ylab = "Consumer") lines(out2[,"P"], out2[,"C"], col = "red", lty = "dotted", lwd = 2) lines(out3[,"P"], out3[,"C"], col = "green", lty = "dotted") legend("center", legend = c("euler", "rk4", "rk45dp7"), lty = c(1, 3, 3), lwd = c(1, 2, 1), col = c("black", "red", "green")) par(mfrow = mf) } \keyword{ math }deSolve/man/ode.Rd0000754000175100001440000003100312352122172013476 0ustar hornikusers\name{ode} \alias{ode} \alias{print.deSolve} \alias{summary.deSolve} \title{General Solver for Ordinary Differential Equations} \description{Solves a system of ordinary differential equations; a wrapper around the implemented ODE solvers} \usage{ode(y, times, func, parms, method = c("lsoda", "lsode", "lsodes", "lsodar", "vode", "daspk", "euler", "rk4", "ode23", "ode45", "radau", "bdf", "bdf_d", "adams", "impAdams", "impAdams_d", "iteration"), ...) \method{print}{deSolve}(x, \dots) \method{summary}{deSolve}(object, select = NULL, which = select, subset = NULL, \dots) } \arguments{ \item{y }{the initial (state) values for the ODE system, a vector. If \code{y} has a name attribute, the names will be used to label the output matrix. } \item{times }{time sequence for which output is wanted; the first value of \code{times} must be the initial time. } \item{func }{either an \R-function that computes the values of the derivatives in the ODE system (the model definition) at time t, or a character string giving the name of a compiled function in a dynamically loaded shared library. If \code{func} is an \R-function, it must be defined as: \code{func <- function(t, y, parms,...)}. \code{t} is the current time point in the integration, \code{y} is the current estimate of the variables in the ODE system. If the initial values \code{y} has a \code{names} attribute, the names will be available inside \code{func}. \code{parms} is a vector or list of parameters; ... (optional) are any other arguments passed to the function. The return value of \code{func} should be a list, whose first element is a vector containing the derivatives of \code{y} with respect to \code{time}, and whose next elements are global values that are required at each point in \code{times}. The derivatives must be specified in the \bold{same order} as the state variables \code{y}. If \code{func} is a string, then \code{dllname} must give the name of the shared library (without extension) which must be loaded before \code{ode} is called. See package vignette \code{"compiledCode"} for more details. } \item{parms }{parameters passed to \code{func}.} \item{method }{the integrator to use, either a \bold{function} that performs integration, or a \bold{list} of class \code{\link{rkMethod}}, or a \bold{string} (\code{"lsoda"}, \code{"lsode"}, \code{"lsodes"},\code{"lsodar"},\code{"vode"}, \code{"daspk"}, \code{"euler"}, \code{"rk4"}, \code{"ode23"}, \code{"ode45"}, \code{"radau"}, \code{"bdf"}, \code{"bdf_d"}, \code{"adams"}, \code{"impAdams"} or \code{"impAdams_d"} ,"iteration"). Options "bdf", "bdf_d", "adams", "impAdams" or "impAdams_d" are the backward differentiation formula, the BDF with diagonal representation of the Jacobian, the (explicit) Adams and the implicit Adams method, and the implicit Adams method with diagonal representation of the Jacobian respectively (see details). The default integrator used is \link{lsoda}. Method \code{"iteration"} is special in that here the function \code{func} should return the new value of the state variables rather than the rate of change. This can be used for individual based models, for difference equations, or in those cases where the integration is performed within \code{func}). See last example. } \item{x }{an object of class \code{deSolve}, as returned by the integrators, and to be printed or to be subsetted. } \item{object }{an object of class \code{deSolve}, as returned by the integrators, and whose summary is to be calculated. In contrast to R's default, this returns a data.frame. It returns one summary column for a multi-dimensional variable. } \item{which }{the name(s) or the index to the variables whose summary should be estimated. Default = all variables. } \item{select }{which variable/columns to be selected. } \item{subset }{logical expression indicating elements or rows to keep when calculating a \code{summary}: missing values are taken as \code{FALSE} } \item{... }{additional arguments passed to the integrator or to the methods.} } \value{ A matrix of class \code{deSolve} with up to as many rows as elements in \code{times} and as many columns as elements in \code{y} plus the number of "global" values returned in the second element of the return from \code{func}, plus an additional column (the first) for the time value. There will be one row for each element in \code{times} unless the integrator returns with an unrecoverable error. If \code{y} has a names attribute, it will be used to label the columns of the output value. } \author{Karline Soetaert } \details{ This is simply a wrapper around the various ode solvers. See package vignette for information about specifying the model in compiled code. See the selected integrator for the additional options. The default integrator used is \code{\link{lsoda}}. The option \code{method = "bdf"} provdes a handle to the backward differentiation formula (it is equal to using \code{method = "lsode"}). It is best suited to solve stiff (systems of) equations. The option \code{method = "bdf_d"} selects the backward differentiation formula that uses Jacobi-Newton iteration (neglecting the off-diagonal elements of the Jacobian (it is equal to using \code{method = "lsode", mf = 23}). It is best suited to solve stiff (systems of) equations. \code{method = "adams"} triggers the Adams method that uses functional iteration (no Jacobian used); (equal to \code{method = "lsode", mf = 10}. It is often the best choice for solving non-stiff (systems of) equations. Note: when functional iteration is used, the method is often said to be explicit, although it is in fact implicit. \code{method = "impAdams"} selects the implicit Adams method that uses Newton- Raphson iteration (equal to \code{method = "lsode", mf = 12}. \code{method = "impAdams_d"} selects the implicit Adams method that uses Jacobi- Newton iteration, i.e. neglecting all off-diagonal elements (equal to \code{method = "lsode", mf = 13}. For very stiff systems, \code{method = "daspk"} may outperform \code{method = "bdf"}. } \seealso{ \itemize{ \item \code{\link{plot.deSolve}} for plotting the outputs, \item \code{\link{dede}} general solver for delay differential equations \item \code{\link{ode.band}} for solving models with a banded Jacobian, \item \code{\link{ode.1D}} for integrating 1-D models, \item \code{\link{ode.2D}} for integrating 2-D models, \item \code{\link{ode.3D}} for integrating 3-D models, \item \code{\link{aquaphy}}, \code{\link{ccl4model}}, where \code{ode} is used, \item \code{\link{lsoda}}, \code{\link{lsode}}, \code{\link{lsodes}}, \code{\link{lsodar}}, \code{\link{vode}}, \code{\link{daspk}}, \code{\link{radau}}, \item \code{\link{rk}}, \code{\link{rkMethod}} for additional Runge-Kutta methods, \item \code{\link{forcings}} and \code{\link{events}}, \item \code{\link{diagnostics}} to print diagnostic messages. } } \keyword{math} \examples{ ## ======================================================================= ## Example1: Predator-Prey Lotka-Volterra model (with logistic prey) ## ======================================================================= LVmod <- function(Time, State, Pars) { with(as.list(c(State, Pars)), { Ingestion <- rIng * Prey * Predator GrowthPrey <- rGrow * Prey * (1 - Prey/K) MortPredator <- rMort * Predator dPrey <- GrowthPrey - Ingestion dPredator <- Ingestion * assEff - MortPredator return(list(c(dPrey, dPredator))) }) } pars <- c(rIng = 0.2, # /day, rate of ingestion rGrow = 1.0, # /day, growth rate of prey rMort = 0.2 , # /day, mortality rate of predator assEff = 0.5, # -, assimilation efficiency K = 10) # mmol/m3, carrying capacity yini <- c(Prey = 1, Predator = 2) times <- seq(0, 200, by = 1) out <- ode(yini, times, LVmod, pars) summary(out) ## Default plot method plot(out) ## User specified plotting matplot(out[ , 1], out[ , 2:3], type = "l", xlab = "time", ylab = "Conc", main = "Lotka-Volterra", lwd = 2) legend("topright", c("prey", "predator"), col = 1:2, lty = 1:2) ## ======================================================================= ## Example2: Substrate-Producer-Consumer Lotka-Volterra model ## ======================================================================= ## Note: ## Function sigimp passed as an argument (input) to model ## (see also lsoda and rk examples) SPCmod <- function(t, x, parms, input) { with(as.list(c(parms, x)), { import <- input(t) dS <- import - b*S*P + g*C # substrate dP <- c*S*P - d*C*P # producer dC <- e*P*C - f*C # consumer res <- c(dS, dP, dC) list(res) }) } ## The parameters parms <- c(b = 0.001, c = 0.1, d = 0.1, e = 0.1, f = 0.1, g = 0.0) ## vector of timesteps times <- seq(0, 200, length = 101) ## external signal with rectangle impulse signal <- data.frame(times = times, import = rep(0, length(times))) signal$import[signal$times >= 10 & signal$times <= 11] <- 0.2 sigimp <- approxfun(signal$times, signal$import, rule = 2) ## Start values for steady state xstart <- c(S = 1, P = 1, C = 1) ## Solve model out <- ode(y = xstart, times = times, func = SPCmod, parms = parms, input = sigimp) ## Default plot method plot(out) ## User specified plotting mf <- par(mfrow = c(1, 2)) matplot(out[,1], out[,2:4], type = "l", xlab = "time", ylab = "state") legend("topright", col = 1:3, lty = 1:3, legend = c("S", "P", "C")) plot(out[,"P"], out[,"C"], type = "l", lwd = 2, xlab = "producer", ylab = "consumer") par(mfrow = mf) ## ======================================================================= ## Example3: Discrete time model - using method = "iteration" ## The host-parasitoid model from Soetaert and Herman, 2009, ## Springer - p. 284. ## ======================================================================= Parasite <- function(t, y, ks) { P <- y[1] H <- y[2] f <- A * P / (ks + H) Pnew <- H * (1 - exp(-f)) Hnew <- H * exp(rH * (1 - H) - f) list (c(Pnew, Hnew)) } rH <- 2.82 # rate of increase A <- 100 # attack rate ks <- 15 # half-saturation density out <- ode(func = Parasite, y = c(P = 0.5, H = 0.5), times = 0:50, parms = ks, method = "iteration") out2<- ode(func = Parasite, y = c(P = 0.5, H = 0.5), times = 0:50, parms = 25, method = "iteration") out3<- ode(func = Parasite, y = c(P = 0.5, H = 0.5), times = 0:50, parms = 35, method = "iteration") ## Plot all 3 scenarios in one figure plot(out, out2, out3, lty = 1, lwd = 2) ## Same like "out", but *output* every two steps ## hini = 1 ensures that the same *internal* timestep of 1 is used outb <- ode(func = Parasite, y = c(P = 0.5, H = 0.5), times = seq(0, 50, 2), hini = 1, parms = ks, method = "iteration") plot(out, outb, type = c("l", "p")) \dontrun{ ## ======================================================================= ## Example4: Playing with the Jacobian options - see e.g. lsoda help page ## ## IMPORTANT: The following example is temporarily broken because of ## incompatibility with R 3.0 on some systems. ## A fix is on the way. ## ======================================================================= ## a stiff equation, exponential decay, run 500 times stiff <- function(t, y, p) { # y and r are a 500-valued vector list(- r * y) } N <- 500 r <- runif(N, 15, 20) yini <- runif(N, 1, 40) times <- 0:10 ## Using the default print(system.time( out <- ode(y = yini, parms = NULL, times = times, func = stiff) )) # diagnostics(out) shows that the method used = bdf (2), so it it stiff ## Specify that the Jacobian is banded, with nonzero values on the ## diagonal, i.e. the bandwidth up and down = 0 print(system.time( out2 <- ode(y = yini, parms = NULL, times = times, func = stiff, jactype = "bandint", bandup = 0, banddown = 0) )) ## Now we also specify the Jacobian function jacob <- function(t, y, p) -r print(system.time( out3 <- ode(y = yini, parms = NULL, times = times, func = stiff, jacfunc = jacob, jactype = "bandusr", bandup = 0, banddown = 0) )) ## The larger the value of N, the larger the time gain... } } deSolve/man/forcings.Rd0000754000175100001440000001550012352122172014545 0ustar hornikusers\name{forcings} \alias{forcings} \title{ Passing Forcing Functions to Models Written in R or Compiled Code. } \description{ A \code{forcing function} is an external variable that is essential to the model, but not explicitly modeled. Rather, it is imposed as a time-series. Thus, if a model uses forcing variables, their value at each time point needs to be estimated by interpolation of a data series. } \details{ The \code{forcing functions} are imposed as a data series, that contains the values of the forcings at specified times. Models may be defined in compiled C or FORTRAN code, as well as in R. If the model is defined in \emph{R code}, it is most efficient to: 1. define a function that performs the linear interpolation, using \R's \code{\link{approxfun}}. It is generally recommended to use \code{rule = 2}, such as to allow extrapolation outside of the time interval, especially when using the Livermore solvers, as these may exceed the last time point. 2. call this function within the model's derivative function, to interpolate at the current timestep. See first example. If the models are defined in \emph{compiled C or FORTRAN code}, it is possible to use \code{deSolve}s forcing function update algorithm. This is the compiled-code equivalent of \code{approxfun} or \code{approx}. In this case:\cr 1. the forcing function data series is provided by means of argument \code{forcings}, 2. \code{initforc} is the name of the forcing function initialisation function, as provided in \file{dllname}, while 3. \code{fcontrol} is a list used to finetune how the forcing update should be performed. The \bold{fcontrol} argument is a list that can supply any of the following components (conform the definitions in the \link[stats]{approxfun} function): \describe{ \item{method }{specifies the interpolation method to be used. Choices are \code{"linear"} or \code{"constant"},} \item{rule }{an integer describing how interpolation is to take place outside the interval [min(times), max(times)]. If \code{rule} is \code{1} then an error will be triggered and the calculation will stop if \code{times} extends the interval of the forcing function data set. If it is \code{2}, the \bold{default}, the value at the closest data extreme is used, a warning will be printed if \code{verbose} is \code{TRUE}, Note that the default differs from the \code{approx} default.} \item{f }{For \code{method = "constant"} a number between \code{0} and \code{1} inclusive, indicating a compromise between left- and right-continuous step functions. If \code{y0} and \code{y1} are the values to the left and right of the point then the value is \code{y0 * (1 - f) + y1 * f} so that \code{f = 0} is right-continuous and \code{f = 1} is left-continuous, } \item{ties }{Handling of tied \code{times} values. Either a function with a single vector argument returning a single number result or the string \code{"ordered"}. Note that the default is \code{"ordered"}, hence the existence of ties will NOT be investigated; in the \code{C} code this will mean that -if ties exist, the first value will be used; if the dataset is not ordered, then nonsense will be produced. Alternative values for \code{ties} are \code{mean}, \code{min} etc } } The defaults are: \code{fcontrol = list(method = "linear", rule = 2, f = 0, ties = "ordered")} Note that only ONE specification is allowed, even if there is more than one forcing function data set. More information about models defined in compiled code is in the package vignette ("compiledCode"). } \note{ How to write compiled code is described in package vignette \code{"compiledCode"}, which should be referred to for details. This vignette also contains examples on how to pass forcing functions. } \author{ Karline Soetaert, Thomas Petzoldt, R. Woodrow Setzer } \seealso{ \code{\link{approx}} or \code{\link{approxfun}}, the \R function, \code{\link{events}} for how to implement events. } \examples{ ## ============================================================================= ## FORCING FUNCTION: The sediment oxygen consumption example - R-code: ## ============================================================================= ## Forcing function data Flux <- matrix(ncol=2,byrow=TRUE,data=c( 1, 0.654, 11, 0.167, 21, 0.060, 41, 0.070, 73,0.277, 83,0.186, 93,0.140,103, 0.255, 113, 0.231,123, 0.309,133,1.127,143,1.923, 153,1.091,163,1.001, 173, 1.691,183, 1.404,194,1.226,204,0.767, 214, 0.893,224,0.737, 234,0.772,244, 0.726,254,0.624,264,0.439, 274,0.168,284 ,0.280, 294,0.202,304, 0.193,315,0.286,325,0.599, 335, 1.889,345, 0.996,355,0.681,365,1.135)) parms <- c(k=0.01) times <- 1:365 ## the model sediment <- function( t, O2, k) list (c(Depo(t) - k * O2), depo = Depo(t)) # the forcing functions; rule = 2 avoids NaNs in interpolation Depo <- approxfun(x = Flux[,1], y = Flux[,2], method = "linear", rule = 2) Out <- ode(times = times, func = sediment, y = c(O2 = 63), parms = parms) ## same forcing functions, now constant interpolation Depo <- approxfun(x = Flux[,1], y = Flux[,2], method = "constant", f = 0.5, rule = 2) Out2 <- ode(times = times, func = sediment, y = c(O2 = 63), parms = parms) mf <- par(mfrow = c(2, 1)) plot (Out, which = "depo", type = "l", lwd = 2, mfrow = NULL) lines(Out2[,"time"], Out2[,"depo"], col = "red", lwd = 2) plot (Out, which = "O2", type = "l", lwd = 2, mfrow = NULL) lines(Out2[,"time"], Out2[,"O2"], col = "red", lwd = 2) ## ============================================================================= ## SCOC is the same model, as implemented in FORTRAN ## ============================================================================= out<- SCOC(times, parms = parms, Flux = Flux) plot(out[,"time"], out[,"Depo"], type = "l", col = "red") lines(out[,"time"], out[,"Mineralisation"], col = "blue") ## Constant interpolation of forcing function - left side of interval fcontrol <- list(method = "constant") out2 <- SCOC(times, parms = parms, Flux = Flux, fcontrol = fcontrol) plot(out2[,"time"], out2[,"Depo"], type = "l", col = "red") lines(out2[,"time"], out2[,"Mineralisation"], col = "blue") \dontrun{ ## ============================================================================= ## show examples (see respective help pages for details) ## ============================================================================= example(aquaphy) ## show package vignette with tutorial about how to use compiled models ## + source code of the vignette ## + directory with C and FORTRAN sources vignette("compiledCode") edit(vignette("compiledCode")) browseURL(paste(system.file(package = "deSolve"), "/doc", sep = "")) } } \keyword{utilities}deSolve/man/lsodes.Rd0000754000175100001440000005630713071630263014242 0ustar hornikusers\name{lsodes} \alias{lsodes} \title{Solver for Ordinary Differential Equations (ODE) With Sparse Jacobian } \description{ Solves the initial value problem for stiff systems of ordinary differential equations (ODE) in the form: \deqn{dy/dt = f(t,y)} and where the Jacobian matrix df/dy has an arbitrary sparse structure. The \R function \code{lsodes} provides an interface to the FORTRAN ODE solver of the same name, written by Alan C. Hindmarsh and Andrew H. Sherman. The system of ODE's is written as an \R function or be defined in compiled code that has been dynamically loaded. } \usage{ lsodes(y, times, func, parms, rtol = 1e-6, atol = 1e-6, jacvec = NULL, sparsetype = "sparseint", nnz = NULL, inz = NULL, rootfunc = NULL, verbose = FALSE, nroot = 0, tcrit = NULL, hmin = 0, hmax = NULL, hini = 0, ynames = TRUE, maxord = NULL, maxsteps = 5000, lrw = NULL, liw = NULL, dllname = NULL, initfunc = dllname, initpar = parms, rpar = NULL, ipar = NULL, nout = 0, outnames = NULL, forcings=NULL, initforc = NULL, fcontrol=NULL, events=NULL, lags = NULL, ...) } \arguments{ \item{y }{the initial (state) values for the ODE system. If \code{y} has a name attribute, the names will be used to label the output matrix. } \item{times }{time sequence for which output is wanted; the first value of \code{times} must be the initial time; if only one step is to be taken; set \code{times} = \code{NULL}. } \item{func }{either an \R-function that computes the values of the derivatives in the ODE system (the \emph{model definition}) at time \code{t}, or a character string giving the name of a compiled function in a dynamically loaded shared library. If \code{func} is an \R-function, it must be defined as: \code{func <- function(t, y, parms,...)}. \code{t} is the current time point in the integration, \code{y} is the current estimate of the variables in the ODE system. If the initial values \code{y} has a \code{names} attribute, the names will be available inside \code{func}. \code{parms} is a vector or list of parameters; ... (optional) are any other arguments passed to the function. The return value of \code{func} should be a list, whose first element is a vector containing the derivatives of \code{y} with respect to \code{time}, and whose next elements are global values that are required at each point in \code{times}. The derivatives must be specified in the \bold{same order} as the state variables \code{y}. If \code{func} is a string, then \code{dllname} must give the name of the shared library (without extension) which must be loaded before \code{lsodes()} is called. See package vignette \code{"compiledCode"} for more details. } \item{parms }{vector or list of parameters used in \code{func} or \code{jacfunc}. } \item{rtol }{relative error tolerance, either a scalar or an array as long as \code{y}. See details. } \item{atol }{absolute error tolerance, either a scalar or an array as long as \code{y}. See details. } \item{jacvec }{if not \code{NULL}, an \R function that computes a column of the Jacobian of the system of differential equations \eqn{\partial\dot{y}_i/\partial y_j}{dydot(i)/dy(j)}, or a string giving the name of a function or subroutine in \file{dllname} that computes the column of the Jacobian (see vignette \code{"compiledCode"} for more about this option). The \R calling sequence for \code{jacvec} is identical to that of \code{func}, but with extra parameter \code{j}, denoting the column number. Thus, \code{jacvec} should be called as: \code{jacvec = func(t, y, j, parms)} and \code{jacvec} should return a vector containing column \code{j} of the Jacobian, i.e. its i-th value is \eqn{\partial\dot{y}_i/\partial y_j}{dydot(i)/dy(j)}. If this function is absent, \code{lsodes} will generate the Jacobian by differences. } \item{sparsetype }{the sparsity structure of the Jacobian, one of "sparseint" or "sparseusr", "sparsejan", ..., The sparsity can be estimated internally by lsodes (first option) or given by the user (last two). See details. } \item{nnz }{the number of nonzero elements in the sparse Jacobian (if this is unknown, use an estimate). } \item{inz }{if \code{sparsetype} equal to "sparseusr", a two-columned matrix with the (row, column) indices to the nonzero elements in the sparse Jacobian. If \code{sparsetype} = "sparsejan", a vector with the elements ian followed by he elements jan as used in the lsodes code. See details. In all other cases, ignored. } \item{rootfunc }{if not \code{NULL}, an \R function that computes the function whose root has to be estimated or a string giving the name of a function or subroutine in \file{dllname} that computes the root function. The \R calling sequence for \code{rootfunc} is identical to that of \code{func}. \code{rootfunc} should return a vector with the function values whose root is sought. } \item{verbose }{if \code{TRUE}: full output to the screen, e.g. will print the \code{diagnostiscs} of the integration - see details. } \item{nroot }{only used if \file{dllname} is specified: the number of constraint functions whose roots are desired during the integration; if \code{rootfunc} is an R-function, the solver estimates the number of roots. } \item{tcrit }{if not \code{NULL}, then \code{lsodes} cannot integrate past \code{tcrit}. The FORTRAN routine \code{lsodes} overshoots its targets (times points in the vector \code{times}), and interpolates values for the desired time points. If there is a time beyond which integration should not proceed (perhaps because of a singularity), that should be provided in \code{tcrit}. } \item{hmin }{an optional minimum value of the integration stepsize. In special situations this parameter may speed up computations with the cost of precision. Don't use \code{hmin} if you don't know why! } \item{hmax }{an optional maximum value of the integration stepsize. If not specified, \code{hmax} is set to the largest difference in \code{times}, to avoid that the simulation possibly ignores short-term events. If 0, no maximal size is specified. } \item{hini }{initial step size to be attempted; if 0, the initial step size is determined by the solver. } \item{ynames }{logical, if \code{FALSE} names of state variables are not passed to function \code{func}; this may speed up the simulation especially for multi-D models. } \item{maxord }{the maximum order to be allowed. \code{NULL} uses the default, i.e. order 12 if implicit Adams method (meth = 1), order 5 if BDF method (meth = 2). Reduce maxord to save storage space. } \item{maxsteps }{maximal number of steps per output interval taken by the solver. } \item{lrw }{the length of the real work array rwork; due to the sparsicity, this cannot be readily predicted. If \code{NULL}, a guess will be made, and if not sufficient, \code{lsodes} will return with a message indicating the size of rwork actually required. Therefore, some experimentation may be necessary to estimate the value of \code{lrw}. For instance, if you get the error: \preformatted{ DLSODES- RWORK length is insufficient to proceed. Length needed is .ge. LENRW (=I1), exceeds LRW (=I2) In above message, I1 = 27627 I2 = 25932 } set \code{lrw} equal to 27627 or a higher value } \item{liw }{the length of the integer work array iwork; due to the sparsicity, this cannot be readily predicted. If \code{NULL}, a guess will be made, and if not sufficient, \code{lsodes} will return with a message indicating the size of iwork actually required. Therefore, some experimentation may be necessary to estimate the value of \code{liw}. } \item{dllname }{a string giving the name of the shared library (without extension) that contains all the compiled function or subroutine definitions refered to in \code{func} and \code{jacfunc}. See package vignette \code{"compiledCode"}. } \item{initfunc }{if not \code{NULL}, the name of the initialisation function (which initialises values of parameters), as provided in \file{dllname}. See package vignette \code{"compiledCode"}. } \item{initpar }{only when \file{dllname} is specified and an initialisation function \code{initfunc} is in the dll: the parameters passed to the initialiser, to initialise the common blocks (FORTRAN) or global variables (C, C++). } \item{rpar }{only when \file{dllname} is specified: a vector with double precision values passed to the dll-functions whose names are specified by \code{func} and \code{jacfunc}. } \item{ipar }{only when \file{dllname} is specified: a vector with integer values passed to the dll-functions whose names are specified by \code{func} and \code{jacfunc}. } \item{nout }{only used if \code{dllname} is specified and the model is defined in compiled code: the number of output variables calculated in the compiled function \code{func}, present in the shared library. Note: it is not automatically checked whether this is indeed the number of output variables calculated in the dll - you have to perform this check in the code. See package vignette \code{"compiledCode"}. } \item{outnames }{only used if \file{dllname} is specified and \code{nout} > 0: the names of output variables calculated in the compiled function \code{func}, present in the shared library. These names will be used to label the output matrix. } \item{forcings }{only used if \file{dllname} is specified: a list with the forcing function data sets, each present as a two-columned matrix, with (time,value); interpolation outside the interval [min(\code{times}), max(\code{times})] is done by taking the value at the closest data extreme. See \link{forcings} or package vignette \code{"compiledCode"}. } \item{initforc }{if not \code{NULL}, the name of the forcing function initialisation function, as provided in \file{dllname}. It MUST be present if \code{forcings} has been given a value. See \link{forcings} or package vignette \code{"compiledCode"}. } \item{fcontrol }{A list of control parameters for the forcing functions. See \link{forcings} or vignette \code{compiledCode}. } \item{events }{A matrix or data frame that specifies events, i.e. when the value of a state variable is suddenly changed. See \link{events} for more information. } \item{lags }{A list that specifies timelags, i.e. the number of steps that has to be kept. To be used for delay differential equations. See \link{timelags}, \link{dede} for more information. } \item{... }{additional arguments passed to \code{func} and \code{jacfunc} allowing this to be a generic function. } } \value{ A matrix of class \code{deSolve} with up to as many rows as elements in \code{times} and as many columns as elements in \code{y} plus the number of "global" values returned in the next elements of the return from \code{func}, plus and additional column for the time value. There will be a row for each element in \code{times} unless the FORTRAN routine `lsodes' returns with an unrecoverable error. If \code{y} has a names attribute, it will be used to label the columns of the output value. } \author{Karline Soetaert } \examples{ ## Various ways to solve the same model. ## ======================================================================= ## The example from lsodes source code ## A chemical model ## ======================================================================= n <- 12 y <- rep(1, n) dy <- rep(0, n) times <- c(0, 0.1*(10^(0:4))) rtol <- 1.0e-4 atol <- 1.0e-6 parms <- c(rk1 = 0.1, rk2 = 10.0, rk3 = 50.0, rk4 = 2.5, rk5 = 0.1, rk6 = 10.0, rk7 = 50.0, rk8 = 2.5, rk9 = 50.0, rk10 = 5.0, rk11 = 50.0, rk12 = 50.0,rk13 = 50.0, rk14 = 30.0, rk15 = 100.0,rk16 = 2.5, rk17 = 100.0,rk18 = 2.5, rk19 = 50.0, rk20 = 50.0) # chemistry <- function (time, Y, pars) { with (as.list(pars), { dy[1] <- -rk1 *Y[1] dy[2] <- rk1 *Y[1] + rk11*rk14*Y[4] + rk19*rk14*Y[5] - rk3 *Y[2]*Y[3] - rk15*Y[2]*Y[12] - rk2*Y[2] dy[3] <- rk2 *Y[2] - rk5 *Y[3] - rk3*Y[2]*Y[3] - rk7*Y[10]*Y[3] + rk11*rk14*Y[4] + rk12*rk14*Y[6] dy[4] <- rk3 *Y[2]*Y[3] - rk11*rk14*Y[4] - rk4*Y[4] dy[5] <- rk15*Y[2]*Y[12] - rk19*rk14*Y[5] - rk16*Y[5] dy[6] <- rk7 *Y[10]*Y[3] - rk12*rk14*Y[6] - rk8*Y[6] dy[7] <- rk17*Y[10]*Y[12] - rk20*rk14*Y[7] - rk18*Y[7] dy[8] <- rk9 *Y[10] - rk13*rk14*Y[8] - rk10*Y[8] dy[9] <- rk4 *Y[4] + rk16*Y[5] + rk8*Y[6] + rk18*Y[7] dy[10] <- rk5 *Y[3] + rk12*rk14*Y[6] + rk20*rk14*Y[7] + rk13*rk14*Y[8] - rk7 *Y[10]*Y[3] - rk17*Y[10]*Y[12] - rk6 *Y[10] - rk9*Y[10] dy[11] <- rk10*Y[8] dy[12] <- rk6 *Y[10] + rk19*rk14*Y[5] + rk20*rk14*Y[7] - rk15*Y[2]*Y[12] - rk17*Y[10]*Y[12] return(list(dy)) }) } ## ======================================================================= ## application 1. lsodes estimates the structure of the Jacobian ## and calculates the Jacobian by differences ## ======================================================================= out <- lsodes(func = chemistry, y = y, parms = parms, times = times, atol = atol, rtol = rtol, verbose = TRUE) ## ======================================================================= ## application 2. the structure of the Jacobian is input ## lsodes calculates the Jacobian by differences ## this is not so efficient... ## ======================================================================= ## elements of Jacobian that are not zero nonzero <- matrix(nc = 2, byrow = TRUE, data = c( 1, 1, 2, 1, # influence of sp1 on rate of change of others 2, 2, 3, 2, 4, 2, 5, 2, 12, 2, 2, 3, 3, 3, 4, 3, 6, 3, 10, 3, 2, 4, 3, 4, 4, 4, 9, 4, # d (dyi)/dy4 2, 5, 5, 5, 9, 5, 12, 5, 3, 6, 6, 6, 9, 6, 10, 6, 7, 7, 9, 7, 10, 7, 12, 7, 8, 8, 10, 8, 11, 8, 3,10, 6,10, 7,10, 8,10, 10,10, 12,10, 2,12, 5,12, 7,12, 10,12, 12,12) ) ## when run, the default length of rwork is too small ## lsodes will tell the length actually needed # out2 <- lsodes(func = chemistry, y = y, parms = parms, times = times, # inz = nonzero, atol = atol,rtol = rtol) #gives warning out2 <- lsodes(func = chemistry, y = y, parms = parms, times = times, sparsetype = "sparseusr", inz = nonzero, atol = atol, rtol = rtol, verbose = TRUE, lrw = 353) ## ======================================================================= ## application 3. lsodes estimates the structure of the Jacobian ## the Jacobian (vector) function is input ## ======================================================================= chemjac <- function (time, Y, j, pars) { with (as.list(pars), { PDJ <- rep(0,n) if (j == 1){ PDJ[1] <- -rk1 PDJ[2] <- rk1 } else if (j == 2) { PDJ[2] <- -rk3*Y[3] - rk15*Y[12] - rk2 PDJ[3] <- rk2 - rk3*Y[3] PDJ[4] <- rk3*Y[3] PDJ[5] <- rk15*Y[12] PDJ[12] <- -rk15*Y[12] } else if (j == 3) { PDJ[2] <- -rk3*Y[2] PDJ[3] <- -rk5 - rk3*Y[2] - rk7*Y[10] PDJ[4] <- rk3*Y[2] PDJ[6] <- rk7*Y[10] PDJ[10] <- rk5 - rk7*Y[10] } else if (j == 4) { PDJ[2] <- rk11*rk14 PDJ[3] <- rk11*rk14 PDJ[4] <- -rk11*rk14 - rk4 PDJ[9] <- rk4 } else if (j == 5) { PDJ[2] <- rk19*rk14 PDJ[5] <- -rk19*rk14 - rk16 PDJ[9] <- rk16 PDJ[12] <- rk19*rk14 } else if (j == 6) { PDJ[3] <- rk12*rk14 PDJ[6] <- -rk12*rk14 - rk8 PDJ[9] <- rk8 PDJ[10] <- rk12*rk14 } else if (j == 7) { PDJ[7] <- -rk20*rk14 - rk18 PDJ[9] <- rk18 PDJ[10] <- rk20*rk14 PDJ[12] <- rk20*rk14 } else if (j == 8) { PDJ[8] <- -rk13*rk14 - rk10 PDJ[10] <- rk13*rk14 PDJ[11] <- rk10 } else if (j == 10) { PDJ[3] <- -rk7*Y[3] PDJ[6] <- rk7*Y[3] PDJ[7] <- rk17*Y[12] PDJ[8] <- rk9 PDJ[10] <- -rk7*Y[3] - rk17*Y[12] - rk6 - rk9 PDJ[12] <- rk6 - rk17*Y[12] } else if (j == 12) { PDJ[2] <- -rk15*Y[2] PDJ[5] <- rk15*Y[2] PDJ[7] <- rk17*Y[10] PDJ[10] <- -rk17*Y[10] PDJ[12] <- -rk15*Y[2] - rk17*Y[10] } return(PDJ) }) } out3 <- lsodes(func = chemistry, y = y, parms = parms, times = times, jacvec = chemjac, atol = atol, rtol = rtol) ## ======================================================================= ## application 4. The structure of the Jacobian (nonzero elements) AND ## the Jacobian (vector) function is input ## ======================================================================= out4 <- lsodes(func = chemistry, y = y, parms = parms, times = times, lrw = 351, sparsetype = "sparseusr", inz = nonzero, jacvec = chemjac, atol = atol, rtol = rtol, verbose = TRUE) # The sparsejan variant # note: errors in inz may cause R to break, so this is not without danger... # out5 <- lsodes(func = chemistry, y = y, parms = parms, times = times, # jacvec = chemjac, atol = atol, rtol = rtol, sparsetype = "sparsejan", # inz = c(1,3,8,13,17,21,25,29,32,32,38,38,43, # ian # 1,2, 2,3,4,5,12, 2,3,4,6,10, 2,3,4,9, 2,5,9,12, 3,6,9,10, # jan # 7,9,10,12, 8,10,11, 3,6,7,8,10,12, 2,5,7,10,12), lrw = 343) } \references{ Alan C. Hindmarsh, ODEPACK, A Systematized Collection of ODE Solvers, in Scientific Computing, R. S. Stepleman et al. (Eds.), North-Holland, Amsterdam, 1983, pp. 55-64. S. C. Eisenstat, M. C. Gursky, M. H. Schultz, and A. H. Sherman, Yale Sparse Matrix Package: I. The Symmetric Codes, Int. J. Num. Meth. Eng., 18 (1982), pp. 1145-1151. S. C. Eisenstat, M. C. Gursky, M. H. Schultz, and A. H. Sherman, Yale Sparse Matrix Package: II. The Nonsymmetric Codes, Research Report No. 114, Dept. of Computer Sciences, Yale University, 1977. } \details{ The work is done by the FORTRAN subroutine \code{lsodes}, whose documentation should be consulted for details (it is included as comments in the source file \file{src/opkdmain.f}). The implementation is based on the November, 2003 version of lsodes, from Netlib. \code{lsodes} is applied for stiff problems, where the Jacobian has a sparse structure. There are several choices depending on whether \code{jacvec} is specified and depending on the setting of \code{sparsetype}. If function \code{jacvec} is present, then it should return the j-th column of the Jacobian matrix. There are also several choices for the sparsity specification, selected by argument \code{sparsetype}. \itemize{ \item \code{sparsetype} = \code{"sparseint"}. The sparsity is estimated by the solver, based on numerical differences. In this case, it is advisable to provide an estimate of the number of non-zero elements in the Jacobian (\code{nnz}). This value can be approximate; upon return the number of nonzero elements actually required will be known (1st element of attribute \code{dims}). In this case, \code{inz} need not be specified. \item \code{sparsetype} = \code{"sparseusr"}. The sparsity is determined by the user. In this case, \code{inz} should be a \code{matrix}, containing indices (row, column) to the nonzero elements in the Jacobian matrix. The number of nonzeros \code{nnz} will be set equal to the number of rows in \code{inz}. \item \code{sparsetype} = \code{"sparsejan"}. The sparsity is also determined by the user. In this case, \code{inz} should be a \code{vector}, containting the \code{ian} and \code{jan} elements of the sparse storage format, as used in the sparse solver. Elements of \code{ian} should be the first \code{n+1} elements of this vector, and contain the starting locations in \code{jan} of columns 1.. n. \code{jan} contains the row indices of the nonzero locations of the Jacobian, reading in columnwise order. The number of nonzeros \code{nnz} will be set equal to the length of \code{inz} - (n+1). \item \code{sparsetype} = \code{"1D"}, \code{"2D"}, \code{"3D"}. The sparsity is estimated by the solver, based on numerical differences. Assumes finite differences in a 1D, 2D or 3D regular grid - used by functions \code{ode.1D}, \code{ode.2D}, \code{ode.3D}. Similar are \code{"2Dmap"}, and \code{"3Dmap"}, which also include a mapping variable (passed in nnz). } The input parameters \code{rtol}, and \code{atol} determine the \bold{error control} performed by the solver. See \code{\link{lsoda}} for details. The diagnostics of the integration can be printed to screen by calling \code{\link{diagnostics}}. If \code{verbose} = \code{TRUE}, the diagnostics will written to the screen at the end of the integration. See vignette("deSolve") for an explanation of each element in the vectors containing the diagnostic properties and how to directly access them. \bold{Models} may be defined in compiled C or FORTRAN code, as well as in an R-function. See package vignette \code{"compiledCode"} for details. More information about models defined in compiled code is in the package vignette ("compiledCode"); information about linking forcing functions to compiled code is in \link{forcings}. Examples in both C and FORTRAN are in the \file{doc/examples/dynload} subdirectory of the \code{deSolve} package directory. \code{lsodes} can find the root of at least one of a set of constraint functions \code{rootfunc} of the independent and dependent variables. It then returns the solution at the root if that occurs sooner than the specified stop condition, and otherwise returns the solution according the specified stop condition. Caution: Because of numerical errors in the function \code{rootfun} due to roundoff and integration error, \code{lsodes} may return false roots, or return the same root at two or more nearly equal values of \code{time}. } \seealso{ \itemize{ \item \code{\link{rk}}, \item \code{\link{rk4}} and \code{\link{euler}} for Runge-Kutta integrators. \item \code{\link{lsoda}}, \code{\link{lsode}}, \code{\link{lsodar}}, \code{\link{vode}}, \code{\link{daspk}} for other solvers of the Livermore family, \item \code{\link{ode}} for a general interface to most of the ODE solvers, \item \code{\link{ode.band}} for solving models with a banded Jacobian, \item \code{\link{ode.1D}} for integrating 1-D models, \item \code{\link{ode.2D}} for integrating 2-D models, \item \code{\link{ode.3D}} for integrating 3-D models, } \code{\link{diagnostics}} to print diagnostic messages. } \keyword{math} deSolve/man/diagnostics.deSolve.Rd0000754000175100001440000000326012352122172016642 0ustar hornikusers\name{diagnostics.deSolve} \alias{diagnostics.deSolve} \title{Print Diagnostic Characteristics of ODE and DAE Solvers} \description{ Prints several diagnostics of the simulation to the screen, e.g. number of steps taken, the last step size, ... } \usage{ \method{diagnostics}{deSolve}(obj, Full = FALSE, ...) } \arguments{ \item{obj}{is the output matrix as produced by one of the integration routines. } \item{Full}{when \code{TRUE} then all messages will be printed, including the ones that are not relevant for the solver. If \code{FALSE}, then only the relevant messages will be printed. } \item{...}{optional arguments allowing to extend \code{diagnostics} as a generic function. } } \value{ The integer and real vector with diagnostic values; for function \code{lsodar} also the root information. See tables 2 and 3 in vignette("deSolve") for what these vectors contain. Note: the number of function evaluations are *without* the extra calls performed to generate the ordinary output variables (if present). } \details{ When the integration output is saved as a \code{data.frame}, then the required attributes are lost and method \code{diagnostics} will not work anymore. } \examples{ ## The famous Lorenz equations: chaos in the earth's atmosphere ## Lorenz 1963. J. Atmos. Sci. 20, 130-141. chaos <- function(t, state, parameters) { with(as.list(c(state)), { dx <- -8/3 * x + y * z dy <- -10 * (y - z) dz <- -x * y + 28 * y - z list(c(dx, dy, dz)) }) } state <- c(x = 1, y = 1, z = 1) times <- seq(0, 50, 0.01) out <- vode(state, times, chaos, 0) pairs(out, pch = ".") diagnostics(out) } \keyword{ utilities }deSolve/man/lsodar.Rd0000754000175100001440000004415113071630263014227 0ustar hornikusers\name{lsodar} \alias{lsodar} \title{Solver for Ordinary Differential Equations (ODE), Switching Automatically Between Stiff and Non-stiff Methods and With Root Finding } \description{Solving initial value problems for stiff or non-stiff systems of first-order ordinary differential equations (ODEs) and including root-finding. The \R function \code{lsodar} provides an interface to the FORTRAN ODE solver of the same name, written by Alan C. Hindmarsh and Linda R. Petzold. The system of ODE's is written as an \R function or be defined in compiled code that has been dynamically loaded. - see description of \code{\link{lsoda}} for details. \code{lsodar} differs from \code{lsode} in two respects. \itemize{ \item It switches automatically between stiff and nonstiff methods (similar as lsoda). \item It finds the root of at least one of a set of constraint functions g(i) of the independent and dependent variables. } Two uses of \code{lsodar} are: \itemize{ \item To stop the simulation when a certain condition is met \item To trigger \link{events}, i.e. sudden changes in one of the state variables when a certain condition is met. } when a particular condition is met. } \usage{lsodar(y, times, func, parms, rtol = 1e-6, atol = 1e-6, jacfunc = NULL, jactype = "fullint", rootfunc = NULL, verbose = FALSE, nroot = 0, tcrit = NULL, hmin = 0, hmax = NULL, hini = 0, ynames = TRUE, maxordn = 12, maxords = 5, bandup = NULL, banddown = NULL, maxsteps = 5000, dllname = NULL, initfunc = dllname, initpar = parms, rpar = NULL, ipar = NULL, nout = 0, outnames = NULL, forcings=NULL, initforc = NULL, fcontrol=NULL, events=NULL, lags = NULL, ...) } \arguments{ \item{y }{the initial (state) values for the ODE system. If \code{y} has a name attribute, the names will be used to label the output matrix. } \item{times }{times at which explicit estimates for \code{y} are desired. The first value in \code{times} must be the initial time. } \item{func }{either an \R-function that computes the values of the derivatives in the ODE system (the \emph{model definition}) at time t, or a character string giving the name of a compiled function in a dynamically loaded shared library. If \code{func} is an \R-function, it must be defined as: \code{func <- function(t, y, parms,...)}. \code{t} is the current time point in the integration, \code{y} is the current estimate of the variables in the ODE system. If the initial values \code{y} has a \code{names} attribute, the names will be available inside \code{func}. \code{parms} is a vector or list of parameters; ... (optional) are any other arguments passed to the function. The return value of \code{func} should be a list, whose first element is a vector containing the derivatives of \code{y} with respect to \code{time}, and whose next elements are global values that are required at each point in \code{times}. The derivatives must be specified in the \bold{same order} as the state variables \code{y}. If \code{func} is a string, then \code{dllname} must give the name of the shared library (without extension) which must be loaded before \code{lsodar()} is called. See package vignette \code{"compiledCode"} for more details. } \item{parms }{vector or list of parameters used in \code{func} or \code{jacfunc}. } \item{rtol }{relative error tolerance, either a scalar or an array as long as \code{y}. See details. } \item{atol }{absolute error tolerance, either a scalar or an array as long as \code{y}. See details. } \item{jacfunc }{if not \code{NULL}, an \R function, that computes the Jacobian of the system of differential equations \eqn{\partial\dot{y}_i/\partial y_j}{dydot(i)/dy(j)}, or a string giving the name of a function or subroutine in \file{dllname} that computes the Jacobian (see vignette \code{"compiledCode"} for more about this option). In some circumstances, supplying \code{jacfunc} can speed up the computations, if the system is stiff. The \R calling sequence for \code{jacfunc} is identical to that of \code{func}. If the Jacobian is a full matrix, \code{jacfunc} should return a matrix \eqn{\partial\dot{y}/\partial y}{dydot/dy}, where the ith row contains the derivative of \eqn{dy_i/dt} with respect to \eqn{y_j}, or a vector containing the matrix elements by columns (the way \R and FORTRAN store matrices). If the Jacobian is banded, \code{jacfunc} should return a matrix containing only the nonzero bands of the Jacobian, rotated row-wise. See first example of \link{lsode}. } \item{jactype }{the structure of the Jacobian, one of \code{"fullint"}, \code{"fullusr"}, \code{"bandusr"} or \code{"bandint"} - either full or banded and estimated internally or by user. } \item{rootfunc }{if not \code{NULL}, an \R function that computes the function whose root has to be estimated or a string giving the name of a function or subroutine in \file{dllname} that computes the root function. The \R calling sequence for \code{rootfunc} is identical to that of \code{func}. \code{rootfunc} should return a vector with the function values whose root is sought. } \item{verbose }{a logical value that, when \code{TRUE}, will print the \code{diagnostiscs} of the integration - see details. } \item{nroot }{only used if \file{dllname} is specified: the number of constraint functions whose roots are desired during the integration; if \code{rootfunc} is an R-function, the solver estimates the number of roots. } \item{tcrit }{if not \code{NULL}, then \code{lsodar} cannot integrate past \code{tcrit}. The FORTRAN routine \code{lsodar} overshoots its targets (times points in the vector \code{times}), and interpolates values for the desired time points. If there is a time beyond which integration should not proceed (perhaps because of a singularity), that should be provided in \code{tcrit}. } \item{hmin }{an optional minimum value of the integration stepsize. In special situations this parameter may speed up computations with the cost of precision. Don't use \code{hmin} if you don't know why! } \item{hmax }{an optional maximum value of the integration stepsize. If not specified, \code{hmax} is set to the largest difference in \code{times}, to avoid that the simulation possibly ignores short-term events. If 0, no maximal size is specified. } \item{hini }{initial step size to be attempted; if 0, the initial step size is determined by the solver. } \item{ynames }{logical, if \code{FALSE}: names of state variables are not passed to function \code{func}; this may speed up the simulation especially for large models. } \item{maxordn }{the maximum order to be allowed in case the method is non-stiff. Should be <= 12. Reduce \code{maxord} to save storage space. } \item{maxords }{the maximum order to be allowed in case the method is stiff. Should be <= 5. Reduce maxord to save storage space. } \item{bandup }{number of non-zero bands above the diagonal, in case the Jacobian is banded. } \item{banddown }{number of non-zero bands below the diagonal, in case the Jacobian is banded. } \item{maxsteps }{maximal number of steps per output interval taken by the solver. } \item{dllname }{a string giving the name of the shared library (without extension) that contains all the compiled function or subroutine definitions refered to in \code{func} and \code{jacfunc}. See package vignette \code{"compiledCode"}. } \item{initfunc }{if not \code{NULL}, the name of the initialisation function (which initialises values of parameters), as provided in \file{dllname}. See package vignette \code{"compiledCode"}. } \item{initpar }{only when \file{dllname} is specified and an initialisation function \code{initfunc} is in the dll: the parameters passed to the initialiser, to initialise the common blocks (FORTRAN) or global variables (C, C++). } \item{rpar }{only when \file{dllname} is specified: a vector with double precision values passed to the dll-functions whose names are specified by \code{func} and \code{jacfunc}. } \item{ipar }{only when \file{dllname} is specified: a vector with integer values passed to the dll-functions whose names are specified by \code{func} and \code{jacfunc}. } \item{nout }{only used if \code{dllname} is specified and the model is defined in compiled code: the number of output variables calculated in the compiled function \code{func}, present in the shared library. Note: it is not automatically checked whether this is indeed the number of output variables calculated in the dll - you have to perform this check in the code - See package vignette \code{"compiledCode"}. } \item{outnames }{only used if \file{dllname} is specified and \code{nout} > 0: the names of output variables calculated in the compiled function \code{func}, present in the shared library. These names will be used to label the output matrix. } \item{forcings }{only used if \file{dllname} is specified: a list with the forcing function data sets, each present as a two-columned matrix, with (time,value); interpolation outside the interval [min(\code{times}), max(\code{times})] is done by taking the value at the closest data extreme. See \link{forcings} or package vignette \code{"compiledCode"}. } \item{initforc }{if not \code{NULL}, the name of the forcing function initialisation function, as provided in \file{dllname}. It MUST be present if \code{forcings} has been given a value. See \link{forcings} or package vignette \code{"compiledCode"}. } \item{fcontrol }{A list of control parameters for the forcing functions. See \link{forcings} or vignette \code{compiledCode}. } \item{events }{A matrix or data frame that specifies events, i.e. when the value of a state variable is suddenly changed. See \link{events} for more information. } \item{lags }{A list that specifies timelags, i.e. the number of steps that has to be kept. To be used for delay differential equations. See \link{timelags}, \link{dede} for more information. } \item{... }{additional arguments passed to \code{func} and \code{jacfunc} allowing this to be a generic function. } } \value{ A matrix of class \code{deSolve} with up to as many rows as elements in \code{times} and as many columns as elements in \code{y} plus the number of "global" values returned in the next elements of the return from \code{func}, plus and additional column for the time value. There will be a row for each element in \code{times} unless the FORTRAN routine `lsodar' returns with an unrecoverable error. If \code{y} has a names attribute, it will be used to label the columns of the output value. If a root has been found, the output will have the attribute \code{iroot}, an integer indicating which root has been found. } \author{Karline Soetaert } \examples{ ## ======================================================================= ## Example 1: ## from lsodar source code ## ======================================================================= Fun <- function (t, y, parms) { ydot <- vector(len = 3) ydot[1] <- -.04*y[1] + 1.e4*y[2]*y[3] ydot[3] <- 3.e7*y[2]*y[2] ydot[2] <- -ydot[1] - ydot[3] return(list(ydot, ytot = sum(y))) } rootFun <- function (t, y, parms) { yroot <- vector(len = 2) yroot[1] <- y[1] - 1.e-4 yroot[2] <- y[3] - 1.e-2 return(yroot) } y <- c(1, 0, 0) times <- c(0, 0.4*10^(0:8)) Out <- NULL ny <- length(y) out <- lsodar(y = y, times = times, fun = Fun, rootfun = rootFun, rtol = 1e-4, atol = c(1e-6, 1e-10, 1e-6), parms = NULL) print(paste("root is found for eqn", which(attributes(out)$iroot == 1))) print(out[nrow(out),]) diagnostics(out) ## ======================================================================= ## Example 2: ## using lsodar to estimate steady-state conditions ## ======================================================================= ## Bacteria (Bac) are growing on a substrate (Sub) model <- function(t, state, pars) { with (as.list(c(state, pars)), { ## substrate uptake death respiration dBact <- gmax*eff*Sub/(Sub+ks)*Bact - dB*Bact - rB*Bact dSub <- -gmax *Sub/(Sub+ks)*Bact + dB*Bact + input return(list(c(dBact,dSub))) }) } ## root is the condition where sum of |rates of change| ## is very small rootfun <- function (t, state, pars) { dstate <- unlist(model(t, state, pars)) # rate of change vector return(sum(abs(dstate)) - 1e-10) } pars <- list(Bini = 0.1, Sini = 100, gmax = 0.5, eff = 0.5, ks = 0.5, rB = 0.01, dB = 0.01, input = 0.1) tout <- c(0, 1e10) state <- c(Bact = pars$Bini, Sub = pars$Sini) out <- lsodar(state, tout, model, pars, rootfun = rootfun) print(out) ## ======================================================================= ## Example 3: ## using lsodar to trigger an event ## ======================================================================= ## a state variable is decaying at a first-order rate. ## when it reaches the value 0.1, a random amount is added. derivfun <- function (t,y,parms) list (-0.05 * y) rootfun <- function (t,y,parms) return(y - 0.1) eventfun <- function(t,y,parms) return(y + runif(1)) yini <- 0.8 times <- 0:200 out <- lsodar(func=derivfun, y = yini, times=times, rootfunc = rootfun, events = list(func=eventfun, root = TRUE)) plot(out, type = "l", lwd = 2, main = "lsodar with event") } \references{ Alan C. Hindmarsh, ODEPACK, A Systematized Collection of ODE Solvers, in Scientific Computing, R. S. Stepleman et al. (Eds.), North-Holland, Amsterdam, 1983, pp. 55-64. Linda R. Petzold, Automatic Selection of Methods for Solving Stiff and Nonstiff Systems of Ordinary Differential Equations, Siam J. Sci. Stat. Comput. 4 (1983), pp. 136-148. Kathie L. Hiebert and Lawrence F. Shampine, Implicitly Defined Output Points for Solutions of ODEs, Sandia Report SAND80-0180, February 1980. Netlib: \url{http://www.netlib.org} } \details{ The work is done by the FORTRAN subroutine \code{lsodar}, whose documentation should be consulted for details (it is included as comments in the source file \file{src/opkdmain.f}). The implementation is based on the November, 2003 version of lsodar, from Netlib. \code{lsodar} switches automatically between stiff and nonstiff methods (similar as \code{lsoda}). This means that the user does not have to determine whether the problem is stiff or not, and the solver will automatically choose the appropriate method. It always starts with the nonstiff method. \code{lsodar} can find the root of at least one of a set of constraint functions \code{rootfunc} of the independent and dependent variables. It then returns the solution at the root if that occurs sooner than the specified stop condition, and otherwise returns the solution according the specified stop condition. Caution: Because of numerical errors in the function \code{rootfun} due to roundoff and integration error, \code{lsodar} may return false roots, or return the same root at two or more nearly equal values of \code{time}. The form of the \bold{Jacobian} can be specified by \code{jactype} which can take the following values: \describe{ \item{jactype = "fullint":}{a full Jacobian, calculated internally by lsodar, the default, } \item{jactype = "fullusr":}{a full Jacobian, specified by user function \code{jacfunc}, } \item{jactype = "bandusr":}{a banded Jacobian, specified by user function \code{jacfunc}; the size of the bands specified by \code{bandup} and \code{banddown}, } \item{jactype = "bandint":}{banded Jacobian, calculated by lsodar; the size of the bands specified by \code{bandup} and \code{banddown}. } } If \code{jactype} = "fullusr" or "bandusr" then the user must supply a subroutine \code{jacfunc}. The input parameters \code{rtol}, and \code{atol} determine the \bold{error control} performed by the solver. See \code{\link{lsoda}} for details. The output will have the attribute \bold{iroot}, if a root was found \bold{iroot} is a vector, its length equal to the number of constraint functions it will have a value of 1 for the constraint function whose root that has been found and 0 otherwise. The diagnostics of the integration can be printed to screen by calling \code{\link{diagnostics}}. If \code{verbose} = \code{TRUE}, the diagnostics will written to the screen at the end of the integration. See vignette("deSolve") for an explanation of each element in the vectors containing the diagnostic properties and how to directly access them. \bold{Models} may be defined in compiled C or FORTRAN code, as well as in an R-function. See package vignette \code{"compiledCode"} for details. More information about models defined in compiled code is in the package vignette ("compiledCode"); information about linking forcing functions to compiled code is in \link{forcings}. Examples in both C and FORTRAN are in the \file{dynload} subdirectory of the \code{deSolve} package directory. } \seealso{ \itemize{ \item \code{\link{roots}} for more examples on roots and events \item \code{\link{rk}}, \code{\link{rkMethod}}, \code{\link{rk4}} and \code{\link{euler}} for Runge-Kutta integrators. \item \code{\link{lsoda}}, \code{\link{lsode}}, \code{\link{lsodes}}, \code{\link{vode}}, \code{\link{daspk}} for other solvers of the Livermore family, \item \code{\link{ode}} for a general interface to most of the ODE solvers, \item \code{\link{ode.band}} for solving models with a banded Jacobian, \item \code{\link{ode.1D}} for integrating 1-D models, \item \code{\link{ode.2D}} for integrating 2-D models, \item \code{\link{ode.3D}} for integrating 3-D models, } \code{\link{diagnostics}} to print diagnostic messages. } \keyword{math} deSolve/man/ode.band.Rd0000754000175100001440000001503312477565462014433 0ustar hornikusers\name{ode.band} \alias{ode.band} \title{Solver for Ordinary Differential Equations; Assumes a Banded Jacobian } \description{ Solves a system of ordinary differential equations. Assumes a banded Jacobian matrix, but does not rearrange the state variables (in contrast to ode.1D). Suitable for 1-D models that include transport only between adjacent layers and that model only one species. } \usage{ode.band(y, times, func, parms, nspec = NULL, dimens = NULL, bandup = nspec, banddown = nspec, method = "lsode", names = NULL, ...) } \arguments{ \item{y }{the initial (state) values for the ODE system, a vector. If \code{y} has a name attribute, the names will be used to label the output matrix. } \item{times }{time sequence for which output is wanted; the first value of \code{times} must be the initial time. } \item{func }{either an \R-function that computes the values of the derivatives in the ODE system (the model definition) at time \code{t}, or a character string giving the name of a compiled function in a dynamically loaded shared library. If \code{func} is an \R-function, it must be defined as: \code{func <- function(t, y, parms, ...)}. \code{t} is the current time point in the integration, \code{y} is the current estimate of the variables in the ODE system. If the initial values \code{y} has a \code{names} attribute, the names will be available inside \code{func}. \code{parms} is a vector or list of parameters; \code{...} (optional) are any other arguments passed to the function. The return value of \code{func} should be a list, whose first element is a vector containing the derivatives of \code{y} with respect to \code{time}, and whose next elements are global values that are required at each point in \code{times}.The derivatives must be specified in the \bold{same order} as the state variables \code{y}. } \item{parms }{parameters passed to \code{func}. } \item{nspec }{the number of *species* (components) in the model. } \item{dimens}{the number of \bold{boxes} in the model. If \code{NULL}, then \code{nspec} should be specified. } \item{bandup }{the number of nonzero bands above the Jacobian diagonal. } \item{banddown }{the number of nonzero bands below the Jacobian diagonal. } \item{method }{the integrator to use, one of \code{"vode"}, \code{"lsode"}, \code{"lsoda"}, \code{"lsodar"}, \code{"radau"}. } \item{names }{the names of the components; used for plotting. } \item{... }{additional arguments passed to the integrator.} } \value{ A matrix of class \code{deSolve} with up to as many rows as elements in \code{times} and as many columns as elements in \code{y} plus the number of "global" values returned in the second element of the return from \code{func}, plus an additional column (the first) for the time value. There will be one row for each element in \code{times} unless the integrator returns with an unrecoverable error. If \code{y} has a names attribute, it will be used to label the columns of the output value. The output will have the attributes \code{istate} and \code{rstate}, two vectors with several elements. See the help for the selected integrator for details. the first element of istate returns the conditions under which the last call to the integrator returned. Normal is \code{istate = 2}. If \code{verbose = TRUE}, the settings of \code{istate} and \code{rstate} will be written to the screen. } \author{Karline Soetaert } \examples{ ## ======================================================================= ## The Aphid model from Soetaert and Herman, 2009. ## A practical guide to ecological modelling. ## Using R as a simulation platform. Springer. ## ======================================================================= ## 1-D diffusion model ## ================ ## Model equations ## ================ Aphid <- function(t, APHIDS, parameters) { deltax <- c (0.5, rep(1, numboxes-1), 0.5) Flux <- -D*diff(c(0, APHIDS, 0))/deltax dAPHIDS <- -diff(Flux)/delx + APHIDS*r list(dAPHIDS) # the output } ## ================== ## Model application ## ================== ## the model parameters: D <- 0.3 # m2/day diffusion rate r <- 0.01 # /day net growth rate delx <- 1 # m thickness of boxes numboxes <- 60 ## distance of boxes on plant, m, 1 m intervals Distance <- seq(from = 0.5, by = delx, length.out = numboxes) ## Initial conditions, ind/m2 ## aphids present only on two central boxes APHIDS <- rep(0, times = numboxes) APHIDS[30:31] <- 1 state <- c(APHIDS = APHIDS) # initialise state variables ## RUNNING the model: times <- seq(0, 200, by = 1) # output wanted at these time intervals out <- ode.band(state, times, Aphid, parms = 0, nspec = 1, names = "Aphid") ## ================ ## Plotting output ## ================ image(out, grid = Distance, method = "filled.contour", xlab = "time, days", ylab = "Distance on plant, m", main = "Aphid density on a row of plants") matplot.1D(out, grid = Distance, type = "l", subset = time \%in\% seq(0, 200, by = 10)) # add an observed dataset to 1-D plot (make sure to use correct name): data <- cbind(dist = c(0,10, 20, 30, 40, 50, 60), Aphid = c(0,0.1,0.25,0.5,0.25,0.1,0)) matplot.1D(out, grid = Distance, type = "l", subset = time \%in\% seq(0, 200, by = 10), obs = data, obspar = list(pch = 18, cex = 2, col="red")) \dontrun{ plot.1D(out, grid = Distance, type = "l") } } \details{ This is the method of choice for single-species 1-D reactive transport models. For multi-species 1-D models, this method can only be used if the state variables are arranged per box, per species (e.g. A[1], B[1], A[2], B[2], A[3], B[3], ... for species A, B). By default, the \bold{model} function will have the species arranged as A[1], A[2], A[3], ... B[1], B[2], B[3], ... in this case, use \code{ode.1D}. See the selected integrator for the additional options. } \seealso{ \itemize{ \item \code{\link{ode}} for a general interface to most of the ODE solvers, \item \code{\link{ode.1D}} for integrating 1-D models \item \code{\link{ode.2D}} for integrating 2-D models \item \code{\link{ode.3D}} for integrating 3-D models \item \code{\link{lsode}}, \code{\link{lsoda}}, \code{\link{lsodar}}, \code{\link{vode}} for the integration options. } \code{\link{diagnostics}} to print diagnostic messages. } \keyword{math} deSolve/man/aquaphy.Rd0000754000175100001440000001530012352122172014401 0ustar hornikusers\name{aquaphy} \alias{aquaphy} \title{A Physiological Model of Unbalanced Algal Growth} \description{A phytoplankton model with uncoupled carbon and nitrogen assimilation as a function of light and Dissolved Inorganic Nitrogen (DIN) concentration. Algal biomass is described via 3 different state variables: \itemize{ \item low molecular weight carbohydrates (LMW), the product of photosynthesis, \item storage molecules (RESERVE) and \item the biosynthetic and photosynthetic apparatus (PROTEINS). } All algal state variables are expressed in \eqn{\rm mmol\, C\, m^{-3}}{mmol C / m^3}. Only proteins contain nitrogen and chlorophyll, with a fixed stoichiometric ratio. As the relative amount of proteins changes in the algae, so does the N:C and the Chl:C ratio. An additional state variable, dissolved inorganic nitrogen (DIN) has units of \eqn{\rm mmol\, N\, m^{-3}}{mmol N / m^3}. The algae grow in a dilution culture (chemostat): there is constant inflow of DIN and outflow of culture water, including DIN and algae, at the same rate. Two versions of the model are included. \itemize{ \item In the default model, there is a day-night illumination regime, i.e. the light is switched on and off at fixed times (where the sum of illuminated + dark period = 24 hours). \item In another version, the light is imposed as a forcing function data set. } This model is written in \code{FORTRAN}. } \usage{aquaphy(times, y, parms, PAR = NULL, ...)} \arguments{ \item{times}{time sequence for which output is wanted; the first value of times must be the initial time,} \item{y}{the initial (state) values ("DIN", "PROTEIN", "RESERVE", "LMW"), in that order,} \item{parms }{vector or list with the aquaphy model parameters; see the example for the order in which these have to be defined.} \item{PAR }{a data set of the photosynthetically active radiation (light intensity), if \code{NULL}, on-off PAR is used, } \item{...}{any other parameters passed to the integrator \code{ode} (which solves the model).} } \author{Karline Soetaert } \examples{ ## ====================================================== ## ## Example 1. PAR an on-off function ## ## ====================================================== ## ----------------------------- ## the model parameters: ## ----------------------------- parameters <- c(maxPhotoSynt = 0.125, # mol C/mol C/hr rMortPHY = 0.001, # /hr alpha = -0.125/150, # uEinst/m2/s/hr pExudation = 0.0, # - maxProteinSynt = 0.136, # mol C/mol C/hr ksDIN = 1.0, # mmol N/m3 minpLMW = 0.05, # mol C/mol C maxpLMW = 0.15, # mol C/mol C minQuotum = 0.075, # mol C/mol C maxStorage = 0.23, # /h respirationRate= 0.0001, # /h pResp = 0.4, # - catabolismRate = 0.06, # /h dilutionRate = 0.01, # /h rNCProtein = 0.2, # mol N/mol C inputDIN = 10.0, # mmol N/m3 rChlN = 1, # g Chl/mol N parMean = 250., # umol Phot/m2/s dayLength = 15. # hours ) ## ----------------------------- ## The initial conditions ## ----------------------------- state <- c(DIN = 6., # mmol N/m3 PROTEIN = 20.0, # mmol C/m3 RESERVE = 5.0, # mmol C/m3 LMW = 1.0) # mmol C/m3 ## ----------------------------- ## Running the model ## ----------------------------- times <- seq(0, 24*20, 1) out <- as.data.frame(aquaphy(times, state, parameters)) ## ----------------------------- ## Plotting model output ## ----------------------------- par(mfrow = c(2, 2), oma = c(0, 0, 3, 0)) col <- grey(0.9) ii <- 1:length(out$PAR) plot(times[ii], out$Chlorophyll[ii], type = "l", main = "Chlorophyll", xlab = "time, hours",ylab = "ug/l") polygon(times[ii], out$PAR[ii]-10, col = col, border = NA); box() lines(times[ii], out$Chlorophyll[ii], lwd = 2 ) plot (times[ii], out$DIN[ii], type = "l", main = "DIN", xlab = "time, hours",ylab = "mmolN/m3") polygon(times[ii], out$PAR[ii]-10, col = col, border = NA); box() lines(times[ii], out$DIN[ii], lwd = 2 ) plot (times[ii], out$NCratio[ii], type = "n", main = "NCratio", xlab = "time, hours", ylab = "molN/molC") polygon(times[ii], out$PAR[ii]-10, col = col, border = NA); box() lines(times[ii], out$NCratio[ii], lwd = 2 ) plot (times[ii], out$PhotoSynthesis[ii],type = "l", main = "PhotoSynthesis", xlab = "time, hours", ylab = "mmolC/m3/hr") polygon(times[ii], out$PAR[ii]-10, col = col, border = NA); box() lines(times[ii], out$PhotoSynthesis[ii], lwd = 2 ) mtext(outer = TRUE, side = 3, "AQUAPHY, PAR= on-off", cex = 1.5) ## ----------------------------- ## Summary model output ## ----------------------------- t(summary(out)) ## ====================================================== ## ## Example 2. PAR a forcing function data set ## ## ====================================================== times <- seq(0, 24*20, 1) ## ----------------------------- ## create the forcing functions ## ----------------------------- ftime <- seq(0,500,by=0.5) parval <- pmax(0,250 + 350*sin(ftime*2*pi/24)+ (runif(length(ftime))-0.5)*250) Par <- matrix(nc=2,c(ftime,parval)) state <- c(DIN = 6., # mmol N/m3 PROTEIN = 20.0, # mmol C/m3 RESERVE = 5.0, # mmol C/m3 LMW = 1.0) # mmol C/m3 out <- aquaphy(times, state, parameters, Par) plot(out, which = c("PAR", "Chlorophyll", "DIN", "NCratio"), xlab = "time, hours", ylab = c("uEinst/m2/s", "ug/l", "mmolN/m3", "molN/molC")) mtext(outer = TRUE, side = 3, "AQUAPHY, PAR=forcing", cex = 1.5) # Now all variables plotted in one figure... plot(out, which = 1:9, type = "l") par(mfrow = c(1, 1)) } \references{ Lancelot, C., Veth, C. and Mathot, S. (1991). Modelling ice-edge phytoplankton bloom in the Scotia-Weddel sea sector of the Southern Ocean during spring 1988. Journal of Marine Systems 2, 333--346. Soetaert, K. and Herman, P. (2008). A practical guide to ecological modelling. Using R as a simulation platform. Springer. } \details{ The model is implemented primarily to demonstrate the linking of FORTRAN with \R-code. The source can be found in the \file{doc/examples/dynload} subdirectory of the package. } \seealso{ \code{\link{ccl4model}}, the CCl4 inhalation model. } \keyword{models} deSolve/man/lsode.Rd0000754000175100001440000005037113071630263014052 0ustar hornikusers\name{lsode} \alias{lsode} \title{Solver for Ordinary Differential Equations (ODE)} \description{ Solves the initial value problem for stiff or nonstiff systems of ordinary differential equations (ODE) in the form: \deqn{dy/dt = f(t,y)}. The \R function \code{lsode} provides an interface to the FORTRAN ODE solver of the same name, written by Alan C. Hindmarsh and Andrew H. Sherman. It combines parts of the code \code{lsodar} and can thus find the root of at least one of a set of constraint functions g(i) of the independent and dependent variables. This can be used to stop the simulation or to trigger \link{events}, i.e. a sudden change in one of the state variables. The system of ODE's is written as an \R function or be defined in compiled code that has been dynamically loaded. In contrast to \code{\link{lsoda}}, the user has to specify whether or not the problem is stiff and choose the appropriate solution method. \code{lsode} is very similar to \code{\link{vode}}, but uses a fixed-step-interpolate method rather than the variable-coefficient method in \code{\link{vode}}. In addition, in \code{vode} it is possible to choose whether or not a copy of the Jacobian is saved for reuse in the corrector iteration algorithm; In \code{lsode}, a copy is not kept. } \usage{ lsode(y, times, func, parms, rtol = 1e-6, atol = 1e-6, jacfunc = NULL, jactype = "fullint", mf = NULL, rootfunc = NULL, verbose = FALSE, nroot = 0, tcrit = NULL, hmin = 0, hmax = NULL, hini = 0, ynames = TRUE, maxord = NULL, bandup = NULL, banddown = NULL, maxsteps = 5000, dllname = NULL, initfunc = dllname, initpar = parms, rpar = NULL, ipar = NULL, nout = 0, outnames = NULL, forcings=NULL, initforc = NULL, fcontrol=NULL, events=NULL, lags = NULL,...) } \arguments{ \item{y }{the initial (state) values for the ODE system. If \code{y} has a name attribute, the names will be used to label the output matrix. } \item{times }{time sequence for which output is wanted; the first value of \code{times} must be the initial time; if only one step is to be taken; set \code{times} = \code{NULL}. } \item{func }{either an \R-function that computes the values of the derivatives in the ODE system (the \emph{model definition}) at time t, or a character string giving the name of a compiled function in a dynamically loaded shared library. If \code{func} is an \R-function, it must be defined as: \code{func <- function(t, y, parms,...)}. \code{t} is the current time point in the integration, \code{y} is the current estimate of the variables in the ODE system. If the initial values \code{y} has a \code{names} attribute, the names will be available inside \code{func}. \code{parms} is a vector or list of parameters; ... (optional) are any other arguments passed to the function. The return value of \code{func} should be a list, whose first element is a vector containing the derivatives of \code{y} with respect to \code{time}, and whose next elements are global values that are required at each point in \code{times}. The derivatives must be specified in the \bold{same order} as the state variables \code{y}. If \code{func} is a string, then \code{dllname} must give the name of the shared library (without extension) which must be loaded before \code{lsode()} is called. See package vignette \code{"compiledCode"} for more details. } \item{parms }{vector or list of parameters used in \code{func} or \code{jacfunc}. } \item{rtol }{relative error tolerance, either a scalar or an array as long as \code{y}. See details. } \item{atol }{absolute error tolerance, either a scalar or an array as long as \code{y}. See details. } \item{jacfunc }{if not \code{NULL}, an \R function that computes the Jacobian of the system of differential equations \eqn{\partial\dot{y}_i/\partial y_j}{dydot(i)/dy(j)}, or a string giving the name of a function or subroutine in \file{dllname} that computes the Jacobian (see vignette \code{"compiledCode"} for more about this option). In some circumstances, supplying \code{jacfunc} can speed up the computations, if the system is stiff. The \R calling sequence for \code{jacfunc} is identical to that of \code{func}. If the Jacobian is a full matrix, \code{jacfunc} should return a matrix \eqn{\partial\dot{y}/\partial y}{dydot/dy}, where the ith row contains the derivative of \eqn{dy_i/dt} with respect to \eqn{y_j}, or a vector containing the matrix elements by columns (the way \R and FORTRAN store matrices). \cr If the Jacobian is banded, \code{jacfunc} should return a matrix containing only the nonzero bands of the Jacobian, rotated row-wise. See first example of \link{lsode}. } \item{jactype }{the structure of the Jacobian, one of \code{"fullint"}, \code{"fullusr"}, \code{"bandusr"} or \code{"bandint"} - either full or banded and estimated internally or by user; overruled if \code{mf}is not \code{NULL}. } \item{mf }{the "method flag" passed to function lsode - overrules \code{jactype} - provides more options than \code{jactype} - see details. } \item{rootfunc }{if not \code{NULL}, an \R function that computes the function whose root has to be estimated or a string giving the name of a function or subroutine in \file{dllname} that computes the root function. The \R calling sequence for \code{rootfunc} is identical to that of \code{func}. \code{rootfunc} should return a vector with the function values whose root is sought. } \item{verbose }{if TRUE: full output to the screen, e.g. will print the \code{diagnostiscs} of the integration - see details. } \item{nroot }{only used if \file{dllname} is specified: the number of constraint functions whose roots are desired during the integration; if \code{rootfunc} is an R-function, the solver estimates the number of roots. } \item{tcrit }{if not \code{NULL}, then \code{lsode} cannot integrate past \code{tcrit}. The FORTRAN routine \code{lsode} overshoots its targets (times points in the vector \code{times}), and interpolates values for the desired time points. If there is a time beyond which integration should not proceed (perhaps because of a singularity), that should be provided in \code{tcrit}. } \item{hmin }{an optional minimum value of the integration stepsize. In special situations this parameter may speed up computations with the cost of precision. Don't use \code{hmin} if you don't know why! } \item{hmax }{an optional maximum value of the integration stepsize. If not specified, \code{hmax} is set to the largest difference in \code{times}, to avoid that the simulation possibly ignores short-term events. If 0, no maximal size is specified. } \item{hini }{initial step size to be attempted; if 0, the initial step size is determined by the solver. } \item{ynames }{logical, if \code{FALSE} names of state variables are not passed to function \code{func}; this may speed up the simulation especially for multi-D models. } \item{maxord }{the maximum order to be allowed. \code{NULL} uses the default, i.e. order 12 if implicit Adams method (meth = 1), order 5 if BDF method (meth = 2). Reduce maxord to save storage space. } \item{bandup }{number of non-zero bands above the diagonal, in case the Jacobian is banded. } \item{banddown }{number of non-zero bands below the diagonal, in case the Jacobian is banded. } \item{maxsteps }{maximal number of steps per output interval taken by the solver. } \item{dllname }{a string giving the name of the shared library (without extension) that contains all the compiled function or subroutine definitions refered to in \code{func} and \code{jacfunc}. See package vignette \code{"compiledCode"}. } \item{initfunc }{if not \code{NULL}, the name of the initialisation function (which initialises values of parameters), as provided in \file{dllname}. See package vignette \code{"compiledCode"}. } \item{initpar }{only when \file{dllname} is specified and an initialisation function \code{initfunc} is in the dll: the parameters passed to the initialiser, to initialise the common blocks (FORTRAN) or global variables (C, C++). } \item{rpar }{only when \file{dllname} is specified: a vector with double precision values passed to the dll-functions whose names are specified by \code{func} and \code{jacfunc}. } \item{ipar }{only when \file{dllname} is specified: a vector with integer values passed to the dll-functions whose names are specified by \code{func} and \code{jacfunc}. } \item{nout }{only used if \code{dllname} is specified and the model is defined in compiled code: the number of output variables calculated in the compiled function \code{func}, present in the shared library. Note: it is not automatically checked whether this is indeed the number of output variables calculated in the dll - you have to perform this check in the code - See package vignette \code{"compiledCode"}. } \item{outnames }{only used if \file{dllname} is specified and \code{nout} > 0: the names of output variables calculated in the compiled function \code{func}, present in the shared library. These names will be used to label the output matrix. } \item{forcings }{only used if \file{dllname} is specified: a list with the forcing function data sets, each present as a two-columned matrix, with (time,value); interpolation outside the interval [min(\code{times}), max(\code{times})] is done by taking the value at the closest data extreme. See \link{forcings} or package vignette \code{"compiledCode"}. } \item{initforc }{if not \code{NULL}, the name of the forcing function initialisation function, as provided in \file{dllname}. It MUST be present if \code{forcings} has been given a value. See \link{forcings} or package vignette \code{"compiledCode"}. } \item{fcontrol }{A list of control parameters for the forcing functions. See \link{forcings} or vignette \code{compiledCode}. } \item{events }{A matrix or data frame that specifies events, i.e. when the value of a state variable is suddenly changed. See \link{events} for more information. } \item{lags }{A list that specifies timelags, i.e. the number of steps that has to be kept. To be used for delay differential equations. See \link{timelags}, \link{dede} for more information. } \item{... }{additional arguments passed to \code{func} and \code{jacfunc} allowing this to be a generic function. } } \value{ A matrix of class \code{deSolve} with up to as many rows as elements in \code{times} and as many columns as elements in \code{y} plus the number of "global" values returned in the next elements of the return from \code{func}, plus and additional column for the time value. There will be a row for each element in \code{times} unless the FORTRAN routine `lsode' returns with an unrecoverable error. If \code{y} has a names attribute, it will be used to label the columns of the output value. } \author{Karline Soetaert } \examples{ ## ======================================================================= ## Example 1: ## Various ways to solve the same model. ## ======================================================================= ## the model, 5 state variables f1 <- function (t, y, parms) { ydot <- vector(len = 5) ydot[1] <- 0.1*y[1] -0.2*y[2] ydot[2] <- -0.3*y[1] +0.1*y[2] -0.2*y[3] ydot[3] <- -0.3*y[2] +0.1*y[3] -0.2*y[4] ydot[4] <- -0.3*y[3] +0.1*y[4] -0.2*y[5] ydot[5] <- -0.3*y[4] +0.1*y[5] return(list(ydot)) } ## the Jacobian, written as a full matrix fulljac <- function (t, y, parms) { jac <- matrix(nrow = 5, ncol = 5, byrow = TRUE, data = c(0.1, -0.2, 0 , 0 , 0 , -0.3, 0.1, -0.2, 0 , 0 , 0 , -0.3, 0.1, -0.2, 0 , 0 , 0 , -0.3, 0.1, -0.2, 0 , 0 , 0 , -0.3, 0.1)) return(jac) } ## the Jacobian, written in banded form bandjac <- function (t, y, parms) { jac <- matrix(nrow = 3, ncol = 5, byrow = TRUE, data = c( 0 , -0.2, -0.2, -0.2, -0.2, 0.1, 0.1, 0.1, 0.1, 0.1, -0.3, -0.3, -0.3, -0.3, 0)) return(jac) } ## initial conditions and output times yini <- 1:5 times <- 1:20 ## default: stiff method, internally generated, full Jacobian out <- lsode(yini, times, f1, parms = 0, jactype = "fullint") ## stiff method, user-generated full Jacobian out2 <- lsode(yini, times, f1, parms = 0, jactype = "fullusr", jacfunc = fulljac) ## stiff method, internally-generated banded Jacobian ## one nonzero band above (up) and below(down) the diagonal out3 <- lsode(yini, times, f1, parms = 0, jactype = "bandint", bandup = 1, banddown = 1) ## stiff method, user-generated banded Jacobian out4 <- lsode(yini, times, f1, parms = 0, jactype = "bandusr", jacfunc = bandjac, bandup = 1, banddown = 1) ## non-stiff method out5 <- lsode(yini, times, f1, parms = 0, mf = 10) ## ======================================================================= ## Example 2: ## diffusion on a 2-D grid ## partially specified Jacobian ## ======================================================================= diffusion2D <- function(t, Y, par) { y <- matrix(nrow = n, ncol = n, data = Y) dY <- r*y # production ## diffusion in X-direction; boundaries = 0-concentration Flux <- -Dx * rbind(y[1,],(y[2:n,]-y[1:(n-1),]),-y[n,])/dx dY <- dY - (Flux[2:(n+1),]-Flux[1:n,])/dx ## diffusion in Y-direction Flux <- -Dy * cbind(y[,1],(y[,2:n]-y[,1:(n-1)]),-y[,n])/dy dY <- dY - (Flux[,2:(n+1)]-Flux[,1:n])/dy return(list(as.vector(dY))) } ## parameters dy <- dx <- 1 # grid size Dy <- Dx <- 1 # diffusion coeff, X- and Y-direction r <- 0.025 # production rate times <- c(0, 1) n <- 50 y <- matrix(nrow = n, ncol = n, 0) pa <- par(ask = FALSE) ## initial condition for (i in 1:n) { for (j in 1:n) { dst <- (i - n/2)^2 + (j - n/2)^2 y[i, j] <- max(0, 1 - 1/(n*n) * (dst - n)^2) } } filled.contour(y, color.palette = terrain.colors) ## ======================================================================= ## jacfunc need not be estimated exactly ## a crude approximation, with a smaller bandwidth will do. ## Here the half-bandwidth 1 is used, whereas the true ## half-bandwidths are equal to n. ## This corresponds to ignoring the y-direction coupling in the ODEs. ## ======================================================================= print(system.time( for (i in 1:20) { out <- lsode(func = diffusion2D, y = as.vector(y), times = times, parms = NULL, jactype = "bandint", bandup = 1, banddown = 1) filled.contour(matrix(nrow = n, ncol = n, out[2,-1]), zlim = c(0,1), color.palette = terrain.colors, main = i) y <- out[2, -1] } )) par(ask = pa) } \references{ Alan C. Hindmarsh, "ODEPACK, A Systematized Collection of ODE Solvers," in Scientific Computing, R. S. Stepleman, et al., Eds. (North-Holland, Amsterdam, 1983), pp. 55-64. } \details{ The work is done by the FORTRAN subroutine \code{lsode}, whose documentation should be consulted for details (it is included as comments in the source file \file{src/opkdmain.f}). The implementation is based on the November, 2003 version of lsode, from Netlib. Before using the integrator \code{lsode}, the user has to decide whether or not the problem is stiff. If the problem is nonstiff, use method flag \code{mf} = 10, which selects a nonstiff (Adams) method, no Jacobian used.\cr If the problem is stiff, there are four standard choices which can be specified with \code{jactype} or \code{mf}. The options for \bold{jactype} are \describe{ \item{jactype = "fullint"}{a full Jacobian, calculated internally by lsode, corresponds to \code{mf} = 22, } \item{jactype = "fullusr"}{a full Jacobian, specified by user function \code{jacfunc}, corresponds to \code{mf} = 21, } \item{jactype = "bandusr"}{a banded Jacobian, specified by user function \code{jacfunc}; the size of the bands specified by \code{bandup} and \code{banddown}, corresponds to \code{mf} = 24, } \item{jactype = "bandint"}{a banded Jacobian, calculated by lsode; the size of the bands specified by \code{bandup} and \code{banddown}, corresponds to \code{mf} = 25. } } More options are available when specifying \bold{mf} directly. \cr The legal values of \code{mf} are 10, 11, 12, 13, 14, 15, 20, 21, 22, 23, 24, 25.\cr \code{mf} is a positive two-digit integer, \code{mf} = (10*METH + MITER), where \describe{ \item{METH}{indicates the basic linear multistep method: METH = 1 means the implicit Adams method. METH = 2 means the method based on backward differentiation formulas (BDF-s). } \item{MITER}{indicates the corrector iteration method: MITER = 0 means functional iteration (no Jacobian matrix is involved). MITER = 1 means chord iteration with a user-supplied full (NEQ by NEQ) Jacobian. MITER = 2 means chord iteration with an internally generated (difference quotient) full Jacobian (using NEQ extra calls to \code{func} per df/dy value). MITER = 3 means chord iteration with an internally generated diagonal Jacobian approximation (using 1 extra call to \code{func} per df/dy evaluation). MITER = 4 means chord iteration with a user-supplied banded Jacobian. MITER = 5 means chord iteration with an internally generated banded Jacobian (using ML+MU+1 extra calls to \code{func} per df/dy evaluation).} } If MITER = 1 or 4, the user must supply a subroutine \code{jacfunc}. Inspection of the example below shows how to specify both a banded and full Jacobian. The input parameters \code{rtol}, and \code{atol} determine the \bold{error control} performed by the solver. See \code{\link{lsoda}} for details. The diagnostics of the integration can be printed to screen by calling \code{\link{diagnostics}}. If \code{verbose} = \code{TRUE}, the diagnostics will written to the screen at the end of the integration. See vignette("deSolve") for an explanation of each element in the vectors containing the diagnostic properties and how to directly access them. \bold{Models} may be defined in compiled C or FORTRAN code, as well as in an R-function. See package vignette \code{"compiledCode"} for details. More information about models defined in compiled code is in the package vignette ("compiledCode"); information about linking forcing functions to compiled code is in \link{forcings}. Examples in both C and FORTRAN are in the \file{dynload} subdirectory of the \code{deSolve} package directory. \code{lsode} can find the root of at least one of a set of constraint functions \code{rootfunc} of the independent and dependent variables. It then returns the solution at the root if that occurs sooner than the specified stop condition, and otherwise returns the solution according the specified stop condition. Caution: Because of numerical errors in the function \code{rootfun} due to roundoff and integration error, \code{lsode} may return false roots, or return the same root at two or more nearly equal values of \code{time}. } \seealso{ \itemize{ \item \code{\link{rk}}, \item \code{\link{rk4}} and \code{\link{euler}} for Runge-Kutta integrators. \item \code{\link{lsoda}}, \code{\link{lsodes}}, \code{\link{lsodar}}, \code{\link{vode}}, \code{\link{daspk}} for other solvers of the Livermore family, \item \code{\link{ode}} for a general interface to most of the ODE solvers, \item \code{\link{ode.band}} for solving models with a banded Jacobian, \item \code{\link{ode.1D}} for integrating 1-D models, \item \code{\link{ode.2D}} for integrating 2-D models, \item \code{\link{ode.3D}} for integrating 3-D models, } \code{\link{diagnostics}} to print diagnostic messages. } \keyword{math} deSolve/man/vode.Rd0000754000175100001440000004602213071630254013677 0ustar hornikusers\name{vode} \alias{vode} \title{Solver for Ordinary Differential Equations (ODE)} \description{ Solves the initial value problem for stiff or nonstiff systems of ordinary differential equations (ODE) in the form: \deqn{dy/dt = f(t,y)} The \R function \code{vode} provides an interface to the FORTRAN ODE solver of the same name, written by Peter N. Brown, Alan C. Hindmarsh and George D. Byrne. The system of ODE's is written as an \R function or be defined in compiled code that has been dynamically loaded. In contrast to \code{\link{lsoda}}, the user has to specify whether or not the problem is stiff and choose the appropriate solution method. \code{vode} is very similar to \code{\link{lsode}}, but uses a variable-coefficient method rather than the fixed-step-interpolate methods in \code{\link{lsode}}. In addition, in vode it is possible to choose whether or not a copy of the Jacobian is saved for reuse in the corrector iteration algorithm; In \code{lsode}, a copy is not kept. } \usage{vode(y, times, func, parms, rtol = 1e-6, atol = 1e-6, jacfunc = NULL, jactype = "fullint", mf = NULL, verbose = FALSE, tcrit = NULL, hmin = 0, hmax = NULL, hini = 0, ynames = TRUE, maxord = NULL, bandup = NULL, banddown = NULL, maxsteps = 5000, dllname = NULL, initfunc = dllname, initpar = parms, rpar = NULL, ipar = NULL, nout = 0, outnames = NULL, forcings=NULL, initforc = NULL, fcontrol=NULL, events=NULL, lags = NULL,...) } \arguments{ \item{y }{the initial (state) values for the ODE system. If \code{y} has a name attribute, the names will be used to label the output matrix. } \item{times }{time sequence for which output is wanted; the first value of \code{times} must be the initial time; if only one step is to be taken; set \code{times = NULL}. } \item{func }{either an \R-function that computes the values of the derivatives in the ODE system (the \emph{model definition}) at time \code{t}, or a character string giving the name of a compiled function in a dynamically loaded shared library. If \code{func} is an \R-function, it must be defined as: \code{func <- function(t, y, parms,...)}. \code{t} is the current time point in the integration, \code{y} is the current estimate of the variables in the ODE system. If the initial values \code{y} has a \code{names} attribute, the names will be available inside \code{func}. \code{parms} is a vector or list of parameters; ... (optional) are any other arguments passed to the function. The return value of \code{func} should be a list, whose first element is a vector containing the derivatives of \code{y} with respect to \code{time}, and whose next elements are global values that are required at each point in \code{times}. The derivatives must be specified in the \bold{same order} as the state variables \code{y}. If \code{func} is a string, then \code{dllname} must give the name of the shared library (without extension) which must be loaded before \code{vode()} is called. See package vignette \code{"compiledCode"} for more details. } \item{parms }{vector or list of parameters used in \code{func} or \code{jacfunc}. } \item{rtol }{relative error tolerance, either a scalar or an array as long as \code{y}. See details. } \item{atol }{absolute error tolerance, either a scalar or an array as long as \code{y}. See details. } \item{jacfunc }{if not \code{NULL}, an \R function that computes the Jacobian of the system of differential equations \eqn{\partial\dot{y}_i/\partial y_j}{dydot(i)/dy(j)}, or a string giving the name of a function or subroutine in \file{dllname} that computes the Jacobian (see vignette \code{"compiledCode"} for more about this option). In some circumstances, supplying \code{jacfunc} can speed up the computations, if the system is stiff. The \R calling sequence for \code{jacfunc} is identical to that of \code{func}. If the Jacobian is a full matrix, \code{jacfunc} should return a matrix \eqn{\partial\dot{y}/\partial y}{dydot/dy}, where the ith row contains the derivative of \eqn{dy_i/dt} with respect to \eqn{y_j}, or a vector containing the matrix elements by columns (the way \R and FORTRAN store matrices). If the Jacobian is banded, \code{jacfunc} should return a matrix containing only the nonzero bands of the Jacobian, rotated row-wise. See first example of \link{lsode}. } \item{jactype }{the structure of the Jacobian, one of \code{"fullint"}, \code{"fullusr"}, \code{"bandusr"} or \code{"bandint"} - either full or banded and estimated internally or by user; overruled if \code{mf} is not \code{NULL}. } \item{mf }{the "method flag" passed to function vode - overrules \code{jactype} - provides more options than \code{jactype} - see details. } \item{verbose }{if TRUE: full output to the screen, e.g. will print the \code{diagnostiscs} of the integration - see details. } \item{tcrit }{if not \code{NULL}, then \code{vode} cannot integrate past \code{tcrit}. The FORTRAN routine \code{dvode} overshoots its targets (times points in the vector \code{times}), and interpolates values for the desired time points. If there is a time beyond which integration should not proceed (perhaps because of a singularity), that should be provided in \code{tcrit}. } \item{hmin }{an optional minimum value of the integration stepsize. In special situations this parameter may speed up computations with the cost of precision. Don't use hmin if you don't know why! } \item{hmax }{an optional maximum value of the integration stepsize. If not specified, hmax is set to the largest difference in \code{times}, to avoid that the simulation possibly ignores short-term events. If 0, no maximal size is specified. } \item{hini }{initial step size to be attempted; if 0, the initial step size is determined by the solver. } \item{ynames }{logical; if \code{FALSE}: names of state variables are not passed to function \code{func} ; this may speed up the simulation especially for multi-D models. } \item{maxord }{the maximum order to be allowed. \code{NULL} uses the default, i.e. order 12 if implicit Adams method (meth = 1), order 5 if BDF method (meth = 2). Reduce maxord to save storage space. } \item{bandup }{number of non-zero bands above the diagonal, in case the Jacobian is banded. } \item{banddown }{number of non-zero bands below the diagonal, in case the Jacobian is banded. } \item{maxsteps }{maximal number of steps per output interval taken by the solver. } \item{dllname }{a string giving the name of the shared library (without extension) that contains all the compiled function or subroutine definitions refered to in \code{func} and \code{jacfunc}. See package vignette \code{"compiledCode"}. } \item{initfunc }{if not \code{NULL}, the name of the initialisation function (which initialises values of parameters), as provided in \file{dllname}. See package vignette \code{"compiledCode"}. } \item{initpar }{only when \file{dllname} is specified and an initialisation function \code{initfunc} is in the dll: the parameters passed to the initialiser, to initialise the common blocks (FORTRAN) or global variables (C, C++). } \item{rpar }{only when \file{dllname} is specified: a vector with double precision values passed to the dll-functions whose names are specified by \code{func} and \code{jacfunc}. } \item{ipar }{only when \file{dllname} is specified: a vector with integer values passed to the dll-functions whose names are specified by \code{func} and \code{jacfunc}. } \item{nout }{only used if \code{dllname} is specified and the model is defined in compiled code: the number of output variables calculated in the compiled function \code{func}, present in the shared library. Note: it is not automatically checked whether this is indeed the number of output variables calculated in the dll - you have to perform this check in the code - See package vignette \code{"compiledCode"}. } \item{outnames }{only used if \file{dllname} is specified and \code{nout} > 0: the names of output variables calculated in the compiled function \code{func}, present in the shared library. These names will be used to label the output matrix. } \item{forcings }{only used if \file{dllname} is specified: a list with the forcing function data sets, each present as a two-columned matrix, with (time,value); interpolation outside the interval [min(\code{times}), max(\code{times})] is done by taking the value at the closest data extreme. See \link{forcings} or package vignette \code{"compiledCode"}. } \item{initforc }{if not \code{NULL}, the name of the forcing function initialisation function, as provided in \file{dllname}. It MUST be present if \code{forcings} has been given a value. See \link{forcings} or package vignette \code{"compiledCode"}. } \item{fcontrol }{A list of control parameters for the forcing functions. \link{forcings} or package vignette \code{"compiledCode"} } \item{events }{A matrix or data frame that specifies events, i.e. when the value of a state variable is suddenly changed. See \link{events} for more information. } \item{lags }{A list that specifies timelags, i.e. the number of steps that has to be kept. To be used for delay differential equations. See \link{timelags}, \link{dede} for more information. } \item{... }{additional arguments passed to \code{func} and \code{jacfunc} allowing this to be a generic function. } } \value{ A matrix of class \code{deSolve} with up to as many rows as elements in \code{times} and as many columns as elements in \code{y} plus the number of "global" values returned in the next elements of the return from \code{func}, plus and additional column for the time value. There will be a row for each element in \code{times} unless the FORTRAN routine `vode' returns with an unrecoverable error. If \code{y} has a names attribute, it will be used to label the columns of the output value. } \author{Karline Soetaert } \examples{ ## ======================================================================= ## ex. 1 ## The famous Lorenz equations: chaos in the earth's atmosphere ## Lorenz 1963. J. Atmos. Sci. 20, 130-141. ## ======================================================================= chaos <- function(t, state, parameters) { with(as.list(c(state)), { dx <- -8/3 * x + y * z dy <- -10 * (y - z) dz <- -x * y + 28 * y - z list(c(dx, dy, dz)) }) } state <- c(x = 1, y = 1, z = 1) times <- seq(0, 100, 0.01) out <- vode(state, times, chaos, 0) plot(out, type = "l") # all versus time plot(out[,"x"], out[,"y"], type = "l", main = "Lorenz butterfly", xlab = "x", ylab = "y") ## ======================================================================= ## ex. 2 ## SCOC model, in FORTRAN - to see the FORTRAN code: ## browseURL(paste(system.file(package="deSolve"), ## "/doc/examples/dynload/scoc.f",sep="")) ## example from Soetaert and Herman, 2009, chapter 3. (simplified) ## ======================================================================= ## Forcing function data Flux <- matrix(ncol = 2, byrow = TRUE, data = c( 1, 0.654, 11, 0.167, 21, 0.060, 41, 0.070, 73, 0.277, 83, 0.186, 93, 0.140,103, 0.255, 113, 0.231,123, 0.309,133, 1.127,143, 1.923, 153,1.091,163, 1.001, 173, 1.691,183, 1.404,194, 1.226,204, 0.767, 214,0.893,224, 0.737, 234, 0.772,244, 0.726,254, 0.624,264, 0.439, 274,0.168,284, 0.280, 294, 0.202,304, 0.193,315, 0.286,325, 0.599, 335,1.889,345, 0.996, 355, 0.681,365, 1.135)) parms <- c(k = 0.01) meanDepo <- mean(approx(Flux[,1], Flux[,2], xout = seq(1, 365, by = 1))$y) Yini <- c(y = as.double(meanDepo/parms)) times <- 1:365 out <- vode(Yini, times, func = "scocder", parms = parms, dllname = "deSolve", initforc = "scocforc", forcings = Flux, initfunc = "scocpar", nout = 2, outnames = c("Mineralisation", "Depo")) matplot(out[,1], out[,c("Depo", "Mineralisation")], type = "l", col = c("red", "blue"), xlab = "time", ylab = "Depo") ## Constant interpolation of forcing function - left side of interval fcontrol <- list(method = "constant") out2 <- vode(Yini, times, func = "scocder", parms = parms, dllname = "deSolve", initforc = "scocforc", forcings = Flux, fcontrol = fcontrol, initfunc = "scocpar", nout = 2, outnames = c("Mineralisation", "Depo")) matplot(out2[,1], out2[,c("Depo", "Mineralisation")], type = "l", col = c("red", "blue"), xlab = "time", ylab = "Depo") ## Constant interpolation of forcing function - middle of interval fcontrol <- list(method = "constant", f = 0.5) out3 <- vode(Yini, times, func = "scocder", parms = parms, dllname = "deSolve", initforc = "scocforc", forcings = Flux, fcontrol = fcontrol, initfunc = "scocpar", nout = 2, outnames = c("Mineralisation", "Depo")) matplot(out3[,1], out3[,c("Depo", "Mineralisation")], type = "l", col = c("red", "blue"), xlab = "time", ylab = "Depo") plot(out, out2, out3) } \references{ P. N. Brown, G. D. Byrne, and A. C. Hindmarsh, 1989. VODE: A Variable Coefficient ODE Solver, SIAM J. Sci. Stat. Comput., 10, pp. 1038-1051. \cr Also, LLNL Report UCRL-98412, June 1988. G. D. Byrne and A. C. Hindmarsh, 1975. A Polyalgorithm for the Numerical Solution of Ordinary Differential Equations. ACM Trans. Math. Software, 1, pp. 71-96. A. C. Hindmarsh and G. D. Byrne, 1977. EPISODE: An Effective Package for the Integration of Systems of Ordinary Differential Equations. LLNL Report UCID-30112, Rev. 1. G. D. Byrne and A. C. Hindmarsh, 1976. EPISODEB: An Experimental Package for the Integration of Systems of Ordinary Differential Equations with Banded Jacobians. LLNL Report UCID-30132, April 1976. A. C. Hindmarsh, 1983. ODEPACK, a Systematized Collection of ODE Solvers. in Scientific Computing, R. S. Stepleman et al., eds., North-Holland, Amsterdam, pp. 55-64. K. R. Jackson and R. Sacks-Davis, 1980. An Alternative Implementation of Variable Step-Size Multistep Formulas for Stiff ODEs. ACM Trans. Math. Software, 6, pp. 295-318. Netlib: \url{http://www.netlib.org} } \details{ Before using the integrator \code{vode}, the user has to decide whether or not the problem is stiff. If the problem is nonstiff, use method flag \code{mf} = 10, which selects a nonstiff (Adams) method, no Jacobian used. If the problem is stiff, there are four standard choices which can be specified with \code{jactype} or \code{mf}. The options for \bold{jactype} are \describe{ \item{jac = "fullint":}{a full Jacobian, calculated internally by vode, corresponds to \code{mf} = 22, } \item{jac = "fullusr":}{a full Jacobian, specified by user function \code{jacfunc}, corresponds to \code{mf} = 21, } \item{jac = "bandusr":}{a banded Jacobian, specified by user function \code{jacfunc}; the size of the bands specified by \code{bandup} and \code{banddown}, corresponds to \code{mf} = 24, } \item{jac = "bandint":}{a banded Jacobian, calculated by vode; the size of the bands specified by \code{bandup} and \code{banddown}, corresponds to \code{mf} = 25. } } More options are available when specifying \bold{mf} directly. The legal values of \code{mf} are 10, 11, 12, 13, 14, 15, 20, 21, 22, 23, 24, 25, -11, -12, -14, -15, -21, -22, -24, -25. \code{mf} is a signed two-digit integer, \code{mf = JSV*(10*METH + MITER)}, where \describe{ \item{JSV = SIGN(mf)}{indicates the Jacobian-saving strategy: JSV = 1 means a copy of the Jacobian is saved for reuse in the corrector iteration algorithm. JSV = -1 means a copy of the Jacobian is not saved. } \item{METH}{indicates the basic linear multistep method: METH = 1 means the implicit Adams method. METH = 2 means the method based on backward differentiation formulas (BDF-s). } \item{MITER}{indicates the corrector iteration method: MITER = 0 means functional iteration (no Jacobian matrix is involved). MITER = 1 means chord iteration with a user-supplied full (NEQ by NEQ) Jacobian. MITER = 2 means chord iteration with an internally generated (difference quotient) full Jacobian (using NEQ extra calls to \code{func} per df/dy value). MITER = 3 means chord iteration with an internally generated diagonal Jacobian approximation (using 1 extra call to \code{func} per df/dy evaluation). MITER = 4 means chord iteration with a user-supplied banded Jacobian. MITER = 5 means chord iteration with an internally generated banded Jacobian (using ML+MU+1 extra calls to \code{func} per df/dy evaluation). } } If MITER = 1 or 4, the user must supply a subroutine \code{jacfunc}. The example for integrator \code{\link{lsode}} demonstrates how to specify both a banded and full Jacobian. The input parameters \code{rtol}, and \code{atol} determine the \bold{error control} performed by the solver. If the request for precision exceeds the capabilities of the machine, vode will return an error code. See \code{\link{lsoda}} for details. The diagnostics of the integration can be printed to screen by calling \code{\link{diagnostics}}. If \code{verbose} = \code{TRUE}, the diagnostics will written to the screen at the end of the integration. See vignette("deSolve") for an explanation of each element in the vectors containing the diagnostic properties and how to directly access them. \bold{Models} may be defined in compiled C or FORTRAN code, as well as in an R-function. See package vignette \code{"compiledCode"} for details. More information about models defined in compiled code is in the package vignette ("compiledCode"); information about linking forcing functions to compiled code is in \link{forcings}. Examples in both C and FORTRAN are in the \file{dynload} subdirectory of the \code{deSolve} package directory. } \seealso{ \itemize{ \item \code{\link{rk}}, \item \code{\link{rk4}} and \code{\link{euler}} for Runge-Kutta integrators. \item \code{\link{lsoda}}, \code{\link{lsode}}, \code{\link{lsodes}}, \code{\link{lsodar}}, \code{\link{daspk}} for other solvers of the Livermore family, \item \code{\link{ode}} for a general interface to most of the ODE solvers, \item \code{\link{ode.band}} for solving models with a banded Jacobian, \item \code{\link{ode.1D}} for integrating 1-D models, \item \code{\link{ode.2D}} for integrating 2-D models, \item \code{\link{ode.3D}} for integrating 3-D models, } \code{\link{diagnostics}} to print diagnostic messages. } \note{ From version 1.10.4, the default of \code{atol} was changed from 1e-8 to 1e-6, to be consistent with the other solvers. } \keyword{math} deSolve/man/DLLfunc.Rd0000754000175100001440000001061212352122172014221 0ustar hornikusers\name{DLLfunc} \alias{DLLfunc} \title{Evaluates a Derivative Function Represented in a DLL} \description{Calls a function, defined in a compiled language as a DLL} \usage{DLLfunc(func, times, y, parms, dllname, initfunc = dllname, rpar = NULL, ipar = NULL, nout = 0, outnames = NULL, forcings = NULL, initforc = NULL, fcontrol = NULL) } \arguments{ \item{func }{the name of the function in the dynamically loaded shared library, } \item{times }{first value = the time at which the function needs to be evaluated, } \item{y }{the values of the dependent variables for which the function needs to be evaluated, } \item{parms }{the parameters that are passed to the initialiser function, } \item{dllname }{a string giving the name of the shared library (without extension) that contains the compiled function or subroutine definitions referred to in \code{func}, } \item{initfunc }{if not \code{NULL}, the name of the initialisation function (which initialises values of parameters), as provided in \file{dllname}. See details. } \item{rpar }{a vector with double precision values passed to the DLL-function \code{func} and \code{jacfunc} present in the DLL, via argument rpar, } \item{ipar }{a vector with integer values passed to the dll-function \code{func} and \code{jacfunc} present in the DLL, via function argument ipar, } \item{nout }{the number of output variables. } \item{outnames }{only used if \file{dllname} is specified and \code{nout} > 0: the names of output variables calculated in the compiled function \code{func}, present in the shared library. } \item{forcings }{only used if \file{dllname} is specified: a list with the forcing function data sets, each present as a two-columned matrix, with (time, value); interpolation outside the interval [min(\code{times}), max(\code{times})] is done by taking the value at the closest data extreme. See package vignette \code{"compiledCode"}. } \item{initforc }{if not \code{NULL}, the name of the forcing function initialisation function, as provided in \file{dllname}. It MUST be present if \code{forcings} has been given a value. See package vignette \code{"compiledCode"}. } \item{fcontrol }{A list of control parameters for the forcing functions. See package vignette \code{"compiledCode"}. } } \value{ a list containing: \item{dy }{the rate of change estimated by the function, } \item{var }{the ordinary output variables of the function. } } \details{ This function is meant to help developing FORTRAN or C models that are to be used to solve ordinary differential equations (ODE) in packages \code{deSolve} and/or \code{rootSolve}. } \author{Karline Soetaert } \examples{ ## ========================================================================== ## ex. 1 ## ccl4model ## ========================================================================== ## Parameter values and initial conditions ## see example(ccl4model) for a more comprehensive implementation Parms <- c(0.182, 4.0, 4.0, 0.08, 0.04, 0.74, 0.05, 0.15, 0.32, 16.17, 281.48, 13.3, 16.17, 5.487, 153.8, 0.04321671, 0.4027255, 1000, 0.02, 1.0, 3.8) yini <- c(AI = 21, AAM = 0, AT = 0, AF = 0, AL = 0, CLT = 0, AM = 0) ## the rate of change DLLfunc(y = yini, dllname = "deSolve", func = "derivsccl4", initfunc = "initccl4", parms = Parms, times = 1, nout = 3, outnames = c("DOSE", "MASS", "CP") ) ## ========================================================================== ## ex. 2 ## SCOC model, in fortran - to see the FORTRAN code: ## ========================================================================== ## Forcing function "data" Flux <- matrix(ncol = 2, byrow = TRUE, data = c(1, 0.654, 2, 0.167)) parms <- c(k = 0.01) Yini <- 60 DLLfunc(y=Yini, times=1, func = "scocder", parms = parms, dllname = "deSolve", initforc = "scocforc", forcings = Flux, initfunc = "scocpar", nout = 2, outnames = c("Mineralisation","Depo")) ## correct value = dy = flux - k * y = 0.654 - 0.01 * 60 DLLfunc(y = Yini, times = 2, func = "scocder", parms = parms, dllname = "deSolve", initforc = "scocforc", forcings = Flux, initfunc = "scocpar", nout = 2, outnames = c("Mineralisation", "Depo")) } \keyword{utilities} \seealso{ \code{\link{ode}} for a general interface to most of the ODE solvers } deSolve/man/ccl4data.Rd0000754000175100001440000000234012352122172014410 0ustar hornikusers\name{ccl4data} \docType{data} \alias{ccl4data} \title{Closed Chamber Study of CCl4 Metabolism by Rats.} \description{The results of a closed chamber experiment to determine metabolic parameters for CCl4 (carbon tetrachloride) in rats. } \usage{data(ccl4data)} \format{This data frame contains the following columns: \describe{ \item{time}{the time (in hours after starting the experiment).} \item{initconc}{initial chamber concentration (ppm).} \item{animal}{this is a repeated measures design; this variable indicates which animal the observation pertains to. } \item{ChamberConc}{chamber concentration at \code{time}, in ppm.} } } \source{ Evans, et al. 1994 Applications of sensitivity analysis to a physiologically based pharmacokinetic model for carbon tetrachloride in rats. Toxicology and Applied Pharmacology \bold{128}: 36 -- 44. } \examples{ plot(ChamberConc ~ time, data = ccl4data, xlab = "Time (hours)", xlim = range(c(0, ccl4data$time)), ylab = "Chamber Concentration (ppm)", log = "y") ccl4data.avg <- aggregate(ccl4data$ChamberConc, by = ccl4data[c("time", "initconc")], mean) points(x ~ time, data = ccl4data.avg, pch = 16) } \keyword{datasets} deSolve/man/cleanEventTimes.Rd0000754000175100001440000000402012352122172016014 0ustar hornikusers\name{cleanEventTimes} \alias{cleanEventTimes} \alias{nearestEvent} \title{ Find Nearest Event for Each Time Step and Clean Time Steps to Avoid Doubles } \description{ These functions can be used for checking time steps and events used by ode solver functions. They are normally called internally within the solvers. } \usage{ nearestEvent(times, eventtimes) cleanEventTimes(times, eventtimes, eps = .Machine$double.eps * 10) } \arguments{ \item{times}{the vector of output times,} \item{eventtimes}{a vector with the event times,} \item{eps}{relative tolerance value below which two numbers are assumed to be numerically equal.} } \details{ In floating point arithmetics, problems can occur if values have to be compared for 'equality' but are only close to each other and not exactly the same. The utility functions can be used to add all \code{eventtimes} to the output \code{times} vector, but without including times that are very close to an event. This means that all values of \code{eventtimes} are contained but only the subset of \code{times} that have no close neighbors in \code{eventtimes}. These checks are normally performed internally by the integration solvers. } \value{ \code{nearestEvent} returns a vector with the closest events for each time step and \code{cleanEventTimes} returns a vector with the output times without all those that are 'very close' to an event. } \author{ Thomas Petzoldt } \seealso{ \code{\link{events}} } \examples{ events <- sort(c(0, 2, 3, 4 + 1e-10, 5, 7 - 1e-10, 7 + 6e-15, 7.5, 9, 24.9999, 25, 80, 1001, 1e300)) times <- sort(c(0, 1:7, 4.5, 6.75, 7.5, 9.2, 9.0001, 25, 879, 1e3, 1e300+5)) nearest <- nearestEvent(times, events) data.frame(times=times, nearest = nearest) ## typical usage: include all events in times after removing values that ## are numerically close together, events have priority times unique_times <- cleanEventTimes(times, events) newtimes <- sort(c(unique_times, events)) newtimes } \keyword{ misc } deSolve/man/deSolve.Rd0000754000175100001440000001307613064604412014345 0ustar hornikusers\name{deSolve-package} \alias{deSolve-package} \alias{deSolve} \docType{package} \title{ General Solvers for Initial Value Problems of Ordinary Differential Equations (ODE), Partial Differential Equations (PDE), Differential Algebraic Equations (DAE) and delay differential equations (DDE). } \description{ Functions that solve initial value problems of a system of first-order ordinary differential equations (ODE), of partial differential equations (PDE), of differential algebraic equations (DAE) and delay differential equations. The functions provide an interface to the FORTRAN functions lsoda, lsodar, lsode, lsodes of the ODEPACK collection, to the FORTRAN functions dvode and daspk and a C-implementation of solvers of the Runge-Kutta family with fixed or variable time steps. The package contains routines designed for solving ODEs resulting from 1-D, 2-D and 3-D partial differential equations (PDE) that have been converted to ODEs by numerical differencing. It includes root-finding (or event location) and provides access to lagged variables and derivatives. } \details{ \tabular{ll}{ Package: \tab deSolve\cr Type: \tab Package\cr Version: \tab 1.20\cr Date: \tab 2017-03-22\cr License: \tab GNU Public License 2 or above\cr } The system of differential equations is written as an \R function or defined in compiled code that has been dynamically loaded, see package vignette \href{../doc/compiledCode.pdf}{compiledCode} for details. The solvers may be used as part of a modeling package for differential equations, or for parameter estimation using any appropriate modeling tool for non-linear models in \R such as \code{\link{optim}}, \code{\link{nls}}, \code{\link{nlm}} or \code{\link[nlme]{nlme}}, or \code{\link[FME]{FME}}. \bold{Package Vignettes, Examples, Online Resources} \itemize{ \item Solving Initial Value Differential Equations in R (\href{../doc/deSolve.pdf}{pdf}, \href{../doc/deSolve.R}{R code}) \item Writing Code in Compiled Languages (\href{../doc/compiledCode.pdf}{pdf}, \href{../doc/compiledCode.R}{R code}) \item Examples in R (\url{../doc/examples}), and in Fortran or C (\url{../doc/dynload}, \url{../doc/dynload-dede}) \item deSolve homepage: \url{http://desolve.r-forge.r-project.org} (Papers, Books, PDFs) \item Mailing list: \url{mailto:r-sig-dynamic-models@r-project.org} } } \author{ Karline Soetaert, Thomas Petzoldt, R. Woodrow Setzer } \references{ Karline Soetaert, Thomas Petzoldt, R. Woodrow Setzer (2010): Solving Differential Equations in R: Package deSolve Journal of Statistical Software, 33(9), 1--25. \url{https://www.jstatsoft.org/v33/i09/} Karline Soetaert, Thomas Petzoldt, R. Woodrow Setzer (2010): Solving differential equations in R. The R Journal 2(2), 5-15. \href{https://journal.r-project.org/archive/2010-2/RJournal_2010-2_Soetaert~et~al.pdf}{pdf} Karline Soetaert, Thomas Petzoldt (2011): Solving ODEs, DAEs, DDEs and PDEs in R. Journal of Numerical Analysis, Industrial and Applied Mathematics (JNAIAM) 6(1-2), 51-65. %\href{http://jnaiam.org/uploads/jnaiam_6_4.pdf}{pdf} Karline Soetaert, Jeff Cash, Francesca Mazzia, (2012): Solving Differential Equations in R. Springer, 248 pp. Alan C. Hindmarsh (1983): ODEPACK, A Systematized Collection of ODE Solvers, in Scientific Computing, R. S. Stepleman et al. (Eds.), North-Holland, Amsterdam, pp. 55-64. L. R. Petzold, (1983): A Description of DASSL: A Differential/Algebraic System Solver, in Scientific Computing, R. S. Stepleman et al. (Eds.), North-Holland, Amsterdam, pp. 65-68. P. N. Brown, G. D. Byrne, A. C. Hindmarsh (1989): VODE: A Variable Coefficient ODE Solver, SIAM J. Sci. Stat. Comput., 10, pp. 1038-1051. See also the references given on the specific help pages of the different methods. } \seealso{ \code{\link{ode}} for a general interface to most of the ODE solvers, \code{\link{ode.band}} for solving models with a banded Jacobian, \code{\link{ode.1D}}, \code{\link{ode.2D}}, \code{\link{ode.3D}}, for integrating 1-D, 2-D and 3-D models, \code{\link{dede}} for a general interface to the delay differential equation solvers, \code{\link{lsoda}}, \code{\link{lsode}}, \code{\link{lsodes}}, \code{\link{lsodar}}, \code{\link{vode}}, for ODE solvers of the Livermore family, \code{\link{daspk}}, for a DAE solver up to index 1, of the Livermore family, \code{\link{radau}} for integrating DAEs up to index 3 using an implicit Runge-Kutta, \code{\link{rk}}, \code{\link{rkMethod}}, \code{\link{rk4}}, \code{\link{euler}} for Runge-Kutta solvers, \code{\link{DLLfunc}}, \code{\link{DLLres}}, for testing model implementations in compiled code, \code{\link{forcings}}, \code{\link{events}}, for how to implement forcing functions (external variables) and events (sudden changes in state variables), \code{\link{lagvalue}}, \code{\link{lagderiv}}, for how to get access to lagged values of state variables and derivatives. } \examples{ library(deSolve) ## Chaos in the atmosphere Lorenz <- function(t, state, parameters) { with(as.list(c(state, parameters)), { dX <- a * X + Y * Z dY <- b * (Y - Z) dZ <- -X * Y + c * Y - Z list(c(dX, dY, dZ)) }) } parameters <- c(a = -8/3, b = -10, c = 28) state <- c(X = 1, Y = 1, Z = 1) times <- seq(0, 100, by = 0.01) out <- ode(y = state, times = times, func = Lorenz, parms = parameters) plot(out) ## add a 3D figure if package scatterplot3D is available if (require(scatterplot3d)) scatterplot3d(out[,-1], type = "l") } \keyword{ package } deSolve/man/rkMethod.Rd0000754000175100001440000002760413023007446014522 0ustar hornikusers\name{rkMethod} \alias{rkMethod} \title{Collection of Parameter Sets (Butcher Arrays) for the Runge-Kutta Family of ODE Solvers } \description{ This function returns a list specifying coefficients and properties of ODE solver methods from the Runge-Kutta family. } \usage{ rkMethod(method = NULL, ...) } \arguments{ \item{method }{a string constant naming one of the pre-defined methods of the Runge-Kutta family of solvers. The most common methods are the fixed-step methods \code{"euler"}, \code{"rk2"}, \code{"rk4"} or the variable step methods \code{"rk23bs"} (alias \code{"ode23"}), \code{"rk45dp7"} (alias \code{"ode45"}) or \code{"rk78f"}. } \item{\dots }{specification of a user-defined solver, see \emph{Value} and example below. } } \details{ This function supplies \code{method} settings for \code{\link{rk}} or \code{\link{ode}}. If called without arguments, the names of all currently implemented solvers of the Runge-Kutta family are returned. The following comparison gives an idea how the algorithms of \pkg{deSolve} are related to similar algorithms of other simulation languages: \tabular{lll}{ \bold{rkMethod} \tab | \tab \bold{Description} \cr "euler" \tab | \tab Euler's Method\cr "rk2" \tab | \tab 2nd order Runge-Kutta, fixed time step (Heun's method)\cr "rk4" \tab | \tab classical 4th order Runge-Kutta, fixed time step\cr "rk23" \tab | \tab Runge-Kutta, order 2(3); Octave: ode23\cr "rk23bs", "ode23" \tab | \tab Bogacki-Shampine, order 2(3); Matlab: ode23\cr "rk34f" \tab | \tab Runge-Kutta-Fehlberg, order 3(4)\cr "rk45ck" \tab | \tab Runge-Kutta Cash-Karp, order 4(5)\cr "rk45f" \tab | \tab Runge-Kutta-Fehlberg, order 4(5); Octave: ode45, pair=1 \cr "rk45e" \tab | \tab Runge-Kutta-England, order 4(5)\cr "rk45dp6" \tab | \tab Dormand-Prince, order 4(5), local order 6\cr "rk45dp7", "ode45" \tab | \tab Dormand-Prince 4(5), local order 7 \cr \tab | \tab (also known as dopri5; MATLAB: ode45; Octave: ode45, pair=0)\cr "rk78f" \tab | \tab Runge-Kutta-Fehlberg, order 7(8)\cr "rk78dp" \tab | \tab Dormand-Prince, order 7(8)\cr } Note that this table is based on the Runge-Kutta coefficients only, but the algorithms differ also in their implementation, in their stepsize adaption strategy and interpolation methods. The table reflects the state at time of writing and it is of course possible that implementations change. Methods \code{"rk45dp7"} (alias \code{"ode45"}) and \code{"rk45ck"} contain specific and efficient built-in interpolation schemes (dense output). As an alternative, Neville-Aitken polynomials can be used to interpolate between time steps. This is available for all RK methods and may be useful to speed up computation if no dense-output formula is available. Note however, that this can introduce considerable local error; it is disabled by default (see \code{nknots} below). } \note{ \itemize{ \item Adaptive stepsize Runge-Kuttas are preferred if the solution contains parts when the states change fast, and parts when not much happens. They will take small steps over bumpy ground and long steps over uninteresting terrain. \item As a suggestion, one may use \code{"rk23"} (alias \code{"ode23"}) for simple problems and \code{"rk45dp7"} (alias \code{"ode45"}) for rough problems. The default solver is \code{"rk45dp7"} (alias "ode45"), because of its relatively high order (4), re-use of the last intermediate steps (FSAL = first same as last) and built-in polynomial interpolation (dense output). \item Solver \code{"rk23bs"}, that supports also FSAL, may be useful for slightly stiff systems if demands on precision are relatively low. \item Another good choice, assuring medium accuracy, is the Cash-Karp Runge-Kutta method, \code{"rk45ck"}. \item Classical \code{"rk4"} is traditionally used in cases where an adequate stepsize is known a-priori or if external forcing data are provided for fixed time steps only and frequent interpolation of external data needs to be avoided. \item Method \code{"rk45dp7"} (alias \code{"ode45"}) contains an efficient built-in interpolation scheme (dense output) based on intermediate function evaluations. } Starting with version 1.8 implicit Runge-Kutta (\code{irk}) methods are also supported by the general \code{rk} interface, however their implementation is still experimental. Instead of this you may consider \code{\link{radau}} for a specific full implementation of an implicit Runge-Kutta method. } \value{ A list with the following elements: \item{ID}{name of the method (character)} \item{varstep}{boolean value specifying if the method allows for variable time step (\code{TRUE}) or not (\code{FALSE}). } \item{FSAL}{(first same as last) optional boolean value specifying if the method allows re-use of the last function evaluation (\code{TRUE}) or not (\code{FALSE} or \code{NULL}). } \item{A}{coefficient matrix of the method. As \code{link{rk}} supports only explicit methods, this matrix must be lower triangular. \code{A} must be a vector for fixed step methods where only the subdiagonal values are different from zero. } \item{b1}{coefficients of the lower order Runge-Kutta pair. } \item{b2}{coefficients of the higher order Runge-Kutta pair (optional, for embedded methods that allow variable time step). } \item{c}{coefficients for calculating the intermediate time steps.} \item{d}{optional coefficients for built-in polynomial interpolation of the outputs from internal steps (dense output), currently only available for method \code{rk45dp7} (Dormand-Prince). } \item{densetype}{optional integer value specifying the dense output formula; currently only \code{densetype = 1} for \code{rk45dp7} (Dormand-Prince) and \code{densetype = 2} for \code{rk45ck} (Cash-Karp) are supported. Undefined values (e.g., \code{densetype = NULL}) disable dense output. } \item{stage}{number of function evaluations needed (corresponds to number of rows in A). } \item{Qerr}{global error order of the method, important for automatic time-step adjustment. } \item{nknots}{integer value specifying the order of interpolation polynomials for methods without dense output. If \code{nknots} < 2 (the default) then internal interpolation is switched off and integration is performed step by step between external time steps. If \code{nknots} is between 3 and 8, Neville-Aitken polynomials are used, which need at least \code{nknots + 1} internal time steps. Interpolation may speed up integration but can lead to local errors higher than the tolerance, especially if external and internal time steps are very different. } \item{alpha}{optional tuning parameter for stepsize adjustment. If \code{alpha} is omitted, it is set to \eqn{1/Qerr - 0.75 beta}. The default value is \eqn{1/Qerr} (for \code{beta} = 0).} \item{beta}{optional tuning parameter for stepsize adjustment. Typical values are \eqn{0} (default) or \eqn{0.4/Qerr}. } } \references{ Bogacki, P. and Shampine L.F. (1989) A 3(2) pair of Runge-Kutta formulas, Appl. Math. Lett. \bold{2}, 1--9. Butcher, J. C. (1987) The numerical analysis of ordinary differential equations, Runge-Kutta and general linear methods, Wiley, Chichester and New York. Cash, J. R. and Karp A. H., 1990. A variable order Runge-Kutta method for initial value problems with rapidly varying right-hand sides, ACM Transactions on Mathematical Software \bold{16}, 201--222. Dormand, J. R. and Prince, P. J. (1980) A family of embedded Runge-Kutta formulae, J. Comput. Appl. Math. \bold{6}(1), 19--26. Engeln-Muellges, G. and Reutter, F. (1996) Numerik Algorithmen: Entscheidungshilfe zur Auswahl und Nutzung. VDI Verlag, Duesseldorf. Fehlberg, E. (1967) Klassische Runge-Kutta-Formeln fuenfter and siebenter Ordnung mit Schrittweiten-Kontrolle, Computing (Arch. Elektron. Rechnen) \bold{4}, 93--106. Kutta, W. (1901) Beitrag zur naeherungsweisen Integration totaler Differentialgleichungen, Z. Math. Phys. \bold{46}, 435--453. Octave-Forge - Extra Packages for GNU Octave, Package OdePkg. \url{http://octave.sourceforge.net/odepkg/} Prince, P. J. and Dormand, J. R. (1981) High order embedded Runge-Kutta formulae, J. Comput. Appl. Math. \bold{7}(1), 67--75. Runge, C. (1895) Ueber die numerische Aufloesung von Differentialgleichungen, Math. Ann. \bold{46}, 167--178. MATLAB (R) is a registed property of The Mathworks Inc. \url{http://www.mathworks.com/} } \author{Thomas Petzoldt \email{thomas.petzoldt@tu-dresden.de}} \seealso{\code{\link{rk}}, \code{\link{ode}}} \examples{ rkMethod() # returns the names of all available methods rkMethod("rk45dp7") # parameters of the Dormand-Prince 5(4) method rkMethod("ode45") # an alias for the same method func <- function(t, x, parms) { with(as.list(c(parms, x)),{ dP <- a * P - b * C * P dC <- b * P * C - c * C res <- c(dP, dC) list(res) }) } times <- seq(0, 200, length = 101) parms <- c(a = 0.1, b = 0.1, c = 0.1) x <- c(P = 2, C = 1) ## rk using ode45 as the default method out <- rk(x, times, func, parms) ## all methods can be called also from 'ode' by using rkMethod out <- ode(x, times, func, parms, method = rkMethod("rk4")) ## 'ode' has aliases for the most common RK methods out <- ode(x, times, func, parms, method = "ode45") ##=========================================================================== ## Comparison of local error from different interpolation methods ##=========================================================================== ## lsoda with lower tolerances (1e-10) used as reference o0 <- ode(x, times, func, parms, method = "lsoda", atol = 1e-10, rtol = 1e-10) ## rk45dp7 with hmax = 10 > delta_t = 2 o1 <- ode(x, times, func, parms, method = rkMethod("rk45dp7"), hmax = 10) ## disable dense-output interpolation ## and use only Neville-Aitken polynomials instead o2 <- ode(x, times, func, parms, method = rkMethod("rk45dp7", densetype = NULL, nknots = 5), hmax = 10) ## stop and go: disable interpolation completely ## and integrate explicitly between external time steps o3 <- ode(x, times, func, parms, method = rkMethod("rk45dp7", densetype = NULL, nknots = 0, hmax=10)) ## compare different interpolation methods with lsoda mf <- par("mfrow" = c(4, 1)) matplot(o1[,1], o1[,-1], type = "l", xlab = "Time", main = "State Variables", ylab = "P, C") matplot(o0[,1], o0[,-1] - o1[,-1], type = "l", xlab = "Time", ylab = "Diff.", main="Difference between lsoda and ode45 with dense output") abline(h = 0, col = "grey") matplot(o0[,1], o0[,-1] - o2[,-1], type = "l", xlab = "Time", ylab = "Diff.", main="Difference between lsoda and ode45 with Neville-Aitken") abline(h = 0, col = "grey") matplot(o0[,1], o0[,-1] - o3[,-1], type = "l", xlab = "Time", ylab = "Diff.", main="Difference between lsoda and ode45 in 'stop and go' mode") abline(h = 0, col = "grey") par(mf) ##=========================================================================== ## rkMethod allows to define user-specified Runge-Kutta methods ##=========================================================================== out <- ode(x, times, func, parms, method = rkMethod(ID = "midpoint", varstep = FALSE, A = c(0, 1/2), b1 = c(0, 1), c = c(0, 1/2), stage = 2, Qerr = 1 ) ) plot(out) ## compare method diagnostics times <- seq(0, 200, length = 10) o1 <- ode(x, times, func, parms, method = rkMethod("rk45ck")) o2 <- ode(x, times, func, parms, method = rkMethod("rk78dp")) diagnostics(o1) diagnostics(o2) } \keyword{ math } deSolve/man/lsoda.Rd0000754000175100001440000004627413071630263014055 0ustar hornikusers\name{lsoda} \alias{lsoda} \title{ Solver for Ordinary Differential Equations (ODE), Switching Automatically Between Stiff and Non-stiff Methods } \description{ Solving initial value problems for stiff or non-stiff systems of first-order ordinary differential equations (ODEs). The \R function \code{lsoda} provides an interface to the FORTRAN ODE solver of the same name, written by Linda R. Petzold and Alan C. Hindmarsh. The system of ODE's is written as an \R function (which may, of course, use \code{\link{.C}}, \code{\link{.Fortran}}, \code{\link{.Call}}, etc., to call foreign code) or be defined in compiled code that has been dynamically loaded. A vector of parameters is passed to the ODEs, so the solver may be used as part of a modeling package for ODEs, or for parameter estimation using any appropriate modeling tool for non-linear models in \R such as \code{\link{optim}}, \code{\link{nls}}, \code{\link{nlm}} or \code{\link[nlme]{nlme}} \code{lsoda} differs from the other integrators (except \code{lsodar}) in that it switches automatically between stiff and nonstiff methods. This means that the user does not have to determine whether the problem is stiff or not, and the solver will automatically choose the appropriate method. It always starts with the nonstiff method. } \usage{ lsoda(y, times, func, parms, rtol = 1e-6, atol = 1e-6, jacfunc = NULL, jactype = "fullint", rootfunc = NULL, verbose = FALSE, nroot = 0, tcrit = NULL, hmin = 0, hmax = NULL, hini = 0, ynames = TRUE, maxordn = 12, maxords = 5, bandup = NULL, banddown = NULL, maxsteps = 5000, dllname = NULL, initfunc = dllname, initpar = parms, rpar = NULL, ipar = NULL, nout = 0, outnames = NULL, forcings = NULL, initforc = NULL, fcontrol = NULL, events = NULL, lags = NULL,...) } \arguments{ \item{y }{the initial (state) values for the ODE system. If \code{y} has a name attribute, the names will be used to label the output matrix. } \item{times }{times at which explicit estimates for \code{y} are desired. The first value in \code{times} must be the initial time. } \item{func }{either an \R-function that computes the values of the derivatives in the ODE system (the \emph{model definition}) at time t, or a character string giving the name of a compiled function in a dynamically loaded shared library. If \code{func} is an \R-function, it must be defined as: \code{func <- function(t, y, parms,...)}. \code{t} is the current time point in the integration, \code{y} is the current estimate of the variables in the ODE system. If the initial values \code{y} has a \code{names} attribute, the names will be available inside \code{func}. \code{parms} is a vector or list of parameters; ... (optional) are any other arguments passed to the function. The return value of \code{func} should be a list, whose first element is a vector containing the derivatives of \code{y} with respect to \code{time}, and whose next elements are global values that are required at each point in \code{times}. The derivatives must be specified in the \bold{same order} as the state variables \code{y}. If \code{func} is a string, then \code{dllname} must give the name of the shared library (without extension) which must be loaded before \code{lsoda()} is called. See package vignette \code{"compiledCode"} for more details. } \item{parms }{vector or list of parameters used in \code{func} or \code{jacfunc}. } \item{rtol }{relative error tolerance, either a scalar or an array as long as \code{y}. See details. } \item{atol }{absolute error tolerance, either a scalar or an array as long as \code{y}. See details. } \item{jacfunc }{if not \code{NULL}, an \R function, that computes the Jacobian of the system of differential equations \eqn{\partial\dot{y}_i/\partial y_j}{dydot(i)/dy(j)}, or a string giving the name of a function or subroutine in \file{dllname} that computes the Jacobian (see vignette \code{"compiledCode"} for more about this option). In some circumstances, supplying \code{jacfunc} can speed up the computations, if the system is stiff. The \R calling sequence for \code{jacfunc} is identical to that of \code{func}. If the Jacobian is a full matrix, \code{jacfunc} should return a matrix \eqn{\partial\dot{y}/\partial y}{dydot/dy}, where the ith row contains the derivative of \eqn{dy_i/dt} with respect to \eqn{y_j}, or a vector containing the matrix elements by columns (the way \R and FORTRAN store matrices). If the Jacobian is banded, \code{jacfunc} should return a matrix containing only the nonzero bands of the Jacobian, rotated row-wise. See first example of \link{lsode}. } \item{jactype }{the structure of the Jacobian, one of \code{"fullint"}, \code{"fullusr"}, \code{"bandusr"} or \code{"bandint"} - either full or banded and estimated internally or by user. } \item{rootfunc }{if not \code{NULL}, an \R function that computes the function whose root has to be estimated or a string giving the name of a function or subroutine in \file{dllname} that computes the root function. The \R calling sequence for \code{rootfunc} is identical to that of \code{func}. \code{rootfunc} should return a vector with the function values whose root is sought. When \code{rootfunc} is provided, then \code{lsodar} will be called. } \item{verbose }{if \code{TRUE}: full output to the screen, e.g. will print the \code{diagnostiscs} of the integration - see details. } \item{nroot }{only used if \file{dllname} is specified: the number of constraint functions whose roots are desired during the integration; if \code{rootfunc} is an R-function, the solver estimates the number of roots. } \item{tcrit }{if not \code{NULL}, then \code{lsoda} cannot integrate past \code{tcrit}. The FORTRAN routine \code{lsoda} overshoots its targets (times points in the vector \code{times}), and interpolates values for the desired time points. If there is a time beyond which integration should not proceed (perhaps because of a singularity), that should be provided in \code{tcrit}. } \item{hmin }{an optional minimum value of the integration stepsize. In special situations this parameter may speed up computations with the cost of precision. Don't use \code{hmin} if you don't know why! } \item{hmax }{an optional maximum value of the integration stepsize. If not specified, \code{hmax} is set to the largest difference in \code{times}, to avoid that the simulation possibly ignores short-term events. If 0, no maximal size is specified. } \item{hini }{initial step size to be attempted; if 0, the initial step size is determined by the solver. } \item{ynames }{logical, if \code{FALSE}: names of state variables are not passed to function \code{func}; this may speed up the simulation especially for large models. } \item{maxordn }{the maximum order to be allowed in case the method is non-stiff. Should be <= 12. Reduce \code{maxord} to save storage space. } \item{maxords }{the maximum order to be allowed in case the method is stiff. Should be <= 5. Reduce maxord to save storage space. } \item{bandup }{number of non-zero bands above the diagonal, in case the Jacobian is banded. } \item{banddown }{number of non-zero bands below the diagonal, in case the Jacobian is banded. } \item{maxsteps }{maximal number of steps per output interval taken by the solver. } \item{dllname }{a string giving the name of the shared library (without extension) that contains all the compiled function or subroutine definitions refered to in \code{func} and \code{jacfunc}. See package vignette \code{"compiledCode"}. } \item{initfunc }{if not \code{NULL}, the name of the initialisation function (which initialises values of parameters), as provided in \file{dllname}. See package vignette \code{"compiledCode"}. } \item{initpar }{only when \file{dllname} is specified and an initialisation function \code{initfunc} is in the dll: the parameters passed to the initialiser, to initialise the common blocks (FORTRAN) or global variables (C, C++). } \item{rpar }{only when \file{dllname} is specified: a vector with double precision values passed to the dll-functions whose names are specified by \code{func} and \code{jacfunc}. } \item{ipar }{only when \file{dllname} is specified: a vector with integer values passed to the dll-functions whose names are specified by \code{func} and \code{jacfunc}. } \item{nout }{only used if \code{dllname} is specified and the model is defined in compiled code: the number of output variables calculated in the compiled function \code{func}, present in the shared library. Note: it is not automatically checked whether this is indeed the number of output variables calculated in the dll - you have to perform this check in the code. See package vignette \code{"compiledCode"}. } \item{outnames }{only used if \file{dllname} is specified and \code{nout} > 0: the names of output variables calculated in the compiled function \code{func}, present in the shared library. These names will be used to label the output matrix. } \item{forcings }{only used if \file{dllname} is specified: a list with the forcing function data sets, each present as a two-columned matrix, with (time,value); interpolation outside the interval [min(\code{times}), max(\code{times})] is done by taking the value at the closest data extreme. See \link{forcings} or package vignette \code{"compiledCode"}. } \item{initforc }{if not \code{NULL}, the name of the forcing function initialisation function, as provided in \file{dllname}. It MUST be present if \code{forcings} has been given a value. See \link{forcings} or package vignette \code{"compiledCode"}. } \item{fcontrol }{A list of control parameters for the forcing functions. See \link{forcings} or vignette \code{compiledCode}. } \item{events }{A matrix or data frame that specifies events, i.e. when the value of a state variable is suddenly changed. See \link{events} for more information. } \item{lags }{A list that specifies timelags, i.e. the number of steps that has to be kept. To be used for delay differential equations. See \link{timelags}, \link{dede} for more information. } \item{... }{additional arguments passed to \code{func} and \code{jacfunc} allowing this to be a generic function. } } \value{ A matrix of class \code{deSolve} with up to as many rows as elements in \code{times} and as many columns as elements in \code{y} plus the number of "global" values returned in the next elements of the return from \code{func}, plus and additional column for the time value. There will be a row for each element in \code{times} unless the FORTRAN routine `lsoda' returns with an unrecoverable error. If \code{y} has a names attribute, it will be used to label the columns of the output value. } \author{R. Woodrow Setzer } \examples{ ## ======================================================================= ## Example 1: ## A simple resource limited Lotka-Volterra-Model ## ## Note: ## 1. parameter and state variable names made ## accessible via "with" function ## 2. function sigimp accessible through lexical scoping ## (see also ode and rk examples) ## ======================================================================= SPCmod <- function(t, x, parms) { with(as.list(c(parms, x)), { import <- sigimp(t) dS <- import - b*S*P + g*C #substrate dP <- c*S*P - d*C*P #producer dC <- e*P*C - f*C #consumer res <- c(dS, dP, dC) list(res) }) } ## Parameters parms <- c(b = 0.0, c = 0.1, d = 0.1, e = 0.1, f = 0.1, g = 0.0) ## vector of timesteps times <- seq(0, 100, length = 101) ## external signal with rectangle impulse signal <- as.data.frame(list(times = times, import = rep(0,length(times)))) signal$import[signal$times >= 10 & signal$times <= 11] <- 0.2 sigimp <- approxfun(signal$times, signal$import, rule = 2) ## Start values for steady state y <- xstart <- c(S = 1, P = 1, C = 1) ## Solving out <- lsoda(xstart, times, SPCmod, parms) ## Plotting mf <- par("mfrow") plot(out, main = c("substrate", "producer", "consumer")) plot(out[,"P"], out[,"C"], type = "l", xlab = "producer", ylab = "consumer") par(mfrow = mf) ## ======================================================================= ## Example 2: ## from lsoda source code ## ======================================================================= ## names makes this easier to read, but may slow down execution. parms <- c(k1 = 0.04, k2 = 1e4, k3 = 3e7) my.atol <- c(1e-6, 1e-10, 1e-6) times <- c(0,4 * 10^(-1:10)) lsexamp <- function(t, y, p) { yd1 <- -p["k1"] * y[1] + p["k2"] * y[2]*y[3] yd3 <- p["k3"] * y[2]^2 list(c(yd1, -yd1-yd3, yd3), c(massbalance = sum(y))) } exampjac <- function(t, y, p) { matrix(c(-p["k1"], p["k1"], 0, p["k2"]*y[3], - p["k2"]*y[3] - 2*p["k3"]*y[2], 2*p["k3"]*y[2], p["k2"]*y[2], -p["k2"]*y[2], 0 ), 3, 3) } ## measure speed (here and below) system.time( out <- lsoda(c(1, 0, 0), times, lsexamp, parms, rtol = 1e-4, atol = my.atol, hmax = Inf) ) out ## This is what the authors of lsoda got for the example: ## the output of this program (on a cdc-7600 in single precision) ## is as follows.. ## ## at t = 4.0000e-01 y = 9.851712e-01 3.386380e-05 1.479493e-02 ## at t = 4.0000e+00 y = 9.055333e-01 2.240655e-05 9.444430e-02 ## at t = 4.0000e+01 y = 7.158403e-01 9.186334e-06 2.841505e-01 ## at t = 4.0000e+02 y = 4.505250e-01 3.222964e-06 5.494717e-01 ## at t = 4.0000e+03 y = 1.831975e-01 8.941774e-07 8.168016e-01 ## at t = 4.0000e+04 y = 3.898730e-02 1.621940e-07 9.610125e-01 ## at t = 4.0000e+05 y = 4.936363e-03 1.984221e-08 9.950636e-01 ## at t = 4.0000e+06 y = 5.161831e-04 2.065786e-09 9.994838e-01 ## at t = 4.0000e+07 y = 5.179817e-05 2.072032e-10 9.999482e-01 ## at t = 4.0000e+08 y = 5.283401e-06 2.113371e-11 9.999947e-01 ## at t = 4.0000e+09 y = 4.659031e-07 1.863613e-12 9.999995e-01 ## at t = 4.0000e+10 y = 1.404280e-08 5.617126e-14 1.000000e+00 ## Using the analytic Jacobian speeds up execution a little : system.time( outJ <- lsoda(c(1, 0, 0), times, lsexamp, parms, rtol = 1e-4, atol = my.atol, jacfunc = exampjac, jactype = "fullusr", hmax = Inf) ) all.equal(as.data.frame(out), as.data.frame(outJ)) # TRUE diagnostics(out) diagnostics(outJ) # shows what lsoda did internally } \references{ Hindmarsh, Alan C. (1983) ODEPACK, A Systematized Collection of ODE Solvers; in p.55--64 of Stepleman, R.W. et al.[ed.] (1983) \emph{Scientific Computing}, North-Holland, Amsterdam. Petzold, Linda R. (1983) Automatic Selection of Methods for Solving Stiff and Nonstiff Systems of Ordinary Differential Equations. \emph{Siam J. Sci. Stat. Comput.} \bold{4}, 136--148. Netlib: \url{http://www.netlib.org} } \details{ All the hard work is done by the FORTRAN subroutine \code{lsoda}, whose documentation should be consulted for details (it is included as comments in the source file \file{src/opkdmain.f}). The implementation is based on the 12 November 2003 version of lsoda, from Netlib. \code{lsoda} switches automatically between stiff and nonstiff methods. This means that the user does not have to determine whether the problem is stiff or not, and the solver will automatically choose the appropriate method. It always starts with the nonstiff method. The form of the \bold{Jacobian} can be specified by \code{jactype} which can take the following values: \describe{ \item{"fullint"}{a full Jacobian, calculated internally by lsoda, the default,} \item{"fullusr"}{a full Jacobian, specified by user function \code{jacfunc},} \item{"bandusr"}{a banded Jacobian, specified by user function \code{jacfunc} the size of the bands specified by \code{bandup} and \code{banddown},} \item{"bandint"}{banded Jacobian, calculated by lsoda; the size of the bands specified by \code{bandup} and \code{banddown}.} } If \code{jactype} = "fullusr" or "bandusr" then the user must supply a subroutine \code{jacfunc}. The following description of \bold{error control} is adapted from the documentation of the lsoda source code (input arguments \code{rtol} and \code{atol}, above): The input parameters \code{rtol}, and \code{atol} determine the error control performed by the solver. The solver will control the vector \bold{e} of estimated local errors in \bold{y}, according to an inequality of the form max-norm of ( \bold{e}/\bold{ewt} ) \eqn{\leq}{ <= } 1, where \bold{ewt} is a vector of positive error weights. The values of \code{rtol} and \code{atol} should all be non-negative. The form of \bold{ewt} is: \deqn{\mathbf{rtol} \times \mathrm{abs}(\mathbf{y}) + \mathbf{atol}}{\bold{rtol} * abs(\bold{y}) + \bold{atol}} where multiplication of two vectors is element-by-element. If the request for precision exceeds the capabilities of the machine, the FORTRAN subroutine lsoda will return an error code; under some circumstances, the \R function \code{lsoda} will attempt a reasonable reduction of precision in order to get an answer. It will write a warning if it does so. The diagnostics of the integration can be printed to screen by calling \code{\link{diagnostics}}. If \code{verbose} = \code{TRUE}, the diagnostics will written to the screen at the end of the integration. See vignette("deSolve") for an explanation of each element in the vectors containing the diagnostic properties and how to directly access them. \bold{Models} may be defined in compiled C or FORTRAN code, as well as in an R-function. See package vignette \code{"compiledCode"} for details. More information about models defined in compiled code is in the package vignette ("compiledCode"); information about linking forcing functions to compiled code is in \link{forcings}. Examples in both C and FORTRAN are in the \file{dynload} subdirectory of the \code{deSolve} package directory. } \seealso{ \itemize{ \item \code{\link{rk}}, \code{\link{rkMethod}}, \code{\link{rk4}} and \code{\link{euler}} for Runge-Kutta integrators. \item \code{\link{lsode}}, which can also find a root \item \code{\link{lsodes}}, \code{\link{lsodar}}, \code{\link{vode}}, \code{\link{daspk}} for other solvers of the Livermore family, \item \code{\link{ode}} for a general interface to most of the ODE solvers, \item \code{\link{ode.band}} for solving models with a banded Jacobian, \item \code{\link{ode.1D}} for integrating 1-D models, \item \code{\link{ode.2D}} for integrating 2-D models, \item \code{\link{ode.3D}} for integrating 3-D models, } \code{\link{diagnostics}} to print diagnostic messages. } \note{ The \file{demo} directory contains some examples of using \code{\link[nlme]{gnls}} to estimate parameters in a dynamic model. } \keyword{math} deSolve/man/diagnostics.Rd0000754000175100001440000000207112352122172015241 0ustar hornikusers\name{diagnostics} \alias{diagnostics} \alias{diagnostics.default} \title{Print Diagnostic Characteristics of Solvers} \description{ Prints several diagnostics of the simulation to the screen, e.g. number of steps taken, the last step size, ... } \usage{ diagnostics(obj, ...) \method{diagnostics}{default}(obj, ...) } \arguments{ \item{obj}{is an output data structure produced by one of the solver routines. } \item{...}{optional arguments allowing to extend \code{diagnostics} as a generic function. } } \details{ Detailed information obout the success of a simulation is printed, if a \code{diagnostics} function exists for a specific solver routine. A warning is printed, if no class-specific diagnostics exists. Please consult the class-specific help page for details. } \seealso{ \code{\link{diagnostics.deSolve}} for diagnostics of differential equaton solvers. %% enable this when bvpSolve is on CRAN % \code{\link[bvpSolve:diagnostics]{diagnostics.bvpSolve}} for % diagnostics of boundary value problem solvers. } \keyword{ utilities }deSolve/man/ode.1D.Rd0000754000175100001440000003144612477565340013774 0ustar hornikusers\name{ode.1D} \alias{ode.1D} \title{Solver For Multicomponent 1-D Ordinary Differential Equations} \description{ Solves a system of ordinary differential equations resulting from 1-Dimensional partial differential equations that have been converted to ODEs by numerical differencing. } \usage{ode.1D(y, times, func, parms, nspec = NULL, dimens = NULL, method= c("lsoda", "lsode", "lsodes", "lsodar", "vode", "daspk", "euler", "rk4", "ode23", "ode45", "radau", "bdf", "adams", "impAdams", "iteration"), names = NULL, bandwidth = 1, restructure = FALSE, ...) } \arguments{ \item{y }{the initial (state) values for the ODE system, a vector. If \code{y} has a name attribute, the names will be used to label the output matrix. } \item{times }{time sequence for which output is wanted; the first value of \code{times} must be the initial time. } \item{func }{either an \R-function that computes the values of the derivatives in the ODE system (the model definition) at time \code{t}, or a character string giving the name of a compiled function in a dynamically loaded shared library. If \code{func} is an \R-function, it must be defined as: \code{func <- function(t, y, parms, ...)}. \code{t} is the current time point in the integration, \code{y} is the current estimate of the variables in the ODE system. If the initial values \code{y} has a \code{names} attribute, the names will be available inside \code{func}. \code{parms} is a vector or list of parameters; \code{...} (optional) are any other arguments passed to the function. The return value of \code{func} should be a list, whose first element is a vector containing the derivatives of \code{y} with respect to \code{time}, and whose next elements are global values that are required at each point in \code{times}. The derivatives must be specified in the \bold{same order} as the state variables \code{y}. If \code{func} is a character string then integrator \code{lsodes} will be used. See details. } \item{parms }{parameters passed to \code{func}.} \item{nspec }{the number of \bold{species} (components) in the model. If \code{NULL}, then \code{dimens} should be specified. } \item{dimens}{the number of \bold{boxes} in the model. If \code{NULL}, then \code{nspec} should be specified. } \item{method }{the integrator. Use \code{"vode", "lsode", "lsoda", "lsodar", "daspk"}, or \code{"lsodes"} if the model is very stiff; \code{"impAdams"} or \code{"radau"} may be best suited for mildly stiff problems; \code{"euler", "rk4", "ode23", "ode45", "adams"} are most efficient for non-stiff problems. Also allowed is to pass an integrator \code{function}. Use one of the other Runge-Kutta methods via \code{rkMethod}. For instance, \code{method = rkMethod("ode45ck")} will trigger the Cash-Karp method of order 4(5). Method \code{"iteration"} is special in that here the function \code{func} should return the new value of the state variables rather than the rate of change. This can be used for individual based models, for difference equations, or in those cases where the integration is performed within \code{func}) } \item{names }{the names of the components; used for plotting. } \item{bandwidth }{the number of adjacent boxes over which transport occurs. Normally equal to 1 (box i only interacts with box i-1, and i+1). Values larger than 1 will not work with \code{method = "lsodes"}. Ignored if the method is explicit. } \item{restructure }{whether or not the Jacobian should be restructured. Only used if the \code{method} is an integrator function. Should be \code{TRUE} if the method is implicit, \code{FALSE} if explicit. } \item{... }{additional arguments passed to the integrator.} } \value{ A matrix of class \code{deSolve} with up to as many rows as elements in times and as many columns as elements in \code{y} plus the number of "global" values returned in the second element of the return from \code{func}, plus an additional column (the first) for the time value. There will be one row for each element in \code{times} unless the integrator returns with an unrecoverable error. If \code{y} has a names attribute, it will be used to label the columns of the output value. The output will have the attributes \code{istate}, and \code{rstate}, two vectors with several useful elements. The first element of istate returns the conditions under which the last call to the integrator returned. Normal is \code{istate = 2}. If \code{verbose = TRUE}, the settings of istate and rstate will be written to the screen. See the help for the selected integrator for details. } \note{ It is advisable though not mandatory to specify \bold{both} \code{nspec} and \code{dimens}. In this case, the solver can check whether the input makes sense (i.e. if \code{nspec * dimens == length(y)}). } \author{Karline Soetaert } \examples{ ## ======================================================================= ## example 1 ## a predator and its prey diffusing on a flat surface ## in concentric circles ## 1-D model with using cylindrical coordinates ## Lotka-Volterra type biology ## ======================================================================= ## ================ ## Model equations ## ================ lvmod <- function (time, state, parms, N, rr, ri, dr, dri) { with (as.list(parms), { PREY <- state[1:N] PRED <- state[(N+1):(2*N)] ## Fluxes due to diffusion ## at internal and external boundaries: zero gradient FluxPrey <- -Da * diff(c(PREY[1], PREY, PREY[N]))/dri FluxPred <- -Da * diff(c(PRED[1], PRED, PRED[N]))/dri ## Biology: Lotka-Volterra model Ingestion <- rIng * PREY * PRED GrowthPrey <- rGrow * PREY * (1-PREY/cap) MortPredator <- rMort * PRED ## Rate of change = Flux gradient + Biology dPREY <- -diff(ri * FluxPrey)/rr/dr + GrowthPrey - Ingestion dPRED <- -diff(ri * FluxPred)/rr/dr + Ingestion * assEff - MortPredator return (list(c(dPREY, dPRED))) }) } ## ================== ## Model application ## ================== ## model parameters: R <- 20 # total radius of surface, m N <- 100 # 100 concentric circles dr <- R/N # thickness of each layer r <- seq(dr/2,by = dr,len = N) # distance of center to mid-layer ri <- seq(0,by = dr,len = N+1) # distance to layer interface dri <- dr # dispersion distances parms <- c(Da = 0.05, # m2/d, dispersion coefficient rIng = 0.2, # /day, rate of ingestion rGrow = 1.0, # /day, growth rate of prey rMort = 0.2 , # /day, mortality rate of pred assEff = 0.5, # -, assimilation efficiency cap = 10) # density, carrying capacity ## Initial conditions: both present in central circle (box 1) only state <- rep(0, 2 * N) state[1] <- state[N + 1] <- 10 ## RUNNING the model: times <- seq(0, 200, by = 1) # output wanted at these time intervals ## the model is solved by the two implemented methods: ## 1. Default: banded reformulation print(system.time( out <- ode.1D(y = state, times = times, func = lvmod, parms = parms, nspec = 2, names = c("PREY", "PRED"), N = N, rr = r, ri = ri, dr = dr, dri = dri) )) ## 2. Using sparse method print(system.time( out2 <- ode.1D(y = state, times = times, func = lvmod, parms = parms, nspec = 2, names = c("PREY","PRED"), N = N, rr = r, ri = ri, dr = dr, dri = dri, method = "lsodes") )) ## ================ ## Plotting output ## ================ # the data in 'out' consist of: 1st col times, 2-N+1: the prey # N+2:2*N+1: predators PREY <- out[, 2:(N + 1)] filled.contour(x = times, y = r, PREY, color = topo.colors, xlab = "time, days", ylab = "Distance, m", main = "Prey density") # similar: image(out, which = "PREY", grid = r, xlab = "time, days", legend = TRUE, ylab = "Distance, m", main = "Prey density") image(out2, grid = r) # summaries of 1-D variables summary(out) # 1-D plots: matplot.1D(out, type = "l", subset = time == 10) matplot.1D(out, type = "l", subset = time > 10 & time < 20) ## ======================================================================= ## Example 2. ## Biochemical Oxygen Demand (BOD) and oxygen (O2) dynamics ## in a river ## ======================================================================= ## ================ ## Model equations ## ================ O2BOD <- function(t, state, pars) { BOD <- state[1:N] O2 <- state[(N+1):(2*N)] ## BOD dynamics FluxBOD <- v * c(BOD_0, BOD) # fluxes due to water transport FluxO2 <- v * c(O2_0, O2) BODrate <- r * BOD # 1-st order consumption ## rate of change = flux gradient - consumption + reaeration (O2) dBOD <- -diff(FluxBOD)/dx - BODrate dO2 <- -diff(FluxO2)/dx - BODrate + p * (O2sat-O2) return(list(c(dBOD = dBOD, dO2 = dO2))) } ## ================== ## Model application ## ================== ## parameters dx <- 25 # grid size of 25 meters v <- 1e3 # velocity, m/day x <- seq(dx/2, 5000, by = dx) # m, distance from river N <- length(x) r <- 0.05 # /day, first-order decay of BOD p <- 0.5 # /day, air-sea exchange rate O2sat <- 300 # mmol/m3 saturated oxygen conc O2_0 <- 200 # mmol/m3 riverine oxygen conc BOD_0 <- 1000 # mmol/m3 riverine BOD concentration ## initial conditions: state <- c(rep(200, N), rep(200, N)) times <- seq(0, 20, by = 0.1) ## running the model ## step 1 : model spinup out <- ode.1D(y = state, times, O2BOD, parms = NULL, nspec = 2, names = c("BOD", "O2")) ## ================ ## Plotting output ## ================ ## select oxygen (first column of out:time, then BOD, then O2 O2 <- out[, (N + 2):(2 * N + 1)] color = topo.colors filled.contour(x = times, y = x, O2, color = color, nlevels = 50, xlab = "time, days", ylab = "Distance from river, m", main = "Oxygen") ## or quicker plotting: image(out, grid = x, xlab = "time, days", ylab = "Distance from river, m") } \details{ This is the method of choice for multi-species 1-dimensional models, that are only subjected to transport between adjacent layers. More specifically, this method is to be used if the state variables are arranged per species: A[1], A[2], A[3],.... B[1], B[2], B[3],.... (for species A, B)) Two methods are implemented. \itemize{ \item The default method rearranges the state variables as A[1], B[1], ... A[2], B[2], ... A[3], B[3], .... This reformulation leads to a banded Jacobian with (upper and lower) half bandwidth = number of species. Then the selected integrator solves the banded problem. \item The second method uses \code{lsodes}. Based on the dimension of the problem, the method first calculates the sparsity pattern of the Jacobian, under the assumption that transport is only occurring between adjacent layers. Then \code{lsodes} is called to solve the problem. As \code{lsodes} is used to integrate, it may be necessary to specify the length of the real work array, \code{lrw}. Although a reasonable guess of \code{lrw} is made, it is possible that this will be too low. In this case, \code{ode.1D} will return with an error message telling the size of the work array actually needed. In the second try then, set \code{lrw} equal to this number. For instance, if you get the error: \preformatted{ DLSODES- RWORK length is insufficient to proceed. Length needed is .ge. LENRW (=I1), exceeds LRW (=I2) In above message, I1 = 27627 I2 = 25932 } set \code{lrw} equal to 27627 or a higher value } If the model is specified in compiled code (in a DLL), then option 2, based on \code{lsodes} is the only solution method. For single-species 1-D models, you may also use \code{\link{ode.band}}. See the selected integrator for the additional options. } \seealso{ \itemize{ \item \code{\link{ode}} for a general interface to most of the ODE solvers, \item \code{\link{ode.band}} for integrating models with a banded Jacobian \item \code{\link{ode.2D}} for integrating 2-D models \item \code{\link{ode.3D}} for integrating 3-D models \item \code{\link{lsodes}},\code{\link{lsode}}, \code{\link{lsoda}}, \code{\link{lsodar}},\code{\link{vode}} for the integration options. } \code{\link{diagnostics}} to print diagnostic messages. } \keyword{math} deSolve/man/radau.Rd0000754000175100001440000004557313071630263014050 0ustar hornikusers\name{radau} \alias{radau} \title{Implicit Runge-Kutta RADAU IIA} \description{ Solves the initial value problem for stiff or nonstiff systems of ordinary differential equations (ODE) in the form: \deqn{dy/dt = f(t,y)} or linearly implicit differential algebraic equations in the form: \deqn{M dy/dt = f(t,y)}. The \R function \code{radau} provides an interface to the Fortran solver RADAU5, written by Ernst Hairer and G. Wanner, which implements the 3-stage RADAU IIA method. It implements the implicit Runge-Kutta method of order 5 with step size control and continuous output. The system of ODEs or DAEs is written as an \R function or can be defined in compiled code that has been dynamically loaded. } \usage{ radau(y, times, func, parms, nind = c(length(y), 0, 0), rtol = 1e-6, atol = 1e-6, jacfunc = NULL, jactype = "fullint", mass = NULL, massup = NULL, massdown = NULL, rootfunc = NULL, verbose = FALSE, nroot = 0, hmax = NULL, hini = 0, ynames = TRUE, bandup = NULL, banddown = NULL, maxsteps = 5000, dllname = NULL, initfunc = dllname, initpar = parms, rpar = NULL, ipar = NULL, nout = 0, outnames = NULL, forcings = NULL, initforc = NULL, fcontrol = NULL, events=NULL, lags = NULL, ...) } \arguments{ \item{y }{the initial (state) values for the ODE system. If \code{y} has a name attribute, the names will be used to label the output matrix. } \item{times }{time sequence for which output is wanted; the first value of \code{times} must be the initial time; if only one step is to be taken; set \code{times} = \code{NULL}. } \item{func }{either an \R-function that computes the values of the derivatives in the ODE system (the \emph{model definition}) at time t, or the right-hand side of the equation \deqn{M dy/dt = f(t,y)} if a DAE. (if \code{mass} is supplied then the problem is assumed a DAE). \code{func} can also be a character string giving the name of a compiled function in a dynamically loaded shared library. If \code{func} is an \R-function, it must be defined as: \code{func <- function(t, y, parms,...)}. \code{t} is the current time point in the integration, \code{y} is the current estimate of the variables in the ODE system. If the initial values \code{y} has a \code{names} attribute, the names will be available inside \code{func}. \code{parms} is a vector or list of parameters; ... (optional) are any other arguments passed to the function. The return value of \code{func} should be a list, whose first element is a vector containing the derivatives of \code{y} with respect to \code{time}, and whose next elements are global values that are required at each point in \code{times}. The derivatives must be specified in the \bold{same order} as the state variables \code{y}. If \code{func} is a string, then \code{dllname} must give the name of the shared library (without extension) which must be loaded before \code{radau()} is called. See deSolve package vignette \code{"compiledCode"} for more details. } \item{parms }{vector or list of parameters used in \code{func} or \code{jacfunc}. } \item{nind }{if a DAE system: a three-valued vector with the number of variables of index 1, 2, 3 respectively. The equations must be defined such that the index 1 variables precede the index 2 variables which in turn precede the index 3 variables. The sum of the variables of different index should equal N, the total number of variables. This has implications on the scaling of the variables, i.e. index 2 variables are scaled by 1/h, index 3 variables are scaled by 1/h^2. } \item{rtol }{relative error tolerance, either a scalar or an array as long as \code{y}. See details. } \item{atol }{absolute error tolerance, either a scalar or an array as long as \code{y}. See details. } \item{jacfunc }{if not \code{NULL}, an \R function that computes the Jacobian of the system of differential equations \eqn{\partial\dot{y}_i/\partial y_j}{dydot(i)/dy(j)}, or a string giving the name of a function or subroutine in \file{dllname} that computes the Jacobian (see vignette \code{"compiledCode"} from package deSolve, for more about this option). In some circumstances, supplying \code{jacfunc} can speed up the computations, if the system is stiff. The \R calling sequence for \code{jacfunc} is identical to that of \code{func}. If the Jacobian is a full matrix, \code{jacfunc} should return a matrix \eqn{\partial\dot{y}/\partial y}{dydot/dy}, where the ith row contains the derivative of \eqn{dy_i/dt} with respect to \eqn{y_j}, or a vector containing the matrix elements by columns (the way \R and FORTRAN store matrices). \cr If the Jacobian is banded, \code{jacfunc} should return a matrix containing only the nonzero bands of the Jacobian, rotated row-wise. See example. } \item{jactype }{the structure of the Jacobian, one of \code{"fullint"}, \code{"fullusr"}, \code{"bandusr"} or \code{"bandint"} - either full or banded and estimated internally or by user. } \item{mass }{the mass matrix. If not \code{NULL}, the problem is a linearly implicit DAE and defined as \eqn{M\, dy/dt = f(t,y)}{M dy/dt = f(t,y)}. If the mass-matrix \eqn{M} is full, it should be of dimension \eqn{n^2}{n*n} where \eqn{n} is the number of \eqn{y}-values; if banded the number of rows should be less than \eqn{n}, and the mass-matrix is stored diagonal-wise with element \eqn{(i, j)} stored in \code{mass(i - j + mumas + 1, j)}. If \code{mass = NULL} then the model is an ODE (default) } \item{massup }{number of non-zero bands above the diagonal of the \code{mass} matrix, in case it is banded. } \item{massdown }{number of non-zero bands below the diagonal of the \code{mass} matrix, in case it is banded. } \item{rootfunc }{if not \code{NULL}, an \R function that computes the function whose root has to be estimated or a string giving the name of a function or subroutine in \file{dllname} that computes the root function. The \R calling sequence for \code{rootfunc} is identical to that of \code{func}. \code{rootfunc} should return a vector with the function values whose root is sought. } \item{verbose }{if \code{TRUE}: full output to the screen, e.g. will print the \code{diagnostiscs} of the integration - see details. } \item{nroot }{only used if \file{dllname} is specified: the number of constraint functions whose roots are desired during the integration; if \code{rootfunc} is an R-function, the solver estimates the number of roots. } \item{hmax }{an optional maximum value of the integration stepsize. If not specified, \code{hmax} is set to the largest difference in \code{times}, to avoid that the simulation possibly ignores short-term events. If 0, no maximal size is specified. } \item{hini }{initial step size to be attempted; if 0, the initial step size is set equal to 1e-6. Usually 1e-3 to 1e-5 is good for stiff equations } \item{ynames }{logical, if \code{FALSE} names of state variables are not passed to function \code{func}; this may speed up the simulation especially for multi-D models. } \item{bandup }{number of non-zero bands above the diagonal, in case the Jacobian is banded. } \item{banddown }{number of non-zero bands below the diagonal, in case the Jacobian is banded. } \item{maxsteps }{average maximal number of steps per output interval taken by the solver. This argument is defined such as to ensure compatibility with the Livermore-solvers. RADAU only accepts the maximal number of steps for the entire integration, and this is calculated as \code{length(times) * maxsteps}. } \item{dllname }{a string giving the name of the shared library (without extension) that contains all the compiled function or subroutine definitions refered to in \code{func} and \code{jacfunc}. See vignette \code{"compiledCode"} from package \code{deSolve}. } \item{initfunc }{if not \code{NULL}, the name of the initialisation function (which initialises values of parameters), as provided in \file{dllname}. See vignette \code{"compiledCode"} from package \code{deSolve}. } \item{initpar }{only when \file{dllname} is specified and an initialisation function \code{initfunc} is in the dll: the parameters passed to the initialiser, to initialise the common blocks (FORTRAN) or global variables (C, C++). } \item{rpar }{only when \file{dllname} is specified: a vector with double precision values passed to the dll-functions whose names are specified by \code{func} and \code{jacfunc}. } \item{ipar }{only when \file{dllname} is specified: a vector with integer values passed to the dll-functions whose names are specified by \code{func} and \code{jacfunc}. } \item{nout }{only used if \code{dllname} is specified and the model is defined in compiled code: the number of output variables calculated in the compiled function \code{func}, present in the shared library. Note: it is not automatically checked whether this is indeed the number of output variables calculed in the DLL - you have to perform this check in the code - See vignette \code{"compiledCode"} from package \code{deSolve}. } \item{outnames }{only used if \file{dllname} is specified and \code{nout} > 0: the names of output variables calculated in the compiled function \code{func}, present in the shared library. These names will be used to label the output matrix. } \item{forcings }{only used if \file{dllname} is specified: a list with the forcing function data sets, each present as a two-columned matrix, with (time, value); interpolation outside the interval [min(\code{times}), max(\code{times})] is done by taking the value at the closest data extreme. See \link{forcings} or package vignette \code{"compiledCode"}. } \item{initforc }{if not \code{NULL}, the name of the forcing function initialisation function, as provided in \file{dllname}. It MUST be present if \code{forcings} has been given a value. See \link{forcings} or package vignette \code{"compiledCode"}. } \item{fcontrol }{A list of control parameters for the forcing functions. See \link{forcings} or vignette \code{compiledCode}. } \item{events }{A matrix or data frame that specifies events, i.e. when the value of a state variable is suddenly changed. See \link{events} for more information. } \item{lags }{A list that specifies timelags, i.e. the number of steps that has to be kept. To be used for delay differential equations. See \link{timelags}, \link{dede} for more information. } \item{... }{additional arguments passed to \code{func} and \code{jacfunc} allowing this to be a generic function. } } \value{ A matrix of class \code{deSolve} with up to as many rows as elements in \code{times} and as many columns as elements in \code{y} plus the number of "global" values returned in the next elements of the return from \code{func}, plus and additional column for the time value. There will be a row for each element in \code{times} unless the FORTRAN routine returns with an unrecoverable error. If \code{y} has a names attribute, it will be used to label the columns of the output value. } \author{Karline Soetaert } \examples{ ## ======================================================================= ## Example 1: ODE ## Various ways to solve the same model. ## ======================================================================= ## the model, 5 state variables f1 <- function (t, y, parms) { ydot <- vector(len = 5) ydot[1] <- 0.1*y[1] -0.2*y[2] ydot[2] <- -0.3*y[1] +0.1*y[2] -0.2*y[3] ydot[3] <- -0.3*y[2] +0.1*y[3] -0.2*y[4] ydot[4] <- -0.3*y[3] +0.1*y[4] -0.2*y[5] ydot[5] <- -0.3*y[4] +0.1*y[5] return(list(ydot)) } ## the Jacobian, written as a full matrix fulljac <- function (t, y, parms) { jac <- matrix(nrow = 5, ncol = 5, byrow = TRUE, data = c(0.1, -0.2, 0 , 0 , 0 , -0.3, 0.1, -0.2, 0 , 0 , 0 , -0.3, 0.1, -0.2, 0 , 0 , 0 , -0.3, 0.1, -0.2, 0 , 0 , 0 , -0.3, 0.1)) return(jac) } ## the Jacobian, written in banded form bandjac <- function (t, y, parms) { jac <- matrix(nrow = 3, ncol = 5, byrow = TRUE, data = c( 0 , -0.2, -0.2, -0.2, -0.2, 0.1, 0.1, 0.1, 0.1, 0.1, -0.3, -0.3, -0.3, -0.3, 0)) return(jac) } ## initial conditions and output times yini <- 1:5 times <- 1:20 ## default: stiff method, internally generated, full Jacobian out <- radau(yini, times, f1, parms = 0) plot(out) ## stiff method, user-generated full Jacobian out2 <- radau(yini, times, f1, parms = 0, jactype = "fullusr", jacfunc = fulljac) ## stiff method, internally-generated banded Jacobian ## one nonzero band above (up) and below(down) the diagonal out3 <- radau(yini, times, f1, parms = 0, jactype = "bandint", bandup = 1, banddown = 1) ## stiff method, user-generated banded Jacobian out4 <- radau(yini, times, f1, parms = 0, jactype = "bandusr", jacfunc = bandjac, bandup = 1, banddown = 1) ## ======================================================================= ## Example 2: ODE ## stiff problem from chemical kinetics ## ======================================================================= Chemistry <- function (t, y, p) { dy1 <- -.04*y[1] + 1.e4*y[2]*y[3] dy2 <- .04*y[1] - 1.e4*y[2]*y[3] - 3.e7*y[2]^2 dy3 <- 3.e7*y[2]^2 list(c(dy1, dy2, dy3)) } times <- 10^(seq(0, 10, by = 0.1)) yini <- c(y1 = 1.0, y2 = 0, y3 = 0) out <- radau(func = Chemistry, times = times, y = yini, parms = NULL) plot(out, log = "x", type = "l", lwd = 2) ## ============================================================================= ## Example 3: DAE ## Car axis problem, index 3 DAE, 8 differential, 2 algebraic equations ## from ## F. Mazzia and C. Magherini. Test Set for Initial Value Problem Solvers, ## release 2.4. Department ## of Mathematics, University of Bari and INdAM, Research Unit of Bari, ## February 2008. ## Available at http://www.dm.uniba.it/~testset. ## ============================================================================= ## Problem is written as M*y' = f(t,y,p). ## caraxisfun implements the right-hand side: caraxisfun <- function(t, y, parms) { with(as.list(y), { yb <- r * sin(w * t) xb <- sqrt(L * L - yb * yb) Ll <- sqrt(xl^2 + yl^2) Lr <- sqrt((xr - xb)^2 + (yr - yb)^2) dxl <- ul; dyl <- vl; dxr <- ur; dyr <- vr dul <- (L0-Ll) * xl/Ll + 2 * lam2 * (xl-xr) + lam1*xb dvl <- (L0-Ll) * yl/Ll + 2 * lam2 * (yl-yr) + lam1*yb - k * g dur <- (L0-Lr) * (xr-xb)/Lr - 2 * lam2 * (xl-xr) dvr <- (L0-Lr) * (yr-yb)/Lr - 2 * lam2 * (yl-yr) - k * g c1 <- xb * xl + yb * yl c2 <- (xl - xr)^2 + (yl - yr)^2 - L * L list(c(dxl, dyl, dxr, dyr, dul, dvl, dur, dvr, c1, c2)) }) } eps <- 0.01; M <- 10; k <- M * eps^2/2; L <- 1; L0 <- 0.5; r <- 0.1; w <- 10; g <- 1 yini <- c(xl = 0, yl = L0, xr = L, yr = L0, ul = -L0/L, vl = 0, ur = -L0/L, vr = 0, lam1 = 0, lam2 = 0) # the mass matrix Mass <- diag(nrow = 10, 1) Mass[5,5] <- Mass[6,6] <- Mass[7,7] <- Mass[8,8] <- M * eps * eps/2 Mass[9,9] <- Mass[10,10] <- 0 Mass # index of the variables: 4 of index 1, 4 of index 2, 2 of index 3 index <- c(4, 4, 2) times <- seq(0, 3, by = 0.01) out <- radau(y = yini, mass = Mass, times = times, func = caraxisfun, parms = NULL, nind = index) plot(out, which = 1:4, type = "l", lwd = 2) } \references{ E. Hairer and G. Wanner, 1996. Solving Ordinary Differential Equations II. Stiff and Differential-algebraic problems. Springer series in computational mathematics 14, Springer-Verlag, second edition. } \details{ The work is done by the FORTRAN subroutine \code{RADAU5}, whose documentation should be consulted for details. The implementation is based on the Fortran 77 version from January 18, 2002. There are four standard choices for the Jacobian which can be specified with \code{jactype}. The options for \bold{jactype} are \describe{ \item{jactype = "fullint"}{a full Jacobian, calculated internally by the solver. } \item{jactype = "fullusr"}{a full Jacobian, specified by user function \code{jacfunc}. } \item{jactype = "bandusr"}{a banded Jacobian, specified by user function \code{jacfunc}; the size of the bands specified by \code{bandup} and \code{banddown}. } \item{jactype = "bandint"}{a banded Jacobian, calculated by radau; the size of the bands specified by \code{bandup} and \code{banddown}. } } Inspection of the example below shows how to specify both a banded and full Jacobian. The input parameters \code{rtol}, and \code{atol} determine the \bold{error control} performed by the solver, which roughly keeps the local error of \eqn{y(i)} below \eqn{rtol(i)*abs(y(i))+atol(i)}. The diagnostics of the integration can be printed to screen by calling \code{\link{diagnostics}}. If \code{verbose} = \code{TRUE}, the diagnostics will be written to the screen at the end of the integration. See vignette("deSolve") from the \code{deSolve} package for an explanation of each element in the vectors containing the diagnostic properties and how to directly access them. \bold{Models} may be defined in compiled C or FORTRAN code, as well as in an R-function. See package vignette \code{"compiledCode"} from package \code{deSolve} for details. Information about linking forcing functions to compiled code is in \link{forcings} (from package \code{deSolve}). \code{radau} can find the root of at least one of a set of constraint functions \code{rootfunc} of the independent and dependent variables. It then returns the solution at the root if that occurs sooner than the specified stop condition, and otherwise returns the solution according the specified stop condition. Caution: Because of numerical errors in the function \code{rootfun} due to roundoff and integration error, \code{radau} may return false roots, or return the same root at two or more nearly equal values of \code{time}. } \seealso{ \itemize{ \item \code{\link{ode}} for a general interface to most of the ODE solvers , \item \code{\link{ode.1D}} for integrating 1-D models, \item \code{\link{ode.2D}} for integrating 2-D models, \item \code{\link{ode.3D}} for integrating 3-D models, \item \code{\link{daspk}} for integrating DAE models up to index 1 } \code{\link{diagnostics}} to print diagnostic messages. } \keyword{math} deSolve/man/ode.3D.Rd0000754000175100001440000002043712477565416014000 0ustar hornikusers\name{ode.3D} \alias{ode.3D} \title{Solver for 3-Dimensional Ordinary Differential Equations} \description{ Solves a system of ordinary differential equations resulting from 3-Dimensional partial differential equations that have been converted to ODEs by numerical differencing. } \usage{ode.3D(y, times, func, parms, nspec = NULL, dimens, method = c("lsodes", "euler", "rk4", "ode23", "ode45", "adams", "iteration"), names = NULL, cyclicBnd = NULL, ...)} \arguments{ \item{y }{the initial (state) values for the ODE system, a vector. If \code{y} has a name attribute, the names will be used to label the output matrix. } \item{times }{time sequence for which output is wanted; the first value of \code{times} must be the initial time. } \item{func }{either an \R-function that computes the values of the derivatives in the ODE system (the model definition) at time \code{t}, or a character string giving the name of a compiled function in a dynamically loaded shared library. If \code{func} is an \R-function, it must be defined as: \code{func <- function(t, y, parms, ...)}. \code{t} is the current time point in the integration, \code{y} is the current estimate of the variables in the ODE system. If the initial values \code{y} has a \code{names} attribute, the names will be available inside \code{func}. \code{parms} is a vector or list of parameters; \code{...} (optional) are any other arguments passed to the function. The return value of \code{func} should be a list, whose first element is a vector containing the derivatives of \code{y} with respect to \code{time}, and whose next elements are global values that are required at each point in \code{times}. The derivatives must be specified in the \bold{same order} as the state variables \code{y}. } \item{parms }{parameters passed to \code{func}.} \item{nspec }{the number of \bold{species} (components) in the model.} \item{dimens}{3-valued vector with the number of \bold{boxes} in three dimensions in the model. } \item{names }{the names of the components; used for plotting. } \item{cyclicBnd }{if not \code{NULL} then a number or a 3-valued vector with the dimensions where a cyclic boundary is used - \code{1}: x-dimension, \code{2}: y-dimension; \code{3}: z-dimension. } \item{method }{the integrator. Use \code{"lsodes"} if the model is very stiff; "impAdams" may be best suited for mildly stiff problems; \code{"euler", "rk4", "ode23", "ode45", "adams"} are most efficient for non-stiff problems. Also allowed is to pass an integrator \code{function}. Use one of the other Runge-Kutta methods via \code{rkMethod}. For instance, \code{method = rkMethod("ode45ck")} will trigger the Cash-Karp method of order 4(5). Method \code{"iteration"} is special in that here the function \code{func} should return the new value of the state variables rather than the rate of change. This can be used for individual based models, for difference equations, or in those cases where the integration is performed within \code{func}) } \item{... }{additional arguments passed to \code{lsodes}.} } \value{ A matrix of class \code{deSolve} with up to as many rows as elements in times and as many columns as elements in \code{y} plus the number of "global" values returned in the second element of the return from \code{func}, plus an additional column (the first) for the time value. There will be one row for each element in \code{times} unless the integrator returns with an unrecoverable error. If \code{y} has a names attribute, it will be used to label the columns of the output value. The output will have the attributes \code{istate}, and \code{rstate}, two vectors with several useful elements. The first element of istate returns the conditions under which the last call to the integrator returned. Normal is \code{istate = 2}. If \code{verbose = TRUE}, the settings of istate and rstate will be written to the screen. See the help for the selected integrator for details. } \note{ It is advisable though not mandatory to specify \bold{both} \code{nspec} and \code{dimens}. In this case, the solver can check whether the input makes sense (as \code{nspec*dimens[1]*dimens[2]*dimens[3] == length(y)}). Do \bold{not} use this method for problems that are not 3D! } \author{Karline Soetaert } \examples{ ## ======================================================================= ## Diffusion in 3-D; imposed boundary conditions ## ======================================================================= diffusion3D <- function(t, Y, par) { ## function to bind two matrices to an array mbind <- function (Mat1, Array, Mat2, along = 1) { dimens <- dim(Array) + c(0, 0, 2) if (along == 3) array(dim = dimens, data = c(Mat1, Array, Mat2)) else if (along == 1) aperm(array(dim = dimens, data=c(Mat1, aperm(Array, c(3, 2, 1)), Mat2)), c(3, 2, 1)) else if (along == 2) aperm(array(dim = dimens, data = c(Mat1, aperm(Array, c(1, 3, 2)), Mat2)), c(1, 3, 2)) } yy <- array(dim=c(n, n, n), data = Y) # vector to 3-D array dY <- -r*yy # consumption BND <- matrix(nrow = n, ncol = n, data = 1) # boundary concentration ## diffusion in x-direction ## new array including boundary concentrations in X-direction BNDx <- mbind(BND, yy, BND, along = 1) ## diffusive Flux Flux <- -Dx * (BNDx[2:(n+2),,] - BNDx[1:(n+1),,])/dx ## rate of change = - flux gradient dY[] <- dY[] - (Flux[2:(n+1),,] - Flux[1:n,,])/dx ## diffusion in y-direction BNDy <- mbind(BND, yy, BND, along = 2) Flux <- -Dy * (BNDy[,2:(n+2),] - BNDy[,1:(n+1),])/dy dY[] <- dY[] - (Flux[,2:(n+1),] - Flux[,1:n,])/dy ## diffusion in z-direction BNDz <- mbind(BND, yy, BND, along = 3) Flux <- -Dz * (BNDz[,,2:(n+2)] - BNDz[,,1:(n+1)])/dz dY[] <- dY[] - (Flux[,,2:(n+1)] - Flux[,,1:n])/dz return(list(as.vector(dY))) } ## parameters dy <- dx <- dz <-1 # grid size Dy <- Dx <- Dz <-1 # diffusion coeff, X- and Y-direction r <- 0.025 # consumption rate n <- 10 y <- array(dim=c(n,n,n),data=10.) ## use lsodes, the default (for n>20, Runge-Kutta more efficient) print(system.time( RES <- ode.3D(y, func = diffusion3D, parms = NULL, dimens = c(n, n, n), times = 1:20, lrw = 120000, atol = 1e-10, rtol = 1e-10, verbose = TRUE) )) y <- array(dim = c(n, n, n), data = RES[nrow(RES), -1]) filled.contour(y[, , n/2], color.palette = terrain.colors) summary(RES) \dontrun{ for (i in 2:nrow(RES)) { y <- array(dim=c(n,n,n),data=RES[i,-1]) filled.contour(y[,,n/2],main=i,color.palette=terrain.colors) } } } \details{ This is the method of choice for 3-dimensional models, that are only subjected to transport between adjacent layers. Based on the dimension of the problem, the method first calculates the sparsity pattern of the Jacobian, under the assumption that transport is only occurring between adjacent layers. Then \code{lsodes} is called to solve the problem. As \code{lsodes} is used to integrate, it will probably be necessary to specify the length of the real work array, \code{lrw}. Although a reasonable guess of \code{lrw} is made, it is likely that this will be too low. In this case, \code{ode.2D} will return with an error message telling the size of the work array actually needed. In the second try then, set \code{lrw} equal to this number. For instance, if you get the error: \preformatted{ DLSODES- RWORK length is insufficient to proceed. Length needed is .ge. LENRW (=I1), exceeds LRW (=I2) In above message, I1 = 27627 I2 = 25932 } set \code{lrw} equal to 27627 or a higher value. See \link{lsodes} for the additional options. } \seealso{ \itemize{ \item \code{\link{ode}} for a general interface to most of the ODE solvers, \item \code{\link{ode.band}} for integrating models with a banded Jacobian \item \code{\link{ode.1D}} for integrating 1-D models \item \code{\link{ode.2D}} for integrating 2-D models \item \code{\link{lsodes}} for the integration options. } \code{\link{diagnostics}} to print diagnostic messages. } \keyword{math} deSolve/man/dede.Rd0000754000175100001440000002003013131230672013627 0ustar hornikusers\name{dede} \alias{dede} \title{ General Solver for Delay Differential Equations. } \description{ Function \code{dede} is a general solver for delay differential equations, i.e. equations where the derivative depends on past values of the state variables or their derivatives. } \usage{ dede(y, times, func=NULL, parms, method = c( "lsoda", "lsode", "lsodes", "lsodar", "vode", "daspk", "bdf", "adams", "impAdams", "radau"), control = NULL, ...) } \arguments{ \item{y }{the initial (state) values for the DE system, a vector. If \code{y} has a name attribute, the names will be used to label the output matrix. } \item{times }{time sequence for which output is wanted; the first value of \code{times} must be the initial time. } \item{func }{an \R-function that computes the values of the derivatives in the ODE system (the model definition) at time \eqn{t}. \code{func} must be defined as: \code{func <- function(t, y, parms, ...)}. \code{t} is the current time point in the integration, \code{y} is the current estimate of the variables in the DE system. If the initial values \code{y} has a \code{names} attribute, the names will be available inside \code{func}. \code{parms} is a vector or list of parameters; \code{...} (optional) are any other arguments passed to the function. The return value of \code{func} should be a list, whose first element is a vector containing the derivatives of \code{y} with respect to \code{time}, and whose next elements are global values that are required at each point in \code{times}.The derivatives must be specified in the \bold{same order} as the state variables \code{y}. If method "daspk" is used, then \code{func} can be \code{NULL}, in which case \code{res} should be used. } \item{parms }{parameters passed to \code{func}. } \item{method }{the integrator to use, either a string (\code{"lsoda"}, \code{"lsode"}, \code{"lsodes"}, \code{"lsodar"}, \code{"vode"}, \code{"daspk"}, \code{"bdf"}, \code{"adams"}, \code{"impAdams"}, \code{"radau"}) or a function that performs the integration. The default integrator used is \link{lsoda}. } \item{control }{a list that can supply (1) the size of the history array, as \code{control$mxhist}; the default is 1e4 and (2) how to interpolate, as \code{control$interpol}, where \code{1} is hermitian interpolation, \code{2} is variable order interpolation, using the Nordsieck history array. Only for the two Adams methods is the second option recommended. } \item{... }{additional arguments passed to the integrator. } } \value{ A matrix of class \code{deSolve} with up to as many rows as elements in \code{times} and as many columns as elements in \code{y} plus the number of "global" values returned in the second element of the return from \code{func}, plus an additional column (the first) for the time value. There will be one row for each element in \code{times} unless the integrator returns with an unrecoverable error. If \code{y} has a names attribute, it will be used to label the columns of the output value. } \author{Karline Soetaert } \details{ Functions \link{lagvalue} and \link{lagderiv} are to be used with \code{dede} as they provide access to past (lagged) values of state variables and derivatives. The number of past values that are to be stored in a history matrix, can be specified in \code{control$mxhist}. The default value (if unspecified) is 1e4. Cubic Hermite interpolation is used by default to obtain an accurate interpolant at the requested lagged time. For methods \code{adams, impAdams}, a more accurate interpolation method can be triggered by setting \code{control$interpol = 2}. \code{dede} does not deal explicitly with propagated derivative discontinuities, but relies on the integrator to control the stepsize in the region of a discontinuity. \code{dede} does not include methods to deal with delays that are smaller than the stepsize, although in some cases it may be possible to solve such models. For these reasons, it can only solve rather simple delay differential equations. When used together with integrator \code{lsodar}, or \code{lsode}, \code{dde} can simultaneously locate a root, and trigger an event. See last example. } \seealso{ \link{lagvalue}, \link{lagderiv},for how to specify lagged variables and derivatives. } \examples{ ## ============================================================================= ## A simple delay differential equation ## dy(t) = -y(t-1) ; y(t<0)=1 ## ============================================================================= ##----------------------------- ## the derivative function ##----------------------------- derivs <- function(t, y, parms) { if (t < 1) dy <- -1 else dy <- - lagvalue(t - 1) list(c(dy)) } ##----------------------------- ## initial values and times ##----------------------------- yinit <- 1 times <- seq(0, 30, 0.1) ##----------------------------- ## solve the model ##----------------------------- yout <- dede(y = yinit, times = times, func = derivs, parms = NULL) ##----------------------------- ## display, plot results ##----------------------------- plot(yout, type = "l", lwd = 2, main = "dy/dt = -y(t-1)") ## ============================================================================= ## The infectuous disease model of Hairer; two lags. ## example 4 from Shampine and Thompson, 2000 ## solving delay differential equations with dde23 ## ============================================================================= ##----------------------------- ## the derivative function ##----------------------------- derivs <- function(t,y,parms) { if (t < 1) lag1 <- 0.1 else lag1 <- lagvalue(t - 1,2) if (t < 10) lag10 <- 0.1 else lag10 <- lagvalue(t - 10,2) dy1 <- -y[1] * lag1 + lag10 dy2 <- y[1] * lag1 - y[2] dy3 <- y[2] - lag10 list(c(dy1, dy2, dy3)) } ##----------------------------- ## initial values and times ##----------------------------- yinit <- c(5, 0.1, 1) times <- seq(0, 40, by = 0.1) ##----------------------------- ## solve the model ##----------------------------- system.time( yout <- dede(y = yinit, times = times, func = derivs, parms = NULL) ) ##----------------------------- ## display, plot results ##----------------------------- matplot(yout[,1], yout[,-1], type = "l", lwd = 2, lty = 1, main = "Infectuous disease - Hairer") ## ============================================================================= ## time lags + EVENTS triggered by a root function ## The two-wheeled suitcase model ## example 8 from Shampine and Thompson, 2000 ## solving delay differential equations with dde23 ## ============================================================================= ##----------------------------- ## the derivative function ##----------------------------- derivs <- function(t, y, parms) { if (t < tau) lag <- 0 else lag <- lagvalue(t - tau) dy1 <- y[2] dy2 <- -sign(y[1]) * gam * cos(y[1]) + sin(y[1]) - bet * lag[1] + A * sin(omega * t + mu) list(c(dy1, dy2)) } ## root and event function root <- function(t,y,parms) ifelse(t>0, return(y), return(1)) event <- function(t,y,parms) return(c(y[1], y[2]*0.931)) gam = 0.248; bet = 1; tau = 0.1; A = 0.75 omega = 1.37; mu = asin(gam/A) ##----------------------------- ## initial values and times ##----------------------------- yinit <- c(y = 0, dy = 0) times <- seq(0, 12, len = 1000) ##----------------------------- ## solve the model ##----------------------------- ## Note: use a solver that supports both root finding and events, ## e.g. lsodar, lsode, lsoda, adams, bdf yout <- dede(y = yinit, times = times, func = derivs, parms = NULL, method = "lsodar", rootfun = root, events = list(func = event, root = TRUE)) ##----------------------------- ## display, plot results ##----------------------------- plot(yout, which = 1, type = "l", lwd = 2, main = "suitcase model", mfrow = c(1,2)) plot(yout[,2], yout[,3], xlab = "y", ylab = "dy", type = "l", lwd = 2) } \keyword{utilities} deSolve/man/DLLres.Rd0000754000175100001440000000771312352122172014067 0ustar hornikusers\name{DLLres} \alias{DLLres} \title{Evaluates a Residual Derivative Function Represented in a DLL } \description{ Calls a residual function, \eqn{F(t,y,y')} of a DAE system (differential algebraic equations) defined in a compiled language as a DLL. To be used for testing the implementation of DAE problems in compiled code } \usage{DLLres(res, times, y, dy, parms, dllname, initfunc = dllname, rpar = NULL, ipar = NULL, nout = 0, outnames = NULL, forcings = NULL, initforc = NULL, fcontrol = NULL) } \arguments{ \item{res }{the name of the function in the dynamically loaded shared library, } \item{times }{first value = the time at which the function needs to be evaluated, } \item{y }{the values of the dependent variables for which the function needs to be evaluated, } \item{dy }{the derivative of the values of the dependent variables for which the function needs to be evaluated, } \item{parms }{the parameters that are passed to the initialiser function, } \item{dllname }{a string giving the name of the shared library (without extension) that contains the compiled function or subroutine definitions referred to in \code{func}, } \item{initfunc }{if not NULL, the name of the initialisation function (which initialises values of parameters), as provided in \file{dllname}. See details, } \item{rpar }{a vector with double precision values passed to the DLL-function \code{func} and \code{jacfunc} present in the DLL, via argument \code{rpar}, } \item{ipar }{a vector with integer values passed to the DLL-function \code{func} and \code{jacfunc} present in the DLL, via function argument \code{ipar}, } \item{nout }{the number of output variables. } \item{outnames }{only used if \file{dllname} is specified and \code{nout} > 0: the names of output variables calculated in the compiled function \code{func}, present in the shared library. } \item{forcings }{only used if \file{dllname} is specified: a list with the forcing function data sets, each present as a two-columned matrix, with (time,value); interpolation outside the interval [min(\code{times}), max(\code{times})] is done by taking the value at the closest data extreme. See package vignette \code{"compiledCode"}. } \item{initforc }{if not \code{NULL}, the name of the forcing function initialisation function, as provided in \file{dllname}. It MUST be present if \code{forcings} has been given a value. See package vignette \code{"compiledCode"}. } \item{fcontrol }{A list of control parameters for the forcing functions. See package vignette \code{"compiledCode"}. } } \value{ a list containing: \item{res }{the residual of derivative estimated by the function} \item{var }{the ordinary output variables of the function} } \details{ This function is meant to help developing FORTRAN or C models that are to be used to solve differential algebraic equations (DAE) in package \code{deSolve}. } \author{Karline Soetaert } \keyword{utilities} \examples{ ## ========================================================================= ## Residuals from the daspk chemical model, production a forcing function ## ========================================================================= ## Parameter values and initial conditions ## see example(daspk) for a more comprehensive implementation pars <- c(K = 1, ka = 1e6, r = 1) ## Initial conc; D is in equilibrium with A,B y <- c(A = 2, B = 3, D = 2 * 3/pars["K"]) ## Initial rate of change dy <- c(dA = 0, dB = 0, dD = 0) ## production increases with time prod <- matrix(ncol = 2, data = c(seq(0, 100, by = 10), seq(0.1, 0.5, len = 11))) DLLres(y = y, dy = dy, times = 5, res = "chemres", dllname = "deSolve", initfunc = "initparms", initforc = "initforcs", parms = pars, forcings = prod, nout = 2, outnames = c("CONC", "Prod")) } \seealso{ \link{daspk} to solve DAE problems } deSolve/man/ccl4model.Rd0000754000175100001440000000770612352122172014612 0ustar hornikusers\name{ccl4model} \alias{ccl4model} \title{The CCl4 Inhalation Model} \description{The CCl4 inhalation model implemented in \code{.Fortran}} \usage{ccl4model(times, y, parms, ...)} \arguments{ \item{times }{time sequence for which the model has to be integrated.} \item{y }{the initial values for the state variables ("AI", "AAM", "AT", "AF", "AL", "CLT" and "AM"), in that order. } \item{parms }{vector or list holding the ccl4 model parameters; see the example for the order in which these have to be defined. } \item{... }{any other parameters passed to the integrator \code{ode} (which solves the model). } } \author{R. Woodrow Setzer } \examples{ ## ================= ## Parameter values ## ================= Pm <- c( ## Physiological parameters BW = 0.182, # Body weight (kg) QP = 4.0 , # Alveolar ventilation rate (hr^-1) QC = 4.0 , # Cardiac output (hr^-1) VFC = 0.08, # Fraction fat tissue (kg/(kg/BW)) VLC = 0.04, # Fraction liver tissue (kg/(kg/BW)) VMC = 0.74, # Fraction of muscle tissue (kg/(kg/BW)) QFC = 0.05, # Fractional blood flow to fat ((hr^-1)/QC QLC = 0.15, # Fractional blood flow to liver ((hr^-1)/QC) QMC = 0.32, # Fractional blood flow to muscle ((hr^-1)/QC) ## Chemical specific parameters for chemical PLA = 16.17, # Liver/air partition coefficient PFA = 281.48, # Fat/air partition coefficient PMA = 13.3, # Muscle/air partition coefficient PTA = 16.17, # Viscera/air partition coefficient PB = 5.487, # Blood/air partition coefficient MW = 153.8, # Molecular weight (g/mol) VMAX = 0.04321671, # Max. velocity of metabolism (mg/hr) -calibrated KM = 0.4027255, # Michaelis-Menten constant (mg/l) -calibrated ## Parameters for simulated experiment CONC = 1000, # Inhaled concentration KL = 0.02, # Loss rate from empty chamber /hr RATS = 1.0, # Number of rats enclosed in chamber VCHC = 3.8 # Volume of closed chamber (l) ) ## ================ ## State variables ## ================ y <- c( AI = 21, # total mass , mg AAM = 0, AT = 0, AF = 0, AL = 0, CLT = 0, # area under the conc.-time curve in the liver AM = 0 # the amount metabolized (AM) ) ## ================== ## Model application ## ================== times <- seq(0, 6, by = 0.1) ## initial inhaled concentration-calibrated conc <- c(26.496, 90.197, 245.15, 951.46) plot(ChamberConc ~ time, data = ccl4data, xlab = "Time (hours)", xlim = range(c(0, ccl4data$time)), ylab = "Chamber Concentration (ppm)", log = "y", main = "ccl4model") for (cc in conc) { Pm["CONC"] <- cc VCH <- Pm[["VCHC"]] - Pm[["RATS"]] * Pm[["BW"]] AI0 <- VCH * Pm[["CONC"]] * Pm[["MW"]]/24450 y["AI"] <- AI0 ## run the model: out <- as.data.frame(ccl4model(times, y, Pm)) lines(out$time, out$CP, lwd = 2) } legend("topright", lty = c(NA, 1), pch = c(1, NA), lwd = c(NA, 2), legend = c("data", "model")) ## ================================== ## An example with tracer injection ## ================================== ## every day, a conc of 2 is added to AI. ## 1. implemented as a data.frame eventdat <- data.frame(var = rep("AI", 6), time = 1:6 , value = rep(1, 6), method = rep("add", 6)) eventdat print(system.time( out <-ccl4model(times, y, Pm, events = list(data = eventdat)) )) plot(out, mfrow = c(3, 4), type = "l", lwd = 2) # 2. implemented as a function in a DLL! print(system.time( out2 <-ccl4model(times, y, Pm, events = list(func = "eventfun", time = 1:6)) )) plot(out2, mfrow=c(3, 4), type = "l", lwd = 2) } \details{ The model is implemented primarily to demonstrate the linking of FORTRAN with R-code. The source can be found in the \file{/doc/examples/dynload} subdirectory of the package. } \seealso{ Try \code{demo(CCL4model)} for how this model has been fitted to the dataset \code{\link{ccl4data},} \code{\link{aquaphy}}, another FORTRAN model, describing growth in aquatic phytoplankton. } \keyword{models} deSolve/man/events.Rd0000754000175100001440000003022213023007076014236 0ustar hornikusers\name{events} \alias{events} \alias{roots} \title{ Implementing Events and Roots in Differential Equation Models. } \description{ An \code{event} occurs when the value of a state variable is suddenly changed, e.g. because a value is added, subtracted, or multiplied. The integration routines cannot deal easily with such state variable changes. Typically these events occur only at specific times. In \code{deSolve}, events can be imposed by means of an input data.frame, that specifies at which time and how a certain state variable is altered, or via an event function. Roots occur when a root function becomes zero. By default when a root is found, the simulation either stops (no event), or triggers an event. } \details{ The \code{events} are specified by means of argument \code{events} passed to the integration routines. \code{events} should be a list that contains one of the following: \enumerate{ \item{func: }{an R-function or the name of a function in compiled code that specifies the event, } \item{data: }{a data.frame that specifies the state variables, times, values and types of the events. Note that the event times must also be part of the integration output times, else the event will not take place. As from version 1.9.1, this is checked by the solver, and a warning message is produced if event times are missing in times; see also \code{\link{cleanEventTimes}} for utility functions to check and solve such issues. } \item{time: }{when events are specified by an event function: the times at which the events take place. Note that these event times must also be part of the integration output times exactly, else the event would not take place. As from version 1.9.1 this is checked by the solver, and an error message produced if event times are missing in times; see also \code{\link{cleanEventTimes}} for utility functions to check and solve such issues. } \item{root: }{when events are specified by a function and triggered by a root, this logical should be set equal to \code{TRUE} } \item{terminalroot }{when events are triggered by a root, the default is that the simulation continues after the event is executed. In \code{terminalroot}, we can specify which roots should terminate the simulation. } \item{maxroot: }{when \code{root = TRUE}, the maximal number of times at with a root is found and that are kept; defaults to 100. If the number of roots > \code{maxroot}, then only the first \code{maxroot} will be outputted. } \item{ties: }{if events, as specified by a data.frame are "ordered", set to "ordered", the default is "notordered". This will save some computational time. } } In case the events are specified by means of an \R \bold{function} (argument \code{events$func}), it must be defined as: \code{function(t, y, parms, ...)}. \code{t} is the current time point in the integration, \code{y} is the current estimate of the variables in the ODE system. If the initial values \code{y} has a \code{names} attribute, the names will be available inside \code{events$func}. \code{parms} is a vector or list of parameters; \code{...} (optional) are any other arguments passed to the function via the call to the integration method. The event function should return the y-values (some of which modified), as a \emph{vector}. If \code{events$func} is a string, this indicates that the events are specified by a \code{function} in compiled code. This function has as arguments, the number of state variables, the time, and the state variable vector. See package vignette "compiledCode" for more details. In case events are specified by an \R-function, this requires either: input of the \emph{time} of the events, a vector as defined in \code{events$time} OR the specification of a \emph{root} function. In the latter case, the model must be solved with an integration routine with root-finding capability The root function itself should be specified with argument \code{rootfunc}. In this case, the integrator is informed that the simulation it to be continued after a root is found by setting \code{events$root} equal to \code{TRUE}. If the events are specified by a \bold{data frame} (argument \code{events$data}), this should contain the following columns (and in that order): \enumerate{ \item{var }{the state variable \emph{name} or \emph{number} that is affected by the event} \item{time }{the time at which the event is to take place; the solvers will check if the time is embraced by the simulation time} \item{value }{the value, magnitude of the event} \item{method }{which event is to take place; should be one of ("replace", "add", "multiply"); also allowed is to specify the number (1 = replace, 2 = add, 3 = multiply) } } For instance, the following line \code{"v1" 10 2 "add"} will cause the value 2 to be added to a state variable, called \code{"v1"} at \code{time = 10}. From deSolve version 1.9.1 the following routines have \bold{root-finding} capability: \link{lsoda}, \link{lsode}, \link{lsodes}, and \link{radau}. For the first 3 integration methods, the root finding algorithm is based on the algorithm in solver LSODAR, and is implemented in FORTRAN. For radau, the root solving algorithm is written in C-code, and it works slightly different. Thus, some problems involving roots may be more efficiently solved with either lsoda, lsode, or lsodes, while other problems are more efficiently solved with radau. If a root function is defined, but not an event function, then by default the solver will stop at a root. If this is not desirable, e.g. because we want to record the position of many roots, then a dummy "event" function can be defined which returns the values of the state variables - unaltered. If roots and events are combined, and roots are found, then the output will have attribute \code{troot} which will contain the \code{times} at which a root was found (and the event trigerred). There will be at most \code{events$maxroot} such values. The default is 100. See two last examples; also see example of \code{\link{ccl4model}}. } \author{ Karline Soetaert } \seealso{ \link{forcings}, for how to implement forcing functions. \link{lsodar}, for more examples of roots } \examples{ ## ============================================================================= ## 1. EVENTS in a data.frame ## ============================================================================= ## derivative function: derivatives set to 0 derivs <- function(t, var, parms) { list(dvar = rep(0, 2)) } yini <- c(v1 = 1, v2 = 2) times <- seq(0, 10, by = 0.1) eventdat <- data.frame(var = c("v1", "v2", "v2", "v1"), time = c(1, 1, 5, 9) , value = c(1, 2, 3, 4), method = c("add", "mult", "rep", "add")) eventdat out <- vode(func = derivs, y = yini, times = times, parms = NULL, events = list(data = eventdat)) plot(out) ## eventdat <- data.frame(var = c(rep("v1", 10), rep("v2", 10)), time = c(1:10, 1:10), value = runif(20), method = rep("add", 20)) eventdat out <- ode(func = derivs, y = yini, times = times, parms = NULL, events = list(data = eventdat)) plot(out) ## ============================================================================= ## 2. EVENTS in a function ## ============================================================================= ## derivative function: rate of change v1 = 0, v2 reduced at first-order rate derivs <- function(t, var, parms) { list(c(0, -0.5 * var[2])) } # events: add 1 to v1, multiply v2 with random number eventfun <- function(t, y, parms){ with (as.list(y),{ v1 <- v1 + 1 v2 <- 5 * runif(1) return(c(v1, v2)) }) } yini <- c(v1 = 1, v2 = 2) times <- seq(0, 10, by = 0.1) out <- ode(func = derivs, y = yini, times = times, parms = NULL, events = list(func = eventfun, time = c(1:9, 2.2, 2.4)) ) plot(out, type = "l") ## ============================================================================= ## 3. EVENTS triggered by a root function ## ============================================================================= ## derivative: simple first-order decay derivs <- function(t, y, pars) { return(list(-0.1 * y)) } ## event triggered if state variable = 0.5 rootfun <- function (t, y, pars) { return(y - 0.5) } ## sets state variable = 1 eventfun <- function(t, y, pars) { return(y = 1) } yini <- 2 times <- seq(0, 100, 0.1) ## uses ode to solve; root = TRUE specifies that the event is ## triggered by a root. out <- ode(times = times, y = yini, func = derivs, parms = NULL, events = list(func = eventfun, root = TRUE), rootfun = rootfun) plot(out, type = "l") ## time of the root: troot <- attributes(out)$troot points(troot, rep(0.5, length(troot))) ## ============================================================================= ## 4. More ROOT examples: Rotation function ## ============================================================================= Rotate <- function(t, x, p ) list(c( x[2], -x[1] )) ## Root = when second state variable = 0 rootfun <- function(t, x, p) x[2] ## "event" returns state variables unchanged eventfun <- function(t, x, p) x times <- seq(from = 0, to = 15, by = 0.1) ## 1. No event: stops at first root out1 <- ode(func = Rotate, y = c(5, 5), parms = 0, times = times, rootfun = rootfun) tail(out1) ## 2. Continues till end of times and records the roots out <- ode(func = Rotate, y = c(5, 5), parms = 0, times = times, rootfun = rootfun, events = list(func = eventfun, root = TRUE) ) plot(out) troot <- attributes(out)$troot # time of roots points(troot,rep(0, length (troot))) ## Multiple roots: either one of the state variables = 0 root2 <- function(t, x, p) x out2 <- ode(func = Rotate, y = c(5, 5), parms = 0, times = times, rootfun = root2, events = list(func = eventfun, root = TRUE) ) plot(out2, which = 2) troot <- attributes(out2)$troot indroot <- attributes(out2)$indroot # which root was found points(troot, rep(0, length (troot)), col = indroot, pch = 18, cex = 2) ## Multiple roots and stop at first time root 1. out3 <- ode(func = Rotate, y = c(5, 5), parms = 0, times = times, rootfun = root2, events = list(func = eventfun, root = TRUE, terminalroot = 1)) ## ============================================================================= ## 5. Stop at 5th root - only works with radau. ## ============================================================================= Rotate <- function(t, x, p ) list(c( x[2], -x[1], 0 )) ## Root = when second state variable = 0 root3 <- function(t, x, p) c(x[2], x[3] - 5) event3 <- function (t, x, p) c(x[1:2], x[3]+1) times <- seq(0, 15, 0.1) out3 <- ode(func = Rotate, y = c(x1 = 5, x2 = 5, nroot = 0), parms = 0, method = "radau", times = times, rootfun = root3, events = list(func = event3, root = TRUE, terminalroot = 2)) plot(out3) attributes(out3)[c("troot", "nroot", "indroot")] ## ============================================================================= ## 6 Event in R-code, model function in compiled code - based on vode example ## ============================================================================= times <- 1:365 Flux <- cbind(times, sin(pi*times/365)^2) # forcing function # run without events out <- ode(y = c(C = 1), times, func = "scocder", parms = c(k=0.01), dllname = "deSolve", initforc = "scocforc", forcings = Flux, initfunc = "scocpar", nout = 2, outnames = c("Mineralisation", "Depo")) # Event halves the concentration EventMin <- function(t, y , p) y/2 out2 <- ode(y = c(C = 1), times, func = "scocder", parms = c(k=0.01), dllname = "deSolve", initforc = "scocforc", forcings = Flux, initfunc = "scocpar", nout = 2, outnames = c("Mineralisation", "Depo"), events = list (func = EventMin, time = c(50.1, 200, 210.5))) plot(out, out2) } \keyword{utilities}deSolve/man/rk4.Rd0000754000175100001440000002335712352122172013444 0ustar hornikusers\name{rk4} \alias{rk4} \alias{euler} \alias{euler.1D} \title{Solve System of ODE (Ordinary Differential Equation)s by Euler's Method or Classical Runge-Kutta 4th Order Integration. } \description{Solving initial value problems for systems of first-order ordinary differential equations (ODEs) using Euler's method or the classical Runge-Kutta 4th order integration. } \usage{ euler(y, times, func, parms, verbose = FALSE, ynames = TRUE, dllname = NULL, initfunc = dllname, initpar = parms, rpar = NULL, ipar = NULL, nout = 0, outnames = NULL, forcings = NULL, initforc = NULL, fcontrol = NULL, ...) rk4(y, times, func, parms, verbose = FALSE, ynames = TRUE, dllname = NULL, initfunc = dllname, initpar = parms, rpar = NULL, ipar = NULL, nout = 0, outnames = NULL, forcings = NULL, initforc = NULL, fcontrol = NULL, ...) euler.1D(y, times, func, parms, nspec = NULL, dimens = NULL, names = NULL, verbose = FALSE, ynames = TRUE, dllname = NULL, initfunc = dllname, initpar = parms, rpar = NULL, ipar = NULL, nout = 0, outnames = NULL, forcings = NULL, initforc = NULL, fcontrol = NULL, ...) } \arguments{ \item{y }{the initial (state) values for the ODE system. If \code{y} has a name attribute, the names will be used to label the output matrix. } \item{times }{times at which explicit estimates for \code{y} are desired. The first value in \code{times} must be the initial time. } \item{func }{either an \R-function that computes the values of the derivatives in the ODE system (the \emph{model definition}) at time t, or a character string giving the name of a compiled function in a dynamically loaded shared library. If \code{func} is an \R-function, it must be defined as: \code{func <- function(t, y, parms,...)}. \code{t} is the current time point in the integration, \code{y} is the current estimate of the variables in the ODE system. If the initial values \code{y} has a \code{names} attribute, the names will be available inside \code{func}. \code{parms} is a vector or list of parameters; ... (optional) are any other arguments passed to the function. The return value of \code{func} should be a list, whose first element is a vector containing the derivatives of \code{y} with respect to \code{time}, and whose next elements are global values that are required at each point in \code{times}. The derivatives must be specified in the \bold{same order} as the state variables \code{y}. If \code{func} is a string, then \code{dllname} must give the name of the shared library (without extension) which must be loaded before \code{rk4} is called. See package vignette \code{"compiledCode"} for more details. } \item{parms }{vector or list of parameters used in \code{func}. } \item{nspec }{for 1D models only: the number of \bold{species} (components) in the model. If \code{NULL}, then \code{dimens} should be specified. } \item{dimens}{for 1D models only: the number of \bold{boxes} in the model. If \code{NULL}, then \code{nspec} should be specified. } \item{names }{for 1D models only: the names of the components; used for plotting. } \item{verbose }{a logical value that, when \code{TRUE}, triggers more verbose output from the ODE solver. } \item{ynames }{if \code{FALSE}: names of state variables are not passed to function \code{func} ; this may speed up the simulation especially for large models. } \item{dllname }{a string giving the name of the shared library (without extension) that contains all the compiled function or subroutine definitions refered to in \code{func}. See package vignette \code{"compiledCode"}. } \item{initfunc }{if not \code{NULL}, the name of the initialisation function (which initialises values of parameters), as provided in \file{dllname}. See package vignette \code{"compiledCode"}, } \item{initpar }{only when \file{dllname} is specified and an initialisation function \code{initfunc} is in the DLL: the parameters passed to the initialiser, to initialise the common blocks (FORTRAN) or global variables (C, C++). } \item{rpar }{only when \file{dllname} is specified: a vector with double precision values passed to the DLL-functions whose names are specified by \code{func} and \code{jacfunc}. } \item{ipar }{only when \file{dllname} is specified: a vector with integer values passed to the dll-functions whose names are specified by \code{func} and \code{jacfunc}. } \item{nout }{only used if \code{dllname} is specified and the model is defined in compiled code: the number of output variables calculated in the compiled function \code{func}, present in the shared library. Note: it is not automatically checked whether this is indeed the number of output variables calculated in the DLL - you have to perform this check in the code. See package vignette \code{"compiledCode"}. } \item{outnames }{only used if \file{dllname} is specified and \code{nout} > 0: the names of output variables calculated in the compiled function \code{func}, present in the shared library. } \item{forcings }{only used if \file{dllname} is specified: a list with the forcing function data sets, each present as a two-columned matrix, with (time, value); interpolation outside the interval [min(\code{times}), max(\code{times})] is done by taking the value at the closest data extreme. See \link{forcings} or package vignette \code{"compiledCode"}. } \item{initforc }{if not \code{NULL}, the name of the forcing function initialisation function, as provided in \file{dllname}. It MUST be present if \code{forcings} has been given a value. See \link{forcings} or package vignette \code{"compiledCode"}. } \item{fcontrol }{A list of control parameters for the forcing functions. See \link{forcings} or vignette \code{compiledCode}. } \item{... }{additional arguments passed to \code{func} allowing this to be a generic function. } } \author{Thomas Petzoldt \email{thomas.petzoldt@tu-dresden.de}} \details{ \code{rk4} and \code{euler} are special versions of the two fixed step solvers with less overhead and less functionality (e.g. no interpolation and no events) compared to the generic Runge-Kutta codes called by \code{\link{ode}} resp. \code{\link{rk}}. If you need different internal and external time steps or want to use events, please use: \code{rk(y, times, func, parms, method = "rk4")} or \code{rk(y, times, func, parms, method = "euler")}. See help pages of \code{\link{rk}} and \code{\link{rkMethod}} for details. Function \code{euler.1D} essentially calls function\code{euler} but contains additional code to support plotting of 1D models, see \code{\link{ode.1D}} and \code{\link{plot.1D}} for details. } \note{ For most practical cases, solvers with flexible timestep (e.g. \code{rk(method = "ode45")} and especially solvers of the Livermore family (ODEPACK, e.g. \code{\link{lsoda}}) are superior. } \value{ A matrix of class \code{deSolve} with up to as many rows as elements in \code{times} and as many columns as elements in \code{y} plus the number of "global" values returned in the next elements of the return from \code{func}, plus and additional column for the time value. There will be a row for each element in \code{times} unless the integration routine returns with an unrecoverable error. If \code{y} has a names attribute, it will be used to label the columns of the output value. } \examples{ ## ======================================================================= ## Example: Analytical and numerical solutions of logistic growth ## ======================================================================= ## the derivative of the logistic logist <- function(t, x, parms) { with(as.list(parms), { dx <- r * x[1] * (1 - x[1]/K) list(dx) }) } time <- 0:100 N0 <- 0.1; r <- 0.5; K <- 100 parms <- c(r = r, K = K) x <- c(N = N0) ## analytical solution plot(time, K/(1 + (K/N0-1) * exp(-r*time)), ylim = c(0, 120), type = "l", col = "red", lwd = 2) ## reasonable numerical solution with rk4 time <- seq(0, 100, 2) out <- as.data.frame(rk4(x, time, logist, parms)) points(out$time, out$N, pch = 16, col = "blue", cex = 0.5) ## same time step with euler, systematic under-estimation time <- seq(0, 100, 2) out <- as.data.frame(euler(x, time, logist, parms)) points(out$time, out$N, pch = 1) ## unstable result time <- seq(0, 100, 4) out <- as.data.frame(euler(x, time, logist, parms)) points(out$time, out$N, pch = 8, cex = 0.5) ## method with automatic time step out <- as.data.frame(lsoda(x, time, logist, parms)) points(out$time, out$N, pch = 1, col = "green") legend("bottomright", c("analytical","rk4, h=2", "euler, h=2", "euler, h=4", "lsoda"), lty = c(1, NA, NA, NA, NA), lwd = c(2, 1, 1, 1, 1), pch = c(NA, 16, 1, 8, 1), col = c("red", "blue", "black", "black", "green")) } \seealso{ \itemize{ \item \code{\link{rkMethod}} for a list of available Runge-Kutta parameter sets, \item \code{\link{rk}} for the more general Runge-Code, \item \code{\link{lsoda}}, \code{\link{lsode}}, \code{\link{lsodes}}, \code{\link{lsodar}}, \code{\link{vode}}, \code{\link{daspk}} for solvers of the Livermore family, \item \code{\link{ode}} for a general interface to most of the ODE solvers, \item \code{\link{ode.band}} for solving models with a banded Jacobian, \item \code{\link{ode.1D}} for integrating 1-D models, \item \code{\link{ode.2D}} for integrating 2-D models, \item \code{\link{ode.3D}} for integrating 3-D models, \item \code{\link{dede}} for integrating models with delay differential equations, } \code{\link{diagnostics}} to print diagnostic messages. } \keyword{math} deSolve/man/plot.deSolve.Rd0000754000175100001440000003504712732046623015331 0ustar hornikusers\name{plot.deSolve} \alias{plot.deSolve} \alias{plot.1D} \alias{matplot.0D} \alias{matplot.deSolve} \alias{matplot.1D} %\alias{matplot,deSolve-method} \alias{hist.deSolve} \alias{image.deSolve} \alias{subset.deSolve} \title{ Plot, Image and Histogram Method for deSolve Objects } \description{ Plot the output of numeric integration routines. } \usage{ \method{plot}{deSolve}(x, \dots, select = NULL, which = select, ask = NULL, obs = NULL, obspar = list(), subset = NULL) %% thpe: since 1.14 not anymore exported %\method{matplot}{deSolve}(x, \dots, select = NULL, which = select, % obs = NULL, obspar = list(), subset = NULL, % legend = list(x = "topright")) \method{hist}{deSolve}(x, select = 1:(ncol(x)-1), which = select, ask = NULL, subset = NULL, \dots) \method{image}{deSolve}(x, select = NULL, which = select, ask = NULL, add.contour = FALSE, grid = NULL, method = "image", legend = FALSE, subset = NULL, \dots) \method{subset}{deSolve}(x, subset = NULL, select = NULL, which = select, arr = FALSE, \dots) plot.1D (x, \dots, select = NULL, which = select, ask = NULL, obs = NULL, obspar = list(), grid = NULL, xyswap = FALSE, delay = 0, vertical = FALSE, subset = NULL) matplot.0D(x, \dots, select = NULL, which = select, obs = NULL, obspar = list(), subset = NULL, legend = list(x = "topright")) matplot.1D(x, select = NULL, which = select, ask = NULL, obs = NULL, obspar = list(), grid = NULL, xyswap = FALSE, vertical = FALSE, subset = NULL, \dots) } \arguments{ \item{x }{an object of class \code{deSolve}, as returned by the integrators, and to be plotted. For \code{plot.deSolve}, it is allowed to pass several objects of class \code{deSolve} after \code{x} (unnamed) - see second example. } \item{which }{the name(s) or the index to the variables that should be plotted or selected. Default = all variables, except \code{time}. For use with \code{matplot.0D} and \code{matplot.1D}, \code{which} or \code{select} can be a list, with vectors, each referring to a separate y-axis. } \item{select }{which variable/columns to be selected. This is added for consistency with the R-function \code{subset}. } \item{subset }{either a logical expression indicating elements or rows to keep in \code{select}, or a vector of integers denoting the indices of the elements over which to loop. Missing values are taken as \code{FALSE} } \item{ask }{logical; if \code{TRUE}, the user is \emph{ask}ed before each plot, if \code{NULL} the user is only asked if more than one page of plots is necessary and the current graphics device is set interactive, see \code{\link{par}(ask)} and \code{\link{dev.interactive}}.} \item{add.contour }{if \code{TRUE}, will add contours to the image plot.} \item{method }{the name of the plotting method to use, one of "image", "filled.contour", "persp", "contour".} \item{grid }{only for \code{image} plots and for \code{plot.1D}: the 1-D grid as a vector (for output generated with \code{ode.1D}), or the x- and y-grid, as a \code{list} (for output generated with \code{ode.2D}).} \item{xyswap }{if \code{TRUE}, then x-and y-values are swapped and the y-axis is from top to bottom. Useful for drawing vertical profiles.} \item{vertical }{if \code{TRUE}, then 1. x-and y-values are swapped, the y-axis is from top to bottom, the x-axis is on top, margin 3 and the main title gets the value of the x-axis. Useful for drawing vertical profiles; see example 2.} \item{delay }{adds a delay (in milliseconds) between consecutive plots of \code{plot.1D} to enable animations.} \item{obs }{a \code{data.frame} or \code{matrix} with "observed data" that will be added as \code{points} to the plots. \code{obs} can also be a \code{list} with multiple data.frames and/or matrices containing observed data. By default the first column of an observed data set should contain the \code{time}-variable. The other columns contain the observed values and they should have names that are known in \code{x}. If the first column of \code{obs} consists of factors or characters (strings), then it is assumed that the data are presented in long (database) format, where the first three columns contain (name, time, value). If \code{obs} is not \code{NULL} and \code{which} is \code{NULL}, then the variables, common to both \code{obs} and \code{x} will be plotted. } \item{obspar }{additional graphics arguments passed to \code{points}, for plotting the observed data. If \code{obs} is a \code{list} containing multiple observed data sets, then the graphics arguments can be a vector or a list (e.g. for \code{xlim}, \code{ylim}), specifying each data set separately. } \item{legend }{if \code{TRUE}, a color legend will be drawn on the right of each image. For use with \code{matplot.0D} and \code{matplot.1D}: a \code{list} with arguments passed to R-function \link{legend}. } \item{arr }{if \code{TRUE}, and the output is from a 2-D or 3-D model, an array will be returned with dimension = c(dimension of selected variable, nrow(x)). When \code{arr=TRUE} then only one variable can be selected. When the output is from a 0-D or 1-D model, then this argument is ignored. } \item{\dots}{additional arguments. The graphical arguments are passed to \code{\link{plot.default}}, \code{\link{image}} or \code{\link{hist}} For \code{plot.deSolve}, and \code{plot.1D}, the dots may contain other objects of class \code{deSolve}, as returned by the integrators, and to be plotted on the same graphs as \code{x} - see second example. In this case, \code{x} and and these other objects should be compatible, i.e. the column names should be the same. For \code{plot.deSolve}, the arguments after \ldots must be matched exactly. } } \value{ Function \code{subset} called with \code{arr = FALSE} will return a matrix with up to as many rows as selected by \code{subset} and as many columns as selected variables. When \code{arr = TRUE} then an array will be outputted with dimensions equal to the dimension of the selected variable, augmented with the number of rows selected by \code{subset}. This means that the last dimension points to \code{times}. Function \code{subset} also has an attribute that contains the \code{times} selected. } \details{ The number of panels per page is automatically determined up to 3 x 3 (\code{par(mfrow = c(3, 3))}). This default can be overwritten by specifying user-defined settings for \code{mfrow} or \code{mfcol}. Set \code{mfrow} equal to \code{NULL} to avoid the plotting function to change user-defined \code{mfrow} or \code{mfcol} settings. Other graphical parameters can be passed as well. Parameters are vectorized, either according to the number of plots (\code{xlab}, \code{ylab}, \code{main}, \code{sub}, \code{xlim}, \code{ylim}, \code{log}, \code{asp}, \code{ann}, \code{axes}, \code{frame.plot}, \code{panel.first}, \code{panel.last}, \code{cex.lab}, \code{cex.axis}, \code{cex.main}) or according to the number of lines within one plot (other parameters e.g. \code{col}, \code{lty}, \code{lwd} etc.) so it is possible to assign specific axis labels to individual plots, resp. different plotting style. Plotting parameter \code{ylim}, or \code{xlim} can also be a list to assign different axis limits to individual plots. Similarly, the graphical parameters for observed data, as passed by \code{obspar} can be vectorized, according to the number of observed data sets. Image plots will only work for 1-D and 2-D variables, as solved with \code{\link{ode.1D}} and \code{\link{ode.2D}}. In the first case, an image with \code{times} as x- and the \code{grid} as y-axis will be created. In the second case, an x-y plot will be created, for all times. Unless \code{ask = FALSE}, the user will be asked to confirm page changes. Via argument \code{mtext}, it is possible to label each page in case of 2D output. For images, it is possible to pass an argument \code{method} which can take the values "image" (default), "filled.contour", "contour" or "persp", in order to use the respective plotting method. \code{plot} and \code{matplot.0D} will always have \code{times} on the x-axis. For problems solved with \code{ode.1D}, it may be more useful to use \code{plot.1D} or \code{matplot.1D} which will plot how spatial variables change with time. These plots will have the \code{grid} on the x-axis. } \seealso{ \code{\link{deSolve}}, \code{\link{ode}}, \code{\link{print.deSolve}}, \code{\link[graphics]{hist}} \code{\link[graphics]{image}} \code{\link[graphics]{matplot}}, \code{\link[graphics]{plot}.default} for the underlying functions from package \pkg{graphics}, \code{\link{ode.2D}}, for an example of using \code{subset} with \code{arr = TRUE}. } \examples{ ## ======================================================================= ## Example 1. A Predator-Prey model with 4 species in matrix formulation ## ======================================================================= LVmatrix <- function(t, n, parms) { with(parms, { dn <- r * n + n * (A \%*\% n) return(list(c(dn))) }) } parms <- list( r = c(r1 = 0.1, r2 = 0.1, r3 = -0.1, r4 = -0.1), A = matrix(c(0.0, 0.0, -0.2, 0.01, # prey 1 0.0, 0.0, 0.02, -0.1, # prey 2 0.2, 0.02, 0.0, 0.0, # predator 1; prefers prey 1 0.01, 0.1, 0.0, 0.0), # predator 2; prefers prey 2 nrow = 4, ncol = 4, byrow=TRUE) ) times <- seq(from = 0, to = 500, by = 0.1) y <- c(prey1 = 1, prey2 = 1, pred1 = 2, pred2 = 2) out <- ode(y, times, LVmatrix, parms) ## Basic line plot plot(out, type = "l") ## User-specified axis labels plot(out, type = "l", ylab = c("Prey 1", "Prey 2", "Pred 1", "Pred 2"), xlab = "Time (d)", main = "Time Series") ## Set user-defined mfrow pm <- par (mfrow = c(2, 2)) ## "mfrow=NULL" keeps user-defined mfrow plot(out, which = c("prey1", "pred2"), mfrow = NULL, type = "l", lwd = 2) plot(out[,"prey1"], out[,"pred1"], xlab="prey1", ylab = "pred1", type = "l", lwd = 2) plot(out[,"prey2"], out[,"pred2"], xlab = "prey2", ylab = "pred2", type = "l",lwd = 2) ## restore graphics parameters par ("mfrow" = pm) ## Plot all in one figure, using matplot matplot.0D(out, lwd = 2) ## Split y-variables in two groups matplot.0D(out, which = list(c(1,3), c(2,4)), lty = 1, ylab = c("prey1,pred1", "prey2,pred2")) ## ======================================================================= ## Example 2. Add second and third output, and observations ## ======================================================================= # New runs with different parameter settings parms2 <- parms parms2$r[1] <- 0.2 out2 <- ode(y, times, LVmatrix, parms2) # New runs with different parameter settings parms3 <- parms parms3$r[1] <- 0.05 out3 <- ode(y, times, LVmatrix, parms3) # plot all three outputs plot(out, out2, out3, type = "l", ylab = c("Prey 1", "Prey 2", "Pred 1", "Pred 2"), xlab = "Time (d)", main = "Time Series", col = c("red", "blue", "darkred")) ## 'observed' data obs <- as.data.frame(out[out[,1] \%in\% seq(10, 500, by = 30), ]) plot(out, which = "prey1", type = "l", obs = obs, obspar = list(pch = 18, cex = 2)) plot(out, type = "l", obs = obs, col = "red") matplot.0D(out, which = c("prey1", "pred1"), type = "l", obs = obs) ## second set of 'observed' data and two outputs obs2 <- as.data.frame(out2[out2[,1] \%in\% seq(10, 500, by = 50), ]) ## manual xlim, log plot(out, out2, type = "l", obs = list(obs, obs2), col = c("red", "blue"), obspar = list(pch = 18:19, cex = 2, col = c("red", "blue")), log = c("y", ""), which = c("prey1", "prey1"), xlim = list(c(100, 500), c(0, 400))) ## data in 'long' format OBS <- data.frame(name = c(rep("prey1", 3), rep("prey2", 2)), time = c(10, 100, 250, 10, 400), value = c(0.05, 0.04, 0.7, 0.5, 1)) OBS plot(out, obs = OBS, obspar = c(pch = 18, cex = 2)) # a subset only: plot(out, subset = prey1 < 0.5, type = "p") # Simple histogram hist(out, col = "darkblue", breaks = 50) hist(out, col = "darkblue", breaks = 50, subset = prey1<1 & prey2 < 1) # different parameters per plot hist(out, col = c("darkblue", "red", "orange", "black"), breaks = c(10,50)) ## ======================================================================= ## The Aphid model from Soetaert and Herman, 2009. ## A practical guide to ecological modelling. ## Using R as a simulation platform. Springer. ## ======================================================================= ## 1-D diffusion model ## ================ ## Model equations ## ================ Aphid <- function(t, APHIDS, parameters) { deltax <- c (0.5, rep(1, numboxes - 1), 0.5) Flux <- -D * diff(c(0, APHIDS, 0))/deltax dAPHIDS <- -diff(Flux)/delx + APHIDS * r list(dAPHIDS, Flux = Flux) } ## ================== ## Model application ## ================== ## the model parameters: D <- 0.3 # m2/day diffusion rate r <- 0.01 # /day net growth rate delx <- 1 # m thickness of boxes numboxes <- 60 ## distance of boxes on plant, m, 1 m intervals Distance <- seq(from = 0.5, by = delx, length.out = numboxes) ## Initial conditions, ind/m2 ## aphids present only on two central boxes APHIDS <- rep(0, times = numboxes) APHIDS[30:31] <- 1 state <- c(APHIDS = APHIDS) # initialise state variables ## RUNNING the model: times <- seq(0, 200, by = 1) # output wanted at these time intervals out <- ode.1D(state, times, Aphid, parms = 0, nspec = 1, names = "Aphid") image(out, grid = Distance, main = "Aphid model", ylab = "distance, m", legend = TRUE) ## restricting time image(out, grid = Distance, main = "Aphid model", ylab = "distance, m", legend = TRUE, subset = time < 100) image(out, grid = Distance, main = "Aphid model", ylab = "distance, m", method = "persp", border = NA, theta = 30) FluxAphid <- subset(out, select = "Flux", subset = time < 50) matplot.1D(out, type = "l", lwd = 2, xyswap = TRUE, lty = 1) matplot.1D(out, type = "l", lwd = 2, xyswap = TRUE, lty = 1, subset = time < 50) matplot.1D(out, type = "l", lwd = 2, xyswap = TRUE, lty = 1, subset = time \%in\% seq(0, 200, by = 10), col = "grey") \dontrun{ plot(out, ask = FALSE, mfrow = c(1, 1)) plot.1D(out, ask = FALSE, type = "l", lwd = 2, xyswap = TRUE) } ## see help file for ode.2D for images of 2D variables } \keyword{ hplot } deSolve/man/ode.2D.Rd0000754000175100001440000003141012477565367013775 0ustar hornikusers\name{ode.2D} \alias{ode.2D} \title{Solver for 2-Dimensional Ordinary Differential Equations} \description{ Solves a system of ordinary differential equations resulting from 2-Dimensional partial differential equations that have been converted to ODEs by numerical differencing. } \usage{ ode.2D(y, times, func, parms, nspec = NULL, dimens, method= c("lsodes", "euler", "rk4", "ode23", "ode45", "adams", "iteration"), names = NULL, cyclicBnd = NULL, ...) } \arguments{ \item{y }{the initial (state) values for the ODE system, a vector. If \code{y} has a name attribute, the names will be used to label the output matrix. } \item{times }{time sequence for which output is wanted; the first value of \code{times} must be the initial time. } \item{func }{either an \R-function that computes the values of the derivatives in the ODE system (the model definition) at time \code{t}, or a character string giving the name of a compiled function in a dynamically loaded shared library. If \code{func} is an \R-function, it must be defined as: \code{func <- function(t, y, parms, ...)}. \code{t} is the current time point in the integration, \code{y} is the current estimate of the variables in the ODE system. If the initial values \code{y} has a \code{names} attribute, the names will be available inside \code{func}. \code{parms} is a vector or list of parameters; \code{...} (optional) are any other arguments passed to the function. The return value of \code{func} should be a list, whose first element is a vector containing the derivatives of \code{y} with respect to \code{time}, and whose next elements are global values that are required at each point in \code{times}. The derivatives must be specified in the \bold{same order} as the state variables \code{y}. } \item{parms }{parameters passed to \code{func}.} \item{nspec }{the number of \bold{species} (components) in the model.} \item{dimens}{2-valued vector with the number of \bold{boxes} in two dimensions in the model. } \item{cyclicBnd }{if not \code{NULL} then a number or a 2-valued vector with the dimensions where a cyclic boundary is used - \code{1}: x-dimension, \code{2}: y-dimension; see details. } \item{names }{the names of the components; used for plotting. } \item{method }{the integrator. Use \code{"lsodes"} if the model is very stiff; \code{"impAdams"} may be best suited for mildly stiff problems; \code{"euler", "rk4", "ode23", "ode45", "adams"} are most efficient for non-stiff problems. Also allowed is to pass an integrator \code{function}. Use one of the other Runge-Kutta methods via \code{rkMethod}. For instance, \code{method = rkMethod("ode45ck")} will trigger the Cash-Karp method of order 4(5). If \code{"lsodes"} is used, then also the size of the work array should be specified (\code{lrw}) (see \link{lsodes}). Method \code{"iteration"} is special in that here the function \code{func} should return the new value of the state variables rather than the rate of change. This can be used for individual based models, for difference equations, or in those cases where the integration is performed within \code{func}) } \item{... }{additional arguments passed to \code{lsodes}.} } \value{ A matrix of class \code{deSolve} with up to as many rows as elements in times and as many columns as elements in \code{y} plus the number of "global" values returned in the second element of the return from \code{func}, plus an additional column (the first) for the time value. There will be one row for each element in \code{times} unless the integrator returns with an unrecoverable error. If \code{y} has a names attribute, it will be used to label the columns of the output value. The output will have the attributes \code{istate}, and \code{rstate}, two vectors with several useful elements. The first element of istate returns the conditions under which the last call to the integrator returned. Normal is \code{istate = 2}. If \code{verbose = TRUE}, the settings of istate and rstate will be written to the screen. See the help for the selected integrator for details. } \note{ It is advisable though not mandatory to specify \bold{both} \code{nspec} and \code{dimens}. In this case, the solver can check whether the input makes sense (as \code{nspec * dimens[1] * dimens[2] == length(y)}). Do \bold{not} use this method for problems that are not 2D! } \author{Karline Soetaert } \examples{ ## ======================================================================= ## A Lotka-Volterra predator-prey model with predator and prey ## dispersing in 2 dimensions ## ======================================================================= ## ================== ## Model definitions ## ================== lvmod2D <- function (time, state, pars, N, Da, dx) { NN <- N*N Prey <- matrix(nrow = N, ncol = N,state[1:NN]) Pred <- matrix(nrow = N, ncol = N,state[(NN+1):(2*NN)]) with (as.list(pars), { ## Biology dPrey <- rGrow * Prey * (1- Prey/K) - rIng * Prey * Pred dPred <- rIng * Prey * Pred*assEff - rMort * Pred zero <- rep(0, N) ## 1. Fluxes in x-direction; zero fluxes near boundaries FluxPrey <- -Da * rbind(zero,(Prey[2:N,] - Prey[1:(N-1),]), zero)/dx FluxPred <- -Da * rbind(zero,(Pred[2:N,] - Pred[1:(N-1),]), zero)/dx ## Add flux gradient to rate of change dPrey <- dPrey - (FluxPrey[2:(N+1),] - FluxPrey[1:N,])/dx dPred <- dPred - (FluxPred[2:(N+1),] - FluxPred[1:N,])/dx ## 2. Fluxes in y-direction; zero fluxes near boundaries FluxPrey <- -Da * cbind(zero,(Prey[,2:N] - Prey[,1:(N-1)]), zero)/dx FluxPred <- -Da * cbind(zero,(Pred[,2:N] - Pred[,1:(N-1)]), zero)/dx ## Add flux gradient to rate of change dPrey <- dPrey - (FluxPrey[,2:(N+1)] - FluxPrey[,1:N])/dx dPred <- dPred - (FluxPred[,2:(N+1)] - FluxPred[,1:N])/dx return(list(c(as.vector(dPrey), as.vector(dPred)))) }) } ## =================== ## Model applications ## =================== pars <- c(rIng = 0.2, # /day, rate of ingestion rGrow = 1.0, # /day, growth rate of prey rMort = 0.2 , # /day, mortality rate of predator assEff = 0.5, # -, assimilation efficiency K = 5 ) # mmol/m3, carrying capacity R <- 20 # total length of surface, m N <- 50 # number of boxes in one direction dx <- R/N # thickness of each layer Da <- 0.05 # m2/d, dispersion coefficient NN <- N*N # total number of boxes ## initial conditions yini <- rep(0, 2*N*N) cc <- c((NN/2):(NN/2+1)+N/2, (NN/2):(NN/2+1)-N/2) yini[cc] <- yini[NN+cc] <- 1 ## solve model (5000 state variables... use Cash-Karp Runge-Kutta method times <- seq(0, 50, by = 1) out <- ode.2D(y = yini, times = times, func = lvmod2D, parms = pars, dimens = c(N, N), names = c("Prey", "Pred"), N = N, dx = dx, Da = Da, method = rkMethod("rk45ck")) diagnostics(out) summary(out) # Mean of prey concentration at each time step Prey <- subset(out, select = "Prey", arr = TRUE) dim(Prey) MeanPrey <- apply(Prey, MARGIN = 3, FUN = mean) plot(times, MeanPrey) \dontrun{ ## plot results Col <- colorRampPalette(c("#00007F", "blue", "#007FFF", "cyan", "#7FFF7F", "yellow", "#FF7F00", "red", "#7F0000")) for (i in seq(1, length(times), by = 1)) image(Prey[ , ,i], col = Col(100), xlab = , zlim = range(out[,2:(NN+1)])) ## similar, plotting both and adding a margin text with times: image(out, xlab = "x", ylab = "y", mtext = paste("time = ", times)) } select <- c(1, 40) image(out, xlab = "x", ylab = "y", mtext = "Lotka-Volterra in 2-D", subset = select, mfrow = c(2,2), legend = TRUE) # plot prey and pred at t = 10; first use subset to select data prey10 <- matrix (nrow = N, ncol = N, data = subset(out, select = "Prey", subset = (time == 10))) pred10 <- matrix (nrow = N, ncol = N, data = subset(out, select = "Pred", subset = (time == 10))) mf <- par(mfrow = c(1, 2)) image(prey10) image(pred10) par (mfrow = mf) # same, using deSolve's image: image(out, subset = (time == 10)) ## ======================================================================= ## An example with a cyclic boundary condition. ## Diffusion in 2-D; extra flux on 2 boundaries, ## cyclic boundary in y ## ======================================================================= diffusion2D <- function(t, Y, par) { y <- matrix(nrow = nx, ncol = ny, data = Y) # vector to 2-D matrix dY <- -r * y # consumption BNDx <- rep(1, nx) # boundary concentration BNDy <- rep(1, ny) # boundary concentration ## diffusion in X-direction; boundaries=imposed concentration Flux <- -Dx * rbind(y[1,] - BNDy, (y[2:nx,] - y[1:(nx-1),]), BNDy - y[nx,])/dx dY <- dY - (Flux[2:(nx+1),] - Flux[1:nx,])/dx ## diffusion in Y-direction Flux <- -Dy * cbind(y[,1] - BNDx, (y[,2:ny]-y[,1:(ny-1)]), BNDx - y[,ny])/dy dY <- dY - (Flux[,2:(ny+1)] - Flux[,1:ny])/dy ## extra flux on two sides dY[,1] <- dY[,1] + 10 dY[1,] <- dY[1,] + 10 ## and exchange between sides on y-direction dY[,ny] <- dY[,ny] + (y[,1] - y[,ny]) * 10 return(list(as.vector(dY))) } ## parameters dy <- dx <- 1 # grid size Dy <- Dx <- 1 # diffusion coeff, X- and Y-direction r <- 0.05 # consumption rate nx <- 50 ny <- 100 y <- matrix(nrow = nx, ncol = ny, 1) ## model most efficiently solved with lsodes - need to specify lrw print(system.time( ST3 <- ode.2D(y, times = 1:100, func = diffusion2D, parms = NULL, dimens = c(nx, ny), verbose = TRUE, names = "Y", lrw = 400000, atol = 1e-10, rtol = 1e-10, cyclicBnd = 2) )) # summary of 2-D variable summary(ST3) # plot output at t = 10 t10 <- matrix (nrow = nx, ncol = ny, data = subset(ST3, select = "Y", subset = (time == 10))) persp(t10, theta = 30, border = NA, phi = 70, col = "lightblue", shade = 0.5, box = FALSE) # image plot, using deSolve's image function image(ST3, subset = time == 10, method = "persp", theta = 30, border = NA, phi = 70, main = "", col = "lightblue", shade = 0.5, box = FALSE) \dontrun{ zlim <- range(ST3[, -1]) for (i in 2:nrow(ST3)) { y <- matrix(nrow = nx, ncol = ny, data = ST3[i, -1]) filled.contour(y, zlim = zlim, main = i) } # same image(ST3, method = "filled.contour") } } \details{ This is the method of choice for 2-dimensional models, that are only subjected to transport between adjacent layers. Based on the dimension of the problem, and if \code{lsodes} is used as the integrator, the method first calculates the sparsity pattern of the Jacobian, under the assumption that transport is only occurring between adjacent layers. Then \code{lsodes} is called to solve the problem. If the model is not stiff, then it is more efficient to use one of the explicit integration routines In some cases, a cyclic boundary condition exists. This is when the first boxes in x-or y-direction interact with the last boxes. In this case, there will be extra non-zero fringes in the Jacobian which need to be taken into account. The occurrence of cyclic boundaries can be toggled on by specifying argument \code{cyclicBnd}. For innstance, \code{cyclicBnd = 1} indicates that a cyclic boundary is required only for the x-direction, whereas \code{cyclicBnd = c(1,2)} imposes a cyclic boundary for both x- and y-direction. The default is no cyclic boundaries. If \code{lsodes} is used to integrate, it will probably be necessary to specify the length of the real work array, \code{lrw}. Although a reasonable guess of \code{lrw} is made, it is likely that this will be too low. In this case, \code{ode.2D} will return with an error message telling the size of the work array actually needed. In the second try then, set \code{lrw} equal to this number. For instance, if you get the error: \preformatted{ DLSODES- RWORK length is insufficient to proceed. Length needed is .ge. LENRW (=I1), exceeds LRW (=I2) In above message, I1 = 27627 I2 = 25932 } set \code{lrw} equal to 27627 or a higher value. See \link{lsodes} for the additional options. } \seealso{ \itemize{ \item \code{\link{ode}} for a general interface to most of the ODE solvers, \item \code{\link{ode.band}} for integrating models with a banded Jacobian \item \code{\link{ode.1D}} for integrating 1-D models \item \code{\link{ode.3D}} for integrating 3-D models \item \code{\link{lsodes}} for the integration options. } \code{\link{diagnostics}} to print diagnostic messages. } \keyword{math} deSolve/.Rinstignore0000754000175100001440000000005112352122161014166 0ustar hornikusersinst/doc/aphid.png inst/doc/image1D.png