deSolve/0000755000175100001440000000000012763274452011705 5ustar hornikusersdeSolve/inst/0000755000175100001440000000000012763247274012664 5ustar hornikusersdeSolve/inst/CITATION0000644000175100001440000000214112763247225014013 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/0000755000175100001440000000000012763247273013430 5ustar hornikusersdeSolve/inst/doc/compiledCode.pdf0000644000175100001440000153163212763247273016525 0ustar hornikusers%PDF-1.5 % 127 0 obj << /Length 3155 /Filter /FlateDecode >> stream xڥZI>j"#$ /$j[C#tMzTEV֭;|wN'I:yy_u'Z9;9H&VIZrq~afٛY$*CS͌V35]ϳ j^t:7IYz>~_g{nu j;`%\,Ib2:l!Ot0 2?ûڋ3-GKR]LMT{jJjՠo8Y$9EƁBmx),"``mV4N3s}/Hb_qaCk! N&!QqPX wMΫ7!΢d%)Upk H1X'nX_/pDyn/>d^Yt(zB)Z xif#QTOe_O'i HPKXTmc3xBB &e!G()8D=Wd]w\D9!,#s _^>lGA1$C_=' bI*CFM&hxkr/sRtt)&e((B?/eZ3nąŀw@6:H#e{5-C*n.)G `^<;K{q;|ȹB1ˮ,ߧBb%tu[)e=\ E ~-[FzB~nl%Y]E %SһpmSfzCqKł㝞dciu zu.քWE:1~>8)5DEt($ vq'zӡ-Ks [;f *+ZU4z7#@It׉ ˏ\hۻ3V|-Ȣ_qsিC*2_ƿ96B f]Vd%t6 oBpw^|y8JwbC`»ORe%RM2)GbO BR endstream endobj 147 0 obj << /Length 2801 /Filter /FlateDecode >> stream x]۸}^Sm(@Q$yPlmĶ,;E|hlEv-Rpf8#=YOWz„Ѫҕ\LJ3!ʅrjjgoE@A#DcQT /3[NY(z%x|7ȦE˙^¿vgNWc`wݪ'ȿJ?=na 7na+[yap3;$dgL[JlMᔵ~2w`^[/7X&i@tS$: |PAi\!suݵlH+}>L'xvaJk> 枻Aq)RTܟvKgA3xLH{Q"ʆ)6NNќz0{br<VAin!W)>JnxCz`Y:>x؇ Q*e=|<-Ӷo4M^vܟD|OLi_ǟpY//O/S?-^$V{HdG0$ז}8P㈏ ^Eri+T񅺽)W]c$Qzh u*rBT8ߦ;a+E凹5x翽!Gnc|#j!5]fP +Ti:U-.pjxs]Z$gv>X BrwE!2EƆKq,ʋe]u1TaA.Hs˦p)=f\4ݨ7~b5*A-BTP^ xϣ `c)7U@̝V.RRXAmaBxL]2'8CW*mU.*~ZNM.k4˾;l~I?Ҭ9zCRZ5=P- ȓTPJoh sSV2#P|;??(BRKhXd#gr̝ŠcJz oscWjvGwPHhkQ9$H \eӑQհu1(iP'v5<wNwPơٍq*|*kS# ^Ԉ-$EڬY* 3GW_%O#8Ys*gS]K}jnmjY 6J2-/rETAuQNR1̻鼎9/H}8C{SaɃԎ6ykA$J\/Hr=L0J ,0ǔ7+Z>x8ϥ:eUݥj7&VsMw}eax!_w?ӻG"=bnifѬ PCdAPs>7㝬v{!1b^(@gg,~}/o{< endstream endobj 163 0 obj << /Length 1967 /Filter /FlateDecode >> stream xڽXmo6_!`_䮖E[[S.Pm(ӸTdCn "s;;/Y0(ByJ Q%YPDwZy_/[x-Z3O(_@Ot7H3W8 $5>#%tm%*$q [~W-n]ZӧcHDA'OB4P6>=.KYs%:]vW /L CR]:aĈOr({s*Wl qұ`BbZCŀż~e ^YFr1)1=>}) $&)|"fЫ`6Q]i)yͥb'J c/s WRA,LL􂖞W<1T6/2LP Oc?F%PxlyޞN!=#Мp[qҙsAbD7_uKʷ&qz.kA!^0 D't'Ypj0|9 [j'@wd}{Q:/s~Hx}Pw҃>()ur苪 e;"p [qU9f4aV˱B.9")%1'la)IioEL7,ӛMG %R7%{K0;Dh#p6aX{XJt]L,i ki`XL_}28B1':,WZlz+ƣgۜ C{*g.bFD#9o">Bd.l~z |*Ixb/%  X;Z1xwSBP r99DDFLC q_8c ~Zf?#T;t6$$nO8R0v Ϟ1#2PgE?3)OY5fVe"C!B!֍` SQF`Iȶs8bMx]IPʺ f˔5JhZo 9ldaPș>蜇m'Ƀ֔s8ct~\&-f~~¿2 wԺ?>VCu63}% 67̍,I]&L}oB"˲ FK&[1  y5ABeX 4O]P*7U`#<)O\2'eRJbL14N؜j v26A}A?0 tmR\O̭ڸ;QhYՖñ3D [pcMztnV̺k"Nc)tbc@ v=)6 3K0a\um'|hiB+#8KtLGerYd)IȇwB~c~+SѮ򥓴7P8Sἕvi;H%3,Ff<(͂(@0}9a)w)8d#tW(ܧ1Md_c5gB&s{*dŋhQmkd`„)ww)AМ8>;=NTUPzaddfxboRv-OFթIyۛ`O.a+rd6) .mO3AVQ#/3ך Տ3agD ,> DٽLv WV̭@ F( K$%b5djbh[KiPX=t.{NnEٽzxJř'\tבozG& 3N?fqk[=8`J:v}^˔Pg}&M _ endstream endobj 171 0 obj << /Length 1450 /Filter /FlateDecode >> stream xXK60Z+Hz͡M"(Z=lsUKv-;C%Ңmm)r̓Cr|~~tq}Ql0 r6dBFm ߏ^C$\"YdM4- OCxȳa(ӠOifJ0q4` l-COp%(I[g s+bP&SMfir-,QDSXkG,ELF)8!ˊ(e `4հ>ACXLw-4BG 5d"I{i~~i4Ϣa5*! {(X wV·YXkf{vg"ja>RCLIwH;Ta7z胊|]ZJhcq}qƵpR[z)4%7?{b6}5u@o4MKYۿ֟mg%~0Epn2bd85JXmTYKs߬G:ExTܼ_@@W7hjԥmfZX}ORI`[ kG,-\5YR݆IQ*+eLLײKeſ#)kJ@6G+nʥHD}tbO=Q $Q*P  i8&b Nu #}m'Tr(t_r|8M.3tWS0ujZi,L):Ըv Ճ J4T3yVZZA"D*oCH WuØ n7jRS%in A$񀁶à_$V} g|YN`vXkA4 F;gi\<3gPy*sMTxdJHy"35=$JRsgc<6py_.neږ*3vz4^xٶ&e0kEJ8m.(gk7YxeMݺ.rj ȲMoB2 endstream endobj 179 0 obj << /Length 3513 /Filter /FlateDecode >> stream xZIPNFH"q<)iwUcؒz%Q2۰Pf/IMMA{&j򏫿^}V])_y=SNIZ卛.&^i?'1f#\׳.8g vxG|5΄8?l_wV忋Wi_Y;:c8lObᜫJ[ոn23NuMÓk5=y?O!YG~[( oG2t^ ;/H\ y)ux @-7k5?P|rum˷a>M?f{^d%hs滺F\5~ Қ:Of(g=DR!E?UڢF ?x Y)^\ =r"c|=m63D73?jfT[B}BqFhq.,NRy`Z˒\[آns&Lҍn7h5;h A AV{S"RaɩuiZގMd{ft9e?`lB^DN>Q[y+ddr)SW^ՕyOk3 j[ḓT h62/ADT⨒_A/)a56 2FDy(%LӆWJZFzDxo4W;a7OoV<}J9Yڏus(Ȕ(ITøbJbLp)v,K1짤c.HǶ}H,6 y>%Ez*S)%aRѾ@co>_ݩHedgE )K"* os.VnQdOI#LB0|;%܎d7vm iiUDXN:&J X5a"B-q M5U3 '\4UQ 9ߨz~v!}zK률O5JQb;~O,)(-nȞ P끉r=zq`i .Y1q=++܀!Q+# Vΐ!^b J5MoȌaJӅ)gѪK)F73<^bS,ד0$\@G/I/V&C)P(תD~1,|!lNbi&)@䆎D*M]w = Ǎ)T{8*Q$4GtAu#& CcXjV`w!i_jO#HQ5b4n_2X% h (0h+|_d9PxFOwZqhd|Zqlt6sVJ'$ F6JޥT%Erfޔ}֔pƖ>t `$5zzW/ӂ4\l`Rel'cZeMQ,ta@uS0O;}?&;l} v@[ۊAK@de=j} Q nLa^0Bnǩكʽƾ7]7t; 6s~d$V]]tD.1vMN7dɐc ē^̼*E#z@ !/rV 1и?ko=+O4{:01 ]9/.D gԅMo4pt~=r2 dCnI~9oƾ&4L2Dї%#ʐ:``9heį7H`i2Mf7r^/jkl?l߶ma絼h[JwotL&87w=ba?W ZĶ +եRLܿ嵪%/X2@3>BrK줿0 ?ҽŷW&3fN9U=|6*RCa[eO@W]Xe$6vg=YMg:oVs*t5}! bN& ^nvshW┆DN9h4(s{#1%X@ 0Ƨp!m\ڔβqUi:NA:,|$atLm +ϙW\~{p}Hr}\EaATk*Cۚt*"Q VVCBn_~\0*Jє;vefyK&p8#퍌NYo#/iw9?Iv }GS6u|WBK bGX:rV %ER:}ԧGFod6V=m˧\N3=V4ͷ˻jqH,x0F+XcQ9Ɉϡ@% > r߉k<~XLN9of3 ~#{Ps?ĤT>.}L3s}@aȺP&ӁyHۣ݋}OdT`d'v۬3ʆVK=},dކO2֢iSJ* S\}n^[յzKi\hA<jZ-n3dKf룻Y@!1PJ&!g;s^.#vlRflKL2ؘj[sIHp:[-ľrA}%ߒN>"٫b_9Kw endstream endobj 2 0 obj << /Type /ObjStm /N 100 /First 820 /Length 2288 /Filter /FlateDecode >> stream xZrܸ}:e_R(딓uUIUgH-~}N\$K#*9HLAw-`sE&bR0RLYǤgZ30hctxLR8@"pBX1{S0` #~A`<  (Ld5+ڜ68f?&ݬ/mU>a?_Փ!,a6H$GLJ[1t{ex5YdhR{5\єdh}f4e۝/inE%um ݿL4Sy*X2Bboۯ1~ ~x# ?]zk-Yz[,AVBYbga)S!-GsXLF2se{sW6,r ѡB{XPmköP}rϷDZ~jTyPU$ɶZFK'||-u$[qڣKutq1~7mnv?E~2{բl?}WgiWUB1+NfIӯ+^QqD^Ryj٬Z#uFP-j'C<BJ^ Ii*(vw }Dnen3x*l3gT rVϛvZiFxQ !rAĩ w.;g2erуt-T0E{.Ysq0?ܒwD䆪yDid| !:x0&pDh!DlK׿]Pz#Wٵb:]'NpRK9I_D>yZ:[n3 /4쟺?tAmm&H88OXqZ}..#s9GnǸ[eGLBCiO%'qߎ_Ӏ/Wr;.vdͽ ;~;8"0 ʆ6|W8}%Lrrʁ\'8i{vtLY]sVJYAPx]6~A~zu.ϟ?Ū6ϖ}zQ-i5q? @ƠcgT@n tDURXvaHN#ľ㝹N莡}v6ϛ]ŢW%ŬnwVieG [XPiKnvNNZ]Xmv<"ۻ}Wg,ŭ̽#F'*tCf7Vb,3|ww!z Z7acW7MuVªWشTX @!b7ϖ1ȧV K 5˫YnjpO> endstream endobj 194 0 obj << /Length 1230 /Filter /FlateDecode >> stream xڵXK6 $%+Y$Ic;tNdKuג]?/A&d{92E$$‹nLH8*x{ ^QRoZ{Y][BiT7!D>I<6E,+o-j ̯ -Lp%gͯS߸Z ;i!Eo\s/w abȡԍ8n`OV|-%~:>Z7w&F]i I^F)qڲLœaJb8Eρĝ%qfQގ55z5T 1o7j+bD@I6J"7vcfmx4ڠ.ؚW;e` p©44 >:P4 8G1|kf`<^ LiVD57=Mog{ABӷȽS=Y373r:2#N\." !."4l ˱:;j\_`ұR\]_vP_]ď?TB*o^GDZO#Jn.sVW:ZQיC3t6f$ƯC-:^U|c`J\I='[Fqˮ t/ O3_h'˿^ B2JJT:,rïLqh-hUL5[eƲo+| 3;]oUOv MmPuj̡1(0jF+W+*[Kw -?E>T`xQF!K|YL V&Q+ :ve)\P%R/-NZJdr:(džB݈AC% 9GS'ћ[,1+xSvU+ ^di=79W{z۹_Qrk<.Ҫ")ONrH$e)FnW[MB;Yɉ@DBq*1z`,"~z?_] endstream endobj 198 0 obj << /Length 2272 /Filter /FlateDecode >> stream xYm6B}X3$Em-6.ej[[n7Rnayyf8drOO_2QRTRrʒ"+DfɲI~}=W.4MgoHKK|g-#%t\Jyi-]wüvF?/zIT2= \HVKS%J*4/Q"DD0x/2)gW* h f)S9k֨POv=^VZK;4M0YtB+!UA.ej-d=d8vMTznP.+41 I I=溜/Cد7A{)Vj0*ݡ ʲ7Z>6i>4jrl ZI#~t3Y|I&OdIأBPbw$LVcȞ)@E@."2YTd8atBZvPN>4mSr6TpfYy^9d-7C8, 5te={gk],;`vSnتE Ox҃{!/B:YJT:wjٿ jbj$ܞ RNgBߘ>s/ uO1j*7{1>d^"AVp5ula).jͲ*ƒ\=Ҙ_2ѐUir.s!88~R͎bfu}t6_ʄH#Luiuhsl{8cU=$Eoc in%hyuzLuZXlZ4Ծ5!!Sbf F2m놸/^b(; @ulԇ>[no&ŎmS}x؉#> S>0=t>-28?/25ݮ(APc@ W=rTUvaäs|GጿXfs-=>ۓ NHצ\jPr75:9l'96׆A9™'?悚5_#ٚx7%P(s"0y?QT5!=T OywO.'J';2ɟ2F@;~Ư<P]Y0-CxOMA0s_ jQey8nviϧ@T- Y?&^qORŁIHsә(wzpiΩ'݁zb>c 0fKlFSN|}ݹPA{q:`D-FMA8}ƪBƢq V5t`߹ D=[L$k;y|KYuu(~mF&5u5l|6ñMMxWG|{zu}/}ԨPM5hIJ4q$t*\X Stb*.))P;E/얃)^0ȠBcWhխ^#l m}Xv.y5NTPn(a1E2u%r+/Lu'['g E {ź$X'AOMs;/=4}>767U17*ƽS`7uEh ¼ AO3%'s{nKbzǐ>W^X}vCy[w&Nb ξa FP?aۺHJs]X"Exb 'm=09Ȏ$1`h1qvOSPiH%a@pOo9U[L.Y (G6nCR,&jE!c9`H1P,dxZ<> stream xڝZmܶ_qm^E(M"M ~HBxWH{>;JRZ!93CWWշ|oL~eҤNksuswU2/:˯nW?orB'U^DI4&Ǣ׶Z5k[]Ūoe* ti{mVO3j^.^_3uVz?v%[}M#m˴U>x9b2MoȷYūT8ڔuRjG>`B 4Q_`v2CHPtOWBD=uT'B~4l?(!~ my#vNs2h%"1Mllf#86Y%;[ݏDJPOJҫd'ZHOMFȓ˪̓nXD48rE%ihTip9pùh?d^|lrMs.szr#e(u pv*Qom7]Lژ:|0;R&ioHdhɼ,44c}#ȚD ~hueuƑP9 ɦ6ԷcÂ7H2XDￇYk:GHamzs=d[`:CbL@KCUU{Ĉ-r .ko*0 ny]8=g@ͬ$ϞWLcT״Xݑfؿ-?wq;aeIK8oEV WD"I}~l6=jKͧHB{*M\U\6QY u1,9mUIn{2)1L-hZ1G8 -r p vЮJ؟7 URgN t£p oW?,!ϓeګ ̱[RWLa%hjQ`6k8 ;/N&EV>qK+ [*E )bLSyYB)i)ӹ&qab%n1Gj D˾):iޠ_LqRډ"U[MZ'v)uߋy|4 j+;;VAv%^1 l6g䑵6PE!M8gR]oK6a(5n([К:DxШ_D'&*;eAl5b?2q>X`{t u'+peMޣΣF?Jk1Z$o0VYXDN((piֻ|&K:ۖFJO?DwM`9& L . y9B/dѴW %'(!$JؽbȽT5C@;h|c9ğHl5QgS嵕N)+$]Vl(ySMS>rsvAAȤ/4b䜑pѦbxgU ʗꙵO7f}Zp3"Uʋƨ<'%ŵFv]֖/F0!o1(=/]z݉]S0|2N>t2^<8=zuf:Opy}J; ?uYĠ}Gʒ8*+ųR],U pq^c4 N w^۩y^;sQ+*'8xaϨ2lF@KzWJa$ =Tӊb%؀MtURi5=窨OzHN+A|eAӭTWo. 3DŽk:\F"-! GCC+ŵ٫ L%-_k2% uYJn֚>d4XRϨ0ie&W ͣ- #c 4k67I꜏V[_s1VRk{A҉ZP]Ǵ\Fyr")ɕ֟4LW;,ݪ؟+gi}nbo_VvPM@qh*M68&7P z5=H+Ɩ/> stream xڽYsF_$`xЖĝvc+?RNÖcBΑt~)z{xmHd{ ϏЋX$*}Mo2g +mRSAL&^=A{i &9ݾkYJxbgP>ϖ̖~ʁB.J|Ҭ!.)B% AOT!4 Ɋ&Z^[D?Nپ%@5[F 3{oJ?۳p h'dbH>l<&ގ~|F{_XFFr߱uB,p΀h %r3YW4csEInƦ>giAUr|_hfXx:#Xga28 ^ÒJV8eMlmt`]!o}NNu/c.{~o = P+YMl 8os!qN`>;k ?"02 X66޲]PR2}%gYyML/a;)u|GNO3>8amӰ`A x]{:LO?JoP/wO i{iB: /_\S(;)d3Z͟5(i[G%_n+e+ݜiq%ɺ.egQӎ1 3 #jDFTS$˳;%Bz Z:چ^2>skٱ\ +$utyO3@DWrݩ$:"ra1-ןLfP[uS2qn$ׄ&4p#gJ;sOKqPT,ʓy)Id[j k %}P̨\ɒ^-iN;b@W*_i$us#)bG bI42ҏi@CӕoZUq 2}|ZجYbl#dKڳx>#ba~n l:Rnݨ*"!f^mw4"4AqH;(B#p3Ruf"H~o + pDa(H6PP& ;KC~w22"|Ηs21X0}"t]wa[O2C<<)Νq:)uG,XU-;~/hH un @HDm  endstream endobj 218 0 obj << /Length 1915 /Filter /FlateDecode >> stream xYs6 _ۓ,?D]֤G>zGg'Mӿ~ JC;mv9Y"  22=t߇9}F'ڠqoq̖W5Y@ډ}c9oc ?:P/Z.LE! ;1@p3`MpA #|DžrljFqS3 d9F4좥r͡ gLWe@e~Lgu.I[):jxB & ggX1N`Ze[L0.)6uv7cD_`^R Fо\y;*sPDN X /d8b~Q%rT-m-h^9򊹍!dκnj89@dHDpإ5DssT+_*37LE!L8܇ 8W $1( 7;)/wNetE#)-$gm(!IāRϡ&^pUsB&.LE3A Pnѭy :HG>l%8:~!(z҂rHCO.HoZ*/̭nYBCxhJߺS^ӌ> stream xڥZYsF~`Lc fplQjw+LBc^(+O_3#J>$?._(NTTzry5y2MP&gzZ^f67Llci Hh:|5,3+,˿˖~_i/zyT([f'5z//sHds-oYjkh{-\c%pKґvBtMJ7~/cdT0nJH\fD&_SzaڨV' vYd#|7p]\.6 u%R8yjUeW]o7Cr=[ :7βdzSK'hΧMCƃw4KQoa}+xKITokvǍg3fӯ_fiyƒXIaQ+ꍈ#}4{¸aWk(߿ !f*wE”CVg,_{&JKX.X7s~m$t\D$w13xt_ ;5 .V`;rT n:ǽZ# 0$L Oy+l3Ac>3g^#k|8ync:;B&'Pp}wpܨZH?vZ% !!m4`*-~]l*kK7ˡRtfĘk1,eDaZN+$"$* tuS2xqid D`?(6Lw(>mnVX=R u'Q!ۡ$kK4[s/q$G`҅nf`>ԺJ҇u$X}~%ʦ0Ca BL, Ӟ'qc֭3d|x2-F0Re!!1EKP]|g%"2SzYH//*-BǂLL"A-Hu% s8ln01 .fˆ]b=( YcR@ } '9BHM(H<ϢhL\0[&L\s<,˧u #.Aݯ~a@5 4d]S/lPmǶf;U7W?Jo%= ,|"F@K6{qi6bjCQDܕ9@k!G&%(;4p2)b2Obk@&`=t:(02^rxiHxLi,2Ra>L10T:rⲬrYI0 q^=&%iY<G,o׹:8qM#&ð4UzZŘ@VCPG~ƶ.O ة7cA~ dqJ*ҹ vYkθ ]S$,*a +s^._;d7񘴦<N98$QqOgeǣ>BG:ApG;n_7H [I֋6b/Pd1*,QEᾍic ]\.JPg\cq*E=D6(4v')zdYyzV\Zpb#vnKD|rr#5 y ɒ9i|bKײkC?z59 + ߟA:X 6Fa6^ *#)Wuׄ9mHANc,@]HGxQRQʓ"q̿iSHGe!A-K{\DXCr4 :qS@{0ݱ)E)xr}=/1: m5O؁,p_i-H/5}xa9 |m`X^T*zxl<}(o4\@U[.eqPYqr({~مN1!H%0{5X4kqt甥_ֽ[8չ͝v^+OJ@u۪ \+֓c8 ‰u FYRM 砋.i%bؒgFlmU)!<ǟH'J1DŽ [.`ނ%+j_ ğkY ՝)4oznz*E.K.,P4P"F?_`q؇3*e62)(3sbsS(Tk!"G(҇<#NtE1|5ݹI4 #eh{r DRqXrذ:ciFXiUM}i16: ;hX3:K'@~M,*+uXH٪/Z9bsr2` 2&*t$pV؄ڝf"ݦ9 A:Þҧ#RmtZj/4?R{2]B6J_> stream xMsF_ArB,g=tRɊP}‚WՎ.zg?L.Yh1MYӹ0+c75-mO~Nb*e.gLА0$tT2;'~lM%Mt n1avųzp.MV}u>qmv)0[^n_J(vķ w?gŽxB7#׋t Bύrx&Q6gKrqvVP =8Gp[] "/kA$W#t˩AnP Ź)tj-x'2ָotsyu6֊@ڽb_=.Ŀ9SaUZ=;r/KCf8/`z)!;Jb1B<jE&(UU$8|G& >6xIZz)+Kaexו|:E_ޣTՎWR\i{/V"#;h*zDO)e7O0 C!MsЍ9ꕀx5݂y3ba!rAF.Zt h\y2hKFr"1wtB1)$;Q!'B:{<<*$)OFC5mwH#I;=}U߼'ǯM%pp+q!|ˊimO;1ybl`MyŃObxYVPnMf= >5L00O2>f"trUvCC4%n |ٴx$"MUk4w&>ޒrXco$6ml}m M7փq 4a(kiX*1L[hmhCmԪǢaiWݲfuWϻ8o5 ?xt7󿜦eSsB(ybt(_?zz_e% %e{D?jvi5L}P00D@t=|NdM#-Et8֌܄GZ;J&|{~OzJOYtQPΗ2X0G@뙲U>p k Vp4vQ!g]P-ߧ) h0 ZI}xBW>qn*$Pz惛CMDmѻ- m&."]yKZv '1X(ȩ]C4$nyZ3l5KCQ˵k(> x`}c'g52r~,G dY&ǏYCX3u #nuߌS콖;pɦ:?:0^Z$+}Wr 0izI_M^ endstream endobj 236 0 obj << /Length 1716 /Filter /FlateDecode >> stream xڭr6_QEi:4vMd\!mg %J ʰM E/0.8xjwtŁ".D0:DGZ YT(&@e )-CT j08:}.`^iq38g Im覥k("9vQZEIAN#PGEGa`t)E1p  TKz ux^۩y:g9蘁_uWLziہQdPH'1 GzR{oCrq/J(SR>JhLm]iEע^k{-n!2Gq/w;v{\s{MbgJUhLtWRĚsx^e"BW\}&aYZR  x"-pAeq * ԑLs_8Aܳ5#آJ;ܹY%AڤU UL&)V+d"ukȡuj WC^RJFR$TÊ+kd3tƬ,o[9"2f m/t~؂FhIPs(?z6 (9JbH!uź`(<@Z,6%.E Ͼ\9`/}ta>L a\ރ'd,f!SoC_?gY3GU՞> ҂~,[zڵCCKUz٤G Š{|0^p\Wc8GmwխYg~|H'> xw/hQDO.)$E$&O1>|M d&qӤaJHê)vfƟr@K7ȕA]_:W? )`wEbnY^Oh3AWRM8R :9l1j 3j!ұ)-&q?@I~/ANó7{'/juJI]\4l}|A^;헌suL)x$m:>n rt İniA<&8^3][.8ׄ2*,iY)gdb( at]T&]S:)g #M1Y›nS$UgJ2fMK F[PyS{B {ĠQFr+Aa aFݬۃ%ϤVwHE;n$Ӣ;>=/w[ih f)YV%mH DZa 4y?s&xxG0&dJFfdpҼ=LYAEa~VuZ;ŔlZB^Bk.uWw:7r}wqdW%#[%P;bߺBr<(l]w}@I]ql}6[[/][cQihC A;'alVYfK18d;$-a],?Ow<"wnqOG=ŷ869\_>t5}Gqr5dA*z endstream endobj 244 0 obj << /Length 1427 /Filter /FlateDecode >> stream xYYo6~ϯ/rc)"uQuv]8m57_$</84)GnLpH `$'NI$YHPe\y0ÐdsVb)!\yHע4ɯѸCh> 3e3r'N?+;) >U+KvSaY[v9#iVJ8T^/UvcwV螨h9F?I~g@"8) Jtug݉H7=D9M?+\NEq  `ި k ˻FDz{uуF,rCn$BCpwc(L!b&?!(smٵk >-=q,e}{ڵ{k ̭F|lewgIQkУwq ,R0ϐn2I":]_FDnL|-kqaIIfE%h*;@J.,m$BB{I.GEk8 8X?i7rŸo PTqKONyctŴb?C8UCT.vnWwhGWxJOsUTnIDY3j[fXD$7M\&nSk]hu&͠_lfOE_ln-D&G [<lϞC;sh`ϡl%)E7âS;6i:|o HP7OM tM NijІ[PCOR:㢶ڡ |4;5W&sk->up ;j<3=i{4њq薲؅T!\]o-J[jF s4ga%[>RTrPKʁ/v`owg?{gRxA'ii2et1,܎tդº/ Ĕ~aD>P9}4x%<ԍB)A}.B=KP6֗z#A5R hjD%mfKt!ENb0a'SB: j3XgUp ݩPi+Lt2 endstream endobj 248 0 obj << /Length 850 /Filter /FlateDecode >> stream xn01L`%T˴e.UEö 4wlvtRվls3k<}^'ĞtQB^R{F2J+ V k QQ3A'<BnaUfKr Wg![1/%Kd|1{?֚!! hBNn "KlPOƾGփip G7%߬%+ys A iyqH%S0aT șFu[#z%0 )ڌ6m`#vChsuE6E!ƪ`X2J^Ȑ41Ѝ'! i WЌ!= &dУQ"xT<S"Px&K1iZʹ_!@py Ygh`-JDSK.{3Rq־w4!'JFFU\ O4"=$F;g.S:tw3ixHd*Y00~ػReiB5WQOjF¢xP5U+poitZ`kZXzNOv7dFtu2ՀOG>p6G tE'oSMWKyG ~B ڲ1{s5wrk"R{yj7f,R:f4M(,6H}ĮmǔHv"1/_׮\m[;+-j@3zG G$F؇C!S_L endstream endobj 241 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (./compiledCode-figcaraxis.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 251 0 R /BBox [0 0 936 432] /Resources << /ProcSet [ /PDF /Text ] /Font << /F2 252 0 R/F3 253 0 R>> /ExtGState << >>/ColorSpace << /sRGB 254 0 R >>>> /Length 8781 /Filter /FlateDecode >> stream x\Kq.HHDr dv>u=wH˔>^HdqzzQU]]͏_=w?)==uN3~_<~[q7oGz[~*[F?Q~m!gF|%C5g׳su9Z q?Gϩ< 1b}b{Nt5۳cb(k=,|y4-z^EWzbBU)|CX6ciabWӏbը|nܟ\c N=eAb*Fsx.|IYRMSV-=-4 q>Gu0b }i5rtB5 g9ch+ <=9~C x69ML g}C+~ΘHЕs,u5;傁P++#} 7e[otL9K?3%ֳP, ̈ Ň~T'q}}qP)ycjXKIz,:YSe֭Ծc#aﲿXV)QߥP= ~/<#%-Xgw_(^1gٳO 8Q>~M{ Q_^U(gɕT _N{My^bI/KOi/~ð] rDyD̅L^RPD<[B?o΋?t,?h?_)KL3}x 7 % +.S۴#w<_""-ז"_vC(~ٌdXǚCq,w71i ;㷦;O("Η0[~{ Cѥ?#Ηps\o:ΗCצ`|kL^b<ߠ#2VXfoFF9^F<"z=oCw y^?A{baƢ|cܲw1gڻXqw77ڻΟ}c}E{a/ d+aD ڧI{<畬q^yc8  { {}eJ{a/a𗰗`/QtP$Ԑ$~?#%ԌyC P3-eڞZa`IW>|؏%BIz9_㛏Qfۜv[JGx>C޾4w~}6q2GicxGqG [VJQ.8Ug0߽ǚߞ1(SpOlEGY9^挾(;1Bn:Ӫb14sC1JGyGf+]e/}fuze%3;T{&SE1z`2+;pGNV1/ K1_o[(,1k(˘* d*'{S(Gё_%!O$#:׸1a"]&O0Cw9٤7w>2q9ﺣ}^fN4; #'s@Or|GpLdz\f}@rA"Mͧ?7Q9ޒuαR1T6fcbrtY#Ol=aG" k(~mqqCxQ-8cY >$0bVG*DbKsVP !Pjh?F"dKrVM=2AC\ʉ0̤;2d↸C>r|*G92q!w2 CBd*ꕃaѝ`*L\:?rL9Ksc/. j1D܊p;821D;x>b߃"twL[w1l!n711!S0ldcK91!c C SblC[aCk|Wٳ*!2gzx.1boux]0TozF|lbof9Z׃k~"1gccCdT1D6X#*~͔ 3Ua"M$sj߅ w!LLS1뙄!&67ea19#lR-Hi/ ~g؝sbvH8O0Z1Y!&Y!f,=ϯY!dz0ބ!ܐ㍰50D?WaҬaOu ǛCrN S[X"k}epe6:>Ȍf8*Mo]͘T?I0ٌ!Vم!n3da1Mw Cׅ!b} HLĘqgIR<#)gx{bt>1D`*{{sо z b̙s<"7owCB 9̜yNb_4b:^9Әs qMA_Tq \Uss5/MTQl"Fxh.au.a5- ,c Cl!Z΋ ẀoC,m 6؄yd 1<^I"a!c+'F'Y"M!YeY !.}XIb, Q[ȅ9x{e\ebܟFy(W&xGNVmebUbU!VAǐ;9UdM#HkqZ-FRFL$a5bga>"k sܫCNEՁ>VD0i0Շ0>4a/a"ƸW''fВI=aFq0bwCD*_!Vc0kCV.ź*\+8Oa'>_S0ırK?!b|!x-a1>k Cl[ݵ!(EG Rq z";1yM]9Z"o~?'~'}i_ qJ '^-.Njq䫅/N/dW WK~y85#Z|0l",Rڗ"H|.2\/E?}. pX_ENjYI5Ah_ .;@竅{{ƫ{ BEcBVNcZ8}x'=; FRŶ{wr\]Bg ">\,_Y a 2Qw.S'@aI#}rF_f<4T7pZS-IVL~h&9亩2q)L(HԉNIN&̈O'mwI/2 ߋOڄ'! B$́!Ir|\Oi> hY|sOG"hY'}x|*mOYI  > h` n| Q-d-'A{OBڂgP$|C|s`}/a./ swWIrGf.8'KfRX$3 5~O*u7fEd\U^TJF3I&LlZh$Y$0]FxӀ#Rc)dk/.+7ɘG G3f̥Ą#˸#SGv2Ȃܳ#,x#0Gx#,y#0x#wمx# }F^ZF^v'vZ|r@4YF]%?Ɉ7;oKx_p3aEKF(9s'AS<(w`c5o:tFruNؼz9\~lG|_Q7M1m5=Ʉ7Qgt2$OMX <6t̃"'dzyޱLMP \Q1E"9uDf=֋N#fL$?tmj(" &3D! cY?U 1Y`n7 _ӎK]?v7ɧ;sGPվ.\`~B먽?ۅ<dv)OB~d)!pZ?C {@|{C0>oybO')Qѵn|__Fɡ ,z!K'y#~(iC?a^C8Cvv!HT^7jid #Q1/d:EnZ0BmVt"|)1%wc$Dr}WtUl6t! 'k.rlc*n˓z;Im"k?x=m&qa"NxVD3OEd&Dē AHnϓ"UH/"1`AeY 0)I\zAx`߈ "^C1JD|_D8!b/TE4-⎈ ĥ"Sm#"&:%æ#3E dcȮVV@NŠY I aqE`BmT q]]5M!a.X_/!1љ1M3c2cH˜]s>@S>mf|iJϘhGI!F |c|91>`Caɴ`^=1>y3%OYf|FZd1>rwu3]4 3>(1>99'b|\7bs2>ݺH_|X O%ғXoϝ=%ޞWo5k?tJs>6~}uQ壍I0>ev^H;lv׼|7iO=~xV_öߨ<|Y.K*Ճg‹ KE S=e/:S=5.ɤz0YI^JnJ3 1#0ՃQ(VT Q=x=Eȇl,E}S=YA?A(J/3=z89Wus:}#`Ȝ8rsDNC8ttl̖+Όeք鴗Jӿf6jxE 7Erꕩ诙 "Dz3c*LgU&8Dݸ8Z(ؚ-T獿77}cw/{+/@ Ŏ{;%K{#_7r> MOY{@/7e.{GJbo0+hbkˇh,Sbo\ {žBs70U+TU].t/ހQbo{<]ra$o3Ob#boȖ,$/9c .r 4yU :.6e6čۼ].uCq&m@9*q6f7FNM8t[5 mA4dy&j,SLX'ݶw1OhĂ,]λ$i4Um){zu(ffh`Oifh8bh@'bhA Sb@fh@-/لe bTdل+|i(7']T .8 14`Z14CUbPf/ƆPQbh@ֶ*ddx0H`Ѳ9ym}+.Rn14|I çj~bh@dPbFѪCg.}CD%uE@D"x?jrƬkAn[%]I33Nɉ15f6yn2J\J2P1ES2ί䙑1M6!ecZM8xj6rqXYs5aU&.,uKf4O_U (NS\ jŠ,.+ds+sN\ hfLkR34߸f*n!,J\ \ebS")*>L 11D iۦ F,#&aa\[MX9Û.4g8K"p?ap'>p=J>=zͅoH|=ww[=ax=znq_}B&@!g"Z|&Bag"&Z|&Bag"Y|&Ba"8Q|~^ HKzyK=?YEz|oQZFY 7R>x]94:oā$́8( 8+!(a(oK!,wCXaAz endstream endobj 256 0 obj << /Alternate /DeviceRGB /N 3 /Length 2596 /Filter /FlateDecode >> stream xwTSϽ7PkhRH H.*1 J"6DTpDQ2(C"QDqpId߼y͛~kg}ֺLX Xňg` lpBF|،l *?Y"1P\8=W%Oɘ4M0J"Y2Vs,[|e92<se'9`2&ctI@o|N6(.sSdl-c(2-yH_/XZ.$&\SM07#1ؙYrfYym";8980m-m(]v^DW~ emi]P`/u}q|^R,g+\Kk)/C_|Rax8t1C^7nfzDp 柇u$/ED˦L L[B@ٹЖX!@~(* {d+} G͋љς}WL$cGD2QZ4 E@@A(q`1D `'u46ptc48.`R0) @Rt CXCP%CBH@Rf[(t CQhz#0 Zl`O828.p|O×X ?:0FBx$ !i@ڐH[EE1PL ⢖V6QP>U(j MFkt,:.FW8c1L&ӎ9ƌaX: rbl1 {{{;}#tp8_\8"Ey.,X%%Gщ1-9ҀKl.oo/O$&'=JvMޞxǥ{=Vs\x ‰N柜>ucKz=s/ol|ϝ?y ^d]ps~:;/;]7|WpQoH!ɻVsnYs}ҽ~4] =>=:`;cܱ'?e~!ańD#G&}'/?^xI֓?+\wx20;5\ӯ_etWf^Qs-mw3+?~O~ endstream endobj 259 0 obj << /Length 1117 /Filter /FlateDecode >> stream xڵWKoFWAmR\> 94i6p C-ҊRI}wvf]XHzkw ׷Voxݰb֜YizY[feav3OUy!cC|FWIkd|͉;_;W"ƙ:av'mU=9a`c8WqCN3z9 vB@t*EG|n+]m:ot/|&qY{~Yn{$Av87hʝ+\Ћ |/g&/$H=?# טɘK|42.=~Bc o5Hr{c}\1 GʡKȋW}wZdZ3eRwk6G}+#$W'"?U6^k2]2aʻ^I'9$C?ܐEx.5VE^ Qd0[ֵ"%ZT]A{!VJox~"݀3I3IAH3KH:tRsOtR6(گ(Ea^ w.+t0^ZOaMX %K|_ҙE$V =rWiAw,X򃸗?8n/ⴔ(hp6ҠfGW`~A@ |+$3V" 8z)7"8D3r`{L'Pa6Ē&wȀDCG~pz+0> zwF"n)al4N 'FoL>zO$iҞ#5]Eɢ%fsJ}umVN@6JS,iz)F)}F.?*VPg̾AmqUb endstream endobj 263 0 obj << /Length 2556 /Filter /FlateDecode >> stream xڝY[s۸~ϯ샼c!xL6xxu:nh#^J@7Is>ˇd$__z}Q&:d~3ErOʼTuOɿ;ӦvkfiNmw63=`z;f:fϏWg -ޟ_yVe2-/{ZuiE3|}R{y*=I]bWhԞe\UE0hw/tE{'p=jGW? (ވFfrbWP#Ȣ8~?'O(ܚk*ceڽ4_ j{!0z < `S(SeM̒$he6adž-(ZögdEVy6{3z vHmi9-n/o,F6!nC*RgBkIi.Ù2a.4ۮD-vOv}ˋkZbƗyv'C~Otf$W~C XY,6 KIL* #HPa< OC9xԹ#I{L6 }7!(Uef$Rm\ O  Vu ݼ#~M3e*d{#~U^n#T#y1U w^ Ce ry}30u$*SdN"w5 ȼ#FE Αc B'`"ꆸ_P|:~U(gbwbAS L]=x+ YIZάOSNu?ظx'9W0+K]Na@jޣWJE{[=2jNza]VH*움o@L"ob8OUiӅ+IG+K)2$H|DteKmD-VF(vT1WVkgԽJr($r07P]m*elESi8ލz.:;na@Uj_nSZkLܩ;ŎG(ozLZ]C`~,aYmk@@_XV3F,~oO8}Gf~/Rzې1|;jr :My:ߓN~"Qbڌ3yT._Wd'gXTƄuU䂆FQʵ7> stream xY[o6~ϯ0{URn6 6H] Cحm7s(Rـ=;u~;y1>yzg^R_ދK7>y2<>zv{r n"Q&?gӁ¨]i$T;ou;5%_Fl R,k /Ո# e6Ƕ ~_kYwW0 dKH~ӴlCqD}w)(?3{+2\^b ,7b$05-LB&_,%aQ}IE 55%D:(&xi$ / i>!ee,Y塚5HvNmH̔@To. fX7ZDH&іC,%q%4Q^|"/j@ YABra Lbg(/(3r^,w,6H<ÚwHE9 1#9-ƥTU$(rxUZ[ÂB EX5=.?N;/$2V+~F&72Su[g2RaZ*l|RRziI 3(NWƸ̿dT^+GnRy??Tf;i&Y5.ФTWR$Y%ݢDjW&h8't]a̰x=S=&U‹2d[v.&&rӫo.݂8H?׍d66#acשTI%B{MG}HWғ"9U. J>Vcn>ީX}-S,_dT u7aXaHvgMeKN3Q̵ZahmnN84ޔ_a6,hĶ#(*+昩tZʤ Uli5;W"8]YC4uĤ_@C(♊S!=*Qv endstream endobj 273 0 obj << /Length 1427 /Filter /FlateDecode >> stream xXKs6 Wx2=ۘEQL{6;NVwNR Ai;ޙ%|H {wMx0m'\R\p#σG5 Z!94(WHS£Ư=L^VxC}~[J|=YJ")N߀!3 8#QHO-K%9|H%^FhPP'd$ok8ɠ hZC7\&0Ā `2wd/.p/qprB{!ć@hi&bZ7@pmWhŇBM\1{V$#'voXCcI' 91b\M0@5| :SW@[5MFVA3+S<]@uW{In.Cr[z_@ح&4Dz#a=Ekh?)+ ({h+DƩBEn3y⏻~c-w@2Í掰3b|;4L G"l2Ʊˍ pyX {Mpٕ@ZԍmW-~W[I Ovc.m[4haxgH #I*N9 ;\*?ҳ7XHsjԸMӾ2*jLMy< ,Aبt2 HMRG᰹CM֕^i{{$(*k4()q7[!9BL{:&&g[Tz#fJbx/K-2 endstream endobj 278 0 obj << /Length 2243 /Filter /FlateDecode >> stream xڭrF@9skvXT9II<6@ĊD((?okFo_:t׋&dFZ&[\fPڅl~ʭEUPQA0) fʗ-_gȗWMzf<̜͛`w6z>;n; W\0΁uð-_v7x.WxufrHؠ 㳹 * &(V5ŬvHWGTK+k{#|0 CeЍW(& o$zV>:asH$h7ٳ4Q3[SGgD"s+D׉8Yx=⾟G Dg)h#jbxF @-M.a+K/u.HT $5z{AUV4)o!DOogwfC-ʗe=a \=mVbX>#D jϊT ёϼcULTYm˭H۹;ѱb: {MU!* YG؉Xtt9r_T}E٩z@-![BƖ EB5^\v7*Ⱇ) Αd0G.Όl$ :aSvd ˇR*^U`kBTam1&JoSYkT ]NXL'L,fsC7A 5A!TSS/5e~e^{^Hߥrܶn;vY_zGulE5~!qZsay'bAH#ȗmSUKm(co7dP$,͔d(mtpS5,uxtPxJyS1DTT>; #"l+p5=`tzTē1Sj;HU{?9a?#˿<|'%"yK4`|#--%rs#iS;iy%݊|SKILGԧ$tѭ8`r<],'t2UMOrzxLOމw[$x,! FG%'r+$Ud+TI6urP|F@iE!H)t%)^]-+ K|/z~{Z PjW1?q鶼O rJ-ndzgI?ΩᐘSHV9aSӧt4}y*vcԾ[=[$ceK\[(;2Ll,8^FWy' ei!puwl'OEoIΩlRi#>ҍn {ˡ񫫁ߤr~t ^;ҳ^ XJG${hВB7:4?9-a$Eksx!5$VD{Nޤv]E#ä{͠-ZWD߁V*/޿? 1PkߞҮSin7YULEz*D.?r\+otE3]mWE1_o/`5lLa|y0}| 1HR @> ' .N_obQEwbwBPz"F_Q؅=rO4?~Ze/7K!/'R '4g?{"'Wa#Ym$> stream xڥ]sݿjM83v\i2nQq "9%%y8N@v{b}՛,\DaPE_Di$QȒ,(dqY:Z-SS]8^zee#L?-^YXv5BT_?ƃ_׹ii=ҎHj;Hā8'D*)6Z$Ӕ>?_/4*Oa9LBx㙷2|-‡ Ão9 Qt݄鞌s&.N8&G}>\(E} ]*)KU/gqĬQQҴrJdzWD^Pb4O̍JdRS灰u$K6&lHb ;Ӝ +8t*I"9Iq.3ckP%b (-E6i8i }66W=YBTit#<ʬSSmk\=ٖgݠŝ4>M3ܸV xq-%Ԗ# `bzfN0ge;$ h U鑸< QXn])  "ɜ^< fO18w$ q{;&rX#{W\SԺˉQ{[b3$XHcS+)r^lMUBѭX4PBjBn_!k/oTW9gj%[j{7oyÈش4LXG_.R :Nͺ^8dS$N@g\BZѩPw_cx/\9\zFֆWW_+fn+d7.3ܥ+^LX֯R%LMa'aGxg!%Cvj{5bp<.qF-}/o[ݨQW #FtG .A+|?CU6%90 B(6;8xH>`2?f4e uZW ՚.ɭJ֏D32%`E4Q!sJ_bՁmbh?4fޑcQ;=v+\4%T$gfkkCsvGV"kwq^/3veL]dN3csזَ{,X=(U^ߚ?=2aSQ6籋\(# m`|EǠ:Y9|]9Kov `]]#ׄChn{.C.0K]qƐQ1 9K"cf}%]e,rW 0a ku_a`\yq];PңP2 f6 0-/Z_HaJ7Gt-C[|tTi^V*?H DD_O-Ws(gvlxT.o4S?~f{>r Bo\ ;56`/kq5 nXP5inJAs=jݚ:/?a$Y>.\<9pML"_k7Bjӵ(tnh9s_n_˪ endstream endobj 292 0 obj << /Length 3409 /Filter /FlateDecode >> stream xڥZK۸ϯPX0|Tʛx'Di,QǿO cOm5 4FwnQ,~ŋ7-tڢՋыժnqY_s_iꔪj s;&$4Ͳ[_zUn˼M:0(̻woKk}n)UZG=\YeS.O0 {a]Wʦg#w{\{莻{xG\oJ2UYSMU1c.&_i"k`Y†?Un6֪e](tӌl=sP 6':pGG#fhH"Jxv5?u*M|u3tT?2MwlKmɜR˕.p!L`z\ ssH%Ve$G# {2 ,U3Ȼp#i,. +,=Md. GfC b y7Lmjp:%vdmT &际 ۂopmXt',LT.9ή.Q+O vGՉbZ^mCZ<|OPdQbNudSZ/V yF7YIVuG$LOVr@M'=PTв͎|M. ˜,n\u3I]:tC؉fBMkRos3v"*L Ilt:N_ϰ,;1:2exnS a׺ýX%)=U dzk {ncEBĩ{ԑtޱrek:,#9ٯ)5V8cV mk/cSSҰ4^49v^g>L{fN$gSJk;3F2_q/j$Rc*[ NyL\:|T6<{mS.??>vJZE]COJ-/>~;cDA(ֹNUOx7F?Nd}3v]I'u-!kE2'UEm4_ b챓wFIf*A@q{ $tz9=*ExEИ9Ъn]coQP%(A*Nr9a=v> 9e =A8.(o{Ԫ(o;ɭATdn XTas)v)>r=.ǎS)甮gɣ&dth\ܼvɱddBr͉$0Ct)\4NSa[rv ! zRa]./h&'\&=j19%"FYu ]Ac#oDb)h{&]@6 xD)L[2qRvpY}ns1sD-/A8<Lbx^{Y)"h867Iʥ##C.c4\.[NR&->p 12ЎZNϩ2{J$8=x탊|sO\Φʘç2ɵ%)tMR)M 1_b5WՑ`RȴE5k5C "ۖrƉM흪'[&yޅB Ь#Ձ⢋>!NEW* [[^}:`1%^!IaWz&Hv,beKpZ( <Y)o1)X|yΥvXV21.!dKY3)H ^FȑuXn…Xvʌr;|6',O ~|^>$U;X₰j 78t٥w~^)j;,/]gFx*!9W)-dvl#wke#He΀痯l(aF..=4jtqJyHΨ.\IՎnޡ<>X>Wʹcn;׼%m]04i}NB deo8MGc}\wc9aT(JAvSEOH6C4BS X Ńp:lܚjFh,cpT]z_ 86e]@!E+1&z ,dٝCyFPR Agb$8%OuVu{U3 OfZ>rxFb+r.{]j-V/F9?:*Uig"=,t U/şkM5Ve Y0RV=g+ҕY}#ena]4Ynb*\U}!i4*[TTG%D.O3LjT~`ǥw rE0%5Nd9VS7ִg8~f3oRձpeQ'.3Cic}ZB!r-v.,%C֬wKk O}iBn^Bf^#'8!8 nO> T,RJ7fꦮ2 c:&Z>lJp2>Ȟ|ӣ3 endstream endobj 190 0 obj << /Type /ObjStm /N 100 /First 867 /Length 1753 /Filter /FlateDecode >> stream xYo6~_ay$hE`݂FFo}˿9B5 dciᒎ2!rrzϢ{R{oszKQ˝Vnrs_%e5.I@Z5&6L}RnߒsRL[?s#A endstream endobj 299 0 obj << /Length 1173 /Filter /FlateDecode >> stream xXKo6W{J%R{)KȒkɦpLɋE(r͐t=zͷm{$ʸ$#Y1¼Q2o]{?į&4>oNᏣ}%jAɧN?jc$߿EYAQiVjˑ-\HRAtrvH, SY&1w D(%)\d{J.$ih)e*Z6Ȼs>w! @|JM#1+CRA){YW8tl@Y8xh_|4wX^ȓKO`2evw!NIL!+Q]2ϲqZĆ\WKcPv쳪n7ꮥ_bTuчI]"EAKVT-ڠEEPpg4?x-)ŷhXtJ1Ha Xx{Mp(z NWM߭o% endstream endobj 304 0 obj << /Length 2254 /Filter /FlateDecode >> stream xڭko{~(PZeESz=)"ޙ7L&%EJmM6cKH2Nj-.P6SeіY2g]-Vu?4NB0J@\)A೮L7yi:uݭo#7U 6Eן|"*îfM`<ɿjM;z#ovw'GQ›3آkbh[̳X8ȁЃ h hm/$Z w('<${il8nS M_#l0ww@NUiG&癵y"=⽷'Qxw<{|ΰ(S=r{XӖQv%HmNyeHNa J_ʲg Y?RX~(a4DAǠv+XKi@ |=wAFJ! y}Ke ғp}S"jک6N.@Jel+W 8C+q9/8pӸnxi=ׂ Hn\[%c✰UЕ8صԹvS}kaEF($v<$ʸ׎Rp4S}Mz!)22d^,>M>t[kɬt)33k89[`s걈"A:~FG{$%ܣNjJA: Bj(upme|JOw/vȷKXRHbVv|BȇPQ45pЍ+woG'Q{s_\v3M VG)8vtSv7mF9hp:?,dC#HUSUm&(.ŪUEU9ۭE'9 ݤ衝d$$f$|\ T]NW2 iXWޔ>K*?@la*buf'x|T G 1p|`1Ąf\\SW?_Z sCWY?w31B`w\U]^\ߔ DCm!af} uf!ADeJCPV8s5E[CR(ךr|U`_2؏ì>«QOcOwRL*5XcKufHחף .` ǒ!do~Áu=b4" Mߠ endstream endobj 310 0 obj << /Length 1726 /Filter /FlateDecode >> stream xYKo6Wr6RDR[M}!-[cCv6/3F؃,|AǃA<仛,8\ n#- Y+= ^?D0)ji~SBT47PfA:q,`=(Mo_h[Vi=rDSW7?_l!J(kN$_SI"8Mq3#9yV o87MG*x^-hb!H2L%2P PH'yO= 1Yb_iD\{OEni|"{u6c )_baXXBcP\}\qk 5ŠB'Wfo\o+=5]K.Xj+W4q 6y>V`^!<֜#өK;e[Z!<.$v28!1[ eLfw a2=Sqa-mraᚘ9 ڟEK."+A2j(VAAbH㣜3Gшc~Hi8vO?d m2Y)oڧ~EŅv=2^D 2k=IsӼg+7MۇȢ`6%瑞ΏD$:>@瘒cA_ZKJ0Q/#,Cx2`vIL@i.8 9_`!tiI[$+=߬# E;+u8\LϞlp.jh)*)9yݝq@j-Y{J!nU=׎(êvVϽ9GF endstream endobj 321 0 obj << /Length 1542 /Filter /FlateDecode >> stream xڭXmoF _!+ ;R,):Xx؇-jIa}OYEtȇ<țzˠӿQXD/^7y}v ~_*D 24ϵa"4-,UW~9U_N$7*7o C7m+XҮu8承bؿPe46w X΁B=2t DߡA%=!U(E o0Bj6$&uXJ'a %0ݮ8@@I_If4zkZ. rb8A 0/spLs-cP\?ga~=U/Df;bFa, @7C GCٌ n8V<,дkC4K7sh!|`x ʄ/,+RMSQ2n+3n)ᷦ|b}ҹDdha"xܚs~`bbb2DG<ю8$H&M!âaX;@5k.o!ҷQmW6u i9*SyE{sO+;yl<3j,їY}8\Ց(XЗĿE[Q3ʌ\Ͼudsf PTg@$In[D**ܛZPr  uCD@Kc͒HnZ*2֦Ò4ŶX]Gidޘ= ű>8ΕV 5.(t(df"kU3K1ݯA(X‹ܣٚF pc]uG"#mZGCmx, ,UoDb؃d-(U@Kx,/]o mH4}~݀]xRxK` {\s[xJ0fM瓹SJ긎CO Y`P^i0#Jul21MyGpr+31?Q޼%7"a" e@e#K3:/ O:ChzU Yhw$=\5?k6*Ǯ̨x endstream endobj 307 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (./compiledCode-figscoc.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 325 0 R /BBox [0 0 936 432] /Resources << /ProcSet [ /PDF /Text ] /Font << /F2 326 0 R/F3 327 0 R>> /ExtGState << >>/ColorSpace << /sRGB 328 0 R >>>> /Length 4916 /Filter /FlateDecode >> stream xMGW{?l)HK,,ĈDA9UbMyޙ>]U$}s}rw/O?gJH??wO_){ۧΖ<˹G?g><톿s_g0ǹ,j#+GnG3#סsgeٖE4Q[ܿiunf'~׹&q~yEsA$xy ̂½Ds~˜d6bsdM̵5Ï5\iVevxau FIZx\5`潶L\XLfOpL `f Ӆ']gս.ޑB.{:xtlDxEN (х~n;]E;]Uـ'[hn`y.OkQa.X0 ,`,0f@h4؀@bb{¶g=aϬv'ڛ{":',R'P)dF˂/JRmgjc|E+T\R QiC4_M.Siϰ~k&ܰ_x:79ƯvrK(@/hZ[zgLO= cX-Z?'Ϯkaso2vW,jXZMS- ߴmnEG)Jkjõ*?⴦u8i^_sҺԳER%?57YřM{EZ *|k3Z&+[qfc*qFu?ܷ%Eشyɟ!ly8&}[tj.<8.0aK g wאjC:b~t ԊNN@i˼R9:PlE>.V׹+S&N&_ԽXX]x7uӰt:Pۖ4mj/u%@-MuaD6ٍ6u0[`s<-S(/|_iM(+/ XJRPlP \V~yrgJ=(M[*OSZ@ߨz0_~/=P[z`柿/V봕DՋlH0*/ibݫ{U^7AiJQ1oz՛Mo҃i_aK?ޥ8')6 {˟5ʥ׉v?ϛ>HI=@L}z{ K}*?0ܧ{/?Kc)?@r-o;)[x-}+?0#)?@ i+?X#w$f ض|n.=ӬL8ߣ(?iy?V(L|^Q~`0!*?0b|UOU~0}z_V~`EWglѹ^g+yU,xU/Tץ`RoZt٪,X,5k҃5[A+̧גl&[ԟ!A[l"?bXd_ZSÐ!%OK-C{!AgKMCGg4^ 1_}Ċ?GNCg[#e U/v%.o\wq]o\+ww?ܻ>}k՟tAVTҫWNjxӯ^V9v=SSuttgB1_NY;㲛G˸^w]͟D 6 2$N>%S!}uQ(?mt Gl0fXcbz6!uUo~&QNj7߾}?{곏K61W/m/Go1oa~\>9 iT>9Ҿ-YwhI`ҫ $)N!"҃U@ǝPT9 u';Aw‚h$Aw_<M} X<19 ı '=(FG@H\E Q }'"Ia@2%H`q"$$xg(H @͇H FCD">~zԹvN@Wz'3ٮ~: 2B$+i'8o4"8>Nqމ򼼑@StI o·@[l*k'/֍y$HH evž"v#8Ӎ^l9 D~%&{˖  D>E;Nj>D\-[z0dM=tW'HڍE d75_d9 "蜈N/_@ >HKЉ@FAvȞdKdPz`aPz`I lH@$$V\"N &v{:}SS䝠 ɿH`P$9KND MrH[dpKί@ڼ?HE- > ~_$"aE+NᏓ0uE"ӝb}鏓 3@ć_$iH$ ?CZ-{@l*H`|$ǂȠlAa՝nr#H ҺU= B+H /$$8 ﾂuz9t=:Od9yjחB߃n ZI->f: IT~`vY~ph:y; ė:\'˿,  ˿  \^o ?s~ڶwhv@I|!H`qK ݿ K f /}d__&*o]_l?2*;H`/&2HĤ> stream xwTSϽ7PkhRH H.*1 J"6DTpDQ2(C"QDqpId߼y͛~kg}ֺLX Xňg` lpBF|،l *?Y"1P\8=W%Oɘ4M0J"Y2Vs,[|e92<se'9`2&ctI@o|N6(.sSdl-c(2-yH_/XZ.$&\SM07#1ؙYrfYym";8980m-m(]v^DW~ emi]P`/u}q|^R,g+\Kk)/C_|Rax8t1C^7nfzDp 柇u$/ED˦L L[B@ٹЖX!@~(* {d+} G͋љς}WL$cGD2QZ4 E@@A(q`1D `'u46ptc48.`R0) @Rt CXCP%CBH@Rf[(t CQhz#0 Zl`O828.p|O×X ?:0FBx$ !i@ڐH[EE1PL ⢖V6QP>U(j MFkt,:.FW8c1L&ӎ9ƌaX: rbl1 {{{;}#tp8_\8"Ey.,X%%Gщ1-9ҀKl.oo/O$&'=JvMޞxǥ{=Vs\x ‰N柜>ucKz=s/ol|ϝ?y ^d]ps~:;/;]7|WpQoH!ɻVsnYs}ҽ~4] =>=:`;cܱ'?e~!ańD#G&}'/?^xI֓?+\wx20;5\ӯ_etWf^Qs-mw3+?~O~ endstream endobj 333 0 obj << /Length 436 /Filter /FlateDecode >> stream x}RR0 +gG$,y{\X4 Mi z$m&I8fOLLFL3U 3\yY3U8)Ub b #s_ i3ެӀ:m@$ѿ1[1-i*bh]qީ40gfJt'}Z& Yk2V[b:/(:)/EuK IH({ɽzpHӦ'8PT:зA2#[FͲ}w endstream endobj 315 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (./compiledCode-figlv.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 336 0 R /BBox [0 0 432 432] /Resources << /ProcSet [ /PDF /Text ] /Font << /F2 337 0 R/F3 338 0 R>> /ExtGState << >>/ColorSpace << /sRGB 339 0 R >>>> /Length 20996 /Filter /FlateDecode >> stream xM-;.$ذ x!xaȲweDdLwߧNLdo??Yʏuԟ~?ۿ7?dq]ۿoǿ}ߪ?6f?n?'M~N4UΟeCXY X6,?\|ȶe ?^? Wg܄h'^~v g,uϓR ։Km.8*|Bh n/lvK'|nraݩ~R~B{/pF><^uQ6ǐF!U|>Q-ǯn=jpӽQ [NX `- υwpya;?pw\mkl1F a*t0ëtMh^h\^xYn/=iX`B6o`c9xr#߅y?p{ᩖlބxI4NY U@}`=FlO-Z&[s/{'O=yO.[Qgxg@<ՇWy[N7N^ 4_=~/a814]݄n9[I ]5?M QО -O~|Ne_Xt݃p%фf a!l ˉ{gǽlXK^Q=xV5mXӏXL2>}pU lmjxy>a9Ep܋,4JhUwrCpUh9jvhx5 ;Gat2zpgWYcz[㟧`p,>V%g>UJgnrB[=-%K%쪯lpzԢ.?huX7N#l> *3oa8>jqa9Mepll lG*E8AtSNUab(ƙt2™WxdxİEvt* Pd}Ad F3;0 40 =?;=??" ]p>7h@+ m:CAOqpw]t: N|C09v?4 3_n"p懞n9;kCŷ:m B0!,ZݙYqn9[m Ӏv8?i@umx2@wmD`ѽn9 cӀ6U4 ƓA|PμWO2½)ǔ: v7MNaOy& ̟,GS Z r: ֟i@W{Ӏ.JlVFμ/2 7sipp[t41>o'ЀAzh׈w)\lr&h'a?НlU؝"tҤ Ҟ: 0ab]^AV@T ;s3N+_fw>>L- x?EmiW1 uZN Fܠ S tڈcЃO`s:A0T!xuc8va?%!4a '&<^OW ^Q\A1Ȃ"(U׋Ks/ ŭ;ac=;A[v 45ІqK\w0~3S# RViCt1CqwXc:v1va+ma M5=i؜8 lǃ٢lRˡ}isd]=A'u0*L1o>,Ux"5enS_ Zx_`s!W-*r798aX[Rnσ]xބ}ps6GgaH1H⸕p 94C/UQ1A~1SѱsIxׄ'vmFn2:Fa$ h94vṞۗﶰۗfםxc)TZsbnQurNXLMUyxpe`\SxþiccNCV {FH{8Ț= hMa/<ˏ&F<x01;YMţQ7Y|{ 7G{jlGlcs#|d׃?Vn_+/uu#>Rٱc#k~}i<$j{' %Tg^x\봯*{}ptOΕb#>w\Gd? ˵?KLtp XTt?z8Gc`c?( >G|7ƯGv5yOO%#A/}U0Hܿi//{#xN>5~N>w=*°/v>Y=FDDH}0&2}?ȖwMȟc {qP>i_SOWێ|/v>b1XZyºZ7"1c#oBj?c|Dke/Gƫ"*G_/ŽOڋ탉ɇvĢ<Lng/|# ~8^LW e|d(>A"6} +scQ8^/IþעXGƏ(>24s||t\D# >51#[SߪH _F.~=#&,>2agEX|wt#X] yǁ+D{a#ʿ.㺑x] aXkRN>F;ҍ|rLW1i_&&}>SfkJ3W3+?%EW>ӂG#M;&5|#lIo<:I⏓Jw>7)\Ka_8}u?jU5>M5WQkډSi/&Gj& 㓢M#a6¤n":)ܴO*7],a_EU.Qpߤ|s6\ߟpR3GS|%pcŝǃi/Y&{‹}IM^uZ̏&UӤtk5nE獪OQi1>X(#fT~4J?WQ4j?x-+kccw>|(cF U"А!8ﴸ>/P{/+Դ]RPQ JŠKKǃDYt˨]V0~Qj烫k`AGP+>FYMیPVz'=#Ѐ~XBC5xƒ -OW}⹋ї//G?-Gj՘yNÎb{1^"]1/HWI\^U|dE$]V.Oac~#ˢ~T.IO뢜t.' zkE{^$oRL&^C>(-]CuQ[LwQ\ Ouڊ,Kג.KW#.fU'ե7Y3kXղҿ/ ^ԙ6W9Ԥ6X%n;]%wzMv/KSx=},OM#w? AB_@]Z.mT~*576e+ϛ:wK_JU俷GҢ}lQ#޼F5-9jB[Ћm)Rˮ^ﱥI]nRC߶J=/wK%^+>"Li =X\W|uSj?7>ϗ}q<ՏqkK}RLm50ke{J*xX=þ&O? a>׹.JpUS"]?%{_xK??3 O}QAM?SՏ?o?/׽nvc%Wn'zuCݵ++B ::~ ^כu:_yW۫)|;q/smgoon=n~q)Wjtoi>bK)^e˄]2z} _oGOqWKI5bE@ @8G M'Qh:vz$iT D1ӄ;R`bul[wLF&76j8n Tw 2Z͍;69r,a &Xs@}kM GxO`)xxD:wmnY7bӿBl/7%qg}mnYrx3GܸBDܸxdjƅs‹ k cb67q' Aa*“3Won *8sSƝգq'HyOW^ vƝXHvܴձ6vExQ?\8SqGW O6hclܙ?[wFmiw[w7ƍKwbc ux1px_ݾt/=Ɲ>}7PH|qT"vj 9> Ɲ&c#mnih:r>xnܩ7T }fX΍;unܩ]Ɲڸx2oR+}ׇw|?۟wʊÍ;EBeH&A~բd~67p(Qr5?6.F:pcgpАz,"h&\c>c8csilA7§#LuSqo?6[abxy``p{@I)#b|` "ܽ|`*lBA򝃍;FYhH*e,X 6e[-n|nhe7&QB: )0"ױ<5o],2(in_`y|?LT {dfk:% "d•{,߷w}q40/퍉oM/ apgx2xV- o}^ma_ƼUxNس6YH:FWBߟI츱k/?q4 f2v5^Qw`7&'QcvӘT9d#?K)h1#Z86aG$BVa>| Y:1aG,ߌXJ^LAZy}Ô'w&msNdջ~ܸz?7Ǎ;}qNPcwn܉sHܸӔI[??ܸ_TniEV0R7ō;ui<\ߏws㎛AFߏwl1%h-f:($lV" *ˊiw߸q*:/3_x>2Z* :&_x.:`7wW[Ɲ58ߡ6n)3;4;6}1+)U߳qNdla#G#ϵ[r o m7C"<6~/G8-s yUѾ\?i"ݎ`cɟ4&L?-ڋO6{# ߦBX„'o#/+e_otsN>1{aoLh˾|2#d WWb/6&Q0ٱZ3~W we|WBEdy}O4lcVEbl_wqp>/ML*ظ0S ~0-8^l,?y?ظӶa¢[t?=JB}Y߷c |=>WOUsG>z}IX#[|~H Uuڀ9 KVaS=A[>/tlG:R௖qcQ~1t|G; wW {||CQ8^e1^"1.[yvBܿ8wxʼn_/ɍ;%΍;#sN չqDsNQ>RU #/{=A:P<+7 WrIٵαƝbVpbcj/7:D]wJ|;%Ɨ;EBt$e^zxsԮDXTg\|m(Y= ny瓃w68OOܸS1X*>2qV?wPxӶov~&nw>׹qJ긳 nܩ%7T%4m}n)J1 C n)JdxsܸvĦ 0׫,0H;f#^-ȉ牏П3c$5Y_WOf'QN>4;H;˴C|$#1;HA>{о^ @,O0HQ|${s(Q/$)QI {gFK͸ar&srȿxkb>9-u“zi\9bJ:^ Q~_lܹkQo\KVZO2nEx|yf|D9a_CvGj0>RGja|$0>D!5Wxaҳ*'vD3>Iߤg)2ɗMzV%b"_K'_Z\_gVcfҳ*2ҿrg-kȗzMZ1^ 8M/פgu,oYq:2X0>jq}QSZzԟzg-JīM|ʸ~ՄoGW-̰WYˌI=E:(2dtަ ¤H=kQYJ\K=kQe@ߗz"=vԱ/z7~g-g-J| U1gsQϢ(q!20^ Xzq7E}}ac?z?]ԳgzңԳ~;:ezYaqe#KgqQ" ۉZ-%}_d?+kd+kd|Dg@X{mSlf O}7 #>Dc+ •uGzp]'HI?H;#> H]GԱ?څ|F~B>rx]i_J)oخ#1 0oƟO|ߍ|DNa&Ow#Qq#-޷nwGay's8Ox{|"_г&\^Mo{p|c0~ =+0sK~YߓUQև|aϰ/=_mwgҳҳ&ǃSz#oxg\NJpWGVW|da&/Mǎ&;w&/5셉K3)^V2^?a"D1W&/-앉K胹1(⻲ї&a"WyV_KܯxoW>]MKR!/ΧDO Mݯ4Fp~_z}g~`iw7A`w70/7 ʩ9"yw)(꧄to=_%)A|~J|f!_@M wR*wߡc7,"3(2HEWn6-8;rv_Nœ+VlnXoyM?x x\\%P7zz􅞎}\$67: fCE.FVg.P#43 8cBLHW#܄p5M;L&D\z<)=lItL i~BGXL$jSjBjsNt8oB-OS ՛)H a)>4Eyĵ)F>17Aj$6M:5r%HAaeJ`iC3~!(Ik]ԿVqDSt٩fqa.G/r=<ڴc2e 1(1-3߰oDgB 8 Lz$46KM6&$ H D}]sLþ44HJfA/{S%uAL RU3.CfZZG Zm6H1wyK{r#p44FҁDKRJbk. rH3k.2cF&nt.)KzHti R ݚ}ާ 5a9ʢ!!bp-{}j#:dNS`Ot6A;eG΂<+N;Mwt|:*> 68̻lrYE8ΰVݻLRsCP rz CN h̻\І tFUn9qL/@8 %\!3Fμ)x84"PZ$T~vBM: =atgt048rm(,ql'X_n1 3oaPW:ģ" rP}()֭Nb983}BxXTҀA_w*i\O% Y *  <4@N% mL;Tcwisr`' V2.;xM. ΂G5°:Uxs\5կ[Sa9'Ѱ١G̛rVw-G\匰xӀ&YہjveN6rqg&7I{t&-G6ϤyxIěpӀ\.VgoBX,tmi|@ g`;_Nh iϋ\{֙WG.zB Vk$`;G6B=>3W6Ùq!Ί4z~n0o]d<Й|s̕@CLu[N}iv2<9rO<"<ك+Q^$'B. +BCǓSJa%D\ t̓`J%Tb|DS t̓7ҋy FV yA Va'?(ꌓQ y'Įq v'?AcdT t;C3~'"qvW?ܙ꺰[֌d:$A$)8;E댓 #w?<*]q\vAoܷ@aIqCv2Lms?""O+DN,N/D:*j%A$pJ:00 x 7?}ddA#^O*D}{D<@v׸>Y T z>̣ʦ}o'"= ROˎ>,8;3/:a_yH| b.GŇ3N c֩OX&Zh_qrs R@WgVL㺳9? 1ګBH9ݾPD~E#SIƔαG!&X'mULq@iw1d1o v.i>^L D_k}/CYg73m.BQ/u0Zu;/u2'DS'C+~2' koQ%r0ko8DU8ٲ#o EXPp۱1b7(Bb@BLjHhx'xOb##"nGdɺȞwǺGz&>&!=H{>/Cǰ{G$vl dzGZC>*,2<ׅʛ|GopU}pcy*dA$6^jeܧGXlD~w |.~"e 74^9bȀ%U24FGF GF? bIX0}InmҾN8A H-_k\G|ZˊeaA$yv>25Ң>|Dy|S-%0LSxs<&m|d##G$׶Gp,wM>'|G >rWw,Rɏ$*q_(9C>Nw?Tׅ;;q/#G"wz|C>68v>bJ fD.l,OPW.'b,7a#\'=IC[MqvdY'vdn 'Vӆ& '3̶a:v^T+&d[z >Y >iA}<x|6/›?ӟwF}pUpg};&,OAī) ۋAq#'gn5p߷=X׉XEO轄X8>h_ ˉev|1=oGb~7#f|D X"PGvxþ#11*#J`ox!ɚ7J?fg20 ;qrh/b UxNRBu},cS.:=A ˉ]<#-~h GN`X|D3i_ZZqdk~܄G$\/06,X|ua#Ea#%Ga#1#QI܄+X#J3592E*a|DnǍ'|D# kӾt@ 0#UqQ!M +>B5NGf`8a_+ay,h6 M%y?,g}ȆE|;~ﰿL+)*>ٟ`|cVڗQQ'ZŸ}1*>ޅOx6[G?Oia&|y?cWx%]TW;%_  kph"/%<)1*)|dpB=D W}i%&'X| ;;:O|'~<x@C_X\Yq]|ucw"Ym덧oae|WXBQdPq-a/L@\8+]qBLb҅h'?_ໜ)YUywH?yBpa|9•Y+\iSV^#J>'ƻf|}?5& >LPߌO}(4)o> Ӕ]/puG}_rb5 ;*i2*Z_' ĝxp/F=.zwϨ u3ƒFY<oЩy;E|Dc[G">RMmVGVܯ+өO/+ D x_D)/^=lQ|:-է/_OojQ:uM=ŦufǕٿ6UsQK+v'GvcSx2 ߦ?lQn'aG8MAFcMMTǍ1#'K<83K/K)MGGJ`݃}{/g'I7QпmTJ"G_5BUaTZģ6^ߞ^CgU57\A?x?|]&#ApG\%\Z}6u9u:g[ug`ߑb->Jʴ&%Qpu@^7J FW z#2H6W}x}B)˂&^'ew+>tD!e/ljoذ_yB7ϯ/>[=a5%\SgJ_%EHԘΫw`z/PΎ/[(b?*1"\T.\#ETc$8sǫdG''w1b)F,ˆ\ n/359΅]-Z2'U~?˅̸]ifk߰{Ipg.rj 667n->3;c*T~9vpg.l΅Lݰ{K0%֛mnF*o_Us5hDj \x3n 7|ޒ{lnlilK{lnFp5mhnh: HִG57;j=#{=li~wxgΚlM  Nvےߐܰ{\J_lIi.OƳe|;[t'}'sÝ '[:%3S2y9 '&kNޟ#]hn\g77dM<憭${LޟYNĬI3k{U~}L?ʅw.|f–&& '-/[ILXR,('klMıD&JdJlM)sÕ '&qVfggvg>J'sdk:LۻE&:G\%乮L~gܾʏYPlW\xs'jD=N,[xYƷiF=j k>5lM sñJ͒q%KLgto&3ugkg|Rid'HpWIpɚG{NL'8IL'ΌxԌʜlM'YS-7%L ^';Mf8wg|{U~}?v\]v5ՖL8+{rU~5_7p[7;;[ք-7\#$޿eK'3z2rV5D+LD+ɚ7pbf&jff\ '[j-3,73c=5Nh=h=f-DID_4l{Xnk7h3y;ܹpM&ZJp%/[ZID[ID[ΕT~'2v"m'2vrm'v)_Ȝl3޿/[:_t2%3^2%{^%9D&zIdD&zMd{MdM/-32-{޲-RoٖzLswp=)%ox[SLDL3s g.DID_4l{Snl'2D%-[ekD&%2ѱ)Wr[Rnmi}L$L޿/[Ҏ 7;;~5lM' ',GlKd&1Jfd&1Jfd?J53Ƿ5ĨLEv%k-Yhᥔphhٖ\[43NLb$v\8yѓbmM'kbdbD&Hdb.%?[r%k-Yƒ॔辫7պg |bg&1Gs$ńۚm7`ndbq-̅&?7Q%ܿʏsgj{d|5lM+d!>p'\7LLb$U/$!)M8I ce|y'+ɚm-Ʉ%٥[]:L  '&a53 IX^:N߲[^wd| wM&醷$-:l;K)0y[϶d=ے$,k/'&aY{8yKɚF"6Ȅ-.Z.rsNKIeoٗ-ٗ-ee억[˸όoo+[ִȄ%٥[]:‰ILNfv/[:_8gsf|+&**ɚVIִJ"+.db%٥$tli$VLb$VLbeW^:_M&VKd%%i%٥Ù %x+%V]5_#ٖL%kGtxug"k&2f"k&,eٚȅoIJ$e,{li}R^:NLbeW^5lM;X;dov$tx+%Lb$;k/KI1wIdM&k⹃7NKIvpɖvLb$vLbw^:^_WY{&'{r'k=YN˾a] '٥dK{d[rMx81=3Y{8y*mLlKdb[rےߖɲ5%٥[)s+{li}Lbg$v^:NgdM;;}IvvdkJK '&OfdJd[:_<_<_S?5YөɚNMdD&N],> stream xwTSϽ7PkhRH H.*1 J"6DTpDQ2(C"QDqpId߼y͛~kg}ֺLX Xňg` lpBF|،l *?Y"1P\8=W%Oɘ4M0J"Y2Vs,[|e92<se'9`2&ctI@o|N6(.sSdl-c(2-yH_/XZ.$&\SM07#1ؙYrfYym";8980m-m(]v^DW~ emi]P`/u}q|^R,g+\Kk)/C_|Rax8t1C^7nfzDp 柇u$/ED˦L L[B@ٹЖX!@~(* {d+} G͋љς}WL$cGD2QZ4 E@@A(q`1D `'u46ptc48.`R0) @Rt CXCP%CBH@Rf[(t CQhz#0 Zl`O828.p|O×X ?:0FBx$ !i@ڐH[EE1PL ⢖V6QP>U(j MFkt,:.FW8c1L&ӎ9ƌaX: rbl1 {{{;}#tp8_\8"Ey.,X%%Gщ1-9ҀKl.oo/O$&'=JvMޞxǥ{=Vs\x ‰N柜>ucKz=s/ol|ϝ?y ^d]ps~:;/;]7|WpQoH!ɻVsnYs}ҽ~4] =>=:`;cܱ'?e~!ańD#G&}'/?^xI֓?+\wx20;5\ӯ_etWf^Qs-mw3+?~O~ endstream endobj 344 0 obj << /Length 1185 /Filter /FlateDecode >> stream xڵWmo6_! LJ,뀶[ ]0t-Œ!mKݑG pDsw3sś 3?e)wS'H48w>A2Qjg S,Ԗgifw~g͠>qKRޑe #Isqpe_ΖI:ZHHi::.[j-bP* <Ҧp0nxk?6- OGCG`<xcy.4i!mݵOԭqsr>9bERddz85F_a;m&p.Jj,=9mu hCt*VFߢU+);^~h0m4?{r`~i.p^=ȼ1G/bm򮧩3r9җ:#A߻bξmӻ4F#>w^wޝX"e˜ýO Q endstream endobj 349 0 obj << /Length 2266 /Filter /FlateDecode >> stream xڵY[o~ϯ}X#Rԭn;vS`wtv")1l'FSQ;T<qoo/}@Q*TVDJ<ͣ2I&%aj+_X&I@sXn?}=E4L."̓1*X&iTdSc~H65Vu?=LP`kan~/j؉{tz{pNr,jAzQBO4Fvȼa;4'ͣÎ扴 =TIF9X qfio+4j0`P:q?殕.|@~>}(Ga b4ž+XN?As͊z11AI*RX VhkӜ,NX>Ht+z-O*(Y˜_=jϻC!ŝG8#o"(.c I#Qk+󖻄߇WdL= F2_! }VN/^Ĝ8ri[n' 2HG 9'I<)OG|3٘Nk)q`WbqMOrWŰ=шsRwМ!DUcLYÍL<_.]~i2DU?#q,i?#vr.i:brgp[(ZVꎁDv%;#(}Տ0{5IEFGF}S mYe=;:#6edܒEi0@bal8_@IrL"@ 4+Jlli#(mg- vX<с--QD1kٹE,m(B{DD/j OB $_;JI+29^,ҀLElc<D#12xQ#M @92{ mǞ"d=.Tn?&iEا}1gnr\lt$QMJh%HSح5%o x8p\YX*hA@Z{ gMFj Q<6r팢(x}MZpS(U@h= U'[e!qBʄ$ڊlz:o'.H<"s1䜟[7kơ%s%RI3-%jWΖH_bS9cߏ8rvC\z9|_dJ]48mȣcղ,Q8"jNz7c 1TesI'J-gWXFfX ?DUİTYaWW+Tӽ-H ihr䑞'6ˑ'>C$n)?Pٔ ͳX9cP|Cw=ݧxH=x3'y(ԆaB V93"[Ճw|3r푇 H8Y5BMFg?0ZcQ=S @\'D0bhV9ChTUN_!>ߖն#@z#v ,0|6BDv@fhDޱ[ ֚PL}jr>%΂^/f_(PAH,_~A():H#^7?gE( MDFVG-r&@FJ"*%˱js }l\KE[7co5#U%_`0?Odֿ{HoY뮂uȩL( zrDP( &l+ah?]_ܜxK7/{ZtV 3j:^0sp endstream endobj 356 0 obj << /Length 2021 /Filter /FlateDecode >> stream xnFrԗu"DEI0-(UlE3;.E)ΡH @qIp_^ίD<an&q*w f_e @ 84ICISy|*S4NbY2 ]LW \^9F vEJ]Ϧ?Y*…z_w1ʢ$تf ߶B z{xEa&,I-35G +f wHUb5>ԖYܴ,h~pXY_*U:+0QdMRx8Q-\K>;F4ٛ4I rY9caO}Fuֳ@PtCҘ|M醩Ԛ}{9 Ls"d1A}VQ`*I܀0`{Wе >\OCt9wŮ.y@v> Cn8k'YN$t%dȖw_۞|C4C8&EdA'6XN l-nxKjzz|9j С8)Pvfׅyi'-sd Xl#ҵb+] )h1aʀ<"Lvc VT͎?۪^iȧh%O L!GC>7Q,hgy{^_Fp=`q/Jg4M %}л67&-c KS{>UyfG62 Fa#A*:`Gv8h:N=kL_}uKȒ4aͮGo;Co{=_2<i\Chj0V.-Q N%MkoS_~E(Ky,'~2Di$~OUmH4*E>JҤUa&J^eS7cKD)׶kU&<{|N(sV_mjNk**AҐ?HqFk``"[Omu?7 yj7.]u\ ̻7yv,*CLV?b))ªY]DiXP/XѸ\"F=E%1썹,)kB'c ZĒo| Is+;&yf7+v%GScJ Vt1#t9qr25.PG2֧j(#oYޢziQiKz[]nB4O؆/z>QWq pddBw#G0jVno8~aG㗖ӛ`1YXSO?rS`r𥰲&fzRێ.gĊAFeLԲg;52=U?# endstream endobj 362 0 obj << /Length 496 /Filter /FlateDecode >> stream x}SKs0W( E,?8P&;i)yvaN&ӷo%nfo2Z3͌V. +̤rƱe5?ëvZ^89 ,Z/< ]5@&@? ȓzyďj U/Ϊ$wЧo$E:t  TE6]+Ryf.L4`K>HB8?0* *y 7!(2) R<? C~KLw¥_DnHp~DMCk1-손ĿEbV} /xFw_nܴ8DS\tߋ[i'A:iw}+X |{KPspX!& y> B)9Y^]{M$$B@Ѵ~j yL0?ߡgxo[L=˺8>x.u endstream endobj 353 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (./comp-event.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 366 0 R /BBox [0 0 503 503] /Resources << /ExtGState << >>/Font << /F1 367 0 R/F2 368 0 R/F3 369 0 R>> /ProcSet [ /PDF /Text ] >> /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 373 0 obj << /Length 1858 /Filter /FlateDecode >> stream xYKs6W9QEGLxR=8-Ѳ&芲]^` $$>}`AbFLNN9JX\2MGE2e\e'EN$IxC3Jn$㴈8ͣcEբF]$;'QiXݏy!Qj]u` C - W\P$=R&8:xFVpM(֋гX,T/I'b;˧/H]MET@WTEm9&صR1 L}Njg?h2 8b~,eTjd 5-jܕ*%&P1Wd7ZiT(3JsuG~=ب`ea]]nJ0zjWz2#Sᕫ,yaCVyV$U%ļjU;AyVeNgi& 5+d ˍ8DCu D+-Dj,1Bs\d]#\ApBV*(S?ڀ 1sGK"tel]0 #- Z1Ǖ|}{a rd z#t1rNH0#ϏH¹ O;wQ֦Lic/8PڷMc>ɗi:.B^,}½kPܼ Nк1uSN5SpKiS}ޢswƱޝyPT=f2S!XhA}&8ʗ`pY2h¼x܇XAKkiI|whdh!CA56Ρ*xС-BstqN-b }%IQ}:3 NGogZ y0%=3]9[ap1اmkvF-T`NGt*q\3BC~xi8 KjNYȡVPB|*D: R"b#ˈr9J,dc ܬ`FRBI*{3Th;a424[j 09tq7;}_译5eFGi.ɡ@muݞظGUdfjq>\ ` _$ endstream endobj 377 0 obj << /Length 1230 /Filter /FlateDecode >> stream xڭXKs6W(HSUxRuzh:J-MHq~}vP #>H`osΛ׳4 0'$tf7N~&Nd$Jm5UIrR6(p *M"2IYt:#VUM(5EޝN0פ:- t[FURUa_1Cw ֌%ŌYRQY3+)Rnಈ1l.o wtdKĉlb1v-X-p6T k+|1v(i%PN&nhfma$e~KI p9Wq?dKܤ<gRaӡ>;y$.tL0Œr eηL?XM$ôA6$= 4ous=nhN0ţlO@’y6#"%{ 8Gy&? [p 3ˇ#]4L@[s=~");Yg񎈆zQ}g\t^G\;*>+-ޚ;?\& w(@ymڵ4}X{=MB`$v?Pt\kBMY^޿%Q؆ HNhby4JfSr endstream endobj 381 0 obj << /Length 1236 /Filter /FlateDecode >> stream xXK6@!-"-IzMtAPl]b{]#~lJ Cr(%{r%3I0 H-%IE* /*` ,z7,l&)!iIAlxJ2+z2Ff(05g cR}[W2,S3*p5 \LJHDt79={_׋kA]V 1-yB4Syڣ[%bGxիT~E8^ OLqhȱVϻV{D`KK<C ɼs{U0"L&DN$h(F -?An"I Q UY0D TMCuiM܌>Gm ݋2GV|ެHHUu64煮Fa]0KM&I?*=D=Q#v`æg6 Qvx_yK_!Vͬcq )h$?Eh<||%cOU3 }gՑTΠDl Y q;6rԔn6u%5:<"zMy{uU\FFx[RpI5v>Lِ-Л2]K 78jPbn^ZH]ytiSmkc_YnýUCPh[Yf7o\X=R9|_@*Ǔ[xr×FC[VOe_/VoV;Q߅7G|-uZ=Hj<;yW/pBa黡:'so\n_;ڜuМNI6]_%)e#@%ii:`8 8gIYTnζn\3޽oI rkRp_zzf(\]rjINS_<wE=/@I endstream endobj 388 0 obj << /Length 1908 /Filter /FlateDecode >> stream xn6=_{Hnhץn:{HBdǨ%/;7J,0sd5q&/Ϟ."g:v$daln0N`2&7_f4f J*Tdq>t*5k+[/ҕZZh<0ni ld`ٴ!i d{mLM "{xѰc?KdQ&P\\Tߤ׎*東t]vyċ:$D*Aw#^wVpdju5DgNCF؍Qu=\}:c`AG$(NJUl츜2".6SM@hbd|]r)aaGx?;{Wa<'c:L)~#A Nk+K&ˏqqޥR$p-[`Z ZLw+ "-XLCуtF׭`*>'hn{p)d2^%aC[S*(AԉRЙ>3H)'0CB V@L[$4~o8/@x׷=?TЎ"h3RKwE?I/trʽiey_#%ȟKYPOP^(׍4rbOKߊjxÂQ\xA`';vѴ<0ṕ$K<0,{x<>PPрDȐڇGjPϛ6`h܇cr,c)>"ȍnTޒ+# Mבހ׬50?(1<^w21K ~4NS.D#<@uðQ ~F) Y<2YN sBe Z)rPsi\^3RfF1 r~%h-аaIڗ|h( hCHϣ6ܓ4\{8h8V3;<&|)?BjLfݔ?T_riD-Oז& Yqf@TZEFm+N'R[MNW6#{-_ޑPܣl'*G D'HHΪU[2p|Amɚ$U784t/A*( :cAR@@96,~LVM`REo^MnY]H;vS0BߩOz"W'(}H=?Z endstream endobj 394 0 obj << /Length 1541 /Filter /FlateDecode >> stream xڵXKs6Wh(פnISh5HE |J3=@}cd5'?ͮ0MI& O,y1 __gibRe V$Iq4H|1 ac'_(75"LZn1eN~j0p!Uq]N([xV+1:oDL)JEM ~ ]^?g>ovY, 8!8V,AqN]Εz\Ǎz}|Ѩ/[0ÄzPQF߄0V,.yafrR*>~^qo_hz7e]6 оJ~$9\lEiB1?w=wH(бF0u%7jJ0䘟T5HW(P.lPq|$b{ͶCt2ף;^A&huیKvā}[!䑳ɳ?h-Hm])BSԪC~H6K=L=$ e_@|;߉\3ՠV&A_TZa',[C4ςl k7e*>л# ^n-V $S(rڬJVO ϖDIhpЍHM+ӑ4:\-*uođP$2c!k;pCC/4YȰ4mCR 3W%Lfֱ7{`h7B3Ĝ7G UNvP!6Ժȯ~ "(!AQ(Ն3BʐY,uq7h %׫+;#8J+ B!QP@֑Z!#|'ZE=&~@#X h(&ǹp:wCچtF6OL=JN#ivJc8n- (Y[- Lځ5G J0$a$H k'2{l 30Xn/ο[Dt4d2 ׁie v%^D!Y?)݉@ld{蟺3HѹNal7զ:Y`2}oc%J,7}.9؇nnp:&PiYKK/> stream xڅWIo6WӋ Q CfZ7bzH{`m%[H-DoF _.>..iPa.ս'LhT"W[m;MGXJ)w J4<:_퐠6{@JX:<6#[?Ylsӑ rI")__/3 v *EZ~'fq,ᑋXZ;Rx?CQt`<$%@*|`{ta4x~!At\BQn}?Vf\w'O=9K@Ftgu=!DkPL!r N_{~`e^Sގby.O0>uWv Ӥr5;Y#^g r X8摈" 0d*q˲d TI$Y5R" S+ަ`Jbl,mҼmx .ۺ^D\6tJx(Aq@OѰI66e:Ƨ9c&)(-H\9:p49 %CnXI)Bܒ+Brg#:*.+~M)y}ȸ¸DGomCZkJ>+ktl=NUq/HPbl{7B?mg0Ej(HC/e!:GÚ9AN'Xe|r|hnEM^w=/R2CKn80hD"tR^.Ĥ5ϫp endstream endobj 417 0 obj << /Length 2535 /Filter /FlateDecode >> stream xڽYKsWrѼ?dwmJ9"DqM IɖSt %'t/|"'=;~RNJ5)\!*&dz2SN~˲HgUJ9 S N[8`ˬ>" -EVlV[^MΚ`5:z< mZl[ᵝɞX5a sK{^%<dDYaHA,8QzϲiNړ.C=rUjQxCGjoo@4wg/qY!GZV LR7՝⎧EQ>;j{@!^3yﳧxqٛ-9K3G0T0ub%P,v&D=mMDaV򡗄 { b7T3[4S&zY]l{p*-NoBAP}Re$ܤW:{lxkٻ@䕔\9a5|7˧uDaH-ᄩ(+dP4j)*FţtG[m me0VC0B m]NQEY7*7l3Jrr^i Йnmxc7$ `LIo-}1"gJq>n4ÂR:6Q*HbT5q?bckEv^hUE&hѨiRV8\X/F4V{+l+;T$,@p^m<`21|)|z|7 8bJmW,nFz]a1~#]6(w2J+ǐM>T[)RI {7:jbK^.>Ҹ$xJ|4P('I'x4]$nUE+txjvl`54݆}7׌gY67~0ug]ya2v,qMRL,ۮxGDXzhBP9q' sӆ8"8QCkˮa%?b^ZX(h[6T1F+t/upj-H%U% < B}~c%r=F:dj 0TdGhe^x/ya]9@QRO :81@~{l$p{8}?kSE-5ښcr#]j ?+;v:$7 ;W,H^c]Y_Upg ]D=4\6f/sA:}'9ԒJXatQ}~XyA%:=.B-pN0ʱwcA֓f#~H((99t"CupE/8Yy1>{X{/!~c++tUuy Eh(6IQHs0҅_.ª}2)J ذ\.ddn8 vL+<5hMG&3h \]VJM:8l6MdDy栂޽Ft5ZJ;׿~ښI#Y=:m'XD $& 60wIs9/bAy|UɵMc~ab6j# $Ni5(bЃHח\ht͡sMd9X FHmtm^qZ77J1T&L|1BfM\E )WĽǺHůe"ڱ/+ѽ86,+_DG%% f}|h(zޱt?ʷI6i#YR{8\E5fpFii9wIOKbj_l&dg(jP@E:Rh;IZ!0Sjes ωǺ+篣J?!_! endstream endobj 296 0 obj << /Type /ObjStm /N 100 /First 882 /Length 2256 /Filter /FlateDecode >> stream xZ[oF~ׯ3s>Q 7MݶpR[XED%%Y$&}99s.߹ )$V([ ?#Ջyވyٺ%-&3 KV;ĀayGDAG_>0M"HBb! 03|0R @^ Al01灵ޠqlĎ5yi  i^,0JOGD¢σM<1p`f($I0Ȅkƶ> ׉β Xy s Z2 "?af6h O"@M!lcT> 6ayt,Hs4e] \Z/x&|!3|e9!4) ?"j 9Ďq4 YM#L V0 {O0C@0i@.x%gyy vcCect^4V ;9n` ryq@3.2-`/fX@-o/o83}7P?MuՊ ~:{!ԛC+.b-yWa94#y5mfv٤{jXϚKNɑL@Xv,w9 N_| 6ht/ʤ۰zjg{کq]reU1PϚɰt;KRR/aJ(?"JrJC^ }0MbJ6\>gd9J-Ig7'CqD>pHo# K|du2x8£0G/e'.Hd3M_ڲ*>V]+;[5mIUu3>+J<9h :kO0'ع~tMݎ0s.wor*~w8+ Zi%,jɦ!kQi~(ny iJF襁.۸lkְK(o5|/ԫyM˵+\׫_^M<Ů@nlx{,} 76IW$(  LPKizZk+{򢙔_wp'r^{9/Og A7̓Yd#~/_Uߊ3Qڮkwǣ;.̳Xn||."㨺nGNfNku3)U(gmzRnG֣anrjRK԰z$RVJg4*ovTZ4UozWVkovJdhdG0a6n48/aHu5dK_V~P !u-Ff9Q?8k6lRmi?f>f8usⓐ;Vde ]]fo psLa>zd$W39h^D2RÝ\'HݾGL'a^tmuVaBa)@w]vݏ͂~1O.}"v\BXwC!s۶V-nI!r6 Y?m5mUJ֒Bt8OBeE{[gWio1߿/Ͽ4|p Gk 5(wu >ߌ!KM_S4!C. iU_\t~E;m;;kU{[KGp%+~ endstream endobj 450 0 obj << /Length1 1549 /Length2 8119 /Length3 0 /Length 9141 /Filter /FlateDecode >> stream xڍ4k6QhkޙQF ;Q`3zEN&QE':!{oZ3ϵgԵ,Py$… ȨJ fb҆tN0$B_2NPs;˝*Pv@|X$(x@"Dn0K*7@:c3 <`6.wi`@‚RP'P5weZH _!XEm\\Dxxݹ흹Nlw @ urZ~5 xfn76@Grq7wpppEXBwZJ*5(⏱N_AW ⷳ9w0Gx+ PWvp#,Ýwn0ŝRjspqv+ݔ2H{{(W}0'(n<NtGx`K_MX: `P%ٿLDȬ. (ĆWxmOoo]H]P_ pqrz[X . 5 O;1;|'x=,?ϗGO[JSFO뤥o.0/W =wus_eW anL/l yZ(/31W yW86=2#"z?K+[Nn sy@-a.?\#cptT\ tw8[ۛN) --`d}wwH DKo xH;]s+ x~ A?H#tj#! G_ ޥʃK/xgH NNwwo?z@!Hȓ`۪ )*wA1T6.ifKIl39J%c=jy1A4Nsd{jk(K3 5ύnjJ2Sz.ѹ{G緳+O^։2(gʱxÅpt0kV9w;p7|6s+#!9 az2٤wqa7LW=3_RпP'w .KWi!blr;u!C,՘!L V Ŧoa~7 4Z(m[wuZ8x/䥆p>0$j̉ffZ]S^ L-M oN\8Qj#/]n;KFԼ9s'}2l™d/K>K*1(ꋖAo}~3b3s`r2 ~}# >(4D~֞gChY XW!OY8hŐ󽾺Duz6LU4:-jJ.gЏ,g@#˶&%~A!d8uc@ {|NÅNr@W&:>cS6 c=jQT׈Wqfy nK,W+<͊~-xs;o ;NfS1Ȭ A=mvt3{dH>F orc>~g/N{1)ܷs \V?A!=*.ĭhPw0e}\[kDL3k&V-{Q(zlCd s5,rG3j 3 I]wzEeӅ ]2^cl<EAD *gDH=iq۫Tv+oy좏VSANt[D&@#<ŔT3F͵O`}fy/{VUPѶJ_%ʨ)#\ugɬ5<|N$n%l֟;ʭi 3@:M7&'9g70YE TR4鰽O6`+lmFg3BO>[oz9p`v o![M"Cƛ-$fGb8%ڕM `=1'iX e>))H{\qC1:l d`@DYAQ-Wµ,8>\xt4RgDna=%v_{Alz?2iRCoʹ6 r &^|R\ @=͔F~ wUDwx1tk|X@őxdtd\%N!s0_G$Hpqwڔ36ٖwu*zaY((.^žֆp$  '?s9b D ޶õOgk^D=%0rF!c4O5ƃ|< c!>.K\6u󝕕5_[|V 1[N+0]C'$q׻݅? Ai;=ɱ/N Q>Ccӽ{#T9?MEJ֝eKEb9x;fD/J$a#x[K*=Y>?7$,&0m0o);mbj^Y8ۜlRϾc!C8*|IDW7נl@'fV cc8`4djA|43mQʢ"?4uVnXO?']KгUQғ1XVGuq+`>b[T@,{D鼱o Ĉ[O'%i;/XY6A("\w>O0%r:sN )xғ/㬍\~;$K2NUu 98D(4#G2QǴGIs.vs).ќ=^&9Dүn%…YÛ3`4y>`UA7fqt-7Q=s\ 509Ξ@ ƍ^A]]q'%%G.D ?C0jދK*R`p[2ZI܂x/G(?t;[Y\AYm1[À^cj-JWj/X:#f087g>WT;`$aET{rԽ{`d <ZLq.zG0iYlEpГof]f9_ S 9fr7حwJh|rRsjj[pA;+6%+3,2PT#ep%^ҟ F,EV(*Q[T$:t ַs-u\6Vg WfG= Ƒ -8דtŨ69]]M{v -Huv$]ޞ(ATꫯ '?? &gvzҧCvbo920MBt G썢)rvF$KH(֜j]Sn̹Q95li6-'}OF fEx8+텫@T/^pߝN`+6a, 0du Εz2F=05[=}ysTzxo|I ,P!돣Qh;v;onBIU+z/{8Vw+V;M\P q@j*7^F&]zОia^9-;nBQe*oFܢ2|.ia422!ydņSkN$d4%)hq_[+qg,,8RP.i3]+b )VSlFƮ++' Ѹ;f 5 I*,<\ MTY6aUF2b3|O*q8"u+F$K/|UKMIw ;HtK^4 [\jti*Grc-/ҧ+'_u1ة쀓?qqdžRވgv1*KxՔB]{|Ǟ#͡UOR5NVvDGNonF K*K/?\ H_:k+w&^r|NDYj7}6R5k1i@L5v{O&"kɰ, 1tpy>h["m#187IZ^`9-f ha]XP0z %) oyˋ\7Bfk<:>q>ޗޚ֯|eEcNTDbn.D!$Þ?7z̸t7N6F}SE&AUnX1!Dt+fxjRO$%j!=g",'T1ǜݧ4HE CxIoqLf"D:|@Kg0J8nWVRL~[Qlx_lwZcv H'5WE&@>H4.pYi((Lzg?YҲ6ƺ^gZu c~Ea,zE<> 2$[<KD2yL0Ⱦ+itYI~ktӸOZtpո:zAߗsa?vzW,-XC=u7.hfQdXWU3G%s+#881RR}(Ct CqrvF<^dbDSb+; B\4R/UӤZ~#zk8D@ޥDh(IFf#'x tT?zeXKB* >.K2".Pq $hF]vIu'081sv-ܶ}bI5jrVP7݉d!4\`T"W-,cLj&NĴ´0UkX)IgD2zzH1Ty-7]~%Iduؑv/CͰi6c}&Nʳ[[XKh~-5xb#_NkSmd/i-v:meB)sD!Wfck]؊VPID6W_Oyk@&6"FSU\zJ-dO4Wݓţ溱Ny.( VTR\T~D5x7k.'hf٩y{v`X:*;E(D*ZGϑJRĕ1B*>&__N ƪA|'6=ǒcM6GO'&R٢w۔ǖ|&B Y@aܵ M\Pҵ %1ri9ݜDwwЋ&i[W>+k}1t1qݢ,`<v0J rfʋ`{/1v_nN1yG'E;syǼYL5=/!x5Bqe-46ܡʮ4DGxų|qHoa*Ta ]xu=Գ(XzU4f:kz0j$"B4&[f3ցZTlq6@J+*grQr,,^}ݖA3.>]&SĐ6[VJNڻ}y^{0Z7L"zMS&&XB^W_Bf I=r-Y?N-~║vfN]J'3(tHօpC^nce(2PҜ\<@\9SΑ)"HT]]Q_|NaH@1ūwE XO4U[[CQQ=TN^̶˻Hnro$t֤x̲,SռX]LJprL t@v:,bLŗlP~򤆂% ڞq3W{9WR_cqO(͋*'eZKV3ĕQ?_i{\vi_4.#z&khov|.fUP|䶹p#c>agjȉ,xcDd}A, Pwf6C}͂x^jkˌ]Gbn[׋K,5-RQ;Kio1RK=w_ a|S&z"/I LUSz@ r2&j֠<1\TbXrWܠ [Z#MQqO٧^d2*ڞE(i, 9HKݧ ǿ9wweqrRjZ֑G]A)Q@Qk ʁ?7#jqVU)߭躅[20?ra endstream endobj 452 0 obj << /Length1 1519 /Length2 9290 /Length3 0 /Length 10300 /Filter /FlateDecode >> stream xڍT[6 HwԐ Cww 10t+)]"*)RRR oZ}{_f㔱u+B᜼\<9 Yc^?&> ێdy@\AG< z:xB@Q߁0Q< b BLrn0qVt A qG3@W q8Mۛ dxC] r5&@C g  TZn`p:/G2 @vg0@KQ A /dG 8_y np.yNA!' WH|\wm>s9ݲ_`K \0<~xGW;Rtvgr8\O 4\P#ҕuu_ jC6Oo9C`mW?Gu8=>~oq2` _K~DG9ڂ}`1 L<saQ!AoH #@^>ۿ/ǿH n j}xkXOQ$/`snF,̱&ZқskXbi +5.Zk+s. 3y;:[$ݱQޑj *N};P'ML9¸yDJ>= [:UBjXqfEL֙SpNjt6ɳ Z$v8U)r}> F r'gcUf cW$f }aSjA䰰Nw!D6`Ά6#gLJv) ŖT;jdcD[ϝ4Gl 䢼q;.4DmABWe1%u4;eyM-!@~|Ӟ\ N'pen,a2kݔwg$/G-D6F|) a*|d2T߬LxP \QHNe}/Z9"<֍Q2xŕl9:D%>tS(KuOS|S >Pv@:z@_\]_,3l/I?|-6,Վ#kyGCw߃VH:9dE+,j٠)ZcJީwA f"jl[eba3F6]P}[IYj~ yAPkޖ[;<444= w[u2Got.|- -o5ƀ1}h)eEV=\JiD ڗ|u޿:B5ˋmم˨쑶خSaqlݔ3?+VPY՘Ą]_jrXD8/.0{(Ԕ=@CocF! H zz)ۚB4°EWL(,ioBjWkҜXU­-d\GO}4S Ndy^-Ȇ/nSk/WiUa Kf/n/vE3`4 4k_USWrsdOM:h ?އIي|K~[$6 cvW'ܧ 8Is^Uam$'Xk\bZpmi<#Jޗ8{Q!57˙.$kȧ:ɳK0bcr#ذ#ӯ#vK'Gf;WƹxOON퓏qBș=fH9}O>;%?gF͝?;n\Y*gX!vǣ?n`%a67f+OW!=1 z'c#ײƟ8.ZW J* 5vɹ33CO!F3? [l/Ԭr(ņۓjS?JN+Ww\,@Ey39#/rnHJL˿|ށ;{4| ö9֤LN>Io_kB$m.xE*N88}t}P^) :ZS婎W_C̅K(*J-bmu. AxȀ~lj%J/=.|Ϛg'akƥqbEiY:Nz<@pfuid8_'e3߱% gF(JM8!Dr?.U6p+l32Y1^t۵*qDaOg>tN**X} 3%׃ЋxJl#[Kc | IfKuq˔|C> زh&lP5ӓ:_;U bf\"KH\l[.>g,rftW9_dCFƌq34J?VB0Wİ~`m.z5M\,ؖbB`.Cm8ҩUWXJ# BjXվϣnv ʹ2Ul[Pgt1zߺKT' iecϺ~2vޅ3ɢAul|V վ%>}uy)qGCtAI"d&li&˼"Zjg-rѨaK3x#7pn8zm] w%`}F؝cɮDsNڤCbGT\ sacxc T[ F~cǨE;2:K+Nؼ\q;wYTsͳrr㘢PkUkn_a;"OJ5u kUv*`՟õji}4 Qd1FpY3\KPhj(}}s# HŝA?Q`#y,4ͮYv OI*tJ։w˾'x|])D”e!kP}"VoZ(8OHI@szo#]X8zp:DAr'A뺽Vw/՜ptɢ,uvZ />.V{ov-K`?MzCjr5PgݳnÈ)j"~^:Z.ْ6^L @7Gn|7EAqZ(m=%vfǚӒ@2˻O :^R b[q/\.G^%KYW$gV1`9u__J0 :=Pǖ:;b(tmՇE)+f7Ư X9 !p(sj0DA$#T3jQOxC0b6K@_IF2Px")AM5$}Ėq1p(2ɺ5pGIEQHN#52½M,oZ?}II"zIbtjD+YᓆWYٶ[1 ? uXXU[3k2 ( :+z' s@0E jH\yB럾o+XƟ >2eB(߽[RbFv|ńF='V OALE%w' xKBQ0R˺$}Ñd#^Z<&$} `L-hdeǒx_> Rz kHƎ_ʪ(8Nj㳅0+Z׮%YJx FAruyW.)~I7ly$ V>}ba1#=bj>l&T/dĎmGzz Zf6TpkvZ25"/bksOd$*6AџxA?_lZܑ QO:Rk΃H  W߻8qf3eLyNRO˵I>(Fx}U+t,ef!,!c_f 4D _PEW+$I/" +-<4´Hkf9_qqS 7 %ɠ'ڪ? aCpݎ6*@O*0a7z tzVkhLд; ?vә,MSt^lM$ܥUkW&^pDx&A`Z_ %VAv^ ZOi6s={Jbuafn콳˸;JDjzl"Pa>}43 Q E\lM)\ X2yJ13vEkUʕ ]}˴o-c3>*n}PgGR!%:reM~9$v$cˡ3\cݛI,sHċM_vn^u*!EqaHtqáC:񣗋/ f'9 Վ'N m5Tb ^lnɈK7n:"ڳG eP*9 PΡ@)&ζKzܳ=v*ai__c,9~h]\ghmL\/֗iFK xcN<cXz-zKjMq$(!4!3ץOO%HP*ϢJDzޗA:jSͬ(ҵ3Z$?ԅzkisOt5 ^f,.hKqCTdjir@sMbXpWU/TTC10lb%vw ȣiꢠl.,> 6ƸճԂӱ K^fZMX4.4A@(`ik΂R¥Y=v`v'>ugG𱦧 Ϛ IL"gٷ!eT"|JRY9`ljh kczH~bS '-uu4nIAxY5Z yc[]H*-%SAhC|N&mB?~QìPk_q ֆ}(k⫉"^5!X;ã ý*ѸNH)Ləgw_,cǟa\tbp BnU)+r!쪙!bӂArZ(R}2>LMXR*/̻v4cP?6N8 ϼrE+`$k*O׬=V1 4/"jqE:8LkrE}W7."fZ>X|NcWB-_<Ap-IS)ؠbvvb{\'hw֞$F  MREipnGKIG*LXNJ5x;`Hah3Yo s+G )PSc9aO%ZQI2V_c̐u`lI!YhY-nd-FM=w'ܣn*Q㧣./ʱ  (ض G^\8EԲp%j;3 [E*Za{@|]E@ ɧVx`97d!Xfu4o]jw0j'br*~sDk~NRVG:$x/|c^(;xJ28;PS a.5&<ӱT\v?hW;}QHHQ;-X:3of8Lcࠦ&z0 %Rf`tg6pYl9aʚ01>4 -B+1!RO bPQjɘ)^`7-JclAܭl9CZ'-NmGۅGKvo a^=5RG e= zU5/q(?p ?Y"0 %۪oBՔRlWd,\"|1*iݾyWyΜY dspMmY9ucAnީ.\E䏷{vWc?nVρG޿H #{uY!)bkm !x#dH\ӤXjXK:ÏQkڴm&O5+,{9Koz҈J@,Uxf#E#O6qA3& lq3[%/gIw*졪~Z'EP}A-Yá*MR[ٗMrxס52#n[ŧ|Bg1y]gn!^);@QӍn=JlD wEܼz1-EMӾd㑺4'j\<3Qz7}Zid!,*z*U\s& ; 涺mX/5/t%b-u'IrLd,•>jGQۑ 7[<=93d՝v _jy8NV5IEl%ZES6UJWIQfl:H-ELodT`dC*q4ml_7 Avt7Hl>KIZ{ $`uid޶Ϸ̢p]Ǻ"#Ĥ<1&MlX$Nº4F e<M/>N}pi݄W m^)v?k1hnP4+m7kBDIQ'^B$2 55 KXz8BObxD4}UDO閟\~-ɳx<^bD[S$E0cVډ T]N(yvp>@?@]B3}>׷٘) ?1ZRʬk12U4#F1d3yQ rRJ}Exr J^DĜ5g0YOOm5/mM]){]f#8 |rW'5 ?y[pvyu γȩpR|H9N'8lJ].ZP2ܬ@O<aӥ܆n;`8x a-r;W*u:%ka!R+^)c䲏2kx-܌:y*U>hɞ<ͼ&hZ[QFu84sO!^ˈsK1 S5 8}֢J}Z]9SR?: wp\\2Vo-)e x/ !OH2i]lvZF*z1<-&Yb Y(4vO"A\->l_9[-ob6I}E{㸓O{mX4zy^; ))@h@@bHa 2XɺlPK2Ƥ^x|+./(B>K)uY߈[yN uڮED*JJ^Z:bQ!UOBV: dn9r N}G`B O;~H5ƌߖӇ)٥y v3?a|bXJ63 L)ԪK+ʩcV'|D Vz|czaaI\C-=џ熥m5T@h> stream xڌPZ Cp'ӸCp84KNpwA=ܙɝޫ}9$J " c$Ι &/ `ffcdffPtGOttBh.7r~7d\l,lN^.^ff+33 Aq#WKS<#@dt{8Z[8_ _[@h 2:{Oj~ gg{^&&777F#['F =t:MQ(MfaBdf l,MvN..v@G{v@h7p+ݿLL@Fvv3K @QRݙ`dg_$EF ى/LyohW}▎@{0p@nv^Afvf0ugRtpJ]Gftp033sq_ RߗSJؙL2VN<(rpX)01ځ]|f GN$o `Lb7I0Iq1$ 6`A {" J+IzϧSA4xޑzn_3ټ$IlmuzL,&L?$ws@wf7M#X7VX|o?*}'v;ПN;G^{!{Wߙ';?B@W? z7wz=8;Vqvᝒ?{7\ H<=6qqt|uӾ/N h2 nwc؛LaZvpyDIx+4܋#A}#BuR֚l2450,RAMx[#K"Y)ޭ_ʽGXž~,s CW݀9yRhgBXZswY7b8:x(/Myr5Vn\r\mBiJ/dEB3B&#eɭQ_b(;ӡ1&ÿlT:qв븊f^X ;^<#+2OXRmo;9ps~Pǿ -8x#v~຿𙜔sTPm `hł$@%ڛ 8~IY2]o} ߏMV?l.:/Ӭxez Ge"XUsud ˃ks̯y'Kf 25.IAvGo3Gd9KTPRh3U⭅.͏}<.JC . 4r.%3C9=JsE>8MPs Dl; ܰja/[%]E!J[;V0(kkxwxˬb& >~^эL=BOǬ&险D[x n17xȣ.Jqpz.dLW39z)OWOIZݱ'0GF'uڶN&{!r6CUrOel}C_5:̸r_tJ.f~ ҍjHb``qbu mӆy b(m!V{iO``ڵVi=sSq! ~[OBwfD X)*goVY o7lV헓,(Jro1dP]QrJZ?= CMf|Ni(dYQ+7 sU G.*e-_լm[6k?"nL2$)B\?Ej{ȵ)ZPwWh208r͓^5{tзƊǰ[ AG]d@)ykB 䘯Yh%Jn us%_pw\E|!BzANv)4mfJ)UFt[kh3O~(I3.Tw͟BUG=:^d(mQhPd1/:.wHNH=fij_sV+iѪ*yOlg躈9OÚKNv0z\v]٨+z~IoJǼ~4ĊӷM as4>^Fuf®Qs^2C C5գocJۡdR:7$0KlT-=SA25e83vz؜^x,X܊SBM;9k %lj5-9&F0Xu/w\gGp<;cu[V7JdHٰm;wmr}Ye Aד(*L^fb>e#ݰCK;uH ^coھ)做NgSs0jzY, 3OYԩ̼ʄy"L;F7Fl-Xaozy9肩XDz*ȭ{XO'l QՆ|Tb Q٦+p# 8P 4R@]-b^pfY3w:g tuLzՠpcNX܁i#yq_wsAyu妬C! Oײ%pckGJNLXEJ3rwoڽBvq[,j/^(Il!̈E[n/~oB{Lƹ;&*[v$A;i9<k (.jGi,Ĕi E.7to % ౦ت0en7O~S1}(:!`w^Ro7qOG{ (M|bwe5ʎճ=C/os#G2CsoSߖpl*LvBlD}1 .+Leh4Ktf eyHBy_h˟b5ߚU: ˜L4 {vBeMR)=m~<:`1Ap!V8XdozdNKuZ汽}k:l馾IY( ͠%advES^jv~3?wŕm3m&ﶧş=u|J6=:ι顺`W:L"z"͵"ʘW'ͽ40`kspSʦ#vS7#1(aX~J ԮF^)Rg= 6mOUk]j2ӧ YWӸ`CxZ_8c;74'XkWpc=N 3e//fo˂O憷xR/CǢIDCZc0n[$|j2NCBhmY66%/ЖxIXtJ_i5MIY+Uf%ߞ= Y:_Skx<ǶO5N++E{奌z=zع$4c>t3O6kl#:?<0΂>%N^uqRN斺[$zuPgБ .s3vj? "ydM&|!)?Ny4ygG'IZs!v#G ,:L\c=JWG-VϘX_ -SlYt_Si0#9R Qhmul0Cv:!}WalvHE+}U].kؖQTU00) a,5"i؛eSןLgqSeۇI=Xn͞Sx#B{O_;`hW(x:cS\/ik|[,!&ʦH4 eJÉS !p1k Ʊ |z$FvQiXPx:b'؋7վvR#אEqՓ)Hmb(rIo VFgz]_xLrN'?+x4 .ȦC44#LpW&~H jnkAr[5~T6n9H4n('Jß(x+45fwX1So)wa!L%Dg}Gb)&Zw)aƐ@gl뎝{+ ˧!'|-,,`EfCHGF1Q̑{T@ZA(]~TJ8|0zkmxi6L4{ST+nv}_9%`;ǤϽb$*) SS4ߟ+58VhnOhSjbƅ?Z^6ICxD^)c5ǝeBjqxhOSFvs# 3>T듫."ua7C'YNDD# k'ώR/Y_-5gȾ䯼r/.NI >|xmPaBXH 7V$ϕx[,ѯÄU gB$hVKB{]w2Z#T4{0Ԋ|N=գy[D;R{IoIieZ}4v&C(JU'/5WEG{Jz((%V$b*j,?0~S/اCp:~,|䲯`cW瀬ñ0f!IV|8uz)tqvx8ԇ5Dx7 # j|[)dC;֖f5䐁)̠/L|}gl%Ft.uH 밒hadj.dh˔CڴԘKokO![ƴR4'/@11ixHΛRifY<$Qk-xBlUfX"V ɭ% yV[M/b(sh2eyj #' oL$wy~ӳ':DyB{EmdWp7E= ?;Y.{d(,yZ;_%Fd/0~w؇}K@ }ҏ='7W-ϩ+掽2}Wu/Qkz뵔0ۤ|Mq> CWzB3koaz#&ɶJQDqިvs*3s\>ox*jYSqmo꘽rS@Lt+b$SMbdlW#=ICu٠~s9/C0"9,aunFYr*8,@H#C^fNЪ \('Q8~X:;7yW{y,D;qqۂsmDP=QQe.͑ɍ*]{+5QTJZ+,P`YrMYNA-E㚲s^v=ZP[$0Do….v3/ a cr," csROG{o z&^x vi):be!i؃$ p~(b CI6}Ɂ4{OR,1$,"7ŀX݋b|=76p<]Ϲ` 3z_G͐$T12rh#w0mV^ ;=D\P2kYD>С6fiW]|u5EC\(#y\dw(J.eV5nϹ,ݬAV,DýRsyJZc􄒔:bEy 2׾,^57R c'G\-TqSj˦+7Z-ɱλk-GxKdbĥoT!SA0T l\78,Cz}/놉^ ұ nk~DSR 3$5 )(-tLԮr3aE!!ʆc /K_G~nŷl$wG}`jce~HpXeyL5Rc7[Bv#oWr*{cmIiNSRaUx7?*, ZxcYÒ y*{ f8<3#w}` zL>*[&Ф@8 [$ I\@1g"]V8ei,͡l~{n>6/(Di'ÀEF&$0[ OflҌZ&,Ԑ@Z2.;(w'PavH: q jT|s`{ęؗ%;]O!h, ԓ=Cd6UaD#o}N4V#dJEp1T/|uY#9}vT^Vw->9j?^][}ƇE}M- :sYm* ӯ=^[n rM;87%ׯQ_J:/IiFrtJvi[Dxl E;.fE|'!WDz!rH^\чINjO2+4 ꓣ>y\ܯIV(vG5sjdU./PTܜ˪Zҿ/d,?G]?)`]]|(!q~M^xX 93}.[Q(MJF`Ծh^`oj4ܯŨ%!ALu(D$Pa^T"MY!!ݶdcu͢NK)Om} r#I;ޤ)y S*] &bKkm7 Z=~[:,>]U\SZI.9^ -'L$NP טBǣA˒mH#RS<9%RkxVfx%g$3L׬v}2[miJv=wV DOw+(;h.m;`,tGשKE% 3RψD %/WA[Ϫ3莈JUˇGZ:C/g99g.]4p9b:<PW^g.#r6z5|5O"d<5&za&"7jfr=괍$1w'P#V tu ϴ]̗Eà D;*@B%N+Jc˧,JˢIsCl 0EĭD\9jﯬ>CQ`w@&-JrŌę n&y9PxHXwa?p3ѻMHmE֮X TtՆ*Q`_WuxW/jjGp߿ǦE3-smD0 3&OiZşԭwjM-Dvӽ޻#ƿH+U\n\%_Hgm?zpAةR݀i.DI%;7 D&ljFw`?M|\z=sK6x;E|F r cb$`lx! jd?R f[2TZq.Q½v<Cp|J}H^/؄bbxQ\82&,}*4} Cg@Ds˞qҚ2X\IKŞ;1dsr|̪Vo\^;$mz JM$jl۷x+jh+NRmPIп poʒoٺ08#F^ɅӜuGHvjCS\Uǜ>9I!==J4k23_<<_y_$ %wA l g&|Γؒ iurX68JON'{lLjƄ7tBw1!U\!Smfb{$"ќ^Z,+QuTNЂi"vX5,FjQuwZG ӒS^7qՠNn:a^/6tuX}EDM֌EJ,HG*>>hեMˎhFih)_ [Yj6M'HG}p0/#5l 2\#n(~ot3-XZY>"d԰+AH8 Sy4lyBڔ]&ͨ>6v)VWc(ο~pNYus Ɉ:1({$)el=I'G竮/bht$5͢^X% ZJr)MT1J-o߯fMU#c+yiTͫjhe!*2 mT2*<6a?oAK:- (r ;SE3!/{hKw@>rݰrU/g~SR Ъ[ *ze޴& WkwN- S\NvjD5_ϕP2|iF&OlDCtȞ$L?_j;.И؃ F~C+7("zLLSR?U-XzH>ZZ$e}0m!:5*d715uS.aFh}0Fr= ל AxVJ:ւ  }Ygvbon #Y):"gVj׹/G/XD0~G:I)]ivTV<.w"#m;gp|Z#`nqD 1HYp fg`Vz&~Е9X.T?e-J-IiMj,=4O*2+&`ߛGv FWPLvu[ ;VU>ɴ ^7hnti PBAP,7=ubm@7};܉Y݌>mHQn7˗SAsWo:~$SrEq_rd}Q2P/kUJp>$AǪ;77տ<~p;Sy*q ar!`{N>F&](9>.%H^-҃hȞZMxb6eг%O^?DI.f~Lx5ϗwH %/L | i>Sٳ4fE=O.M"LgƉ^gxY#49Y d7O=gpFYM{ ED8G}ӷz&C;-Jx e} ƺK.ٖ9_l&)Z^V g='Ŧۅ7~;«nwU$$uTA.6QX Vi[Tԋn)I!Aٔ. t+sFM$T:7%>/[=|iq{a5~<<TZWB;ab̭Z0ܑU7܅W++ 2abgypMG؍7j¢ibwJN<.97ٯtd y w+0y!pmjaѝqJ3C+vb5|NIW$ů;ډӨiIC,QpHu|qp{*c5'fO}}HC**"(qmГf7۞*$fpZ6`.Q7 ^YL>m/>"G0)zV,)H'Gl뺟61c+a\: ]e^6L)jEPH/I/r =dU3Y9ۺQbNIv&}b"Q5Gd#>h*GDâǣW"e~^n=Lrz+mlG?hÄCY)$zG.Ÿ1툘vo 2 +Vϲ"@=eL<NxX.n^kvZ}E'>_Mk*/]$¢Lap NZqێMωYF(eRԳ96?!5FԩH0vϾK-۫Ȇa'9 cPf.iu%pM2ͮ.jٌ$'mgԄMq=qB%L:H>D>dUuΈ[A|জ*f&ϷM֞TD7 jagRn&3S̛.aD@ke`7&:jL(D:H cv?S#MS*hs4zh/e֦ kX ط缂Ђ< 4fޗ }1{!l|Q_-#sό[",2qbS!P]&/ŸaA XS6A9wԲő́g:PsO?AfdƲ/)'eLusd=40b½Hѵ?>t\bv?nqԐemm ʁHIgwLu/mthǫ<%_œuC@k.8] F[YϚT{ܖ 4N 0ftܪwpI^sASd"ǿ;x w ؊J^yrikYw?NC_VZ &'x>֜I~uWFV epw97aGbS i FRC)~euEUi=}ʘ`-1sM6(rX{k|f 1f1T C3*>B?(#vRa|`r2F"Ej0I9Nc= L1Qȑb B!ڝO󂬧fwiWT1^Vb "'i];m/o[ L^; gop!Z5R1֚.Q&FC%%|7W>b?eJ|//{ck=X0hWNh2cjUy]  :S L_%py | @2=ˢ}@{{1󟍵zĒoldsbz .-b' "^ 6g/>ń.PwE[hĆvN@B7uJ)ũy 70sy .a+Iޛ#^b7fR_{iٹ<2 6g@)шi]ˍϸ'WŘHnl cgp"LDVOx I&]ߚb~S!R{ADmeF?*"~.46s5`;Z!p~tہGqozsKjOrEQL|8yB>Qr$ &#dN&p\NHPyk+V?f ?}WН֤z"@(!]~-Vabhx1g1>Z6$,H{*^gfb8_{PcauU=sА*/q endstream endobj 456 0 obj << /Length1 1464 /Length2 6758 /Length3 0 /Length 7733 /Filter /FlateDecode >> stream xڍWeT\$nS:a!f`hiFD.P[.߽?f}󜵆IGWMyc}  llaNп#lP F PM @" Q  @J0&@ ) \|0;{۝pB qqQ9g(`w{@A}USEˋƇ@p`= v5.=폐> nN0v"U5.P`?_4<_CGxP^a $ *]g'U"4|{RiO&p).ki!n pMxs0rw_U=~#8_3O-=oUF?d,p;Vrp[f ᆹ)ü6:0woKvN08TxA@nq}Nn;ҿUC64' ,#`˾(Э8m޿ #oSlH_7+&m&)wۼ4?m!Hjsؿ( @@$CB*hxW|(bb rY ercn;ʛK_fi\ԏd6ZEhԭl+J/9C8$ic2ҩ( wPO{'.=dC0vr=&d}Jczl?R>ВD '_V|‡iws}c)gB9gݟ;yyaˮÓ >{f%!DJp02pц:(>{ ܡJπ; oRwڏS2Y͈wd{SNs*eQP*GT)ځ- tQ{`=(5s?VG4`ey{qLJnF;a`v,mG‼"wd}nxE1nn lY:x iYTsL*Ndl৭3$Ćx阴aW8c0%j+697Mk]8FLNŘ~9|!pz0n 6h[4>1mZX4Yfg˘L|b97}%*d-<%{.Ǵ̳o!Czt:*R=):1:_S l2%M#6{T?|'.hxQ{U-u^t˞@TR[*|D3!!c>]-8+Z'r9˗B9zn!SiF>{XSbν? Tf4sϠ ANQG׶Jvm cSRPVK C>%o6=0rp"$B}|ÙI.p/㐄W)ͧ05 Bș ^pզDPvJCש}gJE ͖5NK,}F$lh 1;Xh!͵7/B„vӞ=wO)kR":0%]FiZ5C7 m}2-J;y d RũzY޹!AٷZj*xܾ%0'ڲmr]i  ßw5NZ&>u>;jwTIkn| â-)EPh׈EǖIݏ3Q:Nsd ܝګ9G:E)w8ыR/95a:_%d,5g!0kKvz;G/]ѽ+ ^QĿpș=ĬgDwlN, $ & MfsMdY5eQlO{POć^ke5+@fځ-ndl;0K ͋RIsEE γ-`gJUt㙜;G H=k/)4 QPATY;,>Yܶ!fitp0&\ƛL!\GzAp|hʫF(mS^ KWm;9!$ѝymz9mׂ!2s=l3`Zc>qYqqNvslX.ctPS=0ގG6x$j,Ycx}]FtB#e}\Nߊu9\^x4|1;ŋ{,+?R,f^s m;l<79f2pߓ_׎5?i&ܬkRv Lru!OU(‚@]ၛ%?*awitbEE0?z ݊EۚXW#yg!2C 6IVbp.  qY#'/pA5~%{yLhkO55a]%H!|&F7Ӧ}ٞoF(5g #տcM(׿j]܅6*-=,A`x('^K;'AP[L0<ܺw$K4琮RNIڒJq*i[N1?0"B2g,b0I|Y㾧j.k$v5LGW6Zdžz6w ҖkT ^؈wS}Kv(+ܐߣFJۻfd <4akSudiOK,3t K.5GA61 \26jNOr[~ &o^8e:~J ^QG2z }{!":1W![;{; iRE2O)}v&1:g M m8'!5 aS"463-HDy xrQ:x/܍$閊Oa|%Ϙ>i>tƁoZ/Vr}HTd&4$;*=~ahM%Vs+WBZ.]hk T٢t$$XNCΗe|;KX DDJ /u_\ OH'~6~ci_JV[ϙoD/5xD-u|%%yƬѽuƩė3b6*P]5Pi+FK^3{k["ݎV/NdJV43&~EZp`aUu{?Fۘ=1:QI wp^VaZy:%I>ǛCu߼Iq7qjH~x!A}p/eFȞK&b*w4MFpՉoجJ#ŎH={_ %@:ZS o|UIL=Kmt G;9y-&wMkd$psL2L_$U>՗~}jmCgZFEWĞPm Fw~vm]Aʿ_<7𬮚!u0*EV-(@j.nQ[7GYgdδuP6a2H캡~8)֊ˆzuLuylK{kZh`D؋X獱/k9dudOPCd q+æ-tr)m.tRe2OPl"LdUⓗI dVr鮲0YrYGjs_e#)QGLɁM<۾بS^ߋGε T0MF|XĦq*0^Bmq a"Ѹ0>2E)C^s?" hs]&:Z~#3U^FK!Q[O|6C]SBeNb?4Ewl}4δPGOЊ띃-\;(-X])i{yNǤ۲ Wg*pAcɭKޮh٦3AD%D}! [f\VrkcEzM|ҽpp~aaЇlԚt;B6y53n._Й"U$\\MO6v_!?&?OO;*]\K*ͦ|sU0d#؁hFZyH[dF,M|7ѫ'RB|\rTfJt۔To|q+2<M#I{Fѽ&}\ݺ(p v̈́F'"C%Q&C:pk4pҴ.pF hۤz#2*4! bCVvhZgv&F&^?9CRO.TbԿkKC{Rr95BBY:z'e;f4߹H3<QpW3@НAB~bqK{vEj2WaN6M{_m+}VЊu*6&%y'1i*jʣeŬa G .!QcLU9Eѥc c Lo|̂hGN@RSMB˶bӍ,ބhm]D>fRR?6>}".zSzAJ?p2ON]{x:jW{SWJLӺn͈3ѸQf䣁Ԥ,o>bg2վ{5Bzg%WNs7_Y {ĦE7*]digwi} #dB$/wyfZ;ߌ; QF2I %{_ZNz.1N*\’FÝ|!o;U7J~bgqUgn6?SjFvKMt[VgW%RG˙s]}`P1 vT!GcyKXw0&_:}-^ >l⾨6] ٖHn|]+NrԌ?DԂRy&L{em x%L}ECkmx'?dS^%/AD6+!ݷaT'pw[t\غJSkrbu1>u)k4L;Em{.囜IMLCϯ% ΤlRlFr\q %FV]7C^J} ƭmh4mBS"FKkQ{B3Zey;-_\BPw7?*.,;6:@4CL9I9Nl#-%]k«QFQ+Z[_^Owgbxȳ٘i@p1/f=Z)'c_ttۧ!(d";Q TV~^=3b3RSġ9L*#{ɮb| v1rXՔE,81$O9KQF&'H?v}P:& f%:|y9t7/N)(ٖd*"sl{Ӧ=*t3R /ۋ6 R rܝIKƢ{?kae 雟UHiZj՝VzM#IQ5֤3GGGZcmۇ&qQ #F%2'%mJ q)6\t);[Ӈ5_i;Lwssvх&\I^Ŭ,O;ŸbdxqKpJ{FQr&CrXb~x)Lj0Ӂa{R@3'a)<{/VC].{qSk4FݲC I}͘ k_=MҞ<# r%UJ ?<8"!.iX/Y-= gnLıѣ~lڔ"AbWC~ŀ@焃H5SHLgHxv}XpG'3zHǘO#ll)~$a[5u?cB=a[RdЩ+v@խ>v,qM1H|+?6WpojQ;oWW[MUX6`y.Tv+ epwAof".(ѿt%i?L&_[$~Rem "1HSYJ]#'}y`hr91c׳>;/A endstream endobj 458 0 obj << /Length1 1466 /Length2 6974 /Length3 0 /Length 7949 /Filter /FlateDecode >> stream xڍWuTۦK)C$Acm0R) AZR$K;NN)}=;g}\3*pO_PXX_MH(((/((LήAAG $Fn|J 1TwDBB҂@aAAi b|TH"vEbgG 5PHJJw:P X` =馣5 ԃ[C(Gh4? G=!({0p 9ZoA҃ۢ xB0M+i?xP_rf*NY[ÝA0h *(w/A|Y~A7;!qF!-~9he" C!~ͧAoNC+v0m[*60+XMOԍo]`wk{_M=7{x9Ý7} "/$ D!\>^ "@Q@+Fw7;LB@_oxfA=h&<-WXA %Db@WAj0[8PꏁoN?C?w-- @ο TPLKM)UgRqB#8_'î=<ߨP#2VCm;ݨBfwl>!Q~A? lAY?t:p$׻&KPb7bvy o;ҿ*ì6D',&! ۾Ā^B7&4PGݤo6DWO_?M!$Pyb?L1 ]f$`w58Z&a|^L[-g㔭mw4,#+mʴQ ~V~"nɷ*< BIi[ejUp ڥ'I.$e ͳt<_aUxCĕUA0ex}OeQm'KSٝ9Gk4edIkZb@n窂^:`{a=I3XU"<0xگH k"l,ޮR= adn̝å|zzүl6VOů(|%9 G=W쯙c(&̪~.Hb/1bgSzJcb *n4J1*Ml.}*KC19c~dy3†b3B@=5uamrSB8_ _%6 m yV%tv W0kr]lZbGI`::;m.aXl-@Tfz QVσYB^?Oyn|DDݽ|pDyysSzngthMj`%Y^"y*wR=ϏWhzf`w2g.q r0kp>VJʹ iQy{{nA\EpIt[efTt[{drwj?WpEM_7[.MOȸwtdf"vnY]/njzZ[,HEɶri ~%xpdQ~=CF5=lA^@'{b..-?; )!c"}[JtߺU2(B>q"<+TI9,B>}wOA:nTH^EDMjE{N\IS^ 3{-Eq쒖 {X(qm#0NwO2ernՀuŇY}^|H5uåO49QI0e%=(Dzz5.\blpLȐ4_4T1ӨHt @ͧxG, K XYTؗA[ųTkRY2I d ?T|VdP|kM{ |u nn ڥӧ{5BVO.>;&^)@Ƌd_E {K1\0 jE)>{(c;85pPb{R-^\ gI*`q"UV Dt:}r9xꊳE<`OT*]qW5Lp0㒜fTz3\ggƲg,f<9G'3HyLX(qvGiT -bݓ쿲qfF;171߮ T(ήU|kOu MӚFީѕ{p,bV$xkN*l!P~MA/?EM~Ӕ|ެ:F~kcX>N 09P{?9 Zx]!K/.4irs0h)O8 ܈<\cf6'CQ>VDn6'0]MY73>{Ì06desaD[:C >nZwfM#9  n8=PQwlolH\#Ըt`h+NpyܦA:Zǻf{uJH0kGkE/{#45T:er;T@-Xp=7;ǚ_WE'I3_Ui=\U3ѐ_M@BgZp $]Zgt0Wf'zW!2TD\4d~_u,q dz<!a[J &u!!q|{#M|=ݣ}.>i?s pݗ B}}yO?$-H4usJYLc2CSZ/* QR>=wC~xꖤ xeE!ΫɶFX<=fM̘l;r{M0PzSa8<+[-\x[UC΀3 w!a=AG"z-f2nv4غC!+dZ[ѷթ*$EҼYO9.1r#KP9q;,=铒eڲf#Ά6)Kn}zjbqܙd5vd阋صYb\>lp&rYiSE$&[wțKL{TW㪑rDmKF .C#s-+5˜5YO:I@߉`$aaE+a-+ !cyjbt5$! wrt4߳&y@4إG6EH؟Tc!IrʐN|$ꁯ?59vCc(b-FSFaY р=.2Oe׉5q9Y n)X_NO8ǡ5-=[9U 0Ӟn1V?0NQJӈהOg0q}k*{{Y24@UZ!SٽH{Fק8W?I$L^|m6UaԻ,Qj]`/{<ɰz6U `t6|+(59)Uc%ji]g>oU˳5a8gbZ#|(TԣpvAtlu;SGVJRq͡pRGnnLTSgV/ZO/cz}E{ 2-+=f;{8,r_r5>XW=?S8jo%ސs]Jd˛3pۡNAgZ:g K!"~Wx 2y c͕w$E//*h4|ɀT.Z~J[_Y-)]"IX S} w(c>Pjjj͌iE;H4R~7ϝWma列8&F8 VxӍG=´P}P.͞N/Vv>ɒ e3 <$4oksʼnq{T-extɢDNwبoɸX=b9%Bg ǃV_}J$?@Sݪd/ }c6ӡ̆uo\LUVׅ1 j @кI: kڲ^E19b 'ˆHC2ڔa'Hb9_%kڨF?vcc׹T,F8 tkGq g_^TOԨHtfApmf9ٕJGr_"ya{tKIzN{ 0A0~CU lvG.6X@)n92ՁZ˟n<OTs)VSi>y_p:XF]a۽L&N\E&V[1j ЏYRsD;FfY4kdޔIU=:n<=k$qO5`{-{) ɂgں14]}Gm @Ԏcߗ;E c .0ch^ŀϖ ՠEf[ -6L3jDO(ԐHDS5T7{OZ)> stream xڍP-Lp A$`A4;!xCp .9rϹޫbղv_ tTlP3H*r@ 7;ȅNGف遝] PEH;A'  u(8|BB@ ;,A,%N =#ќ )(G:@ 19TA0kӉ ;6y5 (wa:[1!0kn;:@Cj s9O;9) x:Pw;g+psD?AP{G' ` Ta0Vw rA@fOIj@O՟3#okuۃ`.듁8͟ݓ:@F mX:r:@\2@_oG# /r`ή`_;sr, 0 l'~3$?N?OFO :yLj9_+KRRP77|G*:XB~tQ&A 0tC /Ho"9W;? {_Ou=*i7T- UAIl<@?9B3S6u/u~I9]~9jld۳4|6}EF= W*E!T<A݃&na5MP5ɝL_)S,[LPlDg!}\faDZ&H z{ 2yoT[P JJ3q$-+֘RNN{M-9nqҝ w"-r(ZŒ\3 }UmB=g*)<Ȫ(PuDf P%Btkn.g1dV@uXɲ`p77$ZG0JKo/wgRN5Q1^ >E'3ꢥ7.}j<6TžU^_pbB"c#6/(*-+n> A;o3j莍^H/?X Ā[`})֞c/ nocfyGо+q.eˆ9)~ޖ4SG:{L4]n9)Y 7&fP?nPO)ᷚsAr. LEt'\mjU3 b2?Pr_MX@w&胤v<^zg{ZgMb5 ^> )q,P5qqf?PAc!<&RțxHwC',S83ϰF2wb_nP^djDqalm2ӱW r,-xc- n޺Ә+1/ x}~b]i ,ҜYs9 ms(޶M(cӇ'D,ۚE~(m\395d&%YI=G;+m5i8;Be>} Gpsd{ӚxVNw-̙ !0,p :)ZD9Y/q 0΢vj~S'XoT2Sm֌A'!HK#MqFP;6]8ݜuoʚеm]oŮ5X$n$L ŋՔć&qTna6Irs)*ets_@DZ?z/8!fNJsx5^s 崐~4S$Ec4qVXrC@cLažMQ@-Ɩ%O 2MZ$stfy]=cɮX@&.e' ~i8A>(wBnoJ'b";MΫCPp-QW'7\o+W 15?N4}E c[Sy 8u܆@Lvֶ޿`G%`8A72kfw@605z" ᦜ1elzUӧ$rJ4s O)>;,L[C%z>9'zo]G3YmRͯWuPfi]MLz{J7,#7^ui_,WX«p0u|_T^ݬΈ5U41ER?e|&e["3_ ^[#+QMwiHR5!POh%TVa.||'7(\ȵE$aJFk9]*!JFdMkFhy[88|O͊$'q6/9;i3#D7Zq43]`l|b|o4V¾ 25W}6 EwgxN]4ffJ~hbμ_Λ9n{G zYx`{U\^9s?E`Mv+f;pypS&L93fMز/aźG7$*2>HG6T+!BDg[yp0;/g/Ac?Ov_ vZ@q&=B}ŋ8j$ibr x]V) zy NW>izyOf{cOZ){6ΎܡTejU"I/=gzpQYih2obzb~T@6XNZFV#BJ,v\L{J,-_?Im26v`GGrjvtFuCn -׳fуmhZG*}~X lR]T>kХ[<8eU{M;t> E6c|P)RPC}ާ;ͼ6[XJV5'V׭ؠRFZD9{85"nJؚ6$ˎHaKu/!/k2k2%{\ه9&/:`\aɶ& &`6p-bLx!ȞuH~:Mͦr$&+-$Dk2諡-'e-jAItY?}ޡbal:sRs_owZ`[Fl9鉗u.CglMHSb3.nBƿ\7SO[<)Jv^f+@E8f~ Վto]n)6m\^z~OePo4%gSB0*j(I3҂aay}a ae"Iv}[UWWrXőwGX)yU~ϔp`lDM{2 sCP#X%xoQc|aV`_{}M^..f .&I.ire*GZʛ=Qe2r8e6^lI#QW<}jyOϻ]$ie/s6&VXoQ|uNF-\:`q~ N0 MIZ^CޟJfM}B<*Épx8ԢSh&ᾏ\<1mQ"*oKmF@ۂ3DiGqj?'k,-W/?ezmTe!C L l ?/vLa~%#ʣ͎2iV}YD!-/p^T:!51Û;_IbT% B]`_ٖI8h k%D;&Fpy~!^hSDS!@(+>;E k_/xQ4lcj~<€u jAp޼ɯ@fhI@"ЈJボȫǼɐ_~>-kh8x:K(kN$: *΁ ?$ i5eqYZW)4+y>JL n2"Lc'FEYES:~$V~[ݗMBkԡST P%m@'jG2ěC1Ik{GB!,(6#}h=m'MԦ(x_*!>h=.ܬEsJT0m4A:Ӛ6\ -U=Pԣ})jkΠc=KZʹv8Q!Ɔ1Ito.RG\Z:j⦀xx RG \ٛsO(%&4fQTw&Eu~rbcWq:&6ȁߓ 希M`x`]07(|69'tsQo yְd;Ǜfar[daȿ5-2L!zΖK3o^5٘ ?+U2S7?{p@)+k`T^3tQ2fkI KB.YUB6Z,s2õ NxC[ 'zdnF^tZslFD^~#88ُ*$U,{"?2ӏW I^`'@~Z鮥7Ṃ63,|: ;k9m"W99|U@L'GtVֿp 4R\`Q-6n?+Pi[6vq` 梶s@~'NfAY1#eunJ6]݃#cgA+q~嘕켮WL?ߧij73BI%Ji0. Z W]3ҒS-\ڌ=p\\w@xIJ,jK8V8}(L/@>ʷO>+yHNQ6,a3k!{3TGHΣuZ\P[z>-H$*P\\< >h3K#~dD%VV(lxexQ!LƎK2f&r` N"!fg[=HWc! ۍb Mku뇦g,Z>x|8S j)XESԀ0nwE?'U[Xx9$oS!76>B[ ٮOi_بI">[|v x1Wr}?-Rd;3h*|Y8MtPA|{UMP%@*WP3.M\g}NZzPXƐq}Og _*|KW,{s8󜴰sg TjkLͼsHZl1B -^et|Nouz- zgW|x ESZpW|!8pJm$ }>U5q-+EOmv挻i[r+f. /gb~n3C e7水Ύ g=xLwo5l1H יC^h'w4,44ϷsQ~m31xŸ%˲5~HcVYX&u‹hٕm suTW%~D=Oxv&q}'-nZ$q E˫61ϩ=5Ċ8=hV -''-ZPV4*6jp_l{#J]K*E@nmKURBM8f7Ն+큷Я#%|zcyH =|<0)/ uZ]ws5x uV3{o,ZY2pV4!Rzއc-OF[+g-ӭ`mX Q-q$5DYdeV2!-}$!t>}CY݄|Gͧq"#-ZfeGHyR8A<ݳGTkV{Ye|pK%vjQE2g"h̽i'um2sk16>m֝Q]:ԩUl) 5DquFOVdf/\)L^l.jǀh5<.`eH,0Zo]ƄP_Goĉ=2~EtXx#nK=ކ$S[c g(bPH-]7pAGT09*Xui>u$ u6ppO\$tD&QpPSk|`@4Tzޝn56b w~o.Dq-:wҧQ` r4";]'0mzAKaY=^;O`\ 6po \̌^ݥZɑTl~aEO{S؈E)!Y=;jٻ/.բp2/x`ZN(mxEJ@Qbqi+^% g ~ޮja6B8QHkd2䦒z0_ʕq?IV>6m} qmR~(~!_%žÓQְE8K(+a.bO f; %իMXBv0%z͜ 1'LioOČ?$r6=L)D}g "WڏT7CR'7e)&C\:QZlP6~H#z V4M>Uv3]{o ~`R/o,#kaсc*j Q6S&@;$ŷ!W* Illk/rA+WVQ}j2J`UNȮ$9ʭLh?-]yF^^P;!YJzA] yT>)_%\(JJ_".H?C~@F77oAnX{h#(_5+jmX#ީ,G Mw&;²@VKH>+FfNx׮#B^8]Lt+P%-z4.Sp[co${!AGn]K# Cj8$0n)>,q XH\{-Ra~,Oӣ;{w>Ta<+7'Qko,+9 Rv&Pq;yI㎚ ¼h36n].*ZiKOwO6ꆕ%m@nQO{;Ãu =ãU;~o K+) ŴzJ"Uir\ɿ뮊OAW;]h->Q$>+'c&q'Yl'3G:pu`m9 b %u%r#Cvf.uF*k*tsRl&>D:㐱n^.x;_VkT;#۾.05S|VnZ/lO'8O_/̽\E2keG7b>鼍xP9E!h48hIhlA R%1 汕IbʗNߑ퍺B lݧ{2B6LCXP>X_p/YR=7j,<}MĻג98(n6[ M}IO<-NJ32g1Ȣ RzP|u.B\y~;) ; oZҾj `)NL9%SQ^Y 09w0{o}k& $""VGO-Pbf?¼uݷja3d,l??G?yJU1քu}QѢ@teh(Ix5sUຒV}{ ۵o34BE4 =t j(f !&|3!g ;캄RI#irT:Wm2"6_kޥS}Fp_*ҐZY%o,8mW6-gw1J7.'e_(jhP%,0X L[m^FsMc<@agtZG8Ҍg|8ob5e/^}TddtbNH3sU/<M2kpzH 2j6;#ld&ń)W]V%G 3!?b EKq/{1]es;3?VZAt 6e$e┯'ߥA 5ŊA@Zr!=Z7S3cnd ß2TJ"XJ2SPl֭pH_0~(f5wtZ.+e;w Ad9QE2"x tScg:R*곞-cʾ<?;bxJtsQkwOnx;K{u'w$Kfc*+s^I"J kɚkת:F ^:|AJJҢ+?߸fIg#({^:ʹ}5{^~51-~GlpR SV/4d! {sCbnZ:94"c086J])'Be9ލf"rhBd%(%J^Sa05HDal$8T!w]s4M}ղ> stream xڍTT]F)0h$`!fC@RBT@AiKP:~w{׬{?{yz!i4!h'X (y8`nBH&Qp$BaP4'EcpH@@!`0 , -%$"I#=6h6Z-X!!I3B60̎P{6C{ ( u@q"Xnp @ 9,A`&$tl?~m `p pAXœڊ*uGX +W!8w2Ex+= .‰vG_@= ɇBPs wP&PpG45"ׯ2SEXJ#`4W2pg=ܬ˰#,~ aȥ;e`\ahXPGs-l~pB~1x9"V!`>p+ u.0E,h9 : cc.x p{e%a7r+I1));@ 0@g (6*" wsWˮ1/uYL - 7ˍ|` ⿪_,φ\G a U$FVf wqϨ"Q$f/',5h ?5{8D=.,0?bYaBPFmˆa>dH_@X|/F0pq"hL 3 Lep9Bp%~<~oaZMaSH `u'ni'Lmf /3KZ!rjRN'Y&*Uzq<[~d7~}tc4똆~V~psmIu6؛×D7rJ!uj Mř*i~,hk;u(b#REN H:;gH[i\wBѤ"42xez3yw/\7ɼI?V}EA)TMa|3͌I$ܤ K_-A f҇YGzYi7LuOu/5 2gmHjG٦Zqp嶒Yk!YmBumǂO4UR<ѹߊ%vQ[!tnqюkD禥~jl|^4G@Ϟz=d\ A+\g,(c#(Ty~蹘!dl))QXɗcQٞ޳ EO˾BVVl/W4&'b2Jtn!j[ )h6nB]lFGǧYl7f>&9p؆ăKc(D#"C))95'<]XM ^?ƧR6e+)V^0Itϛv+$^G](#\'VE2Q',44;T~-k 퇣raV2*qRB3|.f00(q1~63vX:=>o>}I)\KĸXhpy.1TɼlsK^V%nT>cOlVΘQ-bauWxnFew}O gOqPR7I,@猝6sOJCS]%5X?w -[;eg0:t|+{;* 7.#'z]aX,js2b)8(0N{42I-w>}C̼5ᇟDNa6_c"?TTMHUK= YVzxB>kL˴OI/ݦxwwҋ<RwBW6\ۗ *y'L?"OY(*8v{lfw!puG/>@XCV^R-7;zOz)S* C_l#՞f𝂬ʸOkW!;kk@@5 LΛ<熼]{Ƹawu7[_9@kKXj+168=|x9/j )nd}Qvu9*wt}\ Eof}G-fWe͸mtwC<\{svt HFx~}:߻2byUgě<=y}Y#X ޅSSaVBн|l#ikŕO99)VD59*i<)C604NiOiEHeI>V[gO$,(ۚo]V#U*cZR4{҈&i!Ӱ K(4bw Rf`/[`-{ULJ&gZ(rUt0J1 ٻ;m-"⎑ Ԏ=xPB;dP!۬N^XǞ1,P-H3{x1c" WC 1N}䤚Zfp|zzP2S1pW*g? ~nZ:fv~ӰrB+zx=oH1gn˳0㻅ʼkm]{o'1$||]~ WKg3RLbK yd{(5&MhXs>MMup!3H:͗6Gzk?qWEթܠƜrAD2@"A|,U㘕ۯ0}w(9lmXIùҕJJk]Q|;X [b}F\|W7%%Yj+ňfkCGwځȳdP%8E컙va#14td8G7'lcY[}m6Rd>)2WrCä$3+OGS $p~ $Q]J8#YV0!2uorXǪx<p-2{ևwU7D^肵;-~kV8GVD>9J(/[ԭFN;φJ)w"eJ璆_y9f—d-;͑*}*nxùʦjϯKwYc4Ӑ|u^ ,^H@_ٗ E}VwO{Nl'lA?@ݷ4W|8 <,]WIv3 j[&0k;ʗiSώ7cG3wYR+h׍\s>ܕOt~tNgXuId 飳buTIv@?gPLrz1@|<CyMwQ1ۋ}I^miZ{ RP4@Ps'/Wm3S=G3Ԋ%vzHOOjpL_.(R [DRl*-vM٫W7BQ QxJ5X,;,}Хj`7\KymᚍIu 1 ? zO3\R8w abmokVKXt1{37OPDWdѝ2 i*e{ SwQ ϣ=e{vM.KWBg<.[`MM[F > 5֓O6vB^&)& NynZ^Đ} e)J8f[nn#Qz&&~zTWz'` Yy<75'&# Uczt>DyXmtcgcXV\-GGICA:Bi1&ϒl߭OU@H1Y/N}a.))Ꚗ05ϯckV-i%s"+9/(EAWw}g&QO)wKi4Isd[wGFQhm\HVp.bf:,ڸCt!7Kvp#Ooh>zԝhno]ri)srC lj$-g01|g SXo J[yOTzU< e\ ;<:{ݘL=[z|u/0I{3@/EsU|?J.Z"MK+.yϿLX|ǒE֞y.U$E,^}LXoc\ѫYgH-qbHKf-ZOO!K!㯽o\uz0;]P\&]Aqj=:Bud=6gtͼR kBp~+u.\ߌ^d* rNq >0 +wc ОCduX;njO^:ݖ>Dq@\UU@9V=63.:tz?qP&1SeY+4'0a|sWC[-w"NfR~H?A(jAw]06[43W3k˯$twIi,pȦ1z&C[Bʤ0mja66>-QVb;K_/?}T"eFҵL^ Μ}I.g|dmsCx}@,<3URںqF^Kj[7L\af4Hh9nvt=kHl&]m[3"o|bxwSLwhO]1Aj7JCeQIX^6 U䄏$pn9i m'DyZ)}ܺ uc8+Z{#4ܪ,%0'@u[H;,D41Vnd9XLt>}+p{ne}JA<^/Y76XQR[PfFݷW 1l`UFO xLJWJng%R;Td=Qa5k9~frs BG`i8q:SҺW52J.R[@ Ag':4ٲn)UZ yEm,\tkyUڳp4A'yt^譩V؃7cP@Y_O/:gD־SEU3&>\o+jˌ'oYl'Z:&r M2S (~0aqOD<~xv~2_h+3ZeIK~\Ul n}AวW*r4)/(CۘB_bj[_·]e3]n߹jjXlᜏѴdv6&޻ CXl9k,o> stream xڌP\B6n%o ݝ=ng朓{*sYP(0%lAN ,<Qyef33#33+5?b u-@C'L l'o 8[X,<,\<Vff: ],L[B 濏jc 77_a! odg46[ɎՕƑLjdP:\&  mwƈ@P5p[bkj@#dtT퀠6g6F@ mm A 35QB͉`2mhhh 7t164U!@BX `n?9;X992:ZXnwA&66@#,౻3Y++?db g;&53PZ?&` nLëR;z[< ]'g?F,, c'':X 4`asO2Y1kLj tw? `M2.(ZJLmW +vs4RCr]ffc/TG#-H/5_ uv- @TM,mV| 3Q hhdl7[2k Pk^сO pS/|9N)25}bCCwE_$01l.p{S[0 8L"I`LC\&?$ 6`AZ p-?\Z pv?]gW pv?]N?<#Cc+ KcG??885)IBL& + c.'.U򲰂+S;Fnֆ6 17tSoml`nOۙA,Zc? x Je ?^mv܌58 Y#7 Uہߔ?V{vfl41W 6?gab?V蟴`'GſiEp8g<>Gҋ埴,+snqy)wlqs>݀sƼ-w߅]v)v5h<ZP`T}Yw6؅-N}-DyT I?FyrvxޡpM/!<О׳Td E;Iޒ呠]JNYħ)H]lY\R'B8Z37ԙiWb:H|O ֨Y2UVǎq G&)=Edp=Wܚ3WYS+-A U.#m,;YT};qU *c8UY LEV[n;M- j^3Z懾C} Aw C۝f,:a+<%No:4ҘhK.>d|`w{\r_9rHvFD{oLnJKEl]CD6UC۔}3;?&K )ݞ7";Vq!iFP(xr/_= Z vu/ku;j4(e(2<|ջ2 mmrOrBF/GD2u %o:?uD؋iX㚚pAULph`l+3ؑ *mM.u..r#]8Qz /_C |]L0D)7l%P)~JJ I9V*wW>4$_߅AlRaTG'+c(g0Tz2!"ZS-*3!TA O}{pvNj?2xEb̕T#>\%ܫVoX""zt"b/W6 ikgkYpuu߿ 7J8FɂvMeiN b 3A֙1EM"Vʩzrh1nsGvT[5OX}{x넥2Ze#.sw݀7)loUdWdq tHzjHf"/SRu~dVOV$'~PX\gm- :(H~5h۬Q0/&A>dǭ1^w[R(f Ө1`p`fߦ[Vxw R5/hB$`bI! >x*/ƾQš8{c$#e+17n }G~ӷ4J)N#a6S:9q|=;Y1dMkx e <1k@'-Pv)'Ժˤ{Q,}ڥ,D%;tFvA%#~Jl -!(?flXз|P:Ghɯ˿!D* +qmӦeMmmVљd4UJҸ_20;|oȮĂ}3{^=p$guh B鄃-3G SԻİpyI.nri983M5;d |Ǻ >YCѼQ¸C.Aq>kS9?vk 4&v);rd/R,-2D>xKfA"3^d5m:;# 3,Nxb#ի$DwJyt\ޣkmI"rWad4%HnR #Y7`L|pft;^$}=@Q5{t  uًMLduһtOdq \.: bozDCɱ@Z,=N%&BdE &geCfMvxA\P +7y)z<-G{Zm +݋QQW',*n~c:C7&oڳ5߇k+$[˭"3L }7(llD8!Y)u ugzVFk]_ *s?-eC6z>lʭ4]$`88~껼iC&/r>M4qC#%1cѮ?:%c!n9*&3LTͤRٵEoD@jZaq'týşxSZģb(83Ueͯ˖nMH\glq\I`v%ൄU>}>|\~om+2wPOB|&iuX|P'面T`/XZeI9L4- R6+˧M)]R;cc;;V."ϗuLP'afWnXJ(N:[F${xɹ?qbR<ظWXԽs<( Q#T1n?tϚJ/|wyߧ2/pw1{ PRwdgNIFj'ꈓt^y ,!MiIXA(l[9/7ҀqH's2A ~ߺ].&4g#>.)V=^5ώ[*K_n5̒CcXJoT2x3vDY4{x1=S~;,*t,ݟoTXGJe䗆YSOב5vl8d 5a^4 kaR MӕΑj=?`0$ Zߎ~Aܓ@JhMg7l<"zLYr n~g2$g^Ű峊Ë!@^QKxvm$œ8ZBxwi1 bR9hێXX_V&*+ǭ+{x)*~.|~1ܑH5hoٖ6RL{n=y tA|KB^U{iX.L޲s>MaLvh\e.tԛm=!pT8]O*SyIbM g率FH=Dߙy ~RpQc>1[2.(~VaKPD8Tp <+MO1,eL1 :Հqh($[6iyZ.yYq!0hz٨"٭}ʾV:ρL:3C[0?hepmwT}"a3}7GgOwG(jmNY4{B~:7XЛj(s?vGTT˺; 2߮՝ӣ)t-B%"X|U@;C4[͆%y[:3ίp*?qecQ-6$q5诳-߾?4uk%\atq9QyxWZtee TLgvuB#e{Y\{[}9(ㆺwQ vJbѢxTZ j{\Bh؎Anr T@`P[Des>X"2OO)6kYihH4nm- Ö>rP c٨NWZdn ƒ7-on^5Y?u}e/JIH뜰V%_~F͏8˻L}x\T.Ez),u[h-yk[6 :HX)~T6kcVfY cI`rrjQx_t/:uB.9K ֻPe W“T7G>8&rst?$_6k@Gky; !SR3,i4 v[B^s_?o7df5Q' EpTMq$+zBNLŨf5H>{՛"ăBM ,<ZCqض̞EW,°(ӭRPꔾ T9Z8ٹ\WF|CcƯݴIBD!3fF ,y(UB4V!qJj޼WlRAM 0C?b-J _ߛ ar ̛}x7sG87ZIA4ᐆ-:dmϒF)$ʶ;bFAu ։?9@78ww)B6q (i x:y#Ŋveqژy(<ݱX+ Utc%Y34{H#ҡio#t W~"|`rq9fIH94(8fq{';ShB0SZV4EH͕ X9pbzv" q0 _6ӞVpWjq؁A$lq/ANxO(Kz5- #=M5g; vt$qPx(܋dKk{U̡0Bxzi'I3uv8"pKue)h3׫L5KxbʼnTyMʨ}#,26WI*hubN(ԕK&/N֧:ťCMOJk+H>GHv) k (B5w?-pZ8<=∷c z!-@!/AҮ "[P hێ&Sn7p9T21<\XH{j\ OܝahRSsKڧEԽ%T(HlQ.@lsȹ6ZsڍPtG(o:`ܴ*Qmׇz# K\'t ]/bxWa7x;]_i$23L t)=xsEc] @AECojdWJҶ1zUjs-&cg5TA&M 4:I}GS~+ݝx_SKFuwiM+}]I}?JI*ܕ?jǐyM&Akk3c^|K!&BvsgmJ P{pV (1迶 }8ҰG=w)zs4TJ,>F541 h/(M5mku6;x Ah;ׅ&`2' n ^t$CY|$JcXlnd@-$Y~*L茧1E4W}w 7FwgƘp &_ _ 9\Ҵ') -gf5o~ :"{LhBήĸ (ٮQI aD#|/GvRۈ }>h`k:ӭ 8į̛Qⅆ2!Pp>\u8+)ٲ=9~>!,1],Kad*u {KoM$򰴐tn2ѳ'dWM![;kI}@ |$r/)_Bq 㩉J}𖘦J̙ ,C;P+0MeU6kv`΅xT[qHۧ>a #b-pڸ" '^ly fd^EA4(Q#D0W^{k(BaZy:OWc 1݉|uXΗ;14[>`'PlEeL:sf2׃7M'|.BI"wqctoK̘`^_RLu*/ۛu]黟4=`k 4,xGmmwZْUCC ٩I1[$h|(~6~ ^i4_:|e@ Rx%U,"G﯉s t*|`=4AB:➗Y;stv|R(Zr8n: =,E?ܔ=B6i2,k!L 8T`]vNyaWָ4 r(Lwo@*p!m87H)' *;ZAG1՘yFOP BͭH6Y>x:SAcƽ9ބib^xck1嘓w'QJߜ=:/x /":SlՈc xveU p.ͦyUtA|щus>&rmE^?@Ҽw,1Y%MR]{󱱡=O/A-xK0M.C ;=Y֝F}BlEl<5U&h$ՎQ6I NL;!A*mV@SlQ֒KĊ[;t,,{Z?3k&s7TJީ D7:Oе&+"z UV-/(Ԙٍ߭pDCjShf@=hOUfyC7N`XMDAc8'dI]ضۙIECn4JO&zWiԬ75톢)~&p!^=Mb ^%\rQFtG[{j)aZ䵮LRB"Bc5g{b-44hC\Y—NU 8N4^?:?8Rڅd+&k g0 Mm.z5QtΨ)\0iAbc`/MJޑvnJ[uGKo`xONWcDo:ҕ8v\N\F,P$=T %NߛQsَ8:7Ij? Z^oV3Y x}D)aKeO.T{OπpGi1tZ Webm(i 7i%!Ȓg' j91aox;~AڝS|B_-1*:u"Nh`zQ;LͤUYKCgиz}SZUBXR3liޘMRxq\i`BTwC32aoK9Go_smv7dP'YzGXo+/Wc1|B"~)R}ήA/M!?'bvPW43,8e)Kl=BflB9R`[03iIyQNDj!qX)Уh]껜s;Lb@sNFilA⌋.]\<{b9,:ZTjVeȺ]XǪҹ2RX=׺/A;.zsd bpZ_0;۠:%]F;x8>qiJ)5/؉}5bY LʬO'S /K*NJJR\_Q2/WG{$٢xbj1!@f8ble"| <^.UJwnS(a/'ע%e)hHYRM3o=2N '~.W->F/ *Qèc0 XגiB;+la҃Ɯh lM(}=cGkݴTtw3^j.k;CͅQc;^:(=!ݦc`ǧ^Q^o-,/z۾4>  V#?d6dBTۢJ>Ze] !Omx6Nzƒ Bp}a7(S\Z Y<ćv涰n>a[d+w,;j]qEQizc.eb[5=Gm7} }~_0~]_T~IvҢ ʒPȿZ.%y&ji7;D-v"Poφa'qOoNM9<W[i'8ܥ¦'1ٕIKDYR@66b{T?e"7ODǔѡ6BRYRX@Un?"idvI333* %m$S#+VsܜEz;8GĪk V-]O#+vKSâ~Tj9uH" <|07)J \6b6KC!0Ͷ|8Bn|57ud⤓ZTz0;dB.j<襱Q-\~,s2>lPF(B72zG03|i9%CMH`V&àҺqѿ0k{! slrסZ ?}G46c6!:wF^墕P"I[yS%;\ЧQySfQW7ZԡϺ%nC2B`ǩ5뿀r,;wZj($+lW˂wJP:ʟ~DxQlXeK8梼&BUG$B,i *+m0uQGbTkOX } C pRD[Q!;lFN ̖eF&FiQjOŒOk]y|6<3/D`T'f+#amEy7-~Fz١$WNH[C M9сRBTϥȧx[NgM7EMCYz+8PKˆ~%Rj(AN)*].Q._*~ŞYBja Z)޲0p$]c5_wnǎim&Jt i7bֽܴdOӎM0N4hCQӼ*̟׵Y5Vg(*/:HQK3=1@ R V C iJL*k"j/qГ:Q"Օ2p"KM׭{znUt$#=3RO_e{AD>yM|D-,:;z=HݬR@g ؁"+MXA8tck\\NIckzYpԚJl{;۪#im#ٜ0>8RtZnH)Y[5-ц뉶UH Xpb/!F׀H2 y Q$Q ٍ$#׬3Oǽ " H)fչ57`o:_ivZк7 XB#.7'rN6VRc{cQ>naAcu1^zQK-.}hcbWdx@YLwJˌѴ61}ghCɆ̰zf~ZVIi\\3Z# ɷY GS(yk礪^$8*#yw tv]h<1'.4rFB"cHW6/yhcDj7|<'K<[8.'z(>7~(=~5G[Q"/NT@m-Xso]o^e0yO(cdPY/6ϸ) å0/E+ĺJUz.~} P-M0zEk ;]3W!:([{C2Lp!K^&DfnrPtJS O+q!pT,](҂CRiۚMzVC?x'/H2M{zDn]|s]9.'.;3vKqD', Vc2i޲"i ~6KJEnAUNrmFS1hJK*昪s> eࠃ5m=4G3Ff]\)v}FZ,]ѻfXVaY4&\Ԫ8x@x` F>%0Fyǧ7{ud@L}u],9DH ?I0ldE[Πi}P^\ZNzOO:U8%BTE4ڞ%ߠ3_|m0҅x=AYi3ݑ>[$jzG7̯`;EYv?6={8',O\ljmp :?.1;OT`Lq\_]VY>1x h,1cc}MɊCCegAF. ǫ'C׶f/} A A DzvM`P?4:U1{ B?l+TKEjZ59P۩I{t_qwkɕD}+l;8 Z_+v&h H_PN{ :a Nys?˵-#|hYlk~y;"OXH3V*|V̷K84ZΫR,"p*~֙:ic"d=[o\_;8kDŁGB֎=-an =q`ܑV"Co?p< zR fo2Ⱦnhg Yzar[w0^O\pUUd˒g:XP.l 'eTWO`vzw}czviKZBn|&[xSףHCM?f[5K=VCR*86jHD p^=I||/"MMzq;ͻ]~ӏT: ͢[,)P b>cWRz^+?㮸D(҄fh%ĴM>_ _DTUc5C *Jcdޛo^]y.^\: p{,łP!OH%ANp9}E=;^[isv-F:FkqZ6 ;0 a. <eE6.昮\/jCzfP7J6d,wT&mC6d+\}#z}]<ԫvSE}+`!57/td8OUM"h#0U{R`bD_b|6z(m`(՚.e-z ܃ݠ1/"v~`VNA^^x{i]y-OЍme~gEY<APTP\?];j~ۈm<`ꫪZ#uKKZw:%?Cb6h:R.J*d4A좧{3ƪ-1!A+|'+8v¼n쾭^.šdeVUd$m;ujӪzKа5k8ypNTZ'gQfMZ{'}c 1^Z)/atі"uѫ.xZ_,2J%E$ 6WJ.b Uꅋ#tᙆHdr%U0їYlha6U iV8I|{ lm\"L߭G`;7;I2qCܰG)b45CN|Z9g 1$$?3۪aARmd;_*aN14\×' F(KӆJCB&be5RϏ V7q ]Ch1h)4qYR >P'"5J\x1Rq* ͔D 0?=hCa2q_f{ʡ5\݌D uc5{w20#oSOx] 5&+Rt~ڷnwj0{2Uc4Q, @,503 A @--j/{ O #Ϧj,ymmZj?j|ufzYʠZ @8 7>=ZJ/֝tא $q&8@)~6ym%)} %/@0-t2BYV';.k)iOA.ȕNԻFA;ϥa~ N7Ԁal+nMFx[_Pv=~~[:9f,O 2pPq:lEI\NG-nz_|e"܆(|!.DR 5 2. @uv|yJNS/"?_oT  w` *8D@=YW1.#M RkFr*pNkVYw<I?A$gT*w O X>O1MߟWOzu~ehpgD2T$JM E62C# ymDq.ow gb*hCj̹t/ԉ-LE&;>'ÒIq ђI^Y?%J"l{'W|c-PJg@:<R+ZTgRB[WCPr~Uv7(ԯD ePp/dL.tD w@ Pc( Z0E 2aFՂR/(%( .htAH,eCFԑ/" bL%ٹn>J=._yg#K{Og^<(cykb:Ŝk*d tGXZP*Z kO_e3+hvnRXr;IUa*ͱSퟞǛ:V!&܌0Oڼ\{%(@0Lz->BhjL˜Y~S[$.'|ߋ$ uh8h QpBP\mTN^4e @nP8O:?ѻd( a#iJqnivNV4xxRGpnVՌ,:z]12` ʘaZ[u7ƕ;' iJ QۮN:&:HI5e^jÎt^y .U<8IYe"F$$ɀ?$v%Fic-opDzqș AvdW5_P1wfK&!Vy?"1` 2Oqj_"Q=4,`3К2Od;}hAPERE:W?&Tr{ܨ5*!azsK)sM t؋8Ƈ~"]+&vfxD J.,3F 'i7=\T7?BFՏf LMޘ&K v a[Q$M,kȷV$EE(j3JSbqFm3~HāW__¢a9$ATLt'ec;h _zc,;f7Alpٶ 5,;6{E]&𧰄6R8,8#C;^o_4aa68@vMKD+XQ;D| wHxlNFRC~qف%Ϯ ~du"3=LK7ʐf3ڷ%ׄ sek\>s100(}Ml)a 0hے;>»R0! qT/ a?s-,p2 *٧}>&FSUfǝ;$=>|RcT'9Dvac׮3Κ]xGQ0Wh]8$K$^" xdŅUkso!J]qx 09:frVDCYcduNm2>e6$mh#V2n^ht>NÇ_ŤHXGXz CxIP CZDg\P5qZo}4͢:.U@(C/ jX,w1p''N@& & Ce}NDy&׹TC2o܍кyJvVmỏFlW#.Wusj̼c2"U:!(F溬gWꏨ,&2Ia !P3N_PP^ۥH1;2;g&$2!q Ή\4+e AP麩[wyh@;/=sZ1*fκ@5kgǜ4Wc{/1+ )A-ڃx3*x !H ©M뛧f~|XL>ٻ4Pa WU) gvyR,,,L+mkQTtW$7|CAxbd[~zZtgVi |OogNZi^O ! agou&m]+&Ǥi^V'u΂8в@LJtB_9NoP_!Yzx(kW%4$`7fЃ*fIj4,oC7Jg-ķI%FbڠG?z2 @2P? Q7P\DK Wۼs3 8=P.&byngZ;|Lszwv)Qn<ؒ;퐪En{&&Y\B&ȬGM8S!?W*1VF T>l3^*ҶŃyuQa9r z\/E4 CmިFMdM;$P hUU_ vWhB5J4ߧ2ă%#uRW=tLvPjKç;!҄96/>Hbv~8d9Ԫ>#tazEdіN+9W NzVd"O1ͪXݘ*ƽ%"T²[DouK@,Moy~j 8pgkS/tY!9yDG@)Ü]HBʚ;?>uMXpdi滇g], j xKG Xy{1=W]x*[0 ھ9J[1lDwzrB Tn?Yysəe]'m>CZ4b}6 ]V>Y:P'k6+9iZT.mHOQ0xg\[ޟR*)7l:T58,uIJ(RE73 e-@[aM.inw/X*ڥ">P#d!VZh0 T7H"F'v"T]+鉞O3eB($1;-Q덱Q2}C7ƗwMbB"AԹӜ.ߚe: ?ñ=PǵRF++N bbY@3Uuƚ8*:Hn߱O]c2=ҐTʮLR=׎`g5^6=͉cKrGaƘm},PƳߣ8: ޯk`pPw'$Vg׻OSa"1;NZu9|xXxB.f YL GDp&21xOTw:SfL%y endstream endobj 466 0 obj << /Length1 1441 /Length2 6841 /Length3 0 /Length 7823 /Filter /FlateDecode >> stream xڍwTj." C7-ݝR  %t4HHIwRHH|ufxw<]kXu xa`e JE@ (@jA`_z8m(3- @" Q  (xAZ|uAsC[spq@<r`8 вA8]Q7ٸ `v0_!87 ~~ooo>W>Q A8`\+wa|C'𶁃(bz<`8u7@M1c5py v@} PG QC </Cbc2 @YN`<7W W_)B`;T} 9;@Jt7B=jY 0G0 E`wi+ Fs8J@?/0oſ%`Cl(?Q0Ꮜ<Q>,QܲA]|1=\~-=Cm=S!~@0 DQGѵ_5 'YT_k18 C1 @a M.7v [Khm\!.>Q|DCmMMU ltorPGP ~-  օy@~=(^_:V9 JP;6>$a`o0*/ , 'o@Hz1{ #eD!ް򿒵QLJ#~`$؎`~f'6ZΛw}Dzu$oyIY !:uwǩõNSnTs^O+D1т=n_8c6Wgu#';|S89Q%AxU:("x56k d作[Dng~fkӾ4,4f0O oS)\lr]?o=fcࠡ$W[mVMr-fL:XR_E6z$Anu\Dk'7lQ>YV!,FHIKJtd[5wtuڋ{9q yo{|4=L3J)n(uMŧM)$ Ց室ftyU-> Udjf\dD&hӊ]: .S7Dsj xg 񚞂$k-#x\$ }%m/=5Ìh]U(/:|4c<9(0tYԉE'9lHiCX6} OɔL}Y[+z5(Ȱ-s#VRTCW\р5G&ʨb5]]ycM*O7QӴgVfRdYfwՕqVsrsBSq+y5*SNa32ZbuSGI)xOe']mB[G}C5議J+1 <3Q×'Kwb`vMX wsIs32>đkMYq HP)>7fJYUy;K_et#\ݩǁƃXhpeTExarv5+;/cIsyd[s㝔rhiK-8H @QMl\ qvsgyOL|jus+M,i%`ji3$Sv~z%qV_2Q1GmXMf6E>qCt .M3 lyYM هAV+@4 KA*YOELhRF ;dU(dA* χaTB1li;ҫo\pU85NtҰxZTqw*Iw<6 'N.>Qh.׭8ʹ}9NbvԳwn pqQ#6z; Ru$0 ^~Ӹp8}zbw!o|~ {%΃{+ƈ7a5NiEs{N٫V,Di'r,oAz/+H6>_ioD1+:*cȻ9倭ZEƈ;e`1x6W륍G,5kFvT%w)EhV[XoO/"]I}MT4ls>Oi K-cbآ[ 6? 7?ͽw@nȤݙNɺ$h%t~.+b ?eS,%N ')'w;J,Fe/-bߙHeNh+o&T:?ih&r0.8Jkn<鉅؂}+j,K~x6˗/NӜ"Zҟ_07l'rw$Zjv%裉ڋnP4AB&̲SIQsKe˧c>iP'CxT8cnuVʋSElj\l?gt#N:;]:} >*OD|I} &nc%Ȇz;o(ΞH1~u0mojM1zR>:>JZƨIUVqdB@aO2[vyY,Qbˌ#հD&j[Dʝ@|]GøoYG(." R!sRRvO TRRERDo^H3Z\Mz:WÜIVəZiYp}q*ۑu#HD*;ϑ{j/,ެVFZ1Wlxx$eZ bubЃ4gsw"V 6O>x ndFexm)f;o>`@kX{tJVw*24uv R4W|xTUf*it^΋LZe{h-6 VwUi y׼ҵ]0\A\AR< Ϛ0l߂,gՏ;ҺLldY^!m?= 2؄zQ=qӫ},YRCn]eVx([/ \{]"V57U7J  ^݁;RSXbU-v:f>Y8?*vWbq{;L+](_QtyEXsDc mp=U7p9A6VYLhJ׈nϏmDBϔPċQu,%A'Œe'#@iFmRaKFjRg YG.N~Av4˼`Y "ubBz!\ފ_ ,3MF3 ٵ>U$R1OnVr;1\~TO}U|s.SuH_NWdg=͋޹pahPGm v1fNਲ+Ѐ̿ޖ]m6D GSu}uۂ$ҭ[yU^F@ 顧_rãfo\ =H,xBy}`)6](PtFRكtJqC41_GS^ʄц {ڱqR.zeHm ^#ZXڱls&{`"z2:O~-[ x8｡<&䕾02%gÏHZLx5˧|?6P~:qS@D| k|dޏ$A+V'Y9νV$xc2bH(ᬄ8ADMձ4?ݠ`R1dseO\mqK,̽E-.#b{ӯЬmA/(-đW30'Ţ/~xo\ٻ"iq#OaoU ?w X;DFmK,}#d4MNcjy!#i0~ j F$p&ÕʼnEW1ZAj"xCauF.u *b Qf1]ޢ\W+' *5+SA'^|6A10vHu!-N1.>4͋t>9/BH1u9 ďFʜ9B՟G)EKk?~Պ==\2xX'Kq4?>ܔG^[V2ky#pdRWV7%1~ o @_\}oq: IBƞVBՊl\$]׭1;nR!ǤGڠat6 qkz;W,&`qi%֩Zx7{e~쒙("kbvDipc!( qk$NNqs]gJMۙ.>77f4i]XsϾBf.|fWXF2S'}ŠORgsT~( &ܒS|.)>lٞ6tQW/JX\D{% HrOç}P1;Y,*dTYnh1kQ%`r? _x( :wLrtSS b~b]b&SeQ!WwSu'*sڟ'Ki?`+2A!43ZĔXq9f2|C &dh18g٩4au[7=\ɩ/Ǻъlz$h\{Z65ݏNNKߘ$Cy+{^4k^Xat7XޞrLvS ޿! h,q3LLt^UDIU-b]euxMҐتLc bg[3ݑ횳RZ@3ClO .5w z˜שY[D=š?\YuUvt)6^W2nAw;=%dG`Fo> ¯GО};X8v~tn"@>.B0C+S p%$ǟ%0{Ա; oǢrOWJBr+&C_YgT̚ܤr`A|~ߘKOzjn֬u`:uki'bF+?$k̚ )+p_NN0Ғ7,piXkW#VtɄ, 06"aC_2 @˺^XEnRǚqu)5je;ljM U≀enKY۪V-xnZџSbt 7ta(\SoǕbAs ^{nJX5[Cڌ 84a-ug6o`0kkXPض/5Z ŜoɁ*zl?\S. ɓ>כ1wNʱw `s'ЙIS⧯mrãCh;;Z.䔐/i1B f.)jcv#{E)v&O>y/T%)^tư1<ڍ'^W۽6 -wiTDImԕ)9d>uড়?Ďͳ[2ƈMY>ܩs#~jDg(f#Pި&鄳o[lqG>&x٬S@^`l9*ȴ&;d@f^xO**y^QOL^VL|gjZ^(3 sSV)]1Ϸd^^#LGAjܘ#R񑦕*j> stream xڍvTZ6]%)C3HwHJ 000t ҍt) -J}Ykg?{~YƬ+k +aH^@^S@@@O@@lF`_vy (&Ps@BHLB@ ( "!P4jp؍M⍀; Qg p@b<` дB:Q'XApH?'a A:n`\3wa|lXnB( P0[0:v5x] ;_޿A`ll.V0o`J|H/$ fhu< P+kwV%Y]sA@\n|n A]"V !~AmPN0'U ! VUH8vl7v6Q]v;0 @" `{(lg<0@ {eҖ- Օ5LIN @b1Qt e!*,_5҂  -.7u3Ww$Jpg\5w"P3 }7%Vq#?B``׃  5U6NG &0jh}"nkEDV7ŨC[o`p$*`G꧈, ;o@Xz!P{#@!"<eo@fPg6pPǚЖ*YzOa ǯ8y}g?qS8+3-#dS?.+Oe昮}67%6_]Y&m6|yU@f( ]-N>ŅgWmw`VqXI<)$/#y-Z"7^_S>nhYiMh1O}_ݝ-~LnZu~n}6.;-F$41M*IEI8Y j^x PbˮcWn[)uRR*^u<T=Ԣe}*3Np)P)K*/1J|qFw(VBz`& 0O%ZFmPi\Qz' Cbህ<K޺w 7Nnhug\w%#r-PY_{:e)O,)  ]Dj TlJ/B~ک!m/ww˂Չ֒,L7?Ԭ<&l!2Vl I$ڶ sa/uB솄&8_kFfo @AkJ;ߖ]R/zhJF Q~RhhJ8ܤ!ul $M }%w$ d.ed5s1gi ẽPmkF#z. wTF<|]m4A-麨"v4QkpIN&iM}9r6x.FHvV壾׳x^dfG1Et1;#A^h۝MqO;ձK4R>(~1l"m&yײ~ {0ۣD?:6 *8ЪNȧ'ҵa)r>{T02p7;ց\=rI|f:OGv]'k-(8B ?kfw@LgjD șˆ#˫A/VnI_q&3!31Kf+.Of$.Ј܈'0k[Ӄ}S63Too{Ppsm{t8F.qUL+/fy-Il5JDw0 6)S&Z_׷=jY&Aʜ v=l G]Ѭlm$+=8WJ)I+=o;&";f>`y>ZjncF@);q1V3ޥ9|^Ɣ9{u3 H+%dxK\)ɽ~cC<Gw+y=IZ.ŭ9Vԕ7>T:;~nsNU ++bQlS(SNZ+@7I:[Dߪ/Ԫ ]dds{VKfq c3mPX ]]L1D'^sAO6i:*hAT?5}+DCi (v;i{,nE-~rH/_;]/q;~aV)HUtc tfCGF>quG7.SaBy"_!Q5+Ke޲65$(Џjy~d}l9C8"'F]Rέ{v<"JyG}s*O=%A]~txH)4 T_WJL[ EK$;Z9o$xXa)&̄M(Zl0քo~iʎY)f#;mYtKF7608~JeI#-xihfIӕ%LrcC:rH1sŸY=$tvӮ|L'S _`ʭTg{L]V #_Ysj>-n%4YʡٳDeQuઝdpr]ZURӰjI#b32-(tck*sNXG;nC0&"Mr,a!.oDM5b M b ͌gjAK磛A'# T1)r>LO &E FeꭁJ Ihgm)_K6&#+5~[ݝ=XD|9ϗBuا>L79O̪ ;~`7lΘI!YUe9"я*Dx`QmfP0ol&\ +/;W4sv8>YM7`r7pYe(y_f9MJDv.5pc1O'?ޮ \W?ĿUZlܹc]hATQUJlM+xw}mnĀVΙAt8玝}MrGt>Kڼh ƞ#Ena:DbM_(yQY^`D]ZlX<>25{6h/'XD蘱K\7 P"LWekJF=haMZ,}igʇ3Q!DAMr1~lz%!v\i n UY]FbI?=Fl/:.1|H|!ͬ6yYy14Vڟb]L D&S'bꉓի?lKAxM[lgIhC3/͏,mtχj.mQF {CJ˫]AJv qo2[20am#[Ĥ3(2b^5T |"-ɨH8' ŇYPw2a4j`INNjQN\ vC1<ջMȏRR]\+133O3V 4}oiN[V Þ`eRDfC'YnDz9<,3 KwρX2G sMeŻM.L+$?,`[>Sb'ώh֪\NW$QmAQ ͡ ;3ZpV9E,;둯xVҜRΐIv?0Mb&܋fgxCm눮1lXv1ӺGUa}c#ԩSl23!wza'Qmm,\7Ř>@-`pe)fӃt NsGQ .eUZmRrdv'D.WocDeUբ9}ye5ߜW6as.e .=5 uKn_%2W4ܲ{uWۢ_dHrd@bL3o1xqvAH-xY뗯 [1es02w1/I[bfG6.pK"㇕ߙYbAtzL>玫| ކD/8z`pE;qo>fVC%]p]{a"1pO xzU-7'-!T.ת}NbtobӡwFRqa :;;',g?d%UgއvagCf5^K' " 573p*^:v~DkirYhؙXR"6>C˿e\gtzfƭ"܎s ÂE*횽n-kx_ޏK=wk{={Xӷ:}9݉pQ nOyVEAv\e/m2}S+*f1ӳi >9ua߀Jwgˋ? E?FI42D fieFm.Ea6ˉ!`]H >@07=Rа+L'8ݯuY&q7ٌK"ˣ2Ʒ#$0է,]3o}+|6s aÓ ^w"2܌ /΃x髻OLշ{89't!iInR,@Mݖ\=;E B/; Sgm^LC)dN9D9|├SWD.8t5UM_ĬoK<ѧ_(J~Ol3p{ג" ]{;AG2Nq쬰pzXlK[u-L=AEOkŗNܜ+6կ4 /HgWh8*csځ\B2.$=nGe^=݂2fMg]жQ;pa-^&QP!vw6t G4eyUWEYAP"2RٸZ] n9x&}TiA0?j+BMt7{}98ضRo6cNIUY?~t&_%j-p\sno )$U^bxUo kb's/xFn\ F{hf;9צLLÞɤbV +3-E`u'\>Xy) l:1Bɼ%g>(LbJn "PL&奺DTnwq~C!\x6mڬ g?`Zz,%LgtZD-]" ` [bSvq\.2cT~e}_j.F*>Փs^$&F![;98z&;C*K:j* N_OT039$OCB^iؓ "BcMayΤړnZcПb$G"R%?bN筎vgK,<}dA |;SDeDѬ LxZ;3My}S= 5V.&rA5M!P$qO0\}Pvu\Mhm[ Ȋ8C8>7<W'=[s;4/+Ьl`&Z؜C_۸GzJ <}k'B]ݰ~)Ŗ•~>,,ca]Î[ xM0e~7q5q'Fn;HK~/4.9R_yLUj[oB}Sꠉةj˞sS1G*Px)qһ'햠%2}|D%b&- sU|G#> stream xڍP[ nݝn 6K<8'$$ew﫺juku&W`n,l %u~' 5&Z ; p$”yw{;'GW ?`;]%N. k#΂rdaP2s:ݼW :A77'VVOOO3W0=fP]<(9.irǬr4s wGK 9E`; g_@/6;89zV { @EZˍ `hW+m-ofi15[} BֿҼm>I m׽Y>V;G?V GKJtwbr9$fBf tps _5;2u;Jo?Hf@;O&$vv% `9" N0`{k%U\O[RM{|9lv6Nۃ΢j 9Z}ۥӧ`w.e[t6!76{+K_={rx@[+&W%%zf@ry-UAn6?vTPll6Uvo[? ~y#q|wXYnoKo.H'/;U/? `%>/qX5%nj/4%,oׅÿI"7[v?Mo*7NM p(7zre[:9߄9݀ʿo.?M<<ث|l..oWߗ['}^@ PۺЎ1"O Y]̾.h)Y.7b)#}k?EWȞ}[ےLԧwۑpM 3k=;iABvS9~,_ [U۫Q@~*aՊ1 *7Ϟǧsc&A`c]sfD@5?9~"?W#"=s|/ ! ]x!n\0mF+ѕ`HQ 烛 #jgcK/(q ms'i/a 2 HԻ 2E>% o‚>:CÉ_Z}vs LTrVj'1$O)QWA'({n7,)Fw'?5 ]k:4~ߓ.e/\WfvMo1vgm $K+rb&Jum}{VۻXQ{HҰ{YET鱼@0;"v$̏ \yBe$Ӂ3 :<-_bU0xc2)xM;֒畑 4tE3f^VTX)R{SR(/|háV[WaW;1,\+ ,4tb;|InZ^]2HbT-w0ų%XƆGm?]փ>Lk̐MEF9oI&W*8}Ee5֩Y A\_&W?YxTw#(Ht|r@  yNӴ!6"\O_\nn2Dj\0VH60Y΁Q&_+^w0pb L06SDbpl-(N+kY &}9FAS&/,AȉSIˉX4!+cA\8M"Nj; lFm[\?V!>Ba|4kG`+Wz^6~OnU^p-P]cX2:q3=#ad OSqRb. N9?"V \SC`c|;1?iKj]% dLE,++ӳ8yHX>orʕ/['neuo״dcszQ^ب UfgުY[{m,2%1|lAcV&z |o=-BS1EmHCNXRyS KJ&1B5/=LcC? ݏla׼ses2?|Px1iљ[s[);e@rºƛlte`=1g9['#xwK;Ϻ`ϤVvKBZb@݃8&-IO_/YKۈ[,OxEuxd/!r} u k+A~IRIiKI&h4n]1\`<.ԯ&8,wҬLҧSȑR?C4-"rؠ "Z(ꃨ| <^b/NP`uw@ +*. 0?]2B^h}?]dme)ȖE-?=lM [Ýԗ1Ni}?liţ?qnAߨB1G]\7t,$iIi:jbI;xDcyNZ[/:Wl:؟a+VwG+ = O% - |7jƓF8k76gΎ^av:E,*N^t0lTNd8O\iw]CP~&䒥"{Hkk?0xjQ6s,Ȁ @c6IL[v?̢쑠Ȅ@9:9o};[|T~=;fV*fRMtUCP6h7 :7vofG B3pKugN}jY9#ۇϚ~X,P{e+LЎ?aE}t ^ecv^Hwy)}˜M{[|uTs4lym׃̬c̙El jE,S0^ 17-tzlcL;"CFb[*uժMyؿzc{] XY5EeEGp; PoN{aX95A>'0!;E{%/[/9rb@[T!8] (i ҘcpS`y p3-΁A`NׂŜW v#eW%o:q)@4u^掁 5)2Iuh8!Gs/`x}X;~wHUǕ`:5|*#J#(&b>3_gC*u`kv֧p\@dt}>[-mj3uÄv2$hh)::m{_1/W}p2nuKVFG9|A.|YzzbւZc6Z/W?]Z&!;د&xruahv"ċ.~'#0G7C5 }N^Y*<*ZHoSB=e7:OHh(H*mbiw^#Pf22U[FeRBl,̙Aǐ MFt"͝ǔwaX6LLY-#'BEc,bȪ>N 'q8 DfJO 9]h6pT,!wφ^ E{#ELw P { 3ۏ&[6Fog}7zaFDcO^CבwvpDk3.J+jybsCQ{WʜIzld1ݦ#Aüԏj͔MēE#} ^4BǦ_mP{3CoRڅW09B=TB|P0§W> `cg !(Y''*L * dwՋba2 1w 1%Sqم۝{DkJmXkPlhwKu%[>5|KC&=3H[/tFuz-]2Exh,uᗺƜm}:@I3!|C~TNUm5aքޮvj= qnI+N?3K{6~# :cM~U,0e=px3eG3)$!LAdV'Lbx*vNR55N' 6 hR1Vfvu~% URJf! [3%ovC^C|@ǥ靟܎wVQ`s(җObԱl@&8NI"#r4h!r}zq.<ͱݶ‘k:: '49BMi͠^6w&d<xʹq'q$E/cv:dP_/cUQ_s3 ħ}@w0E6&*j9G*G 91ytԬF+a >|~:DWmÐ# vWDDei1Iwm!1+M@ dS`7Ao4[+ JX/_Cvw ߛ:4">gdWB#067ihϲ=uW_+ݚJ Wz~:`J0''.CSxv_c;]eʈp3EWYsWP:Tqoߝ_9 \H44}OI0 _TqA4v_c(|і3Zɣ9_K213]jbq%e&5E"%2e{^5dp uP()&e09VJ𣏕ubi'f՜G=aZDq+? ֍&m~!=_w㨛ۘ&G#0N` >hm.ɹxV`!t_N VYV;C^)S[>8*;4Z良E^us҈+Q_, 3RoViX`cҤ4}ghf(Rq_@fg1à5<"(I=IAgD QTۮ8?(ޥ"]Rk'TZ1wY4A2A F ,UtĈ:xo4YmBX. qqϴջT;k[$ZpsqUKE3qLK UuP}PBJc$b!?< y ~O++K'lj)#^Rv^ϞwPp8Y5y%z^CnskKxܩE R&7gSprhT]%z~u.ղa!ZڈPP;bk屢4P1#52wTV uQyJDdC)EgUov{qzFgYa0}Q~4׳J.Q'dU,yНWirZs}'.Af`=0)VĨiex2)]ѨcEMB2Ȭ` 35Ɨ40e l99k fѼ-aG<1*KPbLe(j gņ}89<~YP22qZϮ,Fq2a¹{'k"LhKn]f#Yw#Ԟ-% CA–g4¬ⳜC׮;aUTaM(.yG]q G;Ϟ͛ҏƛLwsC;ؼG:ٱV㱝\Omr94.ud31[<҆jX!P>p 0f}z꽽JTyuCf&jIzXR"ޤ:O\nCdtѳc޸ј,S-֋m'm׿/8R@-j7"N,KזFVBn&O;%?V{s qwWY4]v֒Ћk'.s %cZ+h]- TSsR#K`oLF=BWa]s<%7y{)C#%w2Y4Ss"AqO0Gn ڳΝӢJ4Z<˨4{N`0m 9(rafо ыz$ w nmpTbrۣEX{';?&nV䓮npM[ K릒7m]7+i 7`nfև{Hsv%g(2U#7Gb:/Q޵ۈ/L[ O=^ R*/hCAh}K"EUPX/(b}\cë_Ưy[[m "V/?O\r>y mZ0ihq2( *n2R RVZA)U!ېqNĻߔ`㦛6H#4gQW/$bԡe.kcatj*à=m<]1Q>!Univx\tu"IgFppuڟG/g l<Ϳ o5JPD Ǵ ##՘ r4x}"6.T,4Pok2􅶩Z: 1?m}wԠe.w^\u2}rnt|gbVǢL|7Jo0?''i}+`}1:V-@43}1Ӳrus Ü_`ӫΰH`4eUmh}H#OK !)n:RPN]R^/+ P.`η/HJՉ(b_k0"CBx]]àʸR WS*a:Pf>~2p\(Y8.9Q9o. RUObHR|43XC2D7g)obN5MziNV\FfhdYI7^iv__1Q.&BjxW&Lu y̫`~#dҝIOHVjʼnv1+mʭe6g6*0u"Zth_ %GϽۭZK6>[59 aL"cc]y"s|_bX~UMM$PazB %p36o,LjK8d6 $_HO^&[>N s̝йkAv/ҊjLy!MhtZs[A*8+.ۓ5EG#X֎H3K6)x~bL30[ T>AՒH@d^ ^΋?`pkJm4)l:oVcᖁPj*YY>Caخ|=ELtZH3Z!Xi3LܚYE(v|Dk.[UTCar!)*bB jtZVw~o9m:nooI9Wh?K-}X:*ͅe(D~zoQt\ylh ϣ̹/N^ umqEܪt!hja7 ? |:B3=}}׎x1K_8gmΙmZlci`  g-`E0tCbqvs 0 S{T }f>д3?NVҴHAf?390]hxP ЅtI9ޠ)! %yVE\n׏`5¸,ҽ>v3NB0=Kelfݾu\{62gʙstYQo wARVWfQ"aiUd%Z,*_cs;>O0ԃe*KjY z}$MrȎBZCj>%QUxU\`-H(Rm#>qHas!Hi9$s&!6``MG'(n[*Kľqkus3}HC+> Վ~LϝFs ZttR}rqz6u䎝̂dc _3wK#MD"φuk~vߚ;A&3$ƖKUnpt(V,QjM=,g4>kD%hE5j)hm ﰋ/͑?"oؗiES(cc_v&ʪUH2<}L E yM&!1oC?ܫKNʮpK݉‰m4c/%8zha;3 N3\.Ov~tZ5O-5Ua9dv !BoeX_CZ^mTwFT%a"9⎺NˣM":e6ʖ3[AoݒwG}ےέ0G<&!MSg|Tyh̷;%G͙R(zn ?s$i=>@LH\3}/ԴwZLLXݸ$!*9~*JajM,ct1g P%1fOׇ>me}iz?ڱFP43p!  ˒ Y[bDr= *[ V\5Ԛ Q lCie6,&uuBfȣ:6WT.nɸZ>1xNx`8M:!+􊼇 +E)'۠X4K  6l t+w]\1H~M]wz>$2YZ89M`wOypo\sAmij/fi{$Tp5,$2վ yPGַG#hPO1 |GدGEYg OL/rT&p-}\䞃WtxԠTzybOʍ~O}rf(\_П}Z0t5^ߞgBϔ6^خj`MH2[ҥLI a->34(LpJT'Rteww.ڻ*Fu XHE@{J ѮIeI D~SUJw:GRh#MV&qY@Ղ`#0v%dbRߝL.}4zp78%w!7d0Ȓ2%ЛՔ|ܧM!#O]S3"5ڨ bIGؔ; &d:6%16^\LxaW,SD UQ~e*+'?eD!^򋙜o!|p~.J?(; N)%M~Ss ":t:\MA~ObĊ5?}F_[I;9Ikj7.4gfKW F*|[xmX@00sЏ,t!!SU#Tğ8嬦#bS Xi;ϏN4CQaİm0]iY6i5z_X;*Z!rp30+v2a1k|܇o#ϷagVT9/O-]MU.p^MjG'o@;/ }ö0隢\oԣ]+5pOkMܐt_\pZ|He/ؕ9arl&_3o)xۺ͒_C?t/C4;O 4ʌiyIjЖѬ]D5\Fq_p-w*d(-׭\$A}Nq+dK=b$Pz[e!ɞ_0CR}?͞ShEB9 /;l"2 9.֐?(EqVS;tX]-|JS{&NS9a .!d!)#!,węKaՀ ėZP4a4@EY"3B&=A`.䢧26u?FIZH5GD+9m(n /a 4?>"It#M؜*HM8UWDb`ju|>8E$CX[2sSZ#w1(wa84HGmS$ΨDB\9S99^ჼ:Bv#Rկv X wTvyʼnvHELl:; WݵBUtסU*>WW͂)4 &&szc+;Ί > <+ .Htón1lY-67՝{eb1 7i~hʪ)sbBYyuP1NDyO6kٞR=$eo* M[Ȱb¯ix(m_ohS_Ɓc5RDUS9x%!GS>bMpT ;jo(+oвEQb4fg8击CLMj #ۉW0`}x94wY*z",  x.@0FP)q(yӶbc@{[0bkڰSީsXCM8zhD endstream endobj 472 0 obj << /Length1 1793 /Length2 12096 /Length3 0 /Length 13219 /Filter /FlateDecode >> stream xڍP\ \k!. 68w8r9}UTٿkuMI bjk CXyb j,ff6FffVdJJu92&d *7*؂N6 '/ /33?q#g)@ k :"Sڹ9- q 6p:L#55@/ # =@S%lƈL P9P59k 6:^dJv@_ #@?LLlmn 9 d (I3B\!#F֎FF k#W?S7H^+>GđdGL,`S1[ G~ 뾻1}V`[ 65 S';& 0 (#ͫ9`ff@W ?T!~`Z d|Cp4r N@/+YX h#hXa`kX?.U_f$dm/ ouN,UlVb: "`׎fadK rMA/f mA\0f{1K3T_GJMlM5VNQu(M2l yu0u@\9^џ`8L%nf? `RLj;Iz_y%d_b{M(2W!Cg87G nӣHhj0A}:ݹ7*p)MiPڨRA#Ugt3~HyRcXQk.b6w5!4t2P=P]F}XW;g% v3beAp 2iXRHf_=/MP`S6WdN$J9O`_cw=9|U :hKF- f$'=ej[k9\GtkRtsIzp4 '|@z@9W q?CnNVkW-\~Huo3^\<ٰDD]pu/ ~h?1PMzWǹLX>L~~$d9)A!@zqܳEr u[[ng/x^FdUdPu7ae1⢜0}a]Ġi ̗*<2*x񼈯.DlX.WQϟFkO_yON:;PG|KrU0Kaahcat E6~e?Ίly'ֶ{ʰ~\.T@?Iអ\nО]с`ރ!')n#  RT@NQwP\78j~DkDͦ,;py^NKdAD9V`|+m?'^B."^%{yx5b Md2NHA;g7(j9X:u!+qp<$,t1OS Uލ lɣUp U*)?@tNceh~P?FIb|Kqq%CE//McmH| #>9S#BS *;})lr}}pw)rD)q{گ[vc=hM&l >#.bfgޖn~7[6>%qv86vFǎӜFVB4$}S,$q1eo(-OF{Y1F<&"{R !΄2 T4iV% s YSM0'!+7>A>o<>*L$i1@-ڱZc}g(mY8?zD%1Vg=ֱp" U3|+:]i!J5GL7(ݪdX#EFʤudݏ7aw -:p,:% Br$Txz.8ƶ^yk/}9sx@"' eRKx+%M1[ir8ooT%mdT7D 4&J Lၦ N/Њ`RxJ)yKMUhEg˩IL2| cQt0Qn0c~/QxO;>nKN7(=k%LFwVаEyBLJ4iQ3q1~6/T4Ɓ[A{!׉X~cRd1+fSu]It &e%o|I1ո)/.xtnŌJF6g`"hmz`[9=~t]1]F<9?_Xܛ""(ъ-cxyf/{^Y& =q/bd6$eXPGHt'rBlwm^|mrJp9\_*6܍pIs͐ᯙT9Bdf4ւ֜~٦s,wKBG~>^O0Ԧ>E~1ֽYH<=X5.# Lt^ 493SwGW Sjh+O+@ .O@4${}١H2j|]C3@-kn!MouVSߛ7JU|u2c~/vmnk~)A { UF[e~.t#wHHX{I)->R6"9kqʟ/0:1:,%PӊضF?8|3MDdƊķg7WQB]ikl_ܧoB\v8{6ܧAL(A%EE kBv Q# d;M7simm6Wp¡Qa|IOާ/UX0Wed{xH!IM1L)oyc 5%<92\?~ax,+XaЗo)y /M`o|V$ʋi }I>DOtC}Ee0d䬲Xb#!"ʨˀ=;]5\_JRѨZsIa9'PI)3q P %1q 7Dcb̛Y_Cea88*Qbv}$pO\k~^X j[/+ќQm"+=# bη>.K8Z@?guB>MkGG#Lw)$MdlR;l0 4x|2ފztI6% ^>3I~~u|?=kcam&D6bL~৏{l= Kx؂ ktH#a*Ӷ-qC8ؓ^1'+ED2raOӻ#(<~c65_#5eowpԬ+f=" Sr kj>` AYÉ7>csߝ?W τGhfAF[;2B'K7AK|C8] ^" (!P]#tUֹN )=LSo|]r yf¥;S6'F:V%_kxb2?5s|D ix,-9cآɻ;:d}+T=L\A'; &M `+54g}b.CKrJ aUi#5N{KHog39:Q=]+ɑ!KT=tiaM&M)ev`N9JUG6̨ݯ~0NXpiǕ;Emp^uJqihWmCo23B[|I'g@qC,_B.:c5b侰]B)g}p0YЀ;?r<v+\rQJgVOXpҬ{""q(@Z5?6Fꫮn-bK|FfdԀrBvRϖˀ}ˠ,3B|/3@ϗb툜a+ǝ%3gF%YGVSo bQH+;>Uُ ya&ǥjP[[Fiqqv.{Lḭ׸%ܲ\4p=k10Y:~8O8eSiEd)EmJ~/9)%{` P5u$^ {TruP_:'D2qV-., s.z3yTi~KTOD9YءU# P"Rnf,@zO%7n[}F{7ehhJ6.ҐL [ !7xC<op^1:r47ͪ}0wTpاK-ɸ"'m<'yĞ*u,#t0w&at8ϋaXNbx:pRlǦ8 CQ̓Ooי{p>;'0,1 Sՠ,[ou|k-Jr>EBWR_N=U\ ģ>՚ǻ\xDiR4`eᓋ3[z((!Sۂ &!YEK^-ҏ 6K:chX@o+*! C`Qoi 7wEZ 橗n2P+ p],$OgХ Wo:\_TFRBO2|V:Al6T˽/&rU_1Ku*}v_]:#<TwCq1"y~A 3x/z*w(xӃASfhػy,D$&V()1 hlY?4] Ewd9yǦ->x+Qzre}œ Y9g`&2>*{L\źKq9.Ȯ=ih5!h' ipcEqv+ucM]c`qB "*څYלzN/dUܤǟ["wdUa4%1AԓJ 2jܴl 'c64kZkTX5W`0iݯ"Ӂ|+hR[*/nHs_oyޑxes5V9!eXe),Fݙ};_\W f =G1gZJMZX*_줐+w18K\ +(ec_(Ji_f2;?<'ݻdxv!z~imԈ#Wg%7 v4nWvTCH( cɟ"Q5 n]!TxpBG`H ˆrOg96'OC@K=pimG bn6t!9T5훐{T=c˫"־d4gc2:U~ JJӈO,h^nN Z*~m by)LگPƯQ2\WtV3ˬ_>s^0mpyzö/MoTbseavn Zd_ 4#2``4ł oD*4xZh? ?O|1y "!P P~h^cQviT?< ك_(7su,b y r΀t6|Ň![PI]6lFi rc+ b ~f(5~t{ 3Wof E(^e6FY7fر"˼`C1jFЂ߇b(ׂ:>FC@Ne"V1 p8*S_7u̓E߬a x6AAC[D6))Q7F8JX@BJR'OP"-3yذ&!߇oLnkxuXaN#w{£@EZ5a@ur;w=OܴVmrChKyޡ>+tO#9QiĄ4JQ;*N^+]"A?D"7q[ 'h I6+̟+9Ū9eS&Rqd% á4y|e^I\=5{?}PW pRZHx?M1`X(L=vLj>[=a( 恺yZDlcPZ|C:+j-t ՛ޠt wKW譜p-WlqH ~~iZHydƺ>9ŎQթ\X%l,bm ``&9Y~O :.ڕM9X|I$NG1|n71}H pG64SEBhs%[И5jhL#0O BǨLO0w*Nip =-Tp%W\oTx~WJ:% kdxCww+:7We>㽣M^]1͏쨴\ƷhsJpѵ5 J׿ܲ"4~\Ҽ]vK56Ye1E4Zpe-h pYf>mA{\.)U]^flR"5ugK s {̈́L R aPI56)\Өŗ)V ($e6-dױ_k~Q,9gZ>zk*+oŅ"mGU3u@i#@)0xg&Ix C\XeU 4쫰кÒȀQD59rjzY)h$Gh~9[2c,U'C^`״VK+J$Cx;e >l3#=*2-je1l);X׎_I7[bSYJ> >:?5Z*e[,/^(tEjKv@,zxs]ֆQUyYIU5;K\WSNH `AٷڭƁw딮D<іC "jN*21a?gH-ZސH6KrÔoBr&~,uzcʋZ"Bt:r>1zҫoH tQtb?t$(\ #o]eW)4tr>\6BC#E 8 aCv8f%EdLwLǰXrg#͌w&Xboz7Ͳ@ DxW_GukH/+V^_t7E֚(兦;%ص>JЩ$W9=U8dun >=`^4@4*d?ܯK Acu_^y=4`Q/u6cx`+ td֫zekt=]6-=Mf)HֻC?] efdEL0؎ 9nvn30<, *aETV7*ecGpv=hnwT!{6Ja ?c/ aۅB3#_ ]9EN]j*+ saIyCIɜR\pǨH-p>1G S쇁Hhٷf ٞ8VHUWХK`g %2G-w)A-qbMj[el9؅ϿX/dX{pNL%p5o+bdL;{`j#}q=eA-G鐁`@9bB IPߏE|_|Z#R8UWT{w.sHHgBq , */i3~QK[{:N萏i!|oz-6@Ε5 ؉t]|8$b݇|\2~#'i#>sUKA#+׾%]-ʒf{RV!3>܄{Rn}ƓdAw-q^Lj"׳#C”a٤~4sZ:^Ψyz+I'6P7x]'N5Gg;| ۛdY~z֯ LHV0֙XxhmWHHމ'MF{ӯMOސ2 -ϫUS gGrruQ %} Uiȭ'gd{._ab`˸`ט~6s\zS1w5*=:_(nRV6A2 lɱr<JŇEр?6k8 ϡɗnC%+9:|6VTY ;A?X龼 ;|At)HNc'#6(UXnYD45l(e#1cCnr's#Z,nS*Z}76(SlQxuj}à kl&áBd1C68.iSG)gW$$ K(o/-N?`RiV󇁧M[?xҲ#rwD2ʽYt)rۙF[LU%c㱄iĩ1sP,'[D4n z94>y)DYfC2Qʐ"[c,# ̙%#dz~Tmv\shD{b+"$q73V2 eO`;HIov$H?'@]b!rY0G!L endstream endobj 474 0 obj << /Length1 2652 /Length2 17401 /Length3 0 /Length 18921 /Filter /FlateDecode >> stream xڌweT/%  1Cww7)HwKtHIJ~kbt$UVc1%AvΌL,|15yuuV ; % Rd KFh 8E@vY+;? G>9@ :!P=-'ƌ/u-`l{43̬e潕=3RflP:]iMl$DŽ@ Pv7K df 6f@;'9P(-,o`eb`am(I39;3L 8&&6&`oQsONfNLN6dm\h ;s1- w|֎@3p=iG;lamgn;s{f ;k$?4K3Xnfۉ=_Ldp>^ {8d 8;}f7B`e[9Lv@c8ZXC `xAv6hf)E15-* rx1\.^.R6O Y\?@=-Ex?b=R o+ct_&63x@॰ߢZoseMk!bg mF^&$݁fV5~Pd0/x>'t{396N. x89^4kLv g \fߤ#. `x/Y`;Y0A`rػ+A`J w?]{W w?lS nL̬ͬ\lsap V6p&f@_d)(_8l'طϛ©GFid{?qMZ[鮟:]g#]i#5j=4^^e> X4OQY1b713r1E|S!%"Me2y+sn>Q;cXJ C]ko4f*}`HեVT1S`CL-Qmo_4OӆEV ྷAUpæ{5Ɲ_bwخ;:~ @n6!9;M?k55`˓I$h!AԼ2&B ӵ?(ftjԬ+(>P֧+1EҼ_ ȺZFL+8|6Ae+:1]-|YIbgkQPKy/'|qxysEUĜ7'p/,1 tg!eMRW(`-OnUfn! @́LU 4aE=tӅ6ZVQi5@Id*;bݚMopΣG}VWq }Qx"b' ONWq1% iX1(M'? `dx ߮Qʐ.TU<*R6ɘq :͢-cHr<*ee` g껌K 8:ٜu<ɿV&p0T84+QMpLX5V)h@zOjDղNU8p Bj?!wy  K@әX͜m8D_FUyș^=Q'Bv>l"]$2[)/ 3.7stLPa^v,Gh$Z%7{2X2uԌ,?c |\8!Ԫ}j?/aO]kZ8e7HA\ÀHyN/|N4c~˽W`ţW`4vIzSAT8.hMDUm~bUXF5c Xu)c{W>6A Ym:3uu4\=FUEQqKuvjҢfh-B骘 ʛ>!@zl*A$72paR`_s33rIi/]DWfV Y򦴸@5[)ÒDvR!a"fspST'P'c&<4mR1$#lh-s1yg @2ɐ<<52rn)A&/PׄۨޭƛM͢sWz?Ê}Noɶ'GDcYh2JYWqn5f_S!ꮁ3yRwdî?7|fM?|mҧk7O ;B3ٝ4w `f&:iÑ^t/;@`j3}~'dÄf 3Kz;E|6w16m>Qڈczj p]5JH߁ڴSduݑ)xtY8)RDz t2U@ޖ,ﲗ"YC>U(ۡ<.h)8#B %Xqs#h'@X"_E HUrD$Mr! u RrśL1qnH lי;`܄bԬۍHWt*ky#3܀)lę5>$Dn>Gt(rCr{( ZЙ^l(HG9]>ͫ ld4YF( lh8TZMzjϼx{4IX AVw`R!5O1NҮdohu8̖L6;/j튇B`lLK9cDf򓻷laG])!Z7~਼4!~Qut5D7KKQb* m]H1alp$z k]Q1l4q~.CM-jz@iJ@XF(t |6/HH|/ OF2{\p{V<[їG~c^ WԜT ;xܮP)R~c5uI$#H?$oj#s)d>)_&WM<^A- {ؠwZ^ kvnPXQs3+*~ cĜ! d{3·B1IKb'4 Ѻm^P6vA4Ew !wM뻀펗T͠{땩Úf,nϛ \:? فDo;CI*&~eZoH_1{fYf}9S▶Eˁ뒰jč}]זp+{˺6'?ǘˤub_q ̥8} 4C&Eq};eRP, @Z5v/XcYoP2_qyFt ;ne=VDҷMQQ֞jaV37UE'.Mf7tg7B}^tڗan"߈3<&mk^ Nz5E 9M<x( ;64Y8,(``KRrJ d8~{F(Sf|jkk ·4F9%qt rI3 sޖ_u#u_?=C nf< a~' Ӏ/ͥ,tcNm&3>>ւ w sS-  4uesoVVhﲎ g/kipgdō W;\.Φ3ۉ Oe8x;y(_8ǾgD|vi}]G\l!U6ˆ==׼93JȆ0NVݖL;ڷp[GBSu t"7(](_v/wKXPncjUhjE})bhM7ĊXRv])+Ua^<>kqܔH#;eE@ۅ f5A7&^\1w;3)9'J9P+Q1tqL]"3pR!* g=!)R~UǑ?R^}|H^f07'ªA'RH>i[oAE^( wGGPrQ~m`ľ4ˣV^P=pSEp1ȐΛŗ <JGW=32;a]j JhY+.jJoz"_xt6Pok 5 wxUaC@$sp tՇq٭Hq.QwH"UUc.?HVܶYR$hUn盳})C:VO$Eؔa bs)iǂ<։A*O ө~ZPeX$^ͩk h I)T?rU'x<71R9#yv"c74]?yŊ_*l!ŬRuj<%*mbf\NSծ$3`!b>udagg3`ǝ"ZkX7:Pk+7vIW-UF!W#ғߕȤh5g.i,IC`]#AnKjЍnа"48HV 偫. ^>źd˖#RKp9OZDIų+M}Bg:qJ]1\_5. ZMV7qC2&Kmz?KRŘY}`{9MM]DZM]Uܛ5kFS~lX$z-DSnFGo;68яɹ!Rcə-آ٤?ߨIQQCvec;hG`e\K Γ# WɁBL1~$Zȓ$TzYziiu7=Kӆe {ObB|z]vsa0V=!*M9Q:Y?6zCƝM &;ɝf!Ë.;5cѥuNBTHmES`B`)NR_ {GEոD۟7efZ_oZ BnER7,LB)# g̤ 5\%Ypօ>=<1ĀPYj8p(@uhfL)t1ZR:f+&&[H1fc{=J]Xϟ%L8] E'\ 72=Po&8UߨVvn=1%*t_{OV/rHnGh(l7Za P8XPjL G 6Wq+hI׋7ȵϰKsԍ]Цi8M+/a V iuJѪu?L(uىp"9N:zA5R&[xuPk9s}ZQ= ¬qkLppTV&)J^Tb 8 k\}߰߃$^bEJ/z{պu Adҫ9 d٥8,n'_Wgx/(%@q[us;0ψ#QvjniL"\ǩC-@wnirӦutø<$9ń1P|z|-V#dez=s̙Z9Tg \0֞$ӀjCKSRٹ=~N"ؿ̻g3=r2;9a5Pi)SA`=Z5/+̝7m⃃m|Q;͸:M!_XVYAI1ռ6E0R9%txYǵt//>v%&4MኖBaz-v~uے&fo qW,Âw*U&st=*󡿉s:oerUZn9APY` j e4̲3ښ{,E̅X)?e` ?;ljǠvn]8} Mw:~C]Vɲ;:uiZCSѕ|RʾaA㻰sxGCXF+Kݎ c_ޯ2J!Z?C*m.=AKo)\yc-_/PMnQ{[_O_t>o1i5VɫC9\͔1)l#ƾfU DBQr,z3O|,JQ_R}WN S&>[aQ|VQKsd$AN:.zFRNǜ 2mUeT%IgJRO,~tAx̴lZ p҆(U(v_вƉs˞57t-FDb݅@dϮRw&S[>SGc_TN DgOe?tq_::eH' -`yM1CN&r,StO%~Utr$acl,y _)W%ltoe1tm%K%]Fn@C84J\mea0~^!Hs{=|Y"I vIb9da}=۔+CK*ѨniyF X.̚a37J>橺<nJD//yW~.<[݇!N]xQyHp\+LZ;wSPYf"?-E'U*(R~L{~Z-}Z}qegנ1YܛS|2+ 1zCݚB[< af l@~ZFnZZRBku/[7k~|K䆌H&6 uШbirԭ֜q3 [ab@vhذ<]az#*qGiٌ?#ca? qv :-B.up}K,]MhF7q;CB}[JzsdK^1v%uǁnFyP&0*mKrteͰ Kظ~x ͳw(2;ycr_ENsmIΪ%͸KW:ךբ X.+JN:ˣVصڭEvČAi^SMh>\_bdsP.9O|XyRtsxGY1>\?n,Ygo lP6HY7}['% #]_2VɴI~HxBLc2P ^]*ڨ̨yFBEG^O5*PGExv?Mrrdy"~MJA(dAG,qqG YzYTλ)#p)RD 5uO-(Hҍv:^+UyΣLpPLM3ZH;ng1RH4|I~[:uʓˤOs?ݗͷrT0L6*T0|"KjRچԩt`շrKR.G*6QC댤% qCp*E(d֛CY_|,yp0\PwqTRV?ϸ~D6=C>I';LɝgxXG)5<| !@^|puzApGxJB"uNhR@1i@\$ŭ,C\0oP-56}0:=,p~u:JHN!NCK[tᇬ%)62竷?|}2h uu O.|(t߻>56kDxՓpS=Ƃ 3g{˜^3ǥzOS?}>bɱR f_591 gNKZ (s(7]^:>o,*Tͦ?G~Xr[N{g |l?q}݂6(N݌NѓāS O[Cvͯl.Tb@ҎЦ' .4R2on_k8݉>i Ms*=]0Lwa&'NZƄ,,(+e2B٤M*JvJlĽw褳#(CL^8CGNt=Lv;;ДEN2kp5@fVv?|9 u&!9H 1 1|\)- Gб6^d˶\'dV |/pG ˓}0UhC,1tIR|2\7^LcR[[q\!#sh 7E`򚪌BĢ&'N+KbZuE}hf%#+~ֺO[sBS¸ K_Q? ~9xd禌ܾ*!*JZ hN-j>q_ē:Oo6~,<r0an7a@{'1py!p2m~֛BHsNyd'K)7u9aҎBonsw<甁q kgB>BSh9ޥ!Y_(5D!/xoq:c}ŃTTg@D0roOwl9OFt^1_i<}+i H@1zYl{`&O|9cjϢLJ}-7 bABVrNza3gX6S)B yuBKV|ؗiJn=Ue?7qkgҿ'ϵ*UZpX9G˫qqkW!Fa*C쒴⶙mfD>roF(!psIIџ#ȑmx z1iSYbˏm@avX֚  ]ou'$_5ҏ&dRnjƨ#kue:ϯK 9_!.q ~G& `jkrеg]|6+0 8 XaMeXYn!FDr;P4i 7[5yoM%a´c Nrp\,pgn# RTn_rNRTaexv>? tM`~nS{ϴ̉AB %KTxD2_(;3IhkJ5&\=Յ9U;Lʆ>dGhAeO>os쟌PJ+UeF Ħ{ѪiuТHأ7v)b&G=CC&r rqkF@ '7,e:EPY|\$闸`7+ū"U}I}VDC*+ȔOzyVO;7X&9bA3G_A̦ X0O~"etE}iQڵw^h:]^J0KrNztȕo"wKT#ü"0jxB_ؖBn|7IJRC g(IPT(- &N[=5plik!ɞn] ?^ʐ*WW~~'.ǜ{-{9y2g^lgO5}x#7]8N?K"&7r`VaO Uꍍ7_ Nw>.eh KytSJVmW}i0kQ3vgy)V_R g)JmsB;"jmeKBHƦˆ5إ(&RP{ > TIH4a9.]KH{=eMB¨c&PmϴE~[s[FG 9 V"]r[ljDjBu~ӽYmnsDŽ>vdy\Jq3"Jsք"vn#,\̣t.%2{7E+L&E%lᜊQxU8-E_ԬgwmgFoZP.-onX鐐i_"$tXY2,8"Vm,vŌ;!Kj1B[&sO2u_k ?\\Gr㍧O?Qd;8`N{W -!N|>U6Ji5nz . HvLËojRүtUb'"t#ӻ`Y {'[g:8$mMJΚEGԈz*,:9a{_ڑ!0{89r[u]WӋTXˣ}y5ǘ4 4q[]![6aw3m#$*-]qx0e z&`ʅ>91ezcGnYr. ,K;VhVnC ]A=,o&vfe`WH70U"t>Ņ&hG$Iႇ*p,D}u=a-+bo|K2&Ƃ2[1!#:>~5Cމ$͈:E""@Ҝ7M`l>r_LE*KHVS$srmV~ˀ@%o Q- ȪC Ã!,WϭEFױ{}s11b3 R3[?|EɎ"H4 $cmc*y ,iX3 j|=ԧO' )`^:ͫ"om谢l)Vq$˸X@ Cj-uQpq_$ƅ|=$PF!k%2k_l~ŤRG,Ur5FVۧ,:N~#w21þsjg; Lc;uS/e<@Av@lLF=\+>bV;A rNrEk[Nnݭxm@ՅHPN6H.ğTgXӚ  PNh.bKtߝ+tnE>FFzp]s}ټ<sJP+ÀL7K$vy (HC)#zSsto-}~eZ܆*mR{o7Ddă I'.U~TlP%!l2w j+s2sG {-'f\KLul/6@OLgQmgI\uDv /cۇ_qwJ 8au(m+ `vmhhRbhmBMX03:>˞%MY9䂮i, ;5g}oC)-v=E/ow2|~y}I̤& &8SG̠vyXѨ<_U sv`}tv;'26]?,\nͣ%)dQS׌.MOOA} ,a8A<${t"v wkV8(@}%{Չ~e?^Ys%+5>ޝ1>/?i~:=Y C"N+Η7_Qda}n8* gQ3H,9gKvÓ%\.$m <]>\Vl9έ 5Z?"qWk^Dm v eWkEחiC- GB{&:NхLRP໡zi[%F_fx*w ]"fqjCktAE|?&=$$#q8$*Aa$Bj . &~$tÌ d+PAj NLL;DAF%i:(⌜9۲ԕJڳBĖ 㻢?!:iQ}!8W-u|^C!܍OU)lwZ9JW:ez@:Ґ$$On7ܸ3[ T^a$o].ᡖ㥅8ENE)~Ζ;8}~~Ho}w|on{m.9qcBeyϹxĈt/_x-SE#Y]塷;UK"1lm0zۮ:0IqȞ KZy,$Ξ–s11?-Ó8/׭@I^uo7ךo:xy@{aRO=9E)& D*w]LEg}Cq(04Z\ܿ'0gUҵ[q7B?)qDE2JK3 FQ fRA2c"\+YCa2\8|vX@7ָ;91n5T6G b^,p_( mHio%^ܫXSO,c5[Խ/}ȷZ[z@'8yH{Dgz0!քAr`௡qnydGie "H=`RbUI]{r}.ܛm5bt,h1Af'rSNgu.-ȩ@m!1ډ*Wµ?/=1w`\!_]+Qy#bUFaZ+N6r|)>m5qР)"Qt09 lf$f{ͥ^`BPWM)R C {$a^ojllUcV x# GZ˾W00\8Qu S "2J3ޘ8Մ|3ϋR/` '4d+L,j@$i*̂ 5{#Ppтb)Pg t=#|59}5Yn+?mKg\!܋ ,fV {RQlyGiHaD`x, ]_;N n|=<,F?m\>xt*$py쐁u :+_ՖnEn|$L,}LՃAtJDH;r1 endstream endobj 476 0 obj << /Length1 1545 /Length2 7094 /Length3 0 /Length 8112 /Filter /FlateDecode >> stream xڍTT6tIEnn bESiF_[}]k}~>gְ0­!p$(hHaa1"!qX !(&/;)DM8 Pp~ ~Q "%E'0Ew@ޮ'nr\ P0 # .+ڀ} O v)$Uˋpp^PA@=!- xqX(>vg  B܁}U @9?/  a>P=`uHo$7"x' %:PYD"οjJ0[ Dڟ"bsw? 0[_ez=A< rnM8!H@q+䷓_W+`w[j}" k=O[3|{Pot+?~Vap?GHANSϒvý_~G@耡n_0;8 no׎=7VA6?j'_Y:){8;A.Pg?@&v`K51[zUa;H(B Ձ"mG& _w vlnĭ( %`6p_c& ,>8[-  h -cGކvpw_g*" 2D>(S|Z qOo$&>mN߈V|A~7\=r`~{Vm¿ob35 u m:Y\Xj3z&duиpMʶ/Yg8|x܏s|۬-#h>I%]~'Bo MNKGhenʖ`4~&.VX| p Nh/䲚PLM̈bHMS< T @Ɯ7ES]|7I<7דݕ,xZB,5Ƭ3#PXOF;Pr>cl[vf&{E`cFeXˠQE-&W!5uO5T%K uLҳ5Y==P~G]G\_N@~EW<~1w>o 喺+kXԘ I .y'!S4Yō>)E(uqwu pPAGFX.mixH ]+WK+FQeLvČ6@B9ሊZ]qo^CaN/lxq_/x ِl>}+b"4ƪ_s޲Kh3+MbISeivuHާ3S=cu{0Wf[%(jԇw}Car)\{mVdmM7<Pj65QMek 0=uh  Ex!folꎔY{2SZn>24_8nvHb%>[`8ql > "Q5wiٝ}BD$Xc߲A-?0ؿMb$„c~ztgi ~Q(3=kݐ蘄#`[R|]Wd PfzCNId+m|Z H+}_K,$MetK|$!sjﲙ P1T6`"kQ |n,ȉ1r/J̖QwOH9)\%#5)xiaNT;_;L@JeZ]1;=bn j1ARtt$Meܲ%NI}S2i Lɲm*SsJ`ʴ*'Hz۹$=?ɌK|0M<۔c SG߻ -CߌE<<31e2ys+w7'b4O|EiK ys-=r݇sbv)M}: _p..ؚ.kcoų8cE5_*7>NFο9;p$XjYfsTk#L-0{-_MhaA[|WȔ G/J{QW ~.9N/D|F.aI ]N sJEbCpp~L6ܝK62''G$>s7a/{~](9 e: -Nj'U_"&}ToW@5{E& Tx=lH?cj1j28T .Vʝ;.þm}&@ڙZcYC]+)Z2 !<Ǭ }u⠦ t1 g}ΤC΃U~|!o?El9*KXUtɋ [hJYq!LҟQ>hUi %wr Aoi\x! pk{(_}}Zu:*ñ<_' Qq\%*i}]) l>W2d Tk I c,5howӲ|:]w~YwOV"ko,~~v]z!MbD}f>q8?s0g,_g.e |8&:UQv}V@-vX$^Ngxd]7qrqϬ={j)oUg&7]b)_l.)L72a}˲1k _'X,utj8cXhꬂ;jj+S;iyBZ.L`nqp`]6P:\fla]^|dd/|{t}Qf+4>SU{>N ceoSUIR,ͤh˩A޹SHv-ICCR%Trw?۟atOxro% S9^ T:iW/ˏ`ebl>*h_Wkf&*E/ ͬ Zτk,-(T‘ۋL ެ:''5~Z~h})w5jŸ ~B%ԳS4!zȐ:|L\ֵ!OɄAfKrG{o+Pb(&FwL ,ety g=3VX!,?|$<^ˢgBMiH *U*^U:pez_^EU~1R[@u#ɓ<'|6Kn .oj8`8YMhSY >[I i}V .Uر> o岶 EOQI%mV/"kcOAI}wވIiffv] f&ɜexCeQTav_$X9%-zJ{юǕp3=lկǷ%L;{?鐋^-T:FUvC l:Of*,5~Lǜ,=Iݎ[FϏq!cz1μb[ė="o)Z@ž-Sc 9{\oXг1Mt X* IQ[+|`׻*Se!]ݸ8ˁj(b|X )541N0~㷧;Np Aޑ%\* P~n)ad19Vuݾ84=곫5n(LM3 tgW^K}+YENO spx!نb\nx4mu -Ԫ Knxgl|ygSI• #^U%hW?Cq5;$x:d(R &Q^:ޥf3YqL?+Bp\Խ+YՐH8^ol)%jX^& [SKN[$:!ù%[/5؇06G| iޖYZ\5*_KC--#cgũ?5O:RC4x)Bvv=_Z;܂w9˥1"ߋ?r 8#w6U"tqU Kg;.ZRq^¶NC\&V%U<.žrZu14.KlOcaKIR8i h_Eطf(6{3I"kgtBD%R#,}FԊJIfB' -u{I6ÍU+R1/yn=7c'7IJ$`!PkNUr endstream endobj 478 0 obj << /Length1 1433 /Length2 6396 /Length3 0 /Length 7361 /Filter /FlateDecode >> stream xڍvTk6t7C )"03 C ]Rt"%!gy}_׽CHX]0`,cd$@" 11&1{ . `|Nhz"8K˂@$ ]Px!`v{(]}e Ct@wG@!.G] #4#*+*-Ay#`{a] g2boxC]<2<]`pwjqHCsk ]_.!P( qE8$S` @_C $ s`@k<;!@QW]Vq)Q( ƃWw8j}E /5U P r" &H pƾA/hWjx ~"x'<m vp ?կp?#|K`h?+kv>8 ,&  1i@Z >Wr5\р̟n?{E!.p[$AЫ7ݐ';;!(/i=1WA_忡D!V!,EO[l04àtF")l-,RMGH/lXP@%G: &A!i'Μ{cnEHnia2'xth33ӝ3C|V{TY$ &GNoJlͷXGJũڱl0UPl=TeQ=P+3)NJċ\}M!@3azQÅM\dIP7SzmF#'CZ@hHu7LU&55C;fEbUYoDY͕!ΌTq;Ur.> \AҮm{7*4 ͱ# Sh?U-=z(NmZu3ay~Sg~ 0 4 rtlWTkUJ]0D$qs.>lPkxyʨl:` G`mZn͏EDځܗ9f_y9/vw24RИ@ϴmfg0QP*[9ݮ=бQʴ sYA<ge#^K.p֕"9#DJV' -&!冱|Z!sV' IүwPe)sL*邿\ߣ~mQDޔӷPfZfn(@SyW3؂ FtSN%ߕ *>?$葀)qY"tf+=Xf/oqwN(% oM`Y6pl|dO2-QXY݄Jy$a%DH9LܕlNVDz%_2;K퉌9nc$䖕 VUݗ^uPnLE)Pte"gʐ8nFQE.M4 ast DHNgwEA ?jܰ;iBr.}e툪Z^bM߰Pcv ؚdk>bPEќ?|++BXUqq;VƟ#j϶+f,J/|_,9U\ޤUSU{^'o8qSIо\ ;ShU!tNR{عH԰svG 4\b=*/3zY_35Fv7'Vl4\XkSQ~a+^msx8xCqz+_ C>NO # 좷+} wzZoVK14=0x7_Ǻ]=Xc<=Fs,+d>gD~mW>TsJGE~I4 C%o Y_3Ef{gv, DJV?K]Fԩs?•G?h`m8 8)uZJA7l}٦`peKEO(:}pUQ-z+0yv,8gDgGUhzzD6vMmBh,Iڿ>[Il~=-ը[RT*嫨jŁuQ$ D`^UC/iI8_;օ K/V/Cc ?|\?v8&ADr&7}|g(J͛VV<8Z34҃ܡV)B=8XL}4uwmcl 'LzG%~~Ev]HAѤ+-y#򦙅`QZ=JQ !XsZ`҆湽T8"Ŷ鴶g iIƥ,=q+Bsָ8CM㍷Yۏy7z%ChO6YW>w,|sn& h۵Vo%\KMy~bJ+D~MehNi0vښr4з!yiwwn`bm+^x&{6\ڂ4\!P.)CWy_MY akikU-anrԦpJCO-۫u JO|]{gl+sgd5 AR<&>A73R lNr9һsPVH>B8?m{:2tNomJjSɴ3.Z)Φy[~EDlml@7  DP8HϴL9Es Hv9wY7̉N rs, SZ7C> u*yYx6R ;S>_c%%.4?[hHR Ub>M(KK+߉z*:+*wdz8PN 0<XnE&$eW!M}%9tio~%X1%U *Ewq|{xh] 6ϲG#fЌd֩"@Pnv[ /Y)i ![4> ϙ5u?vMtRMrJC^aIP{Ifp_^?I!*B]3^΢` bw]nV~'F lv|u1'+x'6p4iIPc!ī+\ULi|VϾHjhMmڒ0bӖ)ج `c=.Rhڮb# ' L)o#LڟRI{Trqphɿ 4"A h?ى`D`E=?qNγhW^[>kK#B:sZUЩp& /.ۺkXεhˑ\˩_C^x],̾ D{$b_SXOC /"KB)@l $%O{gב/4o<2nֲzIe%k]cc|r,%R+h,bcf.7'uX9c@a rb{] a\7.5ڂo(dIF""`ԭdIO;9ƒ"VE~dߢ=I^ yƢٝ<-0G;a~fَso Jc C#]?k濥~Лںs}4^Ƒz{cő{q;i,iwV^͖V[8 RiQB.ѳimPU B WO>iQ^G}4)B ujNPTHj#V'Hc,B87t5whWuڪtPso_x<|>O.) Z jӁH)˸ffz)bܽX7Wk~ S1Zv{7O'0ѹPoc}We1ɧ;~}s|mҩ(ۿyEh9&Rdwt}&w(2_Γhf:k:*YiI~cw'rEt@"84)܊)TTW쳵v UImRT32 H2Y2CJ`F00̚l*i INҭҾk:OϠ>ΦIرK|@AT\/&xa~KGa5j,3I4:\/˷%$_=o qČQB)?ґߣtc ;|6=-/+c޹xyS2- ~WFIHvyiyS:' Vogu~c/bZmtnq|_e7aOh/zi-2}>*Sww[Z缓OiPȎ^ӧCd2])t%)3e3К)Iq-[6OIhG3;otLP;ѫ8s|H}J\4=#f&t'x;S6v9NU8n݇1!%^LH Av5 Ϩ|{z0Y4#=ߑ/r墚{803l+ǁ΋2?;P^Rz r#U\ |$ )wb멽FhТZ,^p2S#/S#Ndia#`->xR=4uϥHn8R4{9/5=>Ht' Ƅa9/'M !*yԅK5_?4ȇj`+}~L"U+ w:ScRsYL&6WeSf˩.7IKF6͘l>B:dbc+n7H2PNj\JpR5UZ4z @'YJkմ_( xhV&4,rO(?Z(E!9qgz${}!Kpn68 pDTsAgTA7K@uӵES&YxB(vKsgp9m6kLP˄èwەmEZ?-^a(J~l~UVSɷKn,&/ 69ZO?۽.$ezwXTI36}Rm awX> stream xڍWuTݷTC$kbEB;U:D.nwwk>{?{yYk5u8VPy dtt A@ r01Pп=8LP+ G nm`-U (9@<0H@pB!"Y; PF8L2g/$u>6HHHw8@ Apeu]v 0(_)XEP(ga..N+'i+PW(j 6@9N&FBG w r[C:J g(vqJgD0`0prý`p[  АWDy`/"qvVŃRZmv AœQ0_]rJsrpkrU, _GGx}60ͯVݜ07쟬[6[(  3|ۇ3`s f}ݡ OǿAP+- w[3|$`!ev3koהQW@3iaVX%  G;T럃w.uĭֿo Bn@o+C]o(v9zɹհvSo1F8ZO  )_[ syB5a(îkap&p*qUov5o|0 ¹=[5\p6pۜ/u._Hpi~UepAo9 B\5qC"on;}@P"l_xV)E2 rf1P`~)7b1V~$on߬.r5g֋N~ݖ*f},甚a- IVىIAr_ڶSKud3kyF,j>Xu=b^tziƠ"tQA8=CA"首[?]쾕Fc@"eY21C$S/]U^,O|j"m.]ۅOH|c!Z~iІ.ěVy&O!k}3+MZ=:sSKPZ]5 uUI©Q96Akl'k kϑfQ9 E>ª;0Zʄ+}VaOkOnWydmdI,:XG,}x* -{Pug7la`č>t >ϘSz[A\Z뤱txXSwOB:NҐh>~G67t{?(۸z^_*p_X>v#94Whܾ b莄WuYʩUPd}udY).qӲL9j2U7&y|Vln2l 3UF)Fe|hscY2V19BMs={x<8ᕑo%ES}3oh E̓f-W&za 1gw-M{Z*?fTccyLg_I'yD~`nkwLs]ņS7E ?g=B43q CvV6@Ͻюqb(.+# rLo7 Mpr 4HyT'yߺ)aqg~l)jek$ 87@U-O!'ɹ"ٵDl1u{MR|;xX+ki- HFb{;CI;o!a#>b4jJ`FmkqOjU L%rwF=]8oĠySjMh:6:+:`ou+uTCl?R#^Y'i3̉*n6{^ 0CPt+,kP \,)L7A`lmt_!pZFĵ2ƈԐ^= 1LrWcXG̴|~墳I<5^]֎Jݮs_ [ʌ3~SF'p@Zjצ^-B7YIBxwR^zJ`UO*8m'zY.Vayd*OPpfڐMm{Ix+JN^`t'ђdH#ď͢>^zMlķ7ʠj}=#[y^浥\>툁[}T.`^{>Cdm"*!5}]w~pK[.ذw\4l{/26QX2#dtiJtj#Ae;X=Bȏeu!j\=#9gZʝy)e;qS5[GйTNg,as`Es+1zҖaեju9a"iwAqMpYOXhŷAupq]rfoyי2SeӹA1uo|W*ޗf_#Y\#WĦS3iL1n# 0-BTYșW; [,rعD5,Je3lϧ\=L㎎&ioo=ǢHFD\^R9b?ݶݱ=+%>ȣG[U%tLB}>u0>֒ER1<*㹙26t&%dxkZ7/{/!# odtrƨKsW&<' ,<}VXd%%&Ifvp||) EHԑ!EC\'Ums$F~J i t>rD^ \bb~J ,k!tOE7XÆz&t RUiVJ ｺ+U5jL7~ܥͶA[">g~g M{m>ӖL/pS{Bw=^׉ORi^BJ"R70N=HVrZ7.w(ӝ9> \VO8+҅{s./Xؔ]C.SiVz^NZU \6#6,&!6{M u0;6ٿ&EɕqtzJ҉$F'3AZ.h‘‚Eʰ!ƜK/?h༠q Iݰ\b~)Cs?>*H==w*Ar<"~Qp]Ά櫗x54$BʟQ_h%U٠՘;,S 3@*;[pD.?X>\,RdhJ˴#Rͮa55lBx'cXKZn>:暩3v\€ҵ9x_DAzt4]pi|Vմ"Tac~k j=v?aKVdVf6^CpX܉xy*Wv܆Gļ3hTUC皛?.@-#Q g_'u@ٓlnܼ|314uS++k}*2jR'x"SeS2qOq\ |Y_ؐWqPt?(d{_ Z 9ZQl`zRWZ˳\`O[|q-TQa韫9̓P4QRyӝD6YdQ=Iz0³)sXU xTO*I~Vq<-1MtmKo'(я}bmV~> ӂ*Fd;j\ᢂkcMstF*!hVOWDt'фKQj<#~s)qDsL0}Ҍg'rd1opՑ)]fp}X+V 뾉MC놣Ok>|)w4Av Hjcj E U~f[)qp3?ŷ+`8(Qh< ҅LU_$ rV'wM-SXNmgze8jܨ㺾iS\$3h_~fPEGKvaO}ZFiB~Lq˲kd½z4:rtݟr͔ٚ ]lKBAWo -WZ [>} ؄ ;K ;kR>v vCkIQu+sYv6|n ރacq~Dd/Y =$V>vM.OHb_TL~ްl,e9v+v6 (Kd%5)Gf8T-:!v4^e* j|})y~&ud6}a&t3őޏAδ0Ni2=(MXawT/]RBW 4uaO]))*S:h`4;۹/t{E/3%Tw-WK=bhڵUMy ED(%GwCJduRlRXM.WG9yH<9Nb/t>9_B]C9y%9>7I%t(l\6q?\6F*r;<7vRЮƞrO.aFRSOG韜͛̂*#Ɗ菫='Fi뻱6ndxeѡǪ2۸O C"1uU6#.K3ND*ٸwx< kXJJGG!"%A"L.?W'hu]clizc{W#.w&`u/t}KhjasN) nXOI:kSpRx5XO]Ouw%K&)YȗQj|4'>My kˏ LFt>Vvϗi"Q QXt:n[7,O/_>15V lRf_WalU-]oܕnH/w?B'bbYqZ 5RL:8p?S5"d>ЁYml ~n\v0 QLI0e;呱ڐ47+zNW Ѯ湝|3+O4ryބp/()h4,8R?ht^{ԽVZ#[?M-ӤC Zҧ^SFgݹxR bczWEglث?ݣa\>6gބ&XZW<)"irx$DS7 *Pjg9UѬ;@3ِTҭp[忰T!y6R>у7zE!.8yqDšl55^rˇH ߻gʑrKD ()TqMp}ۏYnj2}Uk>PaMraӕ*Sal^m < vtOZ~Ok!nn!tz)y K `uRT.94ކ|Q۟sVXOzd'Û6O&!B`DB! endstream endobj 482 0 obj << /Length1 1381 /Length2 5936 /Length3 0 /Length 6878 /Filter /FlateDecode >> stream xڍwX>!C 0J;G+1ƀQ҈ Ғ]M8q<{:|E'o h>A~$PQ VA a~HnG;v؍a(w8!E ؔ h Rjx8%$A $*A<@m~s+"]}Pp{4_@N(PPBBw8PC!6sTB`$C+*) qqGex^pCyl@\``:vh/ Pば@PNgDp`tq |{UG{y/ xB w>ݡ(+ڝkH_i0UDhw(>{iGUw+ ˜ah(D܀0o>N_fHWf?Ce ecmECf۫IDA@APLTDzG: _Fճ4S$\Ab rCG Qs?Sw鿲dT<8D? OhA jC0[{$Z aazp4a78g8tz`B@adu113č\a%3Tc$+0IڰHl$~e-c^( U444fhQ3Ho-kl: Epd/>Y~Ϊ)p H*!1E{7 M,$rxEvf:*ŃM۶wc/ _sąΒ|5S5Kmu~ƌ=t` M͉4D zTs8a.GÄO!tHxd)B3gNOkJijH'&lF 嫡 /ҙ-X-?@@ 0$ ~LJˀ_XN)\JB훗,ݥy%Zb`6 _K T@%׳YFFf^9a?Es4RrJ]|0,~gyDpL XmgvW5jQ:&^QPO鄲wmN~ԧ),xϤˬ>JۨGZMTxطWEŢ7kh"Ljp_=xxI Ȫ]&e.~@ieI^8MƔ&LK>a+SIiheGO蛐jAvMOM1Q7aͬr8#o 58)b²83[] b$ʶ y9u}iy]3Pa)$JeXطqwdP'[M2/+KB)L^P",euPZO^煩OwayzIvb`oq_uߨOZ$($eJyj8%3pQXc6~v ټEh6 &ZsE)5_LG}*4>/Z 7Zdpuze1Mُw'oUn>).ZEв,%m=I@Hϊ7 Yd(O(w QOMO[Ac]7=|}<(dDSP7WUJ1@h7]$zT#wiT/Mpj޶oy#wTDiT$?L 󢂚y]a=2;ѧJԍU9Օ+L[@by g1V@#Ƀ2S%Jo,YgڭRrjvLE(aKL]7=[Fl.D4qÉ!P2QvMVg ~2yl=W=CH¸KkT`Z*akguDibA̋F-_83XXNHo6߭Y|Wdi.⑒RDcQ*PkIDU6 z5Sij.zjji_s~{qg~*qaA\>msy㵠 0ᚄķecl8ʃW(U2,8>XK'1~8sȸCRE꣠Wc @O"1Ss1jc5a R O+捖I +.m21)J}u{]4+fKnp}6(aNE,w2FSNvׂ/srX9Uf_hn0]|;qQ=]9}{]ijA5ys-́k0q93ȝ穂,A/8<³VdĴ2`5~-ާJ?X>dP$D q+M--LhY2)H- :W[9b Ӓ {\l~:sd~+£O^AuHAF#y=$ fzs2lWQo64.=Un&3GoUh, V.۷]dxmed4iO<ܩAMz+^^ |Ѫ4W7eu1;<2<&݌9|şp 3U{Vⷌ'RxIkxfZ<56=I!*k }84'=UcX"L<"-n Y[#3ɗz3' hAɳn$/k4eΪ6.IgE@ԺTKš~~8 0E-2X?Nyw[hea%3ntpոΏm\PE)kwlxWMEэPE9SBq+'F 'T}ȳdH.kq^Ys vByÌ6%qd>imܵBؽίVRG ,4w(Kd1$Tv|#cpR7',d,r 'gLO4\xžLyZʩIe  nGb&j!.z}ƛU(,h_--$0fDfocfaY)kMQ>JһOAɚ:/&iTGdSUn (6HVi>EkD {$UpYLgӄMȥ^;cc:ptA؍Kw/dݲ4C*Y͓ 󪓱TFz3 V26m*c0O➒@R'OH1} EVv_>n!,bUm͠0!ҾSksKSiG۔Rۀ/f dо5EFh@m7;ŰݼB_fIOAZ#|̈fY|$J<ߙa`6HV$els|2|g)mvMVˋ 2(ARIǟ ^*epm.;dB?_X^?㪍 QЦϹfJm ` FДM#On>ۢs?8Rng/'WI/I cv7;?7 /ް8F$Yn=Ͳ)="14\xt}ON~)?Sm&ueyR ̍R !\W4jZ97_IEN[ J~ -i|onQLYgCI|ѳBcŸ7X)9;VthvUfnUohMGUe5#/WmOr2 㟅h $i 'x;!ZK.l(ΰL\wNWi6ξ[!GS<ѐdG|E,[%Q:;GxjK]tх'w}6RY?/Rx~8Ǣ9JAdfv,ٽk@*'k40  * &o6EjLٶ#1hZabjc/ 7T3v5}L̅BR x2`0RPv%$,cםk[BRN Eh|YB@[xBHH{]yl.w2*mz\Kþ&ϭE? =eBUPz9u;D'm:/o-gbZ-8rۨbb?M<_ƖJ?Zg >:D尢hS`GbDMAb&*K˓4TKt*]]dXф5nߧ"R:ZZXDCZܔk}fkWJڼ1_ʎi=S$AJK7 /OoP'np◛z!_ukzÁ7_! Տ,Y,̈́!o(fytwt O_2Q } . -JY 5KfQ&Lwa!qe$.hlb7v٦';IjYàw)?$e3)vNKVw{RӗfS[OB-F&'_2?o472p8*r K:ؖ0G`2%itq` F:qE}N!~oZ,umо낵 {S׾ $H@dr"fK2HNWS SHEUKJ鿀f}urDv:V9 rny.[gD]| endstream endobj 484 0 obj << /Length1 1405 /Length2 5969 /Length3 0 /Length 6933 /Filter /FlateDecode >> stream xڍx4}UgB!ԞVjӢFmYԮRGQT_ڧs^ڟNo$EPHH(P1@ (La `ˉ9Lanh8 )e71X D 1)%ܤ*`8#B(Wo7#[7mPt!`$@q`#B a[qQnr<O8`C<`P`؟9Ǝp_ #=`8DcMܑP` s!ki$?ֿ#p -H/ Fa`8lN PS4 qbЂh8WB`۬*\\`H W~*p7wo?uF<H2B&H#w VDo JGQWcoWoo1_W+[n~0A `p$c0@,@Ͽ XHI\XOR*)’I1 E?l5(_bw8gAx27Eoy_#=2v 5:0(念0vXF %^0>q5M~_O_:AO4U03*Z6aQ1 M5$ a Mf 5QnĿ _@;^`{Kw7779 }0 B<7H: m;QdHPlyو79AiUGo`Pèxz*~%%WEx/E@ k&V1c+2f!E-7 wcMK'Sޫq?M9,{NEw>kPR?ubWhN%6bpE<[}" A7ktCNu-2ڬe"Ӕ_ήQ 9دAw0:t&Qeڸ1CD9J ["$?=SG0ٛ_Ȥ95tY݇ ~{ 4gIFo4m8@1QO%gml%=yOiʫ*՚AuOvK?Pc7!/01^нa!8IAFWbJS&T@ㅱk*;7 _Ns;&xh[us/޸pd1t >$|q֏" R:'Vmcjǘzl+uKnP]-Q/ڢ:IJvDξ; TZF돊GJ*[\a"u9%}I"MTHI"5 O#qZ4ۖO)]N?R2 II\O쭷"v#`fH{KGMS U/Wmo>o.Gih&nlquHNtY TSKv3'qpf XԮhhS:^0}-y> U>/tq2zOBGl"!l{ϭ XUQjU Lıjތy9o?m0fҙf+p߭+i4o7g2^jǑ~a&ILtOR!$锜Z١r}*7fю^0TN-1Pq$#T!owEkgXW<ӷƭˢ*jh8sCNEB~$0G kjH- vv<ďZ4en+P O%wBG{=Iqݶr+t >NP$j} eN¾%@mPҬZOZ2Av#T<ёoĘ5cBԡi}syha{.#ŕ/ ɵHzG\!t_iE^s֓Y0mH*R}H}&/8#ZQJ R^9CC%Xd .W͍-Ho^[E+f)R.z 2Wg׎SY  F (O=â],G\ |+Hu˃q9+683˺E4kLFC:YVS$vDr#X^GM):#5.7 nbmomty2K:xS4h$yJӫ ̬vA9cRVU|ԕ8`=Y7jӆb 7ؿjj3zwvUA0C/k\'CZ=db!CG sU[>5d|#|7Nn-ϾFLe.V@x˔8gvcT6PDXkNObsk`zWmVfCɿ.mӹnpp{~jZxxqڊ3Bs AM)Ggyhw._r˭} E=) /tg0lcf.4`Ys{lb$%;{yV Eڄ1)|~5kͦS_˪Z f}mverU 7pwN ߧP83 ԯ9Js=@]hFMGUDuofRߴc#8A^B0(0Xy|}I|3 8QY<-v{?43TyVѺD__g8+6ԥK2ݣwʃtG[I\ol ԃyܒ؛~Ļ.6:TmuBT"x`T3+If6BE{Hiuv%3fѾD MF|-BťZ)WȱS: Ղ3y)C^-O9 k*`ܑZmӨo.\Ho##VwJlZm^3Я>c$$D'z 1N и` /t|1 P(U6`'tͳE]"Mo`O3AɻQwBTNruV,V7 A#oQNKV3K}Xo˒^fL'9I1R#n+&9thnku.6r=8z4sw2znʸ-;3aA{dᦵ Ҳ@ -IEslEMCM^L^datwl$2}N%fspU #T),J<,m$i?!}"@pSHayX1Yndc8u>Mݏ@+Ԯ]l)NPov*1?f?T-lIp%~b%^mC.*rZ0Yw/W)sc-{GrC,K5F3G%^yڨ7_x:SRďocx10\-rZ>* $igHކ>UM,~4GI)NmH9qfwvf]Mo*8hU7KS8:!{ʂ0~l%3 nZZSFGj6?):T ]|9}e:\W-Fis}⥹|dh| yaq>"/v?nM]^)<˽Zm1[@Qf#D/y5ۯ+UUM=W]ڷČ;i1S"8u4趖њ3'| Lת}39gk l耉S+SOP,zigB7-4b/INQQ#ҐtBܰҪohm1EGO]}ܡ)!xzmE5>uY}ǺǺM6[D4>7oL\]UVMj\nox

c6͈}H"+2Kkyf%Ùn怈Rrm4K1Ō2 I~?FrYEVC@ y8M>Q$ri'9Z:E]AV}༇f̐ϒc9'}h(dhA*[]u$Q' 5 uցgd#On+Oۊ;e;Acg3:mPYi迃RXߞ0m+:H xUM`v Q򕞃w3 M=X=,Ј*^iC NG׬ґQv$rHhY QG$7lt|ч=mUcTy_a%J5)maA_9A(W2(Ä'hSJ|OEL!%ʀ*iCr!h02Pmx-K|h;߁]򥜊'bs,IS#җ'=R.iXN!%E9,>(K]DΛuK䢅   Dјdio }@ՙV71"E ir?&+ߖtE;/j,!_upȣ=ة[q}ҭ4wU9dT78x凚81,{*0PE[iFd:-Wĵ8Z%gRe9)i ?5)51=>l5 pS̃Nq >&Q1U,ےb_h5tz&E0j kQA YzTe(pf;HHuF:CW+̜GLԂʮA.O%DY’+XLiBl ՑX$!pIĐA;ʓ{h:.{&#%[Qo^_& r}׷ED#231~f`S$Җ>>[ >15"Vc~=lИ#q\2 su@iJ6[vr b;b 5,)'^5j8lHm^><"-u1!1O6Y)Rl$@]/MFoMimzV kV҆kddɅE[H]46#hOSE ;Dc @[\A€ ):~s|>aO-r60̮Dad+zO ƻ Z9:gvE(yF5˺*ƆJ+%;>]o]P?G>OIwG%($$Ss S9uL"`(Ǣ,L>o2mGx8]b -)${%ƅlE-I}O{̅lGyxLJ){Wanփ'&'-[~PSO舜[a<I2)˨&)0g)?Y'o1Ǵ &dixJ6bN[d&0nT7Pmƥ_#)v,fpq? 4ԙxGЄv&=dWׯHye$,y$HПA $~=y{nV >poEVd LH`hz @oYs;:abu6ڢ)̌lHHP=ԍmB6NVrsA BPh{چ"ZOY83~.v@A4sCZ(N-Vazvy&^LT*mFjJq/ʞP,zO61xjKrQnloƞr=ϼN m-RMδEH-  &]0 HIr5>Ⱦ&(m1^xUQ֌UrlC;ŶOᔝ*|G)6c ֦6^[Vm܀aJat,H';_$"UpUDD8Uܢ2չ7 yOƘ2 \!yx$)ɔoaFԦ, ^^31O6-C-B@x[:EFu},j 1l7 exˤ9QsqY߮-}vU cjMnAK.9!kIH0EYTS۶:F+Q4|KEt|z|JA o*b!:fwBaFˊ0&"o,70+bb^{es8j&mnk᪄DMD݈=b ﻁh<8NsfQ+Wm ܫ1 u$j$d2j /& @1yl5<~b׭Qd=aCSg^ONM*TR/C O|PkJ__$ !x9)}W|,lb3<HdH ϪrTcI#I\;$S,\e%h( ? 1"KgG;kH-{.m؎B& 3v0f5IIԮh,1߲].k]R_XtLIJd7Haٓ|?qY;,?T{cA܄ K鷖{fMJy`3{3PPҍ mTpBLI% twJR̞A.KQ mp{)~@,mȉ;-K)Es"plF,jMq71"t <&y»R}oeLKPt *W^Ogsր+xd1Pfܽ=ܣt*tWgvBQg7j;icv^O˽OR P.w1 H%K(Mݛ>)W5 {oJOwƺL&AnޖOllǨr!0X o6F0X (^iR bd-)$TuN+]_2wGBMڅۀ$MR`&9oURT Ұ6|>\/h.D* Q,ݫ#-,p{e \}ЭEci֓h6&~N_ߕ$QZ!~t14&⫛*;gR+: X:E:xjrnW70-43,\NLMw>O!эDR.KX$˺")ж2-r7aRFatC9J-{.Hb3"Քr’GroS@A^PCD3F2zPsAk-Q=c&|H!ۡ.D,Yпޕ%Bu|Gc&Q~cB?6}pC3t!)$öѳ`m9+[1b ;K,u6f q9qb\%5т#fJEf"ߪ}.r}KXiΉcOMā4[(Q+b"W5cWzC&OyHN׬&f~ME)zR M{/$Ƨ<7qi v:*[]!KϼƝќa ]|{PnڥpB] IpO9 ̈́iloP]kBA"oc.D!Z).L~a…:RFWℬo6~b'[\@/3ah/AŗwKtcIlTDM-a_3,Fȵ#^kp#ζKX:}sPΰeV&.ULozÅlްEF8N=B%%t|QDZ}, v 4'(sޞw my\_Ңd-^Ɗ>|f6:]u1ٶ1$tR*0^I`hBL JFdzЅY0KPUD"c!,G5 fiX0YC>PayQ7;5^%xf _u;&BBJDY䀮zuvĒeD B<~)y38v-[6AmRh 9y)yb%I,RLu!In64 Ԏ⮊rP4g-3 r B}Htz;jAmj}ӂյ<7r/2 v\7%C .Z (UA|]= DQ~Zt+^@)~-=Yj,%oXB+XX3iWrO,|%w[Xa ;f@YH2Jh4\=ԏDouװ(h$=f+p= v^x]cY*2k#XO^õHФfGNi^3 ;FV֎QFV>7yRW;3(,<"}1APh8v b0**50Pװ :PrC)iRDȚn<3@UI> y\n1LnIƀJ GIN>b4k4LXmaLI| .G6E̺P$F.؛=$7 &s5G'. )Ch߉=1 إh$5r!h>[$fb tfFblqEn3 J;,af~E{Nڧ zW[G=N[!KFu|["|ib&YdZbCBc]M`x7 ׇiE8%T—GrLWB#!:tei-%t߲,"Jt!(r:`xH0 I3L[Jr3#B}┥ktB$-h~*tdĨ?*n" |L76Jf;JhD'$$x.LJIB˜u!hLNQ\ \kmfU)_iUx.Nߴ.0  KAiSƕIIM lzH/k*vSJ<8]`R֮1EZ`e.a+F,U?p1ĮyPwn0nFp]H]]-An0t= R•m`|U eAV#ƁVU"_w*p+0m-pN@e=vT{B:BG`;4wDlFWпqs1%P4IcAsXK?:?`PcI0w~n&';?(NN>dgпvji׬! 0XN5`:4ym@;K>w{:!s]Ǥ.}l!][$0jHȣ= vdW0Wja7- f(X=;ro);hiT}^Ar]b#xkZm:f|Pr_}{MLSlFR͒{3F-ѱݬ$ʂԗ da=Xu`2@gr0N'4xtZԾ@i; BTsO7-)LuȆúsRv8LWrAX˼bmCII2òf@D=\- Qbɖ@-_ _.q5; 'r^:ȩDFmz7!fیP/Q`eXؓX zC`5:R{:lm'Ǧ陴!eڽӼJ#0=T7ViqY5B/M:75H}+=vMG#VG.&T[)R9K$vH6g7N~j%Wd 67ɡ&YX.Y֊Ye!e/ cA@QH3jFK" +sA +KsIkU8P(J#!RY|joUnq+maS/Tae'v"ܻә~i,lH1^ yP[xkPdv ӣi^P1$Xhh/(BO9cmj) rv>aZ|7m5i}kȁA5<"8<*bCt> Bm$(]g)#u@zE}#uS $<&yûq]wgS B1SaXTc+g 4㩡oMMB ,R)ۤ6:"l*B,I2bVoInA?V 2 &e|E8ۏ[ޑ>EݏD~/߼8==>_ӛ;7}[?4Gã}|y=~T7׺~|_wZ?%~>_Ǘ?>ku|Su?O򧷿Ny?6?_<|?~V?*%vG}|_|"l㱼#d|Q<?oOq9~?+ֻcK8?8߾nŧϯc[ԣ繋kU.kg~e)[yT>|̿m_sK֖K<~o_v4 endstream endobj 232 0 obj << /Alternate /DeviceRGB /N 3 /Length 2596 /Filter /FlateDecode >> stream xwTSϽ7PkhRH H.*1 J"6DTpDQ2(C"QDqpId߼y͛~kg}ֺLX Xňg` lpBF|،l *?Y"1P\8=W%Oɘ4M0J"Y2Vs,[|e92<se'9`2&ctI@o|N6(.sSdl-c(2-yH_/XZ.$&\SM07#1ؙYrfYym";8980m-m(]v^DW~ emi]P`/u}q|^R,g+\Kk)/C_|Rax8t1C^7nfzDp 柇u$/ED˦L L[B@ٹЖX!@~(* {d+} G͋љς}WL$cGD2QZ4 E@@A(q`1D `'u46ptc48.`R0) @Rt CXCP%CBH@Rf[(t CQhz#0 Zl`O828.p|O×X ?:0FBx$ !i@ڐH[EE1PL ⢖V6QP>U(j MFkt,:.FW8c1L&ӎ9ƌaX: rbl1 {{{;}#tp8_\8"Ey.,X%%Gщ1-9ҀKl.oo/O$&'=JvMޞxǥ{=Vs\x ‰N柜>ucKz=s/ol|ϝ?y ^d]ps~:;/;]7|WpQoH!ɻVsnYs}ҽ~4] =>=:`;cܱ'?e~!ańD#G&}'/?^xI֓?+\wx20;5\ӯ_etWf^Qs-mw3+?~O~ endstream endobj 255 0 obj << /Length 2852 /Filter /FlateDecode >> stream xZ[oF~ b8޺nmCJe!Rίs!)щ,,P2>g8Xqӛ'* Tq WAdQaf o7zrAiYKА|$IrY|UQj7i1Qa[Vc[,k/'SkM^ì[oL17XƆtkϓ@[Яdį2<9Ϡnzrm.\8"?6P6286Q$$QD #Ud@fuc5i^1iSCN C7??B,J7/n!nF> h!ݮX w<&S՚gp{>92Qb >[%nu[\2Y7 )eV4ho}C*Df:7@dy~f}ldڒپeھMF51h$qdr`m% )s֪,kw#:| `n`i&|!"< eyO)b=_.4% [f+.bXjQnDHir9GbV?ǞS1Q JD( T\|EJ$\ @>6qj@"7N,@NHszҪQHty,D+a)RJӞ#Nb/gLv p!"BTu5PY@&)~+jܗ ]/B]~¦,<9hX:VRc?#Tچ7qN>A%reZg蜜-Y );޳& @HRMV~i/rBS10E oE;@};(D*4yQ>!hMLt'P6w+E94R)CA\^龯宜.Yy,~ qQ;Q#7BWg㐟fD3Ǚ;0YLV`ƀ$wE9C@QTW7a^ -qij]Yz.oBBWec7 [TbF[$^%1a(hp̺-~1z Vq(A:vlJBy5z흳:5@Dab1x%wyOʤ#j~qp臷<~%Yshv lF" A@x!(z!tMv$qbǟ'̘ıFqx6L(lrzѠ~1(J)<'$`8=~⢗fq q:*.eI'≖'.SmvP7Ur-q d4VX!5$)HۢGSQvpD U;g_΍a(d+|aSS6QZֻe84en՜D,*UO0M7u+*08EQzzyNjr \XؕM-ۑ7A6p-!n+YKbTY#a)ƀ֞yaԭ9 ٘ACQ k2&FnNt|sWEC+yDuO< ݽ3MD:y#-1˥0˻t-(Iw(9FTd#TmO\EUci:GiS^-fm^;dpߖDg_~v=CĸT ٺY DᏖsy1A/X~{-^t/{N %  PprCE׎HČc1,{nzr-\ѿ:Y"] 0j-7fW0͔38RA;6B+IXnl".4NNB(PFZ}ij ;^#EAqz!~k:z8"!Eg :U#˯5N樁b+_c,Ʃ-f Rfpܵ߮7u1X\0t\$-߰ Ǚ1O^'_b?3̊HCgIU~zq\#cg*~:>xsTٛHY0\-‹L4jPI_?sZ9\P CyX(UImޱ HSK1[(pvyJe9:;lB.{9.8`Yuc3a_W^u>~pἴ"<',˦4H:| WA endstream endobj 283 0 obj << /Length 2045 /Filter /FlateDecode >> stream xio`X 0ggë( t8i7~-іnaR( J̛wϻg3=\όV.~fB&i$.gsU{X?z'Iyl> L {|}ݮjs?q}  Z\}iES5p$I$r"&H,NRUdy Rc]NAqjzE*xvK$ dcԕ[Æ''LÚp$gX725&afvĸՐ_ur0yu9癶Y -EFDZbHi~{ڈZ*ٮ:` x0/bzJ9};x3pi?m>|sͷ̸s3cTg{gUSƩ1?qTh:OI͒߿ 2Ye(cNph|? ]a'xBNY*i eKh9g \$"d&2嶛ް|e* j͘2Uf!MO #厎= m ]w^(f|8Jg{mz442eϚ%p.bٿ |{_ZXJP3=otgF%2ћV-O4ȵwT S1`-mn-FimNs TJyѷĭ7 WsLC#uA[]OC ]㭰ּIK%-ܠ2BC ]B<ɆllGj)½.ؾ1qrx@E\gmED _P`ºؼs+c @dXh,"s}K8`i|L?(5Jh? bA|Lѽ&Щ:hZXY^g͘ڶCbrNρKWb^J 6^|t5Vڽ* PKGW9*J /S葚2T^ԔvE](>̣.s&=VAj-WPM=d QKɍօ4o"R!"P H&4܃l9lLf8reLPx[2H'_f}o˩JgD]ã @C8-o.!PTTȡv1h%C_޴dʋZRSD 7[(4^#VGR?(?0@* NK?lar8<$+ c1=vcdǴ'Z$&,h+zX*3!>`UE2ݢ*oyl a^H9{rJI&V2]I:R5yAܦVG4[BZwZk2(rWՔzGd2൯xNJ?ЀA%2BT)mݵmGQKGJ*B6sfԡمA8uS/@_:!X(2^&L2X+<#%%^{;aw[xE]eK_qpۋ۳; endstream endobj 294 0 obj << /Length 1423 /Filter /FlateDecode >> stream xڵnFƤ3\&mH$J!P ȿmE37oh6R_OOίdPE4ߌh%YXd4rL$,X_^9u}+gqD~U৆gqU.Q@'?c㽫@u 1+\V lv(Q_  VhǶOx /HVZj  .\V㷈s\a^H}M' q_+{cرx:l>8E?ۄFrgFHsL߿jFڥU)m( S "Qx#)="NNz3b0 ) Tk¥r2h@&aUu~-d܊MOv MG-)T XܻCU+3A`{Wط-[' (oKސkiyCɍWR'f:)tܢ?°Eܰ&TM:6ܔKK搭 ȠklHC /cq8bh~n=ʠAv;Sn~C]\Q 6n:?WUlN:cPb[L~c Pi~RqWvLn侕D ~f rZ׫6U08H{&yq>a7=> stream xˎ6>_aF>E)HAzy٤29hlX`ٓ|V)=AN9XbX/l=7wN̤(LVui9Fjۅ'xl7ï[ZO0<, a:xp#@H:[xKeQF럫с]xo׉ $y%X7wK cжcQH$,HEBο\VDpvA=/`X ++ H S] ?d +_e :jOrDŽ Q? o4%MO@W"Xu+*3wX> Fiӽ%:L#C|r,p0&5;VYoj5?Ȇ_Eؖkԇf*(B8b$Fd r짐#r.QLfІϐ3#r`0$MNTrvDn+HT]+iOJR5 UsU ֩&fR M[CNuEF9]w~<D?e-9JS~N g)}4hsOcB[ ̶ ˈ āU{<1y3sDd c? T!uR1'M=Uj!Ö]v,3Y bOrܔqŢG67,h@>yBVI0!Axºǣ=.VΏh 磊*ucI[jVI1ڔAtzTbL~ 1Р'ӄM]6*S͍Ia{Fs'xTDSYO3Z&r~/ޟs\Ly;qF_="迖 zu)\MɊVR-ڨt*MwQd J.zu6F!gX_vX8+ s86#3+cM] a?Et%KtdTd͟~OQ7TZa*Æij9D v$Fو0Q=B ~9r~QL~J`yE|N ӁMj&3tmy6S% `[9}p=~qDž,IԹEmF)ti%#o< v>!)mcH =Ib_pBђm^V#D7rPB|@4ۗq(]cշ-K觤h`xT洞`*6BQ4&ᘠHY|Y}. tw,[?SCl>`ZoʭE\'fLS:$qZWhFדauqn{ Xz?M==n=nM֭[p`t;eUli6TF4&(IwmhIڌ=f(qixthn E卷یjtN'z|JU2!_ҭi{;?Y}cz=0GHۺIME9n:Ð%׫/W{?tyZ~Ae $%N$O G,W!3Sb5BzhYb =x52؀#kGZyxô2A'E0e9u7篓TYי`}0&7Eֈfݐb. [[i^R;rN 6;mC%tqŷ(xvGRٔRyx?&>v&7哂"_ !d?U^s= endstream endobj 304 0 obj << /Length 1264 /Filter /FlateDecode >> stream xY[o6~ϯУLH Eao/YV+ɼ_?:Yu@/C*^>vv<GU\1ov+"̛ͽ_|>{UtV4[)?&d_/ZXSZ;,s .JAwbՍhWA$F ԝA$ Sc?k)ڗQHaH+gΫfsN2NykB5AcR" J#0)$ 3 fJY:i+†,Z:HK\ #r`kK>)ҡ%lu*:$Ahm^;%]ωmTfdyssڛ;_+.C2lP8]"c4PRHūT?Slnl5'H}w~툄a%P6[U"V:s[%-\}ޱE"=/G e% _| 5"|&2nqkbC6bhD [f_@'p+Z{&iG>^7DqYvzUO'#Ó bsSw'[!+ڿ5>b/?MrKhѐq;6 qDە L_0oL繁lx5%؏;Ū4Gϣ'sh IhaV9#oN8l9jL5%9 /tS_Zڧ(&"}%ٓr00հ6,9-`Ylȷv'va=1~*㶶j["qH/LSrK1Sa%Z0(ʈ|$kEl&M2+WZx!E5+EC>DJT(R"Hj~zdw֑l4@%Xh/ 6+UΫ 3r0FEs픢#&|/gg% endstream endobj 308 0 obj << /Length 518 /Filter /FlateDecode >> stream xڝTɎ1+|%츼 4!R"̀ bzvuN2C4gW[/Lg'lVYg`g!)EU +v_ pZ&mqؔգk,(Hܺ[qXu7͗"9Mկ=oe,7|@]"[r1 KF\{k0ab-TXmճdj4: &bd!WGwQ; \V aۉ wBg;2H%O&Bh y%9YZoi[b&庎Hdơ @$L 'D9tN$! t]u@VL=#'nw5575 쾼VSG%L p0 G endstream endobj 318 0 obj << /Length 2454 /Filter /FlateDecode >> stream xYYs7~ׯańq[*٬;g$Ip~v7!JT$1O'<;yVJpFTg35Tgmr//:S9-d:zrم5~Z#Qwfdݕ8i$ӪGcU}ê೼R;]qBy2)>r:58\Ɵp$ͬ0E@f)e~4'<[+V"X:xp+üabiӀmF Q/ 8S 8-it}$FIǂ7qQF׿=0kDQm}ԕiؘDKv *F, хZuՆ4Wvo y=.rVܦh &<$vY[A6Nn٢hFør0P&wKҫ:"l km9]4g/ܢn]|71^wc2^44 i7#c۔E@ސ /~%#e)^ТEx/n<,Ɲ9+k5n 8 k sm(NLhYAC >rwv2~^$/vW.0^t!`v ' wd 9XnFgPTLs!86ɡ>¢_" i-2*ji=6bJ:Bs\gQ\il$qd<0C"t8m5Z?XLY/ e٨'R5V*tc`S?TD}ڇ EѤĂShWdm̛}JP8^0Ekt7qBtF'^P\ܒ)8J|,k:bڀ9d̻_ʙvU6 QSl`6lj%ڦ)I*1MjOmʠXjsZ=R)${4 zXk &Xt?ʃP3 Bd"]B3l-rG Z~jȸfѐ"+Hi/`ެEjJ*3~8tq' H-x<[/2n4_o4j@Pq\H#FԞy#g|6ʯQ gSX}¡ʣ5aM-p>`Z#kl'Gtm,0 5 󋬼ë64ymئ/Gt/6`(J3BMS)a~FDϡ9o;{eĸ|uLmTv"hb;'8!Cmߤò8a . zZFs4}~1&}$bl\v}2C8ųn$ !]!Ro7g'NWTR[֐tq^0 0luK Nɿe̐鹨3mzWJ}qrL{_EL081)%8Vlߎ뻂3 T׿qPUBdpw*7wE0d#ϸh2>ioŋi-  LUI&U$00eA}1/gGc^2HQPrwus}pೞuSRj8|[)2|B?t% 9 RGhG+"AsB_ԂToH@ "OjUx4L8}He"DNj5*7zU lrH"$#+[ J @$0y*f؂y)쳃#:'lW<{@+ 8ta\?"W vr5 EFIPt>{ Ϧ&qDC+?<%s%i塹Ap@ jJRLW%`yS endstream endobj 206 0 obj << /Type /ObjStm /N 100 /First 864 /Length 2209 /Filter /FlateDecode >> stream xZmo_r/C]_ 6k PM;GHr{3-B\rI3338Î/HF EieAalOəDcp"4{b[Z F$O&VˉK?fo2/1H hfM5fNb0di)RP0'<\ yd )*&Z" BoQ O*k;!߀3އb!cD`qKW 8$B~6} 3d RD2!glSc2("*10.p>,a(Ufi Lr}fT0DK^ ,J#IJ0Q0S ?B*zvFB.3($(‰x}DBtR00p)&+@+ƔYn2 }H:8΃n圠V rʭ M.<SˡJ2EĦՃ%9}(,h%Kfy3)A6g>ꗿ\lvK*G>ZXb~Gdn޼1Ցq,d]Uk=̢D*XKWHqX]%_ ڍS"ˊYôssjG:k)NƋzP@z2c=kz/xnNV,󱹜k)l-)V8nX,IOݰʭ:Alud}٬ !8nf }Jxo8DŽ]i+]Ѷю؜6췝gX3CThy L|LpGX ۱{9x~7O᷋hf~ﵲ_ꩾ[h޺Au|iV__nmR/UǣdԜ'_iEgLVt9Z[u|k9b1ol|ps +N3U_Ǔ=?(e RDO֣E_(mE4MHZL*K^1]R2wb;hwQRWrWvnB7_ |/v|4^ߟǓ@fz^O[Yz_TW0)Q$`Ƥm٩޶V:6OIc@Fymߍ'_E{j~HWДb@6 &8>f{KHY@7H8[xoyE%E$pvسz4PVR 2D @MpE-Baz)ZR,alKWRq$N  ' #.)#=r~Gv_nДFaZfG#!u.d@辄VQxK=cvIMUP[ Xz%ByJ%r;H}n9>WUђ xzbhG*rAM( uң_Kd(`a4qDf@4\暊$w,\&cI+8К-[#g%)kǹ~XQU*)?t&rPe,F*bz=φ&|)O<<|p5 aPGg=1c^a$M=ӹ}Md UD ֻ=|djs/ endstream endobj 328 0 obj << /Length 1808 /Filter /FlateDecode >> stream xڕXmo6_a_5VDZZC6]}AĘ%${!y%%!"Oûw'ɏ'g?Q\LTbO80\35^Z_lA:-w SZ0L/@[z8Iݵҟ<9[D<- [n]\)_.0hk;ЉϖOQ&0IBovlXNy!:iz77to17[~ cf֠|-lW$[a^(qHE+u.9CRO,N`5chY(@UQFf? SruxzƀNN@@wl tn޹: Y ĕkEAF37]an^ qJkas 6NnFym6xZyֺ#KX:v]mMlU#G.{QE*1tRV`1g` DTЂn[y P^/I,UyQhJ󽅊H7yӷۂ95ILKA<c`6s~{}}׻r9 +IokU*B)`JDeҌ%X[<}N:PT"T=r@5\%{"LTZ1G8 ގXkߩ?sľ7,>j.O@]ƌ5Rب?bKzO C_)cB96+=Q0X󒃶0fǘn^e#( Z58e8:{vMI@ : K1urXn1rJt@!ԹΆ"odBߤA*. Ll?ĤAܰyLYl;#TLa _vfNZdk18+T79$I#fFx +:uJp0HE5rHWwAwP*)SF}3X}".MG~bP6JG[wj)]B#L]psهS˕e *Pr,,5uaH}iK!̓Ő/MlbVR%![hEju=Q4'>qp9 ¼m`)u:sr)1A3O&9R/CS;XJFW,e[ˇB4|/ HS}`K=M&[/u7 >F>M63WzXJtC}d;U_ū#josB+A4y΋925躴J=^8Na>s[jѧLeϼ9oL}F wΥz|/]Ft퇩JGZsH˲ȉk> stream xn7X!  QQJ(P&Elvnk{ll>T}n6tv2_tp flvpkN[Uy?"vaע8ҼPy ikӂ=PZDQɠȡ)PG;PZP$(AbERZJ8"QZ( ~ӂ6 ` Š8(D(""(&G T .jY:h"_LF6'MD0rz5Ix]c}wL|ހcsAZHFCѹ.:uKLZOۖ:l8zKJQKN~.f?H CӢr/aܳOsҁLv7[m)m Tﹾk>[醵@ba=6|i\A&L3LˢaK|#݋ڿe84[k̙( Thv|+]t5&0*V.KP"Ҥ"&٦I:?NƾM,}Vh\Gα>t>F/wfƻplè[6E^(1bۄnLR)jLݙ2i!j9u6LxcވX|x,'ߣx7Ff|Ew2..$|Ypt ҝ @Ѧ/{օ.fiޓ~~Gak.Ǝn$7b!e?Q2Wg`jlfkӨvW۲[Re͓'4AC3S>< (96EH`ȧFz:vGMvm&2oo6k\vGqKx0> 9ϥCe,=pw!Rc9 BeqH閜H= :ݿ}SFϝi{UC endstream endobj 341 0 obj << /Length 357 /Filter /FlateDecode >> stream xڍQMO0 WH$G68 mHk &Ii':lI^,TR%NbMU ,Mm*stTT`v`Zkƍ1#:bj0=zgxb!R/T3ReqhmsOݳvëgD5",(( "Ϋ(p`%Ti+sTLUCމJU!OH.nM/;8al|6`䔇ұZk@I }xQpCu_lHoBūlPvQ2;_Xm%͏zꍣOCXKT*2H nWWSoبl endstream endobj 331 0 obj << /Type /XObject /Subtype /Image /Width 672 /Height 672 /BitsPerComponent 8 /ColorSpace [/Indexed /DeviceRGB 255 344 0 R] /Length 29343 /Filter /FlateDecode >> stream xdWu'VQc׃ĈH8x{[f-fdzԃG!`TO-*E؄vT$ h40+wzcmpH%ˇd:6z={{^ի{Ouuw~gsә3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ:Qow_)_K^gOAz$>=8dVnGEg}&3s?9z%Oϖ  pGB锇nED<&{?R|KMڃ7!EKtOVݏa~riO)nVO'g4(DyئҸ|٘ݓٟHF%d64E&A?!{R-Y5B[~V0{+S)͙UD>4D1G?j}Klꟺz3|'Iev.l͕ M9|Z@w LՉJ!":lN#偝Mo|^UOgΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9ڰ3gmrώA =;2A/ /%np}nm-.fFS/\r|Ɨ= QOgt8s{5j%+{).ًp3kU Y짮|W{kg+D|G޷|^_zGKڌ{W<[lT32ZGg׼yyت灳2o?{i9~z ow/.Y}In$`iq_=Kߝ(b1k sKd9ntm?zG9?=rT$`Q?_}H %$I +4?,N~{1%Lf8;o oG8qO;/?3O~NK?2x +D{9"lqb# ?idBH0Rf !]rskrO?[`i  6uAfߑ"gո6MhbwPtLb2&?RåaMSNj> x\?)O4E#~Q1ߗI<ߟ? ƟW@GwL~B]',JǟhTSv?[UHOh&?A~+ \4#?mO!Tt̕?< ?d BF^&?yQ~;P2/ ϩOh?-N<0?&0)pR),?ϥGq;hsX$}SAZ^3 ׁP+~VqY;~%)Ѩ NxSӊ;O{K5'?:|hoy$GOfCϗ[[>;ɅSUR?YS؇Ϳ?S皴PϷs '%S3ǟNt1V=)IO~iJ'ysS/^nKD ؜m~ٷ|}W_>ߜNO~jF0Tkw}D\ѣ XƟ~EoӨ?ߠ~0)-I,2@Wfs,%~ޯwjoz珼6tdW?(&@PN'ľ0́w,`O`pe`7`ّ#V?_HŒC`V<:|>T?o8__ $s8ZӤ?T? z`"-),e Z>l_v2k~HC@ʂZP(;h#4~x.Q$?BmO0Im럯 @ T:l~S?fiG*7j/g3lN) :+l?޻'"Ɵ]7#C|! g5bՈCrsCƟ2I"sf䓤 qG4~ꔋ,O҆?-{j[鮂ړt UI ?[R UL$MWkg&.Zcgw&1t4C?) :7=b0P`^X7pH'Ml=>GpT :tAH0zlNx1s V42'Cy. ϼagVЯLk+dO0ğ -˵)}su_W_%vzƟӺOibs&\P謈gKzz#h8T?B_dVٺCSw󧮐׀7#3&西RR0yRֹö+$73'5fgU$Db札9,hI0US9Ãu:C]ߝ;{϶ǟR$KF*QҚQ78gh}V'i!zG{@h꛻'vw緶?󧒗䂮h:?aJ H%z;)<pt}w5{KռDo^1 uc)cFnp4I_2\( d<V8xry_M~KZo3ğ\K][eټm 8}:@D9l]PH3 y@4ix=p$6mp "dy ht@փ$(Zp>G@?tB[)t&Wyپo.M~? xw M$3^%i I=D).M:"gws3h_K?"TZ0dQ)g5UfpIVVW ډ9L<49-9/Uu3IEM߭?E>(7OrG'0NjȥKyȩu~*2 IY%)z%O+&V윃^eDS7_YyDl`ѺX,r*q&E%D[KZTşP ?8*᮸Gx\&3i׍ ^_4 P@T2ܒ2w[g]+.($ŝ&uE,C )u.S!gh!D\[Onix81dR$Vau k@օ֥oT׈#M QcFod'Ч($ 5.ZH$}˄|r~b|2v n)9s'|޷,@NЭ?f܍ѽ[PX%7`/Cr:g6 盭I? Vl{7hVRY!XҐFxdvoX$D X k?ꟓ[@+ěQ͒!ܻ\}V_W'suDqAdsʤ"!z_ip6?/xE  f-:!hԄʶem5S+I%#}sw]Pu7F$JR}dL.^f;9I)sasxkK???^L h#ӮfT9?{ğM;|j@3 YSr6qYuImmh98 y7^|= ~zKiaʵ)Mua)éD 9 |%i[? Щw;gJ&矝Q( ./L1)'5\ "e+wbHswns}pl{"DyvKL% %l|:laZՑu4u(aho:QYg7: ع}HW?[M^NwZpS'/U$W*Ot:QtĺH}5/Edr7 ޹}6ՊMƟ)m?R%cO "ǾDJRS/ݮ]KT"茁x-gD Lmw19gHtrw_!HR6eW@ͮ;-xu{g|fFW jQMt_q$zr\!L^ PDCaE\e9͟H$#t֫|;~jV%a^V9+Jll|EMy!A@<J ^cKsh0&/c4%J}3P;ܼ'~#{Q|g hi{Hk^ (e:ZC\M=L5i2' l0j#5sg ,qwO?E&珴迃^u2d31'<;C}K;^{Eh~<& q;ӄ={?/]:p){üvh@칐X6lЩ6i:;fぺ;@M7¢ιFV{"1aDIR;.e߼^n54jHoN#8e~ywP~'*IdzdKi>'b |csyȑ^Zr{c>K[YN(+)Ja볳rE> M'pKtnQ|.qw5CnS> eFn6?wn6;Q5s[3}lpq&%~~"X/Cj[1:'ŀG|x3r,D9x ?~o{6GyN+ &Tꕤ37n.r:jQ iK]КaOiITgd*عˇz'o?z ?<wl^nYCȐf$hu@I}Y\-]-]4 :i3 u{}ϟo,=]'~MnY_3FpS`=P5`)3|@OY* (:R $!3;Fc?w7֗˂:Β$H.w+J02U184p*rjH8bRRi=E[ ?kOOUhݗsjص8Ѽz`1vB )=bdC6/l^frO :s|T9S]`ŬesVS" lkŶ<9uw m_v&V {O>3L'cn!T-#CFmmYpF4>NGS9&dE+I= <v,rIORuV:nAobHrI3Щ!zP(3b KG"DS"9┏^kfѫ~;Ng-e[ )a@Ӡ9!Xta}!љ9א:aP2w;o&ڷ?;NC(}iWlJ^˞D]9w& 4Ѿ!sKsv5 2t; ;Fitd:MH3|S_4f'"m>MC R=;;K)$u>K9K<ƝRٓN;@N} 9J;(nԘ}SAX2PwQ+fL֖* /g2> {P4bTOn;1%/?tj鿫L-s5\`,&*V^y;Aitפ ]ѧxsdWw~rvߙU]FaçOCTD8`DKa);/,ף:A;;S:tcHڋw76Jz A`7u|+DfK!1x% -q)2)I4\6%JRv׉sQ^z[+?N]dBU3˅6.h2*XvBZ:έְNRq:ޓژ,)JR8 NLPRoM-h}%r!֩ C٥ڰt\3vu?R_"m]{;/ye>v>e#?[d$ד{@p̀8)U$uw ar|NQܽxdRv.m:΁s^pFKvT-g#ItN_eJEV*<rSY~J[ʨ,vJr>$)o>:R(J%+Ȅʜ &NѸy] ̝n&= g=!Tox1CO5## 43-~'e4RIg.X-X}uȬ[ [k.OCmܺڿR$E QS*x "O1ɮTސ_Ig&'g;?n0jBzfH!ڧğž.rsK"ďZSOF˔m~vS y.gmϡ'()]Mc>X;(tWVQ_nZ)'jKԩSg_ ?/m?XOJt,P`5N$r 4wbWU4&"ٕKɎeF})R3Jyf,w/ƟC|t5"ݴك2 /IxPMN9şH^vr5%qޭ{n)v"陵ђ4ˡE.chzFv::/3L3'C&UƘۮ} 04~ Le E}dkp >zfI}_5?3 ~| =YH@uVq$f  Ē]Ʃζ1agqcBUI vY!1vEc?gL?gL=%O!0d bgʓ@ܦ,h[8^&Z^9xmQ})5B𙆞3Ԧf7?)o=~&{98!u@Z;zamFM%7r ]Mam5%жϰ &`sUֻܳN%GNVr=?ufh߻ٰU #%!E@ S!Φ?Uظ;k\dЭD'M-e_ ~.YfDR7) J#Oo*}9l~sGS-G=ǟjZO=n/m-lm'ob(jjPrI›E.VzNm,9_uM!r3gЙs?zb'q'/Α#Gz#g̜tpԟSa!ր yfWݾtvq -h~L3>#F21|z8BGSw2x:ǯZwg*SN L9op}'RS tp㔣+;,NX[p0)PoӒt+GzrgO -Iipϔ]KqsMBBc_wƞj^S`h䠽g8"g^z8 ma)@eAD\wgΤtrGZ;ܗɟ"9T-l: mn^Oo}?/䡁L=4[ SgpܞsO xH7T_?n;/wC^mB0g܆O|v"{W;`E5{M>M~m;o#3vèD_~Z&hsSqs}U.ZJryGr xNVW5ğa9S.aOK'|qԟQG$Ɵ <:UyU@ދy6OWm|ӧ?p?;Tt?<)ܰDJ^Cc><~o3" Jl߭țe B}CլH{)|םhRt8gV4/w{=߾/9ܷ?S.w9Ȇ߉#Bԙ >rVdB|)@cxQ? w P1nşY?y9 \G&=-E:#Ɵ{aV։0،sVnK]وkLEϤYg0^,wRx65׎CT`"ĞLj/h>W^k$|^ڭgf8 Ynm]{QA2m%2^MZoduH ~nYgQz"]Yt];}?"(N)W?#}[}"fr`ak3k-OYOi n$?bEr̡N}!m)9;Xdΐ%֙vǟ>nk4~h?t>`euuD\C(@٣+OO- sPIfI B=l!sw3}\F9o/* !IApG`VFhaU#'*!hGFsw$D($fpQO.y1Ӣ}gg vl.]ߑoݚZC-hy[E;q ?ah׫ʴ*Y|8ҍ}UnȓgI{0u (f{=6 rTH,~JRW-Re7lY_<"}8xkZ?BMsss~hzp7V_27NۖDPlnOyM,u5SҀ2~RqŌ=_#{Ky JDffD5}g&/j~?h0/Ɩ־"[OoBQNa~.%(}'/>hۚy9bLpPUVڙpX@ 2ʶG]7_Z3䄏4Hmbv8AxO, !UηOT/ 5'=QG/9&D.(RRt(P$lg~03mdl!OwԢ`i ;, S]rԄk V_u'j~ʺ&i+*M$ AJ.U 7DžzK|1 \zgZhu.A#sMS;0Hf)N%){ ?Ep1jN]<49Clfl#Ų߇3<eIOJH~n?=8hq/KHǤ>!BJ;p CBE0:_?CZDw9]$Sش]BW Dχ:E]f~3onc)s2I.+E*,!ifA`QoV#=wY00IBe&b_}Ezr*?RR/i2绀KdQXz3wg/G*}|Oi,G7(ćx.];BEmsigId~ԩ#L3vO0}x'V8_A5ũYJSȭ߆j]ZTY IM="[KSm~zH5SR|CgFn{ >JB,x/9"T*QTBTeMHEhEV*dҽ}Ī!.ecsj{2Z4#Pty>TO \y&+TId=O?v9!)m_D3f(%ݟxi.~Bg/\R ˯3l~1BgJhJ(! 8@  6ծBK i(gNr5%=4ٿ-;<%Ѝ $E",/!| FOAx. rrk*Ek_ HCky'Ut0I''(CJN;6| ]9t-;֒>?wv(ouhND4_6uce*@]!ꤚq=auBYP1iQIO=> QG/yeq_*#bzmC2gy bS‰@:R\&=!D 1~"%fBFRGU;dihz]w\Kbs&ϥRiyXhZX|T: '왾pĽf٥VIўi3'QDOWC;o_J]uE~'>onm配p9OC.P g՗n-ͣ(3("-Mig">ErٳGzLJٟ'əJ?ğ5 Oow|*wcah+q.zLlhɤ ~Å ~by{HTO,* *MJj)巣0~q>̢LY'_yV\ʔYOŢ>DT"g*NI#ʚd_߳X>-Oy~nCj*l_XWѯZzb{EN 9o"4G}(xIF2iE5z?WCQI SxSωw0(h?vqz;VhVSeM!zxet% :fiOG9!S:nv.7"륎Ҿw(,^|6O]YSQBjɗ|_=/@3<)L\T\ e~̟U攰h;}y#и>ȓ.7=3=F"?%d*/%]!J9{lN{bd)$ _k\9PPT~Rzd* ֚,ޑGzڗOZ y qPJutiD {`"EQ1 eqRRkTbi(]n{JI *z'/=Gdɲ^? w:G:4UJ}<8P*N0TOwRsIS)S󶡨^[u܎{Eך˟gCʓ=?$JLpI]It5I5׾;q :lf_N*)f,${ ,Mr9u$LVp:oF9WLYP}t֦_Oe,RReVER7n^bSơb C1>}#ʄ t'Hh_ F6iugT L xF=8t2碑}I2/Oߙy|M^~s{-O3+CI-&R&`]Fu;H$gUG@3gdH6$qCrSrg}~GQgMws.@8-G͝O>㞽$F敹('r+H{Kytzbc% EN?1ϓJ|t}MǃJB0T֎*|.U[*M(= զ*iVoOʃAL*yPckv/=Dр'B#hFDXĻJ0:ݗ/u IS/~7*.Hu$j^-H?a<E£nELv^K:qX=y|"SSH"V(.9U<|t#Mxn3P4TeHUhhĜEWR A[UOъ˾$/+)(",ZUzǩ\)E}~<9R#(2@RS>:[F$ !ey)@Rj|Jp х|6Oğgd}eUO>5[VESבYi^⑄\10j/,tʹj!jg{B\➦tO?|e-{+o{O~!LKSļ>nBӰPZ 9Jq*_{wO|=ذ{=5P4F`={)E;q:GI%Qrs~Klj?e5ʇf=kYII<6|.{Ș,h}Oo/?砖]椧ypQ%p U.[Y1skCi?r_}+nn,G&M}to2-uR_ M|@ĥwZśY}ZT˳+Xt[G7l>y8,m&ϼĔіL G82zߐ4qyTs΀j,j> Q_tbzL>ϊ5Q~W?s+Kş"bᚸEzea㢲F\w C4J3bRNHJ??c>F{y]>pb'?'[JxBsϊJD Bn$Hԇx|9:=pkPF5,f*@T/)d;`~ͥa]TfHsD[9O/x-Ӈ,yK j)nʜ&;=gGi}պ9=7,m!43͡,IWPE-#=?/~v6I5V+y%A EjQ!k,sFTS/J(5"X_?/ 'h"D^R! ,xr`^{KN+j+hZl4}-3Jc?;S+ZYEcb7d2:c]!2K<F%iZY.wݼd:%3zs>fPpd0ZGDdXAǷ9uNZD]&[B(l\uc̏:YWu`uL(bO*|ϓ(Rv-kjzS7犞??w詩S=B)=oxv2^@U@Qj'uc3!kϗ ?=[ïi@qI.B=.:nX,$VFC1IGFEq:qWOR^Z'?O>iqFSĆnϲ*ZL'K\_y~s/D1ЅFNz XyiK ^^؍]jl|NfU!хs =rLwS@,'E0TF:P DK-ofs;MptI̤Yw|jF5K(آWӉs"I> Ӷۯt':𨦽WP%WhMOrPt~^ CuשzҖKyپW?G{$JRWwv/<#ڨL K[м_1%ʼsq(j{7vgvxFAn뎲:@- ݻ[!y1?ޥ.Ž?K/_W_U^/ |h br'=.\]FRՉÕf0+Jr)P*N qFE.ݻZaϗ*u]?l%d"$fZ+{,)0YuwPDIE&¥ϯ=vi\^)b֎T}WuR[\tiTťhWX|ʗʗ׿Q#~Jjf6siO5.P0=)T ғ,ѯw&?G[nJ+u&L$%[[K0  L`&aHMv!uoO@㫻ZsO;~RMUs$'DTJ^.A̧ ׼W=3RP*x~09 IL_6 9ctVMQԷ*5ѥSvJ_i.^\{h wMFN4Qi ta^5p;n|9H|BpDЇ=ZGǟ)~a ~.E9)Ζ04SY0O:Դh( 7ω?P\-e-=svi߻C;SZL!U[EN=ͣꤌ:3KMy1swMT$JYȢѕZ;mĈRؑͲ(I(*[v+NCN-?ih0"f4 EEQY$G8sR ިwV+OEkf;(By:iG~ +¨W+h7[?O,w@b )b3yO=%MTwHhz -ӡP8%l D}^fuX!Osm s˫ a;&T'S~B%5hpz˲.k,6%O!Zk=ZwՉ&O,/ >?7]_?61;Oq4M 4Wǖ|Zy Ʈ>DZU ;9J.'?ez{~Q;U \'Kjk{'?A6??K_։=&=\1`u7?{#gRwO<|oH)}4´l3:Q~J'@eJJVyys5{ٺfuRwkե `?Eic$hRM{,nR;L*l?=r&AQi43}<"Xȉːvyi?ş O&DN (Q׮_j`Y|{N5{&d:GM~G$9ZcUwRz>;kOs~t'x' SN:f-՝ bV7EJ[쟛M7j Ītu|C]lYQgiOe|%uZKol,Idmm?iH M:`G0:^ux:)Y瞷=~8 zxO{Sܿ ̈ОKv BYnIm 𮰥x__.߼g _;qɮcҠr3-Py|?%uoyx?DŽE.@n70Do2Jmm?׍u9.,w?YkP d N+cZ$h26ş :OwH@l$}j/SR uf'nYG\Z?2J?ڼY{ ƨO~EDBgk< ]?"2~G;pWlDN ,ʲNu&/R/*zNNz]:ISeh~w~ l,UǟsGm6T$N|JasXbmY4Q?\T|g`*'_ "=xVqe 0$~rCK2Zs^m*hYlgQ$ XqΤ8LT/m?6 +5[ew5$^!;W& }lG; *ǟS4iLY r%B9#:)'ׂUdmGBx?lۛ3`Ke&'s?M:> r=<:|Ⱦ~U?"HT(SgPE(@JtNd/[m!~Qxuߢ4~G+(uCsj/pSO*IkĨAUrRzF%A2Ϸ-ݢleK@CPNkcO"|b~I!R~dΛ z[r~gc[yJ/9<JFOZX?nG6ed?~v𗈪&Ђ!g#@_8}J@3hO_7j G?тWZ4 ,kO!Q[|~#XL6i?ނ;ݶħ0  %}nq2Oy~IZ}vZN-L_cf3ODDqd(G0AGU,bR1''?)m*'Y+P?(9 U#ڙ]hy9glq͒<A}?=VbNdzE"](Ï'OæG<~=A>#2}T_GɶlъrON!,1TOje=VG–Q0T=?}x_P SSd$DY'2?}V3`TOvj8}q_n9~0 zTU?#pRf#jOJ@1\!OeG|<=b?Kg{7s6;dTTfxZF*KJş>L1绰 c? k-~jJ&B']"rq5:F Yg>XIE[h wg eђ6$"͈&:{uE&Nj>gY? e!g2pOS144"T]sb[`GSX'!^/GW'eJGO[)4ob ݾax@ )\J{󛏬xe+?]ˬٿ869ҮIj wޱT?Q?UĠx&V@)=Þ=ss^96 #+UpZ1a"S@KM$Rxu8ffo+sw?" ^<op%#^r/~mw2߹#̢Z )7VOsR_D:4?~U݋Rlm*]V±I1[+ Y5~uiODӸQ  #p}svptDşZ>?nTSt u|2s 8r!mer_ܳ9O5fhO WSTGZYu*lFLuӳ? S5E<c0<Jşa- )kQN~3OlwX)SLT#{&$Wk1+ה%55d9|:A/ 3b(4-F.q[z@=OyN֕&K$cM 5=KnCF mJZ2͉GQؤX;dr"@ׇIKlka6PIYC^~Z,3uiM?>JfRKfT+ sG6$5 ?\dǟ@=)P}v۴žB$Lŏa{0{?,R9jRMG1VOT!>|OEuQoτYl ט5m^ߓ1߫&ar_d,h|I/NR ]wqN 'hQ|HƶGrlR k%l5m(I]-P"X[oչUp7P-罹 XRM`y-ȗ %g Ciٸ <'QRmߓ^(x#{'n3hq'JmtܽtDot9SI&oC}3[˙>-O`SvO (nWOX=6)#ykdOy֞?_hWNa4mdO Fѵ0$ꍟsS;'5jW\5ܓs)8M6'5Z-Q`fs:fbQ?\ ' &FF`"mϹQO0bZTnMB>zCg's=z .sY-`)v6!fɟÂs|֐Sꑬ狳IK9;xΪ2O?;wges(owFş5' FC*s]Wc?*n?fq{Fo;xG'6>{j>OԜ?{j?:tDF`ϻ?{jCtWSk?{j?:t̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜc#?d=f3+(詵=7GEuݨ06i;==qlmN6Om;7h3ggTʏ6?M#zQg1~;YRl:?T(ϖhO矕^?-L_9j#Ϗ<3td u79s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9slL֩9o:tә3"D_0qSVW X033~-lGuEF⟛EQX?әvg~w:?3,: ~nj"uş??=-1wggCgQU>(f;t6Nx-!gΜ:s 3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gc? * endstream endobj 344 0 obj << /Length 760 /Filter /FlateDecode >> stream x _hwpMp_,ƣz%K3MK¨RTJiXBX?nV63tB\Fkv[zƮw;y%rw̉3 RdE޹iS 5Nmi"|zch Aed"2=}yqx7m>][g; <r,vgR;, Ovܛ"AƦG[ e}3킹y)7 Zv p R0~{m{N3ذ5EĪ+ xfŋ޴ӱ)I8[UunhN횝k~Y-w\RK0Wp (k:"Kgl ^[鼷ۯud:]%V ~5y!d娇uUIb77ҊweC715#L/>NRj\xg:TKbfaC/ä5맮vC|Ą7h"Rj|ťZ%mI.=?W炳[j?9f=#гj^kMˎ:S6%@ _PO-Q}JLNOK.FLaZ6lNPIҳ䑅K iOegUg9ZV䢹> stream x}QN0+|%z  p4E ]񢤨o=A"]p[<$Œdqs"/T&쭸MS1J%40)Le\0'lj*G'IZ?՞V)NʳYE>u-Namj xqp@"34Ҧ]ƫ_;GB9?Yg*C1'NP(hx$2Xۀ'Rww15w#| X8vr$> /ExtGState << >>/ColorSpace << /sRGB 353 0 R >>>> /Length 6064 /Filter /FlateDecode >> stream xM%U}Iw[d $XXl,3FY'"8TuW, LNq_=^Gם-]9?bq_?/u_/_^{{|2%E}|i*Uzz8GϹq_^7.^vpb8m쮍]6z9,Wgْݵkktz~[dٱE{rq],=,whِ簹kctzSh1W 0_͞!e][zX+s8Ş+pvFves8q4 |Φ;k]i6:Ea FzHqCLJr4F9fP䤧qh᜗Cs~fTy9Mʕ Ѵ)Ө lhrݴӬ }#fYGR~Z4-\6-0lZQOrgiZl2M曖7-󟛖5gFby?OCmjW[z;vjU+mU[q+WGd:b+GmEZa;ulئ1v>e[TId;-<&[~^~d#[l5pǁ[>,"+Evxz{ջmSs7ܲW/x88m KPGp<2#x>=౲@/ьZk" $X$|N!\y0yfzHa}03U4ad3 hEt .vYˬ]d4hD(BEjwDZ+Uۼfo7 oֿ?f'6;ŋmNT$*z;eb w؆;\w0u(WF^4Ȇ7#D =Bd W`.'+BC6dqlJs-Y|2=J6O 4Yd&2iv.fQǬY1mݙެmlf73շ_:bezӛ[fJzeG6_ߎ`΂/FoaY5X{V@oG ٭w9FoYa}Q+uX -6 ߎ/3M?75Tޖ/>|q?)_#_|<ϫ|ENEf/~QPb_2"跰P_9~Gp~se|MJ}}6﷼7{u׏U7Yaouoo傑-+o~lFgĔQ+~;y-` &0x,IH -WJ \-6X{0O#=*`<  =\In &h̢`$w?ڌ `ܬ`#[;pkFp˛[5F_rq<:KJ-k%H}wl5`rx1-ALby)V+uґs`nh Lmk50W9me<p ^MČcŌ3律}(f0hw4#85hNa4zkΏ/~un~|5\]}U7WqpAa4Rp(- 7pp1x٩$2=Ux*^2V(^'r z#G^ "AvJ- УwћlnGo^oszw8cZ9vun7aFPW 1p&+:x8θ^ (!$k Z8pvƿ ȉWЯe$yWB 8;c2類_(Z7r*JjiB2C!#2S!sQ Z4 [$3(aFC2\I{UrF2\ÏN,1F,$cS%n%K,4 ,;~!y+^-d(ޒÌ`%eG(אLszȑsPNIyS_U8qF~f~(0F~5[Yw7奬Q tpk]GG5t?긖wq]_0~ڈl"o]՜ͨuq?I1@s_?R3_Q^h oen΄.G6^ zDG4!l E={#1 )"!zFm n~H{#ّN9Dv7"M.=0#b5DAaDOr1Eh|E3=R4GEy)A/6Y*ofyh7E3T4WjS4≢z߷[fR4   <]Iz/~m4l:vuutV Dyى5p磧\ ќC,\Sö%G iM,l+` *u!,Uf#WHJzIc :I$=nm"I>/H!d8!Ws]Gucσޏ}$(i<$Uf~4SIiI.,o%ͩbf(iNF i7g8cꯙCfqm{Џ &jIa&D^zw"Wm\ $Qﰼ*9kJgPw_7K|7Cy#țIo] -/fy*o7y3w|f<)oxk<7•Ho0ooF=FC볣?=:82*2՘x$M?+l3|ek2+OoeY|~a*lVv., [a!4Xg.9XX!^d=cERvl!c'T;ǶQS0?Lc׀ȚGLXkz#d|^f~5KY#?ɚMY^z,Y@ѯ/x"kƛjVaJ!6\p t %tGk:.sO+W57Y h 4c %hR@3jDʎh*b`X΁əhcf9W8g.f 'ǹZQdkxsP8ZW#1&K#s>p^k~gU-g3?Oμ9ș!gO-/yəA/rf~3Y"MΌx!gƓrO$LgPgK&!x͡gWkV7Jt`!ceM/ʕO;rGbzz~>n{"/=K*jp])kH=(D-5G=6q*M6t8y%敚Q05?xG Fa`KHn0Mmrܾn_oڅ4G0']eKYW }%{.\m\t)YBӸrrڥbM_a)7)Yٚr؉-()iܘO()7SU1%`cJP F/KD_.HrKD/I}AڒPKdYZDF])%>Z?_UFӴ'hy:r|ށ+k`Yo̧ G EyՀgEyxV9},.5ɬ(&{EK;kJ5s%Zzix-\UGq_۸ziӪMW"4߼p~Cy{su;/8Csqh0܎84;[ [Wo9\7l9$5}ÖË+[BDl`6'0?q'ta|l>tqa|l?S~> oہ+{k ǛB=mgi܇v1uaӱ߉^o-m%فY㍌}+ˠayͰV2M,ɗgi;Jw|o=ʽ3Am]vwF"> stream xwTSϽ7PkhRH H.*1 J"6DTpDQ2(C"QDqpId߼y͛~kg}ֺLX Xňg` lpBF|،l *?Y"1P\8=W%Oɘ4M0J"Y2Vs,[|e92<se'9`2&ctI@o|N6(.sSdl-c(2-yH_/XZ.$&\SM07#1ؙYrfYym";8980m-m(]v^DW~ emi]P`/u}q|^R,g+\Kk)/C_|Rax8t1C^7nfzDp 柇u$/ED˦L L[B@ٹЖX!@~(* {d+} G͋љς}WL$cGD2QZ4 E@@A(q`1D `'u46ptc48.`R0) @Rt CXCP%CBH@Rf[(t CQhz#0 Zl`O828.p|O×X ?:0FBx$ !i@ڐH[EE1PL ⢖V6QP>U(j MFkt,:.FW8c1L&ӎ9ƌaX: rbl1 {{{;}#tp8_\8"Ey.,X%%Gщ1-9ҀKl.oo/O$&'=JvMޞxǥ{=Vs\x ‰N柜>ucKz=s/ol|ϝ?y ^d]ps~:;/;]7|WpQoH!ɻVsnYs}ҽ~4] =>=:`;cܱ'?e~!ańD#G&}'/?^xI֓?+\wx20;5\ӯ_etWf^Qs-mw3+?~O~ endstream endobj 363 0 obj << /Length 2473 /Filter /FlateDecode >> stream xڵYs_q3y9%o%gNLNl?PIXddww/,a'B?}ru*N ++ 68Yo_&mr ?ko&ScLy ͫT!M?luyr6:AJQIeyhv|#l&O~~m8#l`HΟPV5ROBV NTIVK;L4뉁]@k9CT< q\| vj@`ȞejaLeg0`^u,Zv߁>ž݋vB^$p/#h\RX:fVW]mR; S5ׁ1}i*t|^>L]U\3bFxlN{NFK1Tʃ|GxnM0l9&@3:dJO|xM6C46E%}ǹ5E9tw qcF3~(])TwOҨ*'pDH]>\]~hಽJdc̻PG%«tJec.bfmugfM ڇqc> stream xXo7 O祧ꭻlЭ6PؗW#%n!O~H*@{M@^JDB;g,S/m%ᣇK(=A08?9T{Lh StSD ``3!XeDdF)E 93%W0trgv_oa׎n?FBū_^7깿L&5mj+)B5,xW Z|iĴbڴbDۖLTI+54hvYS:jq(_]'Pg!;ŠM:ZM#|= L3{Bwa Q عg ؕA,Va=ZRr&c'_N6IUc˗IٴNH] `r4m .RBHב'XY*JZXVF\׍VOA{DSgr oGBZiAvJoFƝuƹe5(] uL ),$TCRɴ.#fۀerHb&;ıcEiLĞ#I0H=wIlk|H[u\8b7RU N}*#0S>~P@J d6F|Ȕ.PC,饽s_ w-(Yǻ>YG*`_u1YTbqkR&HcȞ4Kɸk"hR ӊMhRTIofʭg-$S=A5/a8kLh@a M|Q8VJL@fgdRn'~Eb<S`+L)lʋ}|95toh{شî(_ۯyyW0(:w Fw^qD>s "N ",/֍ l7[诰‡TtU;kF¿SO틫_NO. endstream endobj 370 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (./deSolve-figdae.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 377 0 R /BBox [0 0 432 432] /Resources << /ProcSet [ /PDF /Text ] /Font << /F2 378 0 R/F3 379 0 R>> /ExtGState << >>/ColorSpace << /sRGB 380 0 R >>>> /Length 1802 /Filter /FlateDecode >> stream xXM5 "G8;Vt%CbHόOJqb;c>9 ߾ :c*k,%h%ȜJM?{R ϿXSw!o9|/o/n=Ǯ!woęCnU¯>b!UGRX`[fIcK3qV85`g)q\5j1x,b+3j3b=Ҕ?"R Xod;qu#xqt%&۲燁 xxAa+W8JI8/i?R4&4w[G`^6d=K5/@ pLPqVR->z ~dQ=i߷ 1IE\x12}+J~XfԺҾG;F,(nR@Ct1M%WϿޕi!F4ɲ $w&Í׬OGl&iߝzO4'V d^3ەJv>*~F~z/oƢpl̵{lw\d,leÞmAT+ Ńz/eC= 'IJ%nW|OЯu=4Zy ͱ]{]/Qb,x{ -;B⫫u7uൾr~{Zë7$x?~ZY)A0<}`;4hb< (-KO/U`3,aL7x~'lt?y|*[li6~\oKj8=%@1/C.لQ-'%0q&ΥM]޲.[lX!M3l,Mm%XD.C\6qdoSl;]ӷK6!(Cl^2si|ɦv&l2l&n٤K6q:Olː%(C!8C6a̱v˦dn+C6i\dHjcޖMy6nl߲ɧK6AM!RԷLZ n,ܲtlB.slc$M˔%ˈ%@ilR>d82k&]!9K66o4טeeu:dtȦ9lRjc%dd2MF٤ֻlҼM4K6QXnلS6Q!Ě%d˞% KLfoلzr&i.Sl֗l%ӷl-Po-8߶lBS6)PM%lزMOgɦ[ eےMe-P% ql#C6Fv[6Uueh%rȦڜO[6XK6u[6эz&Ի{Q endstream endobj 382 0 obj << /Alternate /DeviceRGB /N 3 /Length 2596 /Filter /FlateDecode >> stream xwTSϽ7PkhRH H.*1 J"6DTpDQ2(C"QDqpId߼y͛~kg}ֺLX Xňg` lpBF|،l *?Y"1P\8=W%Oɘ4M0J"Y2Vs,[|e92<se'9`2&ctI@o|N6(.sSdl-c(2-yH_/XZ.$&\SM07#1ؙYrfYym";8980m-m(]v^DW~ emi]P`/u}q|^R,g+\Kk)/C_|Rax8t1C^7nfzDp 柇u$/ED˦L L[B@ٹЖX!@~(* {d+} G͋љς}WL$cGD2QZ4 E@@A(q`1D `'u46ptc48.`R0) @Rt CXCP%CBH@Rf[(t CQhz#0 Zl`O828.p|O×X ?:0FBx$ !i@ڐH[EE1PL ⢖V6QP>U(j MFkt,:.FW8c1L&ӎ9ƌaX: rbl1 {{{;}#tp8_\8"Ey.,X%%Gщ1-9ҀKl.oo/O$&'=JvMޞxǥ{=Vs\x ‰N柜>ucKz=s/ol|ϝ?y ^d]ps~:;/;]7|WpQoH!ɻVsnYs}ҽ~4] =>=:`;cܱ'?e~!ańD#G&}'/?^xI֓?+\wx20;5\ӯ_etWf^Qs-mw3+?~O~ endstream endobj 386 0 obj << /Length 911 /Filter /FlateDecode >> stream xڵVKo@WX9ŢqZ $!z0FʣS"ߙ{׵a=+/Nz8Da*$B{Tio2d;Rj [(AG>;\L`#% >sk@?-};{kO/'N * zDD5?K=" ш$P 1pC{-o@*uLtmZ@S_&2n,]lܲdj]{ݰ7%IV7I\#ߘ吖3Q$ȿ].V:utcg.dQ̵ j W=mhcT e bUFEAlIZm>7i4ƿh|^zƕ5>E"0YQ\e<<ȄK]$TDjI'WS"<#O7# ;g2IԖpX0o -&^n"SX!lw@q{g*U,bH7Q٥I;f It -T'PQIf;!LyԀ/Q{*Zp_H~nQUwՁ.B-@R`֌R4P h fZў~ut,.`6uM-G,ؕůt%݂=aAkw|\Ԙ|0>8JT餳.V2YmkD-WVFU->M <ߗ|x|?Cq2:BY~ SyIub endstream endobj 391 0 obj << /Length 460 /Filter /FlateDecode >> stream x}SM0WhKĵ9ݢl86 mC?v?ۡɪȱ33ofD)xvL+TЬٰZU2ǚ5A͇ŲRӨJKk0E (J@ yw S2[-#h-45= UR%QoEiQϸ(1ddG#/6D%S]p?@7x䊵Sa3@5S r0 RiVXZ*EL5awn(>31g9Iz[~Z:R|]A(_M6i~D}vSY)f8L984/`=U2xKI43}G(ݮ;n-|4ʈJ)] 5WbgF̜bLyλ4WKd5~oS4ΆuJ*VZſDXwI? endstream endobj 383 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (./deSolve-pendulum.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 394 0 R /BBox [0 0 432 432] /Resources << /ProcSet [ /PDF /Text ] /Font << /F2 395 0 R/F3 396 0 R>> /ExtGState << >>/ColorSpace << /sRGB 397 0 R >>>> /Length 33559 /Filter /FlateDecode >> stream xI/˖4 a# Y \ ϒ1'j"z]nX]Q_׿-oc:r~v~o_?J)6˯_P;o0o=8 [1pI8 G'v lK[*S<~:>gy/s<{E9>i<0~3s[x OUa婪6Fѱ=-G<].j.Y pT>S܀Cg ȝha /1rz9@WB 86j E巣E;~;:~~>sk!|NéF{镭2}/ZEkkx?Wx~њsF#gߺ͑3CCϻ-M x~l94K`󋞿&|~Yw3 s䗩9rzIniܫp>ǀE-~E ?EklVsԣq0r|s6ǎ2p^)5Hx~8*'GNqwC_ʳW}3,9s=[|>#=F ~si3G%Ec2~W{wѩVyA@g~ gn9v?@/¤^Lh9~\(ꏛA~Ay#r;Zp7%w6@9172<[99Sp rʒi]/.NZ:vcslM̑}ٛ&⢇9T7g$Fpl)?Iayfix0On#'/Sfla`~ښF4J5GNZ0 |N#~ =!^X >*EQG}j$ܮyL9r9r܆\,ðp ߭3A5hk"7 ">6Mn'@iotIki4B^T{,NPj7dp[~88>ʹ.|v[i} 휦3L-'im[9h-mMSm=b܂{@6;ajSR j0ʭi?Ew'pa?/As;Nۻ.Y:!9F`BSg 7<7Aנ=4a͖׋Ix~9.m;^j㣿c~ F稯_Wp'^p>+F}8ߛl9pl.`7VA$4_<9eA > ˆ`,|A;6 HBlDL`gLF[sdƐ`GscA9Qp7q#xec9G>s<3UәAL_ gp32Vu,jʨΈ{9 "hln$$Iڹ3Nص5MW6aN3iUt[-MmUcpYT皂(\KHp4&6 XnӱIQ!tOZ:Bؙd_mnP!&.4Vh<㗥\7MB7_?[T;r3 ,_ʁ o4V{:ɈQwzi,Tak4{h/{߇i,Őw0i`k4wLcmp.K҅ұiM4VSn0c<\0bOaKq XNaKN)Lcp0@O?`|SmT|i,i$_Fp ֏cq>\9r؄z PGf4F4of>JP9#G*A팑iC&$4k\`C#:GN]w3 y .p7 |V ·U94HיCwpMp)Jnq?u9Ct`d,U[?홾m]0c#O@0&#˥}`>i' 4H0ahqoJCnS:pDl̛-9GN9rj` `pC-;nQJ7C S-d; -:gmQn=4@MpTi08RTTkdD>ɈCᇛ <m{ݭia&Z9M-MY0r:LFT kkҙ)4hm=Hcm%@=%f 3^R {X*i,4Ji,nr? 똜iA?tK;+S)ANcIXO8y2@ r4? {½?!@z~? ^w#șY#giFֱpC[**416"k󁊍I6F0od*X¥`B҅26fl$C#' tm N|pJ=ܣ;@sps7c36SmGʑsy j.@ %SaF ;gl Xb*@]T*O i= >$2t$܇b0A .EA­Z4\oI|| Z Qp{$ܮ2 #HC/A 6ڐ40զ< N异;tօЙpwZ?iB$\7ST4?bTdT[cT;dX4B=1t*$#*LF4c3(qly38pgƚ҂}?:6XEi,= iw](h4֣;66!(A[ƪ:v|Lstk ~ܖ:%x4Nc x`KXX#h!/ ^ˏq!'@6j)7ڍ?aq OPQ';ߚ?u٭yajh$ ,.4}6И“>I'z/1B&\ݎ!5h? ,qI\qX0"'_(<2sdm%WY8VA0]F>2"|4V 388VaߺOg}k'8 E9%9!)'gjk*W91m=W~d]#[NnK|M#|]@l蹖?k * 8;mOL&Tjm7ZXi;=aAwYNNo]ïea'No?/&!Ɵv>c. Gz^=~3]|q3o$v,+?`sXCveXi2?y+Q6Ju>e,=7[6맶4e8~?͏x_<`⽾{7X)W9׋O\O|>Ǐ7Ļ|^w~|V1淪mna%a'7Q-.4^>*_uHS p92]5juFy{S#X N>>3^r.GM>~/p|0awa5vǯߝo;}q[iߋc4a|!iFzx﷏ngqLh zOo_r OzҊ0,,[H7{޾^jo. IyG84=(J qgA3`?YM* Yj|x=2vԨ,dW7ch;Y_1>џ C3:|P+5SXS/N+탿9}4Vwh:%&-ė+7Moh[8g48{Xp/ÅCۤ@9<%f/f0џQv>ĨSjx}5Gc S_f}fɺ>z2;՝EѣDZ#ٳ,`4x{fwwQ01pe4G>~Z9eMFGFdvمhM#ۘOaxTlF_=.gw=/gwN`O8 4>y.ª(.gt4.w﯂"A od@Q3<~ەx$g|Fb3ln ,+>}6Uadw?~ς|M8~ƻc~J}!kV_|6>do)Öϻÿm(tp]@Z-翸80?n?Wq60uzPObQ0A=B{eJ\?51 C~xOrx|O~VoTۗX堰Zt]Dsqp6*ܽ =Ju9b6ObdwZ=d}#-m[!ߟWg 8Yσ|Nz>>28~=YVF_TRihuM7 +ۆ|/aO8^M[*,PW|<'c{g:ՁRvJ|dz.Wܟ|k8! "U<{~"߯<~)Y;|Os|e.1NAC_o~lh{g[h9Z|"U>O _%W+P= CC8Bă'ڍ4O>ħTXA{%-X9W.z~O$v燱̶qE~ V;|>V0gRCRJViC&{>T"m (0z<cId71jVÞw*%jA"mhS+Z}5GK\Gk*mp}/>OWOJ@bdw=TVm:SZ\!o*,oW6|r O, +ON,_4/>~~>g}f[q/&l"[#;NKq='׮z~TӛG_sۓxŏ>j؎H[s|離ÿdOrb~ L|ߤ|P G(W#J/[v%ߗ#ߗ"Ljڊ-JUۣjjb7|+>ߣ5 7vm|Pͧ||FbU ?#y|{Mj2MkըZq51n޿/#wuxWk=n]͘}0OFaۏ|F5"&N6&>Z(8{>CլG};|ɮqƏrZ°'7}~҇|=7(F]|c}GkZFYSչ3|/H\rhuD}iLm4ZPϿZpyU oW &zMBCY#ߟ#)zw~U?_:%9Լ|}Ws a=vWߛt駿i-!{w>^o8K^sZ4|~~zi&z;Wv}'zi6&@ys|ͩ[R}TF~<%;=J?W*s|55|>>5_#&IOSL"v+w'ߗ|BM;016vChG;G.HUvbz{$Fw5^kԱq%}Q~K|:G6.$|~u}}5_KѾ)~$i=>Kعuګ~!q)ʌ;s3|UCDXz?|'Fw3x-G_nx@f++pu=BxW8PG/o_+)}CWwҞC+DT(1dT KxO'/'ߧĕ]Zni!9^O&jKw񽪗{3zwm+ϐ/p7s5ă-k_xV7}>K7zہywx8~/O'AzUqR/AO1`(K_K>iO GQOC w~ < ?)8|/vIxK*z|K+:Gj,L|_B.I;%KT~4|5oʍ27C&%[kq1x7 .i$C'o[;ڡ^m>MvG&vGZ7mJ_?/Hط_;[!|9-l/ j7=&hw߃P[J8=CH+ٜKZ&q}?GacPc ?E6#O||?Uߛx w_/Kj$-ALhW<AA.Kd#>cHt!M#Ӭ.q7(BbHy!x~uW}VĒ.^G?D v{ۇC||vůwxS%A9w=C*Zxn?vUI=ApcP+xhPw>jP;h'w|ߴ JxݠdpSj_? JjAb㷃|_{ŀt0bL}bdq=Wk^CqIf)&`|3~oOo?Uo=O%?Ʊ:<߱>˱@]v)M?O{O Wo)K1$ܐiC*OeO|ܼTݒ5A|ۣ~oTz}+qx:YlOr~Z.qړ2I {1=_\.o^3$ߏnPCT&冧l\®O翹]W-k5MaNKK}3_3}'oS|x;B71)J]/6J|3'e㵓2Ovl|\0|3Ǡ`խo\sC]"|?\7)R׾Kۆp}U?g6V\+>]oyx>WzD?ŎL_HkGK5.x0[+_SŪOYϤr{-~1llВ(O [A5(g1uڔb=Os7ՌmL_bR!i?L}^kr~čjsn P'uX^wݧ"+ @^\PK]1R 3jz"}]"OuŅVJ)nZ=oI4qo"oOW p1b'"zZEo:ٌb{\ZhJKs=Ӻk y8@K^B_%.-9x|?]|_|QhK|?fu㐏VP[zb-=tݵ>mo a@ QO@52{KhGܾ_"O׿/D`{cQmqxj{CIM p.O^+K|K~+ⶔ{,{rŸ=~[dL* -^mB&ʿE ϿMM4H\iKRw{;9wgwwٻwA=g%@~А 铿=~YՇ#OIW'g[~ +W;;)y4TPSCD'gTTgUT^(+7^uoWat)(Z! )E&~w-|2 !n5ϏN%\&sx{/o0V?km{y?2+|*̲ϧ5x Yu3.eX}QAY-W#h+^<łݘ]|5:$zՂ5=G5fѷ`?`X]3YC‹]_ }eu:3.FEح|V{EiERX0cyG8oo__QGO,TI'wcW|4El k?5h>TT2Ʈ&52GcU*V*_8U~XUU8~NO\!*YjG㷳j6:5A_~KA:AY*\Y8ĝQK c*4=dg0*#`uu4ͬ1VUGS킊2n㏦qbikNFdTpk>]0Ӵfv&jhɪzU0U0x?>kU6>3ʨ@Gplxffpړs.5.ɬ1~/C9Ui =KmͅӖvUͪm+,Z=ߑC®6=. FY^,.]]4|mo }/ [8W8UU{U1&/?O(Qlŏ/_>ߩ__~?fJ/O)x=y^o2 UlBUj^o~yRtoSK')^kpAΠU71iU;U^H74ڿ!.O|_%V`{ oW+?^'c{QUYEjRy~Xޓ0VcbkT,PQ(1\M8;UT٩btvfGgW6`1TQ?;T(PZ<7.d!/Ys(WEU1"]ŮK5m{{|vU&i&3rлЪʥAw|Z|>' Govn_Jcu_} Gls|^ܨ"@jR*sY~T},R\@5|;UxPJE2q=I/,ANW|ߚIoL}50jc[M]i~m{~%߷|loN<*A'))>/o_w|1GR}=/~.k]__|2뭯0la^>^rź|[9^UU8zq>/*_@{nn%.@О.% {RU80iO{Z B"wwETm>ߠJ& 7ǣ*v"W|?ȩ+/bRrTrJYsڡ}k+~2K|VtojŢ.ĵ*[Ty䧤:8#~^]?XFi 5[Ju|'?VxT/ؾ ,oTH54,~ޞ|m-}%U,?BZJϓ|ߵ bĕ_3nM箪dC#~-߮Go|u]{׺|?o?5/QUۑ=|E_{{ׯl.w)Mh]nn,m [?\!LpO}[|?t-ގU5%o}UWimUϻ1fWΏϬ=޿FO/[%T=>_}6<>z^, *!7;UGb@g/6UTL1SS*˘*#3}Wuル:l;6Wu_**z_**X]_ECb]hI 9raQ܌E|*wW3w Oh 1UlAAwoʊ||: kD"P]ުwK!P˞_[|Gyy{ړM//m='kQ)«XY|_/*Uor~V\X]Ms0O*ϭ{ZVI]>voMor|{ob|$#&_>}돶jb{_}\v?7>|}3z{O<*>q]X|_/{_ߙo(8IU:UCvؓ|ϲ*CWO؞lؓZ (ShOz>8ͧОT$0ca'W@HxaWhPtѡ?y!O;l@c wsTzBԵ_ƻ{A8^X ^C:Ty>/p%քUoApJSrPAk])HRuxkyHKN]]0EQup^Lί$B7Adڋlc-oj‡lT}Ry.}ZA*Q˪|}5U$@|߇ aG8 b oGW1R}Hor'G[8VNܨRC6Ze{Fk*oT޾۵xSe TTϪf=f ѮJY_U}0 ~BOFTTיUU1uֳKU.QϮīLvp3:WUs-_er<-lT|_xs1p!ECUPC6VA= =TyRH~ AcsVmlZk=m|ߜ<7盂*Ag%ok+jc^b97{> >^M6^oePYPq^!"{ &B^-j&ߏ;^ b?M* Ru3WmDr3/;cUڻJ]]UBv#OV)TU1H\כ?W\SezM{ٯ L`?Hp;>epeKgW\u_6}xo8^t7^8>(*ώ'V;ݧ +߽q|5Ux^%1 A+5jc~N41Is&T9_œغ&>I6.χSQQKU%>**&Q[ʻg{`jC{? MEWU-**Um**@E v%LF{(MNiw,[C'wM=(8!wNG:sy"#>8\r_G2?+T4`9׬< Ta͵ (^Vzra46s10]:.\dr/Q$NP#zMc. `+ץ\ՀW}>JTHĂjW/Rl (O1U/= HXtcwub'a^j'UF LPIjLX)Ij(qdOg4'ٳja[XZԞ*HZ\5ɞEZJY@6ZT90ɞ{k2t*y4*ϙ Σoz }=$^:&n3 V2AKr$f Nr*鲕 T&J[>Up5I ?Nf'1OҦR͓Y6U9S&uʧR>%|R2uɷ&Y}|&WwMwsn/7A.0B 1m!$8&3?(g'nV&6UO:0V16JjZʏ\S%{'s(L:ɞc=Ԙdϩ*W^hu5M>9#<ɞKNR8vDTɞc=^l"DMFyYl=Ԅ'ed칕bJbODNBԆ8.2߫ %{.-:ɞK>${.%'siѡziZ`Zx#̘TSu/թERIZdϡ$"{,H!FN}aԊ*GTORȞ]k86Y b/gS)*eZaM9nx[;'{fRgNZz=ٳjeE$ /Ij0"^<]< ;<}<]Cbp[;c1 IRQVXXͳ8/Ц-W\S.zhs{0aq5VơPhsK5|6Fm.9 ]ͥ-,΅n%0T6e} 9e,Ω9hszԂ6'/g}o&i28j[M.-&isҲ_Gj.tL.Xx3qϘXZ%k6VhXͥmnE&hsEY Y-Xsmu-Ц=h3<&cC_1x.wb kyR(wVk,gBG Yg=gײ\U?α&5%pU#>VZ9GTuab:Pn+ձhq:CMnMSodm,͑c?a^27+|Ixrd)'M팰7HVTpY&}l>:;7NYT7Uպ.4uw](GNQ 94|5{U7a0 ߠz6.X|êxKolgDž2yۂ,j3*.fáu؂ՕKXZg;.lk*,Zr&6#.b4愶=CdJso#6mmW&QMin,1RS5 iLMۼy7rMޔɛpWgyR-WHeK ܕ8͸^M*zGn=eKm|Ia2! tO!F /i6nT&%B!?ݦP7s9) Ã0鳫j~>]%d@rZ0u!TGIf LVEq7sܤ41 X+)ׅcYguh| .3/j[[7}Sj9sI"}XJjq*a0! qW'Y>(ڤϥG7sImcT̑=s>Mj+ߤO_6sjM lyզvΑ3>IxjH]9I]ū=sgt^/gX %`5|?ϦCl*ߜ 0mzNNt:Z:a(u0MbGe:E\Xgonon$XoniPft_(9!u,UqKq\AMH|Sp S}}\9sS:qySACT٧cy@vt݃țKbo.Y\k{im\RR$ʶڲXxs{Û[vour39N *O`{ڃn&NE+%0gd 3Fq3?ݭr989W].=#&L܇9 <ϡX!}f A[{}0T5{?'.jK" 53SE XġHt Wx ·ic=׋Mԋj.R 2qV9A6ݲM hsim` R|'Y. r`kɡ Ц%9Հͩ/w ڜJX$ЧG@AR!ى\gzDaF2EcB\6Yy?@֏ B  \oO7;3!α94A( $2Ѵ5WCny.j[]tՐ[ T-S=]dϥMب9sWcG%a6w6s@(Rh9?ءFQSs\Fvwm!Q9~m# 3ԥRŒupOεpX*ze ! [񅞡)Fi`W;5Ucz gB`9AsМ@||TBK]5<%=dLY.i\ڊ 50 h亽3Ô%  hsZ'a(3:=uU9/ $̑3̵,:gN 舰OA.#AOAi {U9,z^\F$_I{{'2V5Y0_w,"! %FF'$F 'k060Ϸ$>^E=dbIu݀p92qc}B8m~d,Ev?r[w1=R!>Tr!+bz}HͮNj 9O&FM49_C ǧbnz`8~ VN78L'0w~Ql= EPI9&y;k{$y;Ș S[f-o^r/wQGCϴzAT5rt,м0~}T[ٹ+X4ht;;s^-`E)Bkou39sbARw=[3+6pe'aՃtnMnx÷q=6T?H٢_:?!Zlng ݭV) o[|oO%_-0%$Wz;_-A`#?25O ?n.?7#JnNVwk DVX[vv$턟)wl}Ch Q7Pz<=8F0@C'0sTjCZs˿7Mޙ,̗/itR-TӲvnA=X KPm1VBbT$!;h$(yg*EPΤI,gҧb{:]냔5G*gWtl`g|3D-+]+j!;U)잉h_hc i+G|33^2bу% J .J TitRkŽm"=Up7HqBR~⹯Gْz0HB3t= |歍{˹+E0*“Utǧ_G5=oWC68=^4:1t*O Ne3UF PQ\QMpN.G@(z>qHYb(LJԲFe.։Lƪ2enJ-^LaSFuFvnEl>ߎO90r"`=F~ O*pcI[4&gEcv`Wo_>c!w$>-?"(*_N Qi:ƙmsJ#l;G[G )c& \ߢ`0%|P.F|ZۤFУ C U{񤁕 Wf yY1}Ic䃤='iO[)nZLb 21<ڨ\\9ui*Y@b⥪VSoŒKoC$ٌKۛZV% lYԽ?ir1*f Ɗ|>Y%a 6-_CQUA=ib~f 1vCW҉a*Kܨ\ dYBҮJ\٤ߋ0f6p$ULJ.m05D|g ¶U癜'ϗ:S'kBhɷ,a:h ݘޥ:ńϧjiU@€w>Zf`僭}8`=TKYbN&lmX1z+[d|}S/Mz& v@xv$Tl1ꭍ8[  N(l_hCn]l)iNxGBx:3zIK7aE&<,=^B;`뭪)oU.# _w3/ ϯ=wCm 31$FXFe~X~pD~e8Uk`x >|k_ ]@A+(jT7M' i[)w"Tà"ԮH*h}:mxN{ڞ_)|>bC?SH1APT_购3v^~$ʐ}.ia]}A9)Qi"}e0\G6PG_1fd^^NSfE!~ HT68*[w%Ӝ`t]S.hR BXST ^OUVzklkh[;Q- j[lzkCZu ,4YRNUDor୻cowd4'Y܃ U󥺪ҼDuۻ$(4xkOK3E(׆%V 8Ӧ +s/^_x^HK q9C>|קMR娍^-tb].N:m ''C8S贫ӾD;iQZ$ v+B EUMp+R._~t&.87DÛ5ذ闋M`v#}v}"ѲUu%c~{I\._$y^R煴7M$/$g~Pl~y?8nvR!IsI)DNtږ=>H-4ڬE]!qrW\A&m"۟O}7N\_KZaXKW٫e/uhy^th|MbabnA=@asSe2P if2PBU]tӼ1ۂ .ˀo[7)bYч.6f/kp{?w1X! yuϧ({'To _$[%fũOUKN7PzOWMMsACfṔ."E$,@.?b..o8Qs@"\9~1[{'L,`.E],lQi I7KEn褾lV]t[]=_~Nv<]o#l]E.^Lah0]{?9CdJ[=tgRJAhH,}?v5K8+(rH0}yڊӿK[˟Yi[5l:Ɛnt{mzm!y i;OkU8ZSa޶[Q??щ*! uͫ(U)U*zd`XL;vMCް)>^ ETzmN[Qs\_:7Ui׾XʎMq 핢 c}ˇ*r S᳗D˞~{@$$HdvsKsE?(mTTpze2Y{Uaj]uɾ>ءjfwJJ//6i Wy*uv yq?7}~a[}ٖD*i߿-Ү{]uio>%# $ =T;U%.AZҚf`Ѹ0J VzjjPK{UNKVX_|޺C6#MjESFΤQ6 F,г0Ʀ?r8G'5/zC#ҼJdy]qؔ d(dhv Zd ̎t9\ ( \(JBLWpݱxՐiK;r-M ji*UMv֊$[7oڥچLE Cm/bۉrƭRبmom#'^mܨPEݫh\[NLܦ&yN(!x] MXtsװ4[7r0(ϜbΫRiw4+V9%kˌ]3gͥ}[/2-,Mױ+sݯ(A"{ |p&PXbhyȨI4=lC\t ՛͏1TR&ThrN]^Աؓjt_qm` j}m^Wi[5B4-M߷(7H[z ojKK 9&mx'_ ALL&x-PV*Y<viWWQtnt{{}S@]vqi{Ha_>=lr~DKj˒ӰRj+.K:0?ƵthNMK.@  g8lHkPn3gyUU[ ;eMMp.B=DJU+6;<zÜzpthr n+13p`;C xu@dN)\ w;p4g3'\e`[Iټ wN'wOap{xMw`>L+ zt/`x.*+n%N45|pEgS&gо.^HU 82 fQͭW}8Ps}\9N<ǟ|ӸYf 7ʿ_@/ij G45 k/?P;~7wfXz>Nq8qOh'h??| }C3ϟWYXϯ? U߽ǗC\/W4c9ZjSmCOm6zJn;FFLAc&U#Uٶ͑-Am5 nyR%̶zc}Gz_Dl'mޟs1YO[~}x\O=(>Pm+;U%cvczmvfkg6joykVV۵`6me]eW6j=t*U0;ocƹԫIz{몧gڅ byكu˾á%XIPj,٦Po4ABmfň1]!&I[rp. c1IPIDY[zHӸH4mÈG "QǸ5~ +38x(إdGeXM v(5M(E4Vtɯ3;E9M&$j+kLE4QoѦҕQJFE*mLpY*FE:`iS@vcI ť\W،i|9i'GZ9oJaDF#*sJ>v[T&NƏ4.d8>-9>N#D~hf>9}[mP44Q~Х.t~_e5(ө_,䖺Qu5UnTo'QPָx<:F"=P^((pyE~Pu/ -_ڞ_߿?w`}uWc_Y__S]ߣ_%'jxJXƠ\Og9h}j.r?SN_ٕrU*TC^*T/g J Y( * h=E~R9%(E]Dn\*łPv:!r{a"BNڐɢzcCYW[=yL̛= s*P;g<5/I,|@t^Y-Ȕm<2\E8:-=(/I[C,!zQ)Њx PޫG/(' 6pv\Q#uH", ykL@̩/YEtTK[Je ۆ9.iDBq9%=s䭚oFWSFyX1*]˿gbc&y&~ܜ)"v؊UC<㠊AՍB%W4Ĩ"Qp+%cՃjBQPF7i׶%Bи6!Ji䁲t (mο((/^P[5/(uη}P~QQD}}}Y}ި5,'Kp=Q= KY#^oAqW㍴ԍ3\X铥Yg'8d7i|;@ZAJ>Yߘwy=T ]maYfzڐH@S u]^xQu),ᑾߝVj ~y{%P_!yٕyhfP <v)H T V]9&7$jo n KQHӻܪKRaAHZN|tsHݭO왞츶g$8:]izwz($! &\*xB?{6>4-LQf 0ӥ e8DFwF.b*'cbQj'[(PK6AvmK5*2v2ӥZ⊣܂% n(ap}P7(,=o_F.ut]S-l:GQkmejDQu; {>jDiڣtW3T6~QO-UgY|rU^@%Pjܿ{P)W>k$Bvj՝Wh.kصܠ@!S]j Kz(t}[$vyõTHQ탣ZCӿk˕Yia,/L$_ݨPd6Ѳѡݬ;d?sr1ːMNp@Cj%p$.T3ȺHR "%JдgBIn1R存트ƐܰkRuQosTE">Cٺ##QC.Q*1Àr ćd ӸI#2H$hf1Cj̮Q^jn(x9 ؘM0M`O 1[0c51;f]xErc[e/rW1N < QZjᰁZjc(t9Jyv: ﮭxzs*jH[.UQh!]z {De@Bvrݲy/&gS|*uw/80sNՌWRF)n9Aa'*j{][J/mujU @yѥ]Zi{,DcQlEs=}lKT CV.+jjӄe"tPpۼ-^(5^I9[=YP]F#D+sLLmt'v9 JTJH7TqF}d+""1 ԒDFn cU 86S&c9 a6H(q@{#j@ E 2*-Z/N6ft-_r^H\FOuP:b3D AQ}F!vmrLmԘ8EڪT[JK]J-+TkBI텲FJ0u*Am>qom4ܾO|w|O\LJ[3>~?q;g^oT:R/mԂi.Z2`o{^N$Z9Y/PZΒ`k Xե]JͱGv B ;6{ |!K??fzK<4ApN{\PUbU)+hP[Y]9 _~x4 0!F$5UӅ@XoY>9s.1ԦXMtB55Ct}aJ{B+(s]CU*RG4"Qa БiY@Y`]'!]f.V7*܌OVItNr+GQxR;%qv[(,'Tٸ6Gɠ's ߃y&v/0vj-_(n}=,TbH?QPy{ߏQ3+(0s3،άf**57 Ud׮U(UYee~XٌBfr=BY$Ѝ,ذ2An0j͐^/r#VI;_F?63b5 ܕ]BryG:E"0 O6nB1aRN@BG9Y;4ps)y/Ek@6AE3A_C.U0i Tdj՗/YVj'r%DD;t$n(9tvz-Y9fD!l8d| ί.6L~~LS{S7( ?I( ]Н*6pBlZŒQդ \ F2{AUNK &veJQqKFڗjc3)XvmsJk1 ȋSw-uR0(#B].uF\QjgZd YvVJA]ﾾR` CyăzU|ޏZNOojVo޿uk~> ߃rUn7 Ѫ_t?},}!';O ~]Pl)q~W>}ϽՅJ<o4ޜ}8z'{>A OwE"_=_}Lo 2pOUY~m5r0z C˯Y/ՇQTː1?[-̇P_U;Dᖻ,AԆR endstream endobj 399 0 obj << /Alternate /DeviceRGB /N 3 /Length 2596 /Filter /FlateDecode >> stream xwTSϽ7PkhRH H.*1 J"6DTpDQ2(C"QDqpId߼y͛~kg}ֺLX Xňg` lpBF|،l *?Y"1P\8=W%Oɘ4M0J"Y2Vs,[|e92<se'9`2&ctI@o|N6(.sSdl-c(2-yH_/XZ.$&\SM07#1ؙYrfYym";8980m-m(]v^DW~ emi]P`/u}q|^R,g+\Kk)/C_|Rax8t1C^7nfzDp 柇u$/ED˦L L[B@ٹЖX!@~(* {d+} G͋љς}WL$cGD2QZ4 E@@A(q`1D `'u46ptc48.`R0) @Rt CXCP%CBH@Rf[(t CQhz#0 Zl`O828.p|O×X ?:0FBx$ !i@ڐH[EE1PL ⢖V6QP>U(j MFkt,:.FW8c1L&ӎ9ƌaX: rbl1 {{{;}#tp8_\8"Ey.,X%%Gщ1-9ҀKl.oo/O$&'=JvMޞxǥ{=Vs\x ‰N柜>ucKz=s/ol|ϝ?y ^d]ps~:;/;]7|WpQoH!ɻVsnYs}ҽ~4] =>=:`;cܱ'?e~!ańD#G&}'/?^xI֓?+\wx20;5\ӯ_etWf^Qs-mw3+?~O~ endstream endobj 402 0 obj << /Length 1741 /Filter /FlateDecode >> stream xڽYKs6WH7ӸӴӤ:,ɏKrcw߻$HS'=>.)]d4qxpx\ЌQba[;90:|=<9<#CD t&pf-?<2cIe.e6ZM N'gխ  o`|n 2v25]Ƃ1nag0f "{a[N-ëM?-lBJ.c z3X/fcRQ@--D)'pBylo0\*p9r6ҘΧ.n t̝P:ӕnJ{&֦ə[xJQ8{ݦi57`.ag6n\Q;.4;wr]%A qAӆt@2q֡l^yhHSz-f.g^EƵtZDpMS`MF:s1…wTˬ&Ӣ$IM$N%HiɎf0wx!WHcM@R⣈Tw#L ޥb⌘^|)JޏĄGÓn|z/]RJT&}||BH\wTފBQjw&j6CSYk enV?ET\caƣQ_%-B+&ْ =b²R,V%d d_-N_-홹 GuJKpwTgoB=MLQ:If8dt?PhhN +& 0qOt&\Uoa8C-`ɰu8g?c^`!yw֝˶x'ەwi GL UO &l IR8J]%3^Ü,7|}{X43Io%˗6 C2%שd5K[шf;YѾdYb_uҴnhxG5fyfPM򋎎|mPǛ>*Iw5%:0>s5E]N* jY߫a>q,4|z3>̀N JxbuH#ӊl}3>jj܁dw&xh30!oWOrYW#&`E$). ~/ ICkHdz:XE!x%i3Ry/DxJ1* -Zj65V+Oð0N9{/2`6E<|J|r/hڔ16D^27-xڔ16DrUO[.GUK`c7, )·`86ݦ<}|Mdv]-]Y2O(8 endstream endobj 407 0 obj << /Length 1671 /Filter /FlateDecode >> stream xXKsF Whz"!WLN'tI@KZ][' q>`,@w/_<u7&IM r?̗R/#MyUl [E֭VxO=' =ii{Vrmm_Y٘$ži[ 캇~=}zcd!~c^(I?\Y5ｄ_35+%͘f'Vi.\ZO<:THlqƱmzK$@K#j*_~פv CH%^/ҀӖ|f(oQ+ɚ />h9E{Oٿ |!4S7ï`8kfM.Z=B"peiʻ$;V6kS ",EV5@vO7r"h6cbYZ_ڼGŐ"45@җE捂9c>|tGC퟇Z j=GӼAy,b(r#]* J+$E7R;FU+FX-$OEմDokӪҨ0H1$薔&6𚧻{ ^\eT(Y)iB3sU.qʎEJ頌6&f;s^6=Y6Ft?P 5rPP7rꊢQ%[TEZn:tNh¤L_/]K;Xôk !SMMhsOu6|Aki%N+np TBv^9Ln«0e8fG3th]ҍpɠx?P\eFJ4%Ö`$$o˦i:.4?,˴}(k~y%lS~`,i]V'r$|{ra>TMy,Wsk e26N_jښ-ؘ@쌓a,0Q6'6?Цqmč(i͢A.ȦuIy}7Itd b]cgQb?ƙ:sq)ɪ{k>t'NNu{RBk<~{PH!qӢ8H:bɻ-xA> stream xWKF@>1J4!7srs`fwXl6(=jhXf8e4EUWW_W7ʻwי UhotN,$޺~\iví^g :5:}#} DzןV ;V9oB~cUG~`0%8Oݭ~_~~ Q;Ąq@BdPJI^ Li+#5&m7ˆ}v"8y) $-6^nLB+|F`۟(voU@n0֢fS8CׇBA3a-HڄI\0Bh/ohz*J_*qQ.U(&TSQm+t 1&p:T*&u/b\:AS* PaTd~C'&Qxْ[J0Imhpm%3\wP%?d#:vճ% TQĔA QQfy߲s^aЖug'=-Bv?~Pwr'5*~,qB <)ߓׅ\H67,QMKÉ[m&w}/w۾6ۄ#*S; _1xi=lBqH N\[ꍠʀFɒl%6,Uڮ_@dOEu/-cXDP-K3f3jJɔ狳A_zB 6r2F.KQh?~4NɈzUuI|<مztYCmDNI ^n|b* O6n45[^۲k!Ƕ_ȱ o*i!FiٽнF溙vEzq;⵭sU( M7eQxX4,{EбDo1-@HY%5>og.E2@ۛ3bG)KaZ@Ihv#r;e/4@$ݙ1SVc.DZb6s*Ϥ}Z_ 0a endstream endobj 417 0 obj << /Length 2434 /Filter /FlateDecode >> stream xڥn |j&fk$p2V`0x\29Pd۰))B{^m"%kyZjTWLDUvU'&׷VLӔ2__USŻQj hߧ-择l_.ޞiZu-ܡTgTɢa҈IS3Un wj:SJqG^qA ^=lO0 On;%miVv/M2DRZT Xl&3eʶ`әv,g/qlUDQՙ0s3)ˮa$i/g˭%..Y5V Q-~?ɺa-QCy [@fvaػmwbwhxo쉃353Hx]ʒlN=`oisPC~|Wu-eq}G0!A1"ı'Q&(v|gN606dE q-Qk`]qz>,1Ϭ?YJT$NRﰳE/GfѬVdA & { X$Z҈҂D!Ű-"W3a~LSNB^Pd[V=d0jEYWk_ܞ5BE^̚(Ur'i ąuo7I\4@,TоzkL@KG.d*?.vv ڢ쌱61~[itq-ksS}訸n]&J%&Y31?5NPMv0qw:}kŸW%\d_qtЦkܴv>U܌mYGzuѥώ稉Ӝ}?Ԇ-qL{>r ̄J`TC.xrk,gKj{$1U"Le,`vRax@Ep&ȈXb9l VKGmC(wnɵ&N{X6({|p$[O]t>Z3Ska9 MVuLVU"l\^Gw/h2 IJ 5Z JaDm OEz 硗t|cd|X*L|Y\0Ym&q{[{Jwt5ѩ3љRt241 l1f@8$F(8Ҏ9&iU,3t4<ЄaýǑ'Q C}‰nI:/Yׯ,Oa\-ti iLm)//j!-Zi !ko&/M.Ѡ'4ȯ>oV@&n1/)XH=?]?ϽL endstream endobj 425 0 obj << /Length 1197 /Filter /FlateDecode >> stream xڽW[4~﯈)ǹE`)a^vMfFsI08~y/|3\'#QFfkOfHei.JzwH~ҷ^P) sjAҷ- jZVGA߃"at_Ў=hTnՍ DJ$E&G>|?H=)d,4Dr74F3…nO\}e޷/DNshR #e$\zi,$q"lN L忣dvv;q*!5MA^=+UA\`ƙͫ2#eTbZȣB:X 0u4J_!Q>OOidzjnIAP*&%ye4'W@Z쭾b}ݽFE|"R_B_K*j9ڥ?]n;oWiQ 軽P`}{4KN#L7tK>n @H-oj䄇=g8!(d3pf|I5ɲ-'ݻ6JBuLCwSJ^8bsE0:[D2oCs[ՊzwycdaI9< pƉI)[o=ΑXs\)IeR"W<5tubPX0Soٵ!+ŹY ͬtbj9`?$aMTגѦb0rp;¡\Ph!{%oܠ&]9&%?'|$?f_|8?b/i嬜Yxv}z/lAVa@َ 3ҽU974/y~e% l >aeN[ w L7캋ɳTHwS3fđX~p*G O&>j/,Čc-5'֚x#GԜ/v f-,/8 GcXְᥳ(y ~3G/"/i\1s<7Gv9:mR6*ulfқ⎺/v`hI\``8){a?)^,QqPB뾘.7n~9k^^|V]\ _ endstream endobj 414 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (./deSolve-figevent1.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 429 0 R /BBox [0 0 576 288] /Resources << /ProcSet [ /PDF /Text ] /Font << /F2 430 0 R/F3 431 0 R>> /ExtGState << >>/ColorSpace << /sRGB 432 0 R >>>> /Length 1982 /Filter /FlateDecode >> stream xXˎ%G߯%,(2O|mm%`Zb2FbF2'"NVxlͳWY<'$ԫs9+/K0[sou t~mXp l`hs3c6}Z;Zrg6i3e$9yadw0fso:[\~e!>]dcfhL;i-$a38Wᥠ]*Ò mcĆ(퀊-CPFTo>XGl2**NUHH b 5c]3\eG䘥Uw2['6fM)Q d hz w*a!fNi^&< %AԐ.P2Gs'Bh>*>H?k"$:70j u $>r&sucyzs=e=\x__ArZ~5"w!7hD۞e9>F@&v{z{ÓnQTq=j/?ʒܮg3Β򳆠g]sl> h(kb]NzXV t_xԘcyz̰s=e=>w߿~}9ңpiGr@0 >~jь? DܸRfkجs c:%IXVhChF#Z|u!A(k8/?1lϚK54򥪆ph0:+* [Zi`t5xF +-:kY軂=:kb#Tg=ag;,]XtV6siXeMS]^9V4hiMeD{Ō]+ɮ_xT{͘?^%+N{=d!i~8S a zhQғr'#a",f쁋F{6IўjnP Ў hr 7MSu&!-Q2 v#2dFrMUG&)/YJ Sc8DRほ)(G4?kϸt.y#ì_V-NRS`i\*9U:Wz@ Tk6!UA4FgoһsȿM|[^x {^<;Qe CqH_7BO)!}!}g#?AqgH_仄ϐR.!}gH_?/⧦TY8+eMKP5-5-[5/[W5/離>,KC,BИBe(}BD5)qn,gHR≆"務"߭LA)_jR(A*Xa}𾾪̱e=\x__Qr~5x ` { `~ `z p$keC2`MPk9*jcQqCQ7 xY_pˎ/;W+^0ZSC"!x+cKu\냗uP^8|?K  s ap?د endstream endobj 434 0 obj << /Alternate /DeviceRGB /N 3 /Length 2596 /Filter /FlateDecode >> stream xwTSϽ7PkhRH H.*1 J"6DTpDQ2(C"QDqpId߼y͛~kg}ֺLX Xňg` lpBF|،l *?Y"1P\8=W%Oɘ4M0J"Y2Vs,[|e92<se'9`2&ctI@o|N6(.sSdl-c(2-yH_/XZ.$&\SM07#1ؙYrfYym";8980m-m(]v^DW~ emi]P`/u}q|^R,g+\Kk)/C_|Rax8t1C^7nfzDp 柇u$/ED˦L L[B@ٹЖX!@~(* {d+} G͋љς}WL$cGD2QZ4 E@@A(q`1D `'u46ptc48.`R0) @Rt CXCP%CBH@Rf[(t CQhz#0 Zl`O828.p|O×X ?:0FBx$ !i@ڐH[EE1PL ⢖V6QP>U(j MFkt,:.FW8c1L&ӎ9ƌaX: rbl1 {{{;}#tp8_\8"Ey.,X%%Gщ1-9ҀKl.oo/O$&'=JvMޞxǥ{=Vs\x ‰N柜>ucKz=s/ol|ϝ?y ^d]ps~:;/;]7|WpQoH!ɻVsnYs}ҽ~4] =>=:`;cܱ'?e~!ańD#G&}'/?^xI֓?+\wx20;5\ӯ_etWf^Qs-mw3+?~O~ endstream endobj 437 0 obj << /Length 2097 /Filter /FlateDecode >> stream xڭXYoF~ j=xEu}h/IHBq;.4 {|s,~,~~sN:QeRf("OsUt.^.McӓgySZ9 ,䗕)U2*͖վ3ň*˴?]e{|fIr(SOWkE{Sjm]>1.\e:Y*,LQ$ m3`zodws[$u.G:S”^ߐ&F[eHLeptF(!ms)_ ?'Y{ tlt&Xx&w)sw<=ɖ[4k6ԃwϛwlk$d/u5VK=Ϛ3Z2M ^ttѵ5h ?u$[ye9 w D-tyEO OzQ􌏱qpCr-6wlM;4+Fh;dxuNN6@&FQQ@F&XTQ)¼8Hp^,pAVyO&B"`88y%6xMO4`D`7u%[GΔtU7~XJGо&6<߈b /oa<+JS\H'jdZܺ_W`$ˈcwKm7|+AdS 9@}6h g1y`Q 5(!=J@p'!X-N5PT}reS`:@hy/J=?@< !4@#tx I\w0;z0OGk)HJ!5Ӽ\ NYvA BiZg^kVHDwM.-Ge(U7GBLbtFEə_%Cqf0=U=a=n$@,QEv!|29a_(l&>FJE(m if0Fp-Q%ɒJpCc`^l-ڽtK,r 9 :o`o6erEHRtj%v> ^ M`mߍ@%ɕ8<_ի:^.'$C14['<pQq|T9]$ M$4&`uS2.R(~ϱ,Xxzo:+}(GYf)\ޅ,oFxpw 2|j:=9N&ֺOtu00WPgGurpw!v͊!}UKO%$.!D &%lPRğ3qԸ[79<მhZg*ޒCUok ͩX!A("r1ت#0J 7ȡ'o=yER?R?Jk&gbhdaD =wSk!#YScb U|\i/>TWIVPh'*mqF"\ zաRh3|DYzIR%h :Zq *!e{ xx)bxɛĢ'&Lg؜&s,LV$ i㙔^ʱ:ky}ș\*]8<QyLu O{cgdW7I/[o2]= *g|UD~m4R+H'h| ]\vPs޶R24qp1J iLbPoe.c| Y endstream endobj 422 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (./deSolve-figevent2.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 443 0 R /BBox [0 0 432 432] /Resources << /ProcSet [ /PDF /Text ] /Font << /F2 444 0 R/F3 445 0 R>> /ExtGState << >>/ColorSpace << /sRGB 446 0 R >>>> /Length 11979 /Filter /FlateDecode >> stream x}K;r=)"ib!DK#"2s^Ue돾_|o믿nk_9{W=׿Ͼ־[k_}o7|vu̯:_mw_~__7W ;{ﻄ}/_<>˽3z|Ì;48 ^w罪=ѿM\G>x|m*{o^˟0{Uyy$ƈp6}~mIxφޫ%߫]0_FkzCykz#sߗ50y_^ {d!|_mdmGp66=OC _o'gyR^Xvzm~nl7 us ͳE xpN}YoSxtߤ7' `qonF|~U!>4矎7Ew`Tqx3f ؠ>j$ |\7c9 d9dk$'.a6 L`p^\ͣ&Gx3쐰1f!acl781ze $l̫pHxx&?X5F$lX6Z>nϊuD lltYwH a6u o _!Kgk3 ܔS<2aj#lcY߂Ϝ] t4z '6i''Ep9ن_f[Z.O >%j]6ߢQ$l>|2`>jfu| Gfoš$l>v)hK&֣-GFhyBqpI|'/?7f>NdTa_͉0wf7H+6UQOڌU ܢՃr/ XC}̫sI|s㒰4#0߂VMx= F>{GX@1@EŽWy_P$as,8.8a[J/|<$,5|qK3m >.ޜݭڰ‴࡜Nn \sgr{ c M`>>#s!>s P7Ϙ@9IL3 h_d'^ڇo+[ڛx \LG#a\MVoj ><އ9~,w^x3xᇧH_,Cx}]0CXx?ϋx_@GDGijSjHp^zYƩxh^t}ꯤKGكӼsKk6O]|Y=óIpm2?}j܈.,?#1ekYLa8| ܥqM}0i={SoϢ=7|]|G3 n#H{" k`rpp=Q ;T]W7ߟvXF~O+{Ufi6U1bpH?wDKjo}֨\-i@q֧ Ab#J"^>|1P^HJkɵN0Dʿ=V ?6 ?(5Nqrupqv84muL4hu=]Y5bφ?8lgR,bVȱ6s&gO|!gj9иmmHoz8WgńȷfHTʥb+NǕi ]?dcM6H|KYJLc)R>`c͖d;r3okhMV33lLڇ>R~y 1 캎5KC=TC|[>.>YOL8m:eLk iMDi~< \&Q;w$f=;}Jż|$;12>Pɏ4>|\qI4$ߑ"&NyrFt4Ք^1*{3w>5F̳ 9'##LsG{$;Q憱c[?ɘhF̃g7_US +/S|?ŗ)#Wσ*6^y~+90F̃W3^wS|GI##uFs{͘aJ[߯Y%1v˩ Pe6w$|/ wc}#A{ahy>()\8Ⱦ.|ިqۨ9ok"5 uiY.c_ơ8 ,{ 93 LcѓXw`NMCTסi,~Q|_iFs"Fl/X|Q6XB,PMSVΖFҳ3ߚJNiV)֬$"߉14V"߉R4F/iŇE_Z;wOwuaU9VҔd?/~8Î|xJ0r>H<~-}ciei a0ia>O+M6߻m7m7f+*^ G# R߷w`&YpQ}qK#ZrWHmc𽻞|eQ^*cl{+{qw?u?FO|?G%~޿woGi?QTסw\vAplU?:e4ci_C؟%i14]9^A̟`ݿQuw)a|/+r~)P'txHԷ>x:F֓.ޫ85kM141}- yP eec9\WK {(G*rURpa0jmbQn_\|8LV0O{B-`Td{;K{fKW$}cɼe0|V >ؕcTt4`|K7|y(t {,\Q!"+Ơ8$AV&si[#]km W&ҀW~P<\ 8CoA2]!E32WGv)=yP<+u@23E4ŇK܁AB_Q|+$`(mig8~HL60(>o(Ơt&l=(, HMcy֐ɵ!hZ]_:Ơ@/G |!c뫈x  ix~G|_.zMO//][}~Rp8˘C%4^!u}k~z)H83aZB|ߑK- /XXxL Ϻ>Ҭ/wene [ZOciϝ%|`n+)Ә)^KL/]:ax?Y|Ob?IV o!Ϭ+#n)u|.?4-9c}|fmg!ơGOc߇o=$߇h?iC{1{?׏ )M~({?9"Q%<[{]O0^F|x#c kUܿf1I)2:U|0ԎTIwsÒ(IQRlR|oOϠ?e/aߣ#e_J[{ާܨ^חv*zP6֊Ln/?ev-mR|oQ'7^6]}[ϩڵ*㟨DޯK01Qun}v4ez(k=oyT5?wć*:^Ou|Su}[eA#;KJV@HN ;7+[Kg~ba;:wLKd_1+!:h%F.Ya2V)!ޖ#r!Ct3wVc##7wVc˸w<u}J?w֨%HaC@Y1Ncmu}Ksw{Iw<] \TE ~v  D7N-cnYsnX+`=掹PY@7QҊ~߽y~3uꙣ+~׶^Z&(藲Wp4,GwCL~;' 07tI]*R)~n‡|9L?߁Yڍ/L{j=N]эiL=)(`v@<\ '|"qsVL.QKG 㩒aS^g͡Oś_mCS)U'~?.}g߫)~otu.OOL G5X/):੔Wg_撞Yz0ֺ2HZtxe =l{:z?O{S<|GU&-|(0?PB#i~/2y#ieJ~r`w|*yc 2 Rv]ȲJ&@}YfJfo|[*XQƛƈw`1H]n]GkC蕏XC3ttztkxG20^zu.FT>$ߎG# o{PDb_ 񄿏|Ѝdx5|]KNGkUu%>%rZe)4}_[Ω]"߁w3dΰCxXD ]#;*a/=bpJ8E%NZ|c!4FS%C%"6c;YۨP;>yT[|nm uFJPl=+_{v-SM/ex[|xO߳{|.~5fm\sO_[|.b-y*Ck~c?|~l[.P|O%xjg}u]6KOA Urվ%}|/e7]|1S>`هo\S85^{^%N7-?%tZ/N}>9Nv?RWlW~c_mۭj~iBArۘv |o%tZeOW~%s)B1[U;Q%[NQB-`Zj[_m)3&Y3o^O?y>y+)h  cCpiz*,{pwV.6UׇoͯC#=.}ƈV靇|G|1~qwCj/ ih};Ld#7y֎;Y #6;"v{{;"lC_owtT\]'M7קyD[ +@q5`k7|* TЯ^r#G]n\JGt.E]}Gn>J[ *}*}}EVLĥA~Txt{M_ѻw4xkY,[yM,W|]*wTyބr2ޒ_>^n? C*wywj:ޑ'`u0-`<0]G rܥE|dhn|1<+Q6[e$KN>{Z^K ܸC㍏S/DnWf,=/z)o3QN8Lc+\1cQއZvh пHsV`u,W{g;{FПSQ1ޙ_S;]㕸r}^^pRz/U;nE;~@dnMӍ-gneħ?Jz?^e*7>T nSR~?y'W'cu9/Z| ou\Cfqt8rL9`ʙ>!u|}X¡rSxTҹy…U_8)93{R wN3܉T?;QL3SLɩt4/!t^OWa;.qlSqoN_fo_'ߣs`5zøƩk'y~lX~05k~ZߗO5?TrAjMSnM9,C'8~ŭ*?}z,!һ>Egk{z1>R|.KAI|>;?TP߫<|Ϛ?)O]ۏ`c P!=H]UW;^"z{zSeUJ:O( 8N|/6u;ܘNydP+{}:%QA|GI_Wϋ?>o[f{ UVP06j,c"L1?q<4r7]gsk~۵d_tNm)9xj>z]'-M{+oq\'Sb2k_}&(7^TG]滓-Ϻ|O2CwMZOz_(m"u?ZWoOߗo8+UZڛ?yֲz/ /}jJZCk=O-j~}^۳~?4{?47 }?SlT}tm Qm[߿+G%K||_`f{+sm韥OeaC;S),qfU轎YP;U DiʝU{mQcC-QP^m5K,{/1nߛwToE>Oy, >(7gƭff}/*,Fa4\ olJG w94nQN>J+[:FQgo~zQT+01\mp}z6Zʢv5v/]|eܖҪyqSG1tu1&K:8O:|0Lc>Yy#jgrGcQ;Kgo3fYֲ;C*qFK$S_rS̓nz?K;SL. <<{#ԙ9g`..R^:la>3tx6p:G*86ԑtmخL9>t6wJi?tpx_uYȇ@>.\w=x]7< r|Zs'7__RCx zJ˯;?_yv?:_? V5 z['ls7a}u7Һ_'`a9YP>#?>͟W6~ws;a,3CknZo^njBc_'W?@.3I+??tZ:?go?5 endstream endobj 448 0 obj << /Alternate /DeviceRGB /N 3 /Length 2596 /Filter /FlateDecode >> stream xwTSϽ7PkhRH H.*1 J"6DTpDQ2(C"QDqpId߼y͛~kg}ֺLX Xňg` lpBF|،l *?Y"1P\8=W%Oɘ4M0J"Y2Vs,[|e92<se'9`2&ctI@o|N6(.sSdl-c(2-yH_/XZ.$&\SM07#1ؙYrfYym";8980m-m(]v^DW~ emi]P`/u}q|^R,g+\Kk)/C_|Rax8t1C^7nfzDp 柇u$/ED˦L L[B@ٹЖX!@~(* {d+} G͋љς}WL$cGD2QZ4 E@@A(q`1D `'u46ptc48.`R0) @Rt CXCP%CBH@Rf[(t CQhz#0 Zl`O828.p|O×X ?:0FBx$ !i@ڐH[EE1PL ⢖V6QP>U(j MFkt,:.FW8c1L&ӎ9ƌaX: rbl1 {{{;}#tp8_\8"Ey.,X%%Gщ1-9ҀKl.oo/O$&'=JvMޞxǥ{=Vs\x ‰N柜>ucKz=s/ol|ϝ?y ^d]ps~:;/;]7|WpQoH!ɻVsnYs}ҽ~4] =>=:`;cܱ'?e~!ańD#G&}'/?^xI֓?+\wx20;5\ӯ_etWf^Qs-mw3+?~O~ endstream endobj 325 0 obj << /Type /ObjStm /N 100 /First 882 /Length 1783 /Filter /FlateDecode >> stream xZKoFW>t;*& 4"3ZG dH}!e"GH11;;o3TeQYyyzc=A91Y<$OxARD "eFˠa32lALX q2 [e ɊS+D. 8 ! H c@pMĩh T8bl$b-\ 0 ,%%;&'#h 0As"N'A&T8d@U d[IAbVܜyI쌧0A5#h 9&SIp:[le H i=74АYVyߺ0 %.6c'XRd; A`86ͮ`6ZHSCZXHl@"$@C bD 2k!Cp8S*`(j3l/ FV * V(c\Cb<\K8@ 3 ˘$%MABjf91*Y=}U>F9,&p6c$NZLv";,p ȇ b(N]L5\ {8۞y(_I5Wg|uLէ:/%}UеίpUz6,\]LF'u&Nf`4-dz&aHyO(OΛO_EyP.Ys9/!&\dC)6hXGxS^OQ{ڸDZGd^铺ܤ=1 w4P0GP.pejz}yyk;.r Axn m Z׊$h@Xc5'VҪcPA#O|]8r :nyuo%ŅGepЖ{"iayul拶OTRb7/)PS/>HF Tf[ L=v8FI==+(Ɠe\답{%v^?&+zzzq=fӴe%ΝhE*_Fd"FWUOƣq:/&Mh,?//>|qx(G.]7'Z_'ӧӫݻ ^,?LW ACF6j)m2QV, VŷH>[hy17)9k?hMV:H:[>&jf,Qp#̍$(zIL9] U")[H>9&&J>yKF6ixligV!l}d1"Z~Dd뫮]!meUp\kᰙÆp/>3v*mmO覾&}FU]m3f[yqv0:½vt~=l"۟|/R:|;E (wTOۛDc̺RϢ^\~]7ŏ.ov _ˤKfMҁVd endstream endobj 452 0 obj << /Length 2047 /Filter /FlateDecode >> stream xYo6_a + cJ0 f0tA؍-{4w_)Wi]=Ȧx&W5GOr5*.U'ˉΊ8$O4d~z?-icVJtluH7"YYvq<`,΀L8L&$ߚ=[ہYk?OQN6|/8R*^z3<M 0-ܩVA߳?/6bU99&+sR5գ ,TֽsyꞽOI\gNJãx78%)<:xR2SV=&{mLq*~̉'O;@_|@!AZʪHo~}(G#-@E̬p[ؚg˴`mu2Fb6:6LL\bs(8-r:3]Mg/&T~9iowbǚ/ю{{Ql:z3k=*A\%gǞŊL(Tշǐ_ B)  ]JVp/ ZyF&h'/@k .D\8C;rժ3< ΙFrfqM^&I9LL N<[@­,ވݰ3"vxIړ$RApXчD"{i o\Vz>U2Qi\։@z8){H>' M1f&qfL~&ǁ=T@/ f#]wwa⾹U%`ad=XU뽖Rƻg,tviPVyБ?6%¥)GX<*WsOWuB/c L0xϣįu7J]ʼn 'f/}DWC/A^*=J)8T2:VkА/L <9@E};QrAZVJ 5T"0vx6$C)es7>4t%ֲ)rn^r۱2[2U`ܬrt"z͵RF8cW 2⨿qgymyzQ&y\޾8}p!A;5w>Ő|mܕ f\|èK))yJp-O4GWd 9/3nw$l):[囻㲈wFEXREdRqz}dm3V/8q8|wDt>/ endstream endobj 459 0 obj << /Length 1481 /Filter /FlateDecode >> stream xXYo6~ҤHh)-C٫==΢/3cP1 9|3oO~]r`< 2:ex| ,<">U*F%543IXJZ`I"$ayimXG2!M 4Ŏh /7KuoŒ,I)ßvQ,a#2i^@%&O\[o-pngpFq,ΝS. bR%13fY Gf$h9_e7jSNؚ @<Ιllz$d %9x:7T}d?#@i5V@nؾ_u TJ=pE7+iӘv5(uYR 9dӾ_~ -z9 2nzg 1>4#B!:]GziYh{}Z/m ܾ6RR߉O Qv]W8 endstream endobj 465 0 obj << /Length 314 /Filter /FlateDecode >> stream xڍQKO0W̱M֛F1@M`nzg(N;߼Qd"W *h(_Ag^: w AY#WBBX߈ZEbrl d]7d<OaǡX4x.v=:+Spq4_y4( x ֤2u^:a2\fG]aqy8-~{JiYq;`!p$M-?ך<$jER}F1kzRFxN⭪6rh%n2:~\+/ endstream endobj 456 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (./deSolve-figdde.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 468 0 R /BBox [0 0 576 288] /Resources << /ProcSet [ /PDF /Text ] /Font << /F2 469 0 R/F3 470 0 R>> /ExtGState << >>/ColorSpace << /sRGB 471 0 R >>>> /Length 31229 /Filter /FlateDecode >> stream xMHr_,gb~Gl%l ʒn9'AU[궺>.~`0?"#/}_Uÿ_]uP~5_PP|Uʵ~ׯ=-lWgB+~efi2ZR3d ەqdf11#13+aH{Fz6O#-{+agɓ=aflflflflfX6ҲӌOgR282zZf#G6rd3f6rf3V6re3V6ҲlJƙ\GFOX{FKZlF#9љș' ʓ•Pp$'='-%l5Jس=9#939+lg#'=&=a-aWf3'ʉ#9#93+i Fz6ó~'%,-JXkƙh2ȑșȕ\ FZ6óH{*ZR3d ەqdf11#13]ȕle#-H?ٓcEɱrbS91yr\ {6g#G6cd#g6cf#W6ce#W6òlf R2΄82zɹ"bAqd#G6cf#g6ce#W6ce#-aHf$O<TvP$<㍕hhhhhle#-H?Ͱ^ڞʉ)= =am-aWžȑȑ͘șXȕZ6ҲL GFO<;("&OɓrbG6rd3F6rf3f6re3V6Ҳlg#];(Z2棵f\ [8+Șȑ͘șXȕͰle3<ٌɒ7Z3qJx7n ƍ#c6ݘȑlFlFZ6Ҳl)=YSɓ57>7zžȑș͘ȕXHG-iHF+n\ ٍ4 GFO(O -<)\ Ia6Cf3V6re3V6ҲlF>ELX#aGk [h {͘ȑٌٌTށp%'=) Ia kh [͸lFF|td#g6rf#'jƕK GFOXzFKX[ƕՌٌ^2f3F6rd3F6rf3f6re3V6Ҳ|O#{dO=)W3StLxfn#939+gP3(\=}ngPtJxE7΄-=AэG{'-%5JJƙЮ#c6ó~1'0ғgBzrHȠhc 9o#13ȕdPɍ='dP\ 6 6΄82z3f3z˘ȑ͘șXȕXHfX6ҳ~iۓ8ʓ‘PtISP19Jƙp^GFO<>BFZ6ó~ 63z2ZV3=gIH8='\-%q%lFJb|f-/ ^όQ܏*xd>{3lτG1|&g:_[Z_2♹_/>b`<-l/^W}1dEOGfODNye7YL{3+lOm^QmSm&f;mn^nns_L{df<^Ǖy˿gfw,n/~/{ZxmŞ[3 ^8XF2z1b<_mV(<+3.'p1md[fJf<2ӿ{f[xᙙŞYl/`̌kyܮp͖99y=åxf׋?ˮwmnŖYy*^)<ʕm9><^왕zbKI36 dpgnG%23q| S+-)^+5kxmGro/>s=^ {E߇aϨda333]lO xb_/y#3^{23^.^K<33^E<23^{ǫ3ӿ-30읝L><3ӿsC}Lgfm o[c4>n [fb3;KVxb_eMlNb9Yv!ߣ8̷GsbyyT'?K{gy 2+?[|u⵭?dݲ(On ƣ[bs]-CxOp=($3CO&zB2D}׊cl[xg>m ?n>vkJ7ެ߶s:׶%8>SUSֶ GOڥ3{?׏Z87qLF9ؖAF|n}E|n}E|| 뉥73;CU2df{~`Fu^795sLWQcriM=ojtL=o릞7U:&ǏzѨ1~hM=*uLʿX4ju ::srV^P`xѨ15JvDXFvj?Dl;]aƓFxf؃Q#^!?w ?|z|Pdnh|`X(q=l8x^/SC>_ﭽ2{}qr\?KQc˿G_Gu__ o=^;=KFE\>kCߡw|LC?ǓZ+##3k(l(u>׺Z_:kC1z(6u=ז3t5=y_kc[kgOп[A|v{$@t~::㵥1^[:5Oxs*0Ɨ_Ewu}UwR׶ .V~m3C"{_ a{ $  AMxzzLct~kOZ׺x M׊gv|kpM2d#>T%:uC.ɐ?XIz]W6Ig|)Nҙ?T'霟:I:N}LZ{ F Zc)R4P1)i;uJB%Ny|eTI{sL^W^+jOUo TUߝ%UxS~몞7eK?*%UugtIa<ة]R/)^R^(_R>/)GVT0)%L j?Ƈ*&PI|BIK%Wɰzxe| }^wcaUM?uMuE&Egʿ|>6)Wk:`/Ǘ)rIQIzSr=)rRꔶ)s N;~ imf{;?uMr'M^XOe@/j7_/zq>Ջƀ^Jv^W^KZjaKL F>o@/0Z|=Pxf@/jKR!{l/K/RjaK6Srﰗz)UQ_QzqK~U>k@/^j֯Ǔ@s9t@//u8~ `[w^2bڙ?K~|^ O]fǮa]P]c^JLxpP/qKi/rts3*8Gz)A{RoJhW~ǹqș,R8Jq3"t1B&ŵ+zD'#fgמ5:\BHqUGT|C`bD}Ε!]/s%U]q ~M#CP]7E#7 FȢxU/rWu. Gӕ2«\(P~Zy2W:k7B K#nW,8B ŋ(y- 3`Kn3/~1 6c(_*h3zʈ=rˈ}~b9ķ%q #9E/͌eUFT3a/}S+]hd3F6r 0=ۇ'|'EO.Y~<a}1A>;>!lOS1hW boc*v%F #M&^nUMr#Mn&^5{" aWp7MsdcR~a}Wuл̈Jm^]˓un6cXU>20jj#L\/F(sc8ZP1qXE4p?1|GpT0} &( W뒝(v]/D &iR) &ڤIctRL*tX&LQfb؛~q82 ]7ˑ"}PP.o!:nƈsB/L(l  &E  لI=`R {ڄIUpB/2oVe&Lj@5`RjB*P0zdB#  M+ V32wFu jLvLTP'mZaOTк  DWg(5QAh'LvXMTкvM(t &];B&LdBdh9`2shџEH;ClBd &lL( 8`2" gemBd6'*hS OTfgvBd*:QAC &S;P'*hs>3^S;zqᛧ~gV<99N(LeT'*hS;&LT{T4>`2O(Le'L'Lf6y}ÿ+  ƄT4`|w o؝‹lh;#3vP5QAC╌e;ջ#*hjI׎ Z7&*hM ld%8C)P0{H7ǓVeU8xA*\3d'cda:Hf{$d=#d}E*޴*1O[yn8LfԕL$v=71޴)u:4f|8 =3]ؠc; YsplW5feZx9єniGՌW_`#O.gc] -g2mFui/MCd~[]rEQ3{)-DHqb(Ƨ3a 38]IBOX{FKZƕ׌+1侅ye 'O<لpӓ&#=@`]$r|+>I<mc]$BRsEf7 .v8eX(6Պn+qźӔYq-&kJ'H{@ #lG],b[H"+ Tm+OSfE9ƴD^!*bړ"1eVHrEm*BO3@BOh e XoŀiqĊJ)BHĴOfETZ1b+\؝dW$L;VTLq)Z\QȊ:6>LMzFWʹ{t>L1Ubic ɚY,=\À>`L\1KooO6+MCVXW yS{E:sm+Uȅ5 SV܋ + U}+iSeŝvMP 1m\Q2W ˊiG ӆ*> }S9hE: u3.W1[ b@qE\.3[dKȖiVx̾bڣB+ ^ȭPwVq\QA&V eשR:Hy әd׈JEՙl2rF#CԿ|U5w]3]Y.&ýU@z[<[l[dl.'Wp4k5Ƃ Hُ * 1V[P)kT@nP/z ~AdWTؿP7ΡT * k+g35u~¿BkQdECb;Y =~Cn/U|\* * 4WNyAb] Ӯ4;Z5ڿTs^PSH%#]XqQ=ߡյK&n'#Ƿdjbyb .^1?`dtj^E" u]cK*uۥ쉷{QOl܌ Cd+U SqЕd?#\cئd,j6eF+$VBsYgdm*lɪ}*LfV*ہ#ED;=բeEEw=F{bu= XZ|,ҳPXzb@$FR^78[zbL]FZ [{fTXdaeBHVUKuz0@M*Ub2ɪH<lL`ddFX k>dՃ0""Y%DɪgB$le#-H?Ƒ\{FOX[FKjƕg3@-6O2 gZa$:[$g>ߢ'谐H9Tw9tѓ]fxfL]F“CFr*FOb"3ѓ S9f$2f$K*KR-b1 0 Si\:D-Eg'l^fxt*E%sM60^vj]wZUf ]P>H 欅"BP<#u]YZ(܎i`ixi`i`ixs{102xhe^(za{d 3L7HׅV).[)Уtf2:>.;N]5){ScQc˞UXGݩ`8F`2Fo loKvy(5TsH] ʎ2`;|ڍ吺SŔԵCbI!u*#6қ %)Br_H]Xaᐺ0I'8.LR CP9}.aW1R.mjɝ;ꖢ(JKW=."ƥ}:rRgEߏE}Y"Α[E;']׮iT軦Q!飚FuqFOQ!_F:vT|LKJU|.cxuwMb˰]jfN50rBE ت4~OF{va\ +;cn!'WQw".QPӥhE75Q&=4<"Ƶ1E8QЩf1.]U!`U,v0YE70- "ƥ(b!"慂SccWԝh6#zJAݩyH[S(;QENmĻFX%^u' xW},* `̦Fco~b(Qp3~B޸gBޘ-P7~wBp(bB)*1sJVaKd{eQ@{.|'(b\E JhIxALJd&}/UfX/QBhG-5؞K|?;95Po(b\µ6*U^J.[;J_xĥP~]Jxĥ](hoń 1|GH^.} 0_}w8ڃEJQ1`s -!C/vhjƸl轳e8T&Lutx[֡2}1ߎ(bp5"ԩo\ bgվ#k{WV=*F),Jj!6Uێ{xP[>@$89U&ʄ~dԩ :UXLб "Yuy䁊T&.t&T&֞ɷ&i9LK>K;7ړ"RxB.Jds| pzijƙKƣ>=',-%5JJƙg3z6g3F6r39+lg#|^+> I ]^ Ȥ} |riCм( >C]ԛ'?,wd_%?>7|j|}AZh?5 ^uɿP*gK 5 5"lw,jRm(&K&Vf◔!ho ovͻJl- BljsGNQ3JТ`>;CW An9?!<`Ħnq͗*-!BFkRrH֛oG4wXpmikRnY_Xra_-jRCHbQc2vxDMs`鎥:r<Zڟ[, bA|Iogb6qqIU|y :>QhbQ$ 5 XTUMŔ] jRUػoUuEbP*SрW$>hl|~Ϛ-4$b?*Q!v4?@Unbg5iAxR6e~$x=`ya~'ޣ0熯M~D2b\ƿ ;M^Lzj1A|)2!=(b(bYUd39چʄĦ{L6C0=aqZdٌ=jE S,U&XGDQ*ޯT&~dɪ&&ƑQkR7:|$Vn\GbIeB>6LT],)&usMKxMu=ak-aGG8Βq$\WƞQг~ٯS0*p&<GFOX{FKxHof3lFlFu~Q7QC0F"F/Y+'"f=Q gT%Uz'x1z9n=%\-JhGﺓK㕭^Ux)zUOȺFKX"F [8ѫ*xqe<ʓ2E^U۸Q蕞GWzA?wNQ;mGQCHNj7zA{&II0JOvzDoی#ͨ[c.(bbK[z'1.K"F!r*BL􍈩 INCfCץ` u1O]hFWiBM tfTΌ|Tԙ%!냞»EXAO" "“TiitoSC|B{j}P0B#-1~L=RQU?FxYeKvA"#~<eR0 K>g(b3QHo-O!I-$;zTB'?CTcFqȝ Qә!e>CjEc 5ua1Lgƶ&UE 6E1U(oVbu'mVӔ';Qש uo!Ue |9Jg3e;5E}+MZQg(bL筰yLШ=lh }@ۓCO!vT Q}@4m@V4׍wOُRҾ;&o0c .1[#|ҩO߈>iGcfc\ |QBzG]d0$&3[S$/$$Ј"ƥ3[. z~=Q(GLs@b(ҪٯchQ[/9٢#5 LVx5.hE #7whyϿ~^_/1` (V[Wà#}6yxGqs\iζ9͛/#7O~_% xƻE=v'8ox9[~h_}?n#=3 qa߃>z;ӡtxoQǁq|to!4WO?/uqD'oknzk￶_ױ~:/i4 P?qh{ _~`5k+B#׿o|_A;^Lj}o4|O_ɨoɑbӯ_;w;8Oww_0;GO_{?^^_;;qTy/㏌?2\qKwظnrSyO\^g3a=Q~\'sa?q1 y(l?o;fw׿9K//xWr~!_˸/d~!!_ǹ__)~\yl?׏\ǬW՟~>S~r׿/ߚyɿO~&szOq1Oxpy1H|^O{Omۋao+3׋aO}/xx_l/^/////~_g쩯뗗?Gyi/~]|ʕۋ׋Gn?Wq{q}qg2B>,?s/Kǣy}ϖGw5>>ixk8?3Msmڋa?󗖙5|k^5}{~+y_m]d|ef0x{f_t?Eߢx`3|~E}3~a;g{sjeeNVnvעtMx{?\/%^Xa~7i,Z,٧Q>I(${?/=_9Tb]_+s{_e?[n5?vW=?ߺx'Su~x\vn^ݟp?e?kow~Xot=ɵǧ =Twד_ ^`]k|x9_ ].~ϯaߞW<`9L w~ۙ7w{Yq/͚y;wosfnX3{17z_<^ =zq1//~]o7_ףw=}nCZ|)qy<\i(hz_Zod>-g 7y?OuywLuQ*c<<̿]:Og?|Z̟둢s!٧|K23W3))^^~y~{g|?sjٿ(~F~=s=~?iߗ}N`| {3ifo&_ww{[{9^|a=VobU|څ;Vx\?HWw;p_jw|m;^?v|qOg(G>^zww+ƿ w]/S'|?c+G|2GO|X'^Vf'W.5s^i_`?ȲWEl7h_|^ kQ<ԟƷaaRhXװ~vm_??4'Kb@f1~s<0S=.{&َiQ}km_Oo!%u2\?Q~lO̡ǟx;ۛS>d(6kfᒙ|붇Qﯔ||~{x>g=^땡 'OC[uG}\]a}m? 6w>g"2Mˆx xhd/5>:U=~~U*{q7&U왟 /I߼x'8aώ?x|y~SuE=:>^u.iB#'y~K돕a>/Ƈ `\o"?͓ϳLK둁mi=20^l@##dZo 'AS?/8z#cczxu\ㅎkqS/2ߣq=?wC~߆`gxx̚]8+o5`>>34{i3ɚߊx\|^}Ec=z+3W_axk_\O1/\p=վw#xuwS<?ɶ{j\OG|G:z\_Q u~Z?akԱ'W6'oMdSW4/x$x/gS>``4c0L?LߺD5^.]cxʟ,<./]C{O,?'η󷎿wͷ^^Cc24sP}!_3jg?+οzd<?#nM1~zyx}~D9xz8_~F.dɎ=ڛrx_' ?qCkp0wgʯ}Uϓ{nn̯ۑḃzǏĬ_o=#}u玟w=~cL2Uzj?;_9'yzm"b}6F{*S/GS\.{֧c}_?-% #^n> 񛣾[Ԋ0ƋQj/gzs7r*p+cUgooGQ`ޢ,ߑ^ovk1?O,op/pwp}ǫNϐo'7#G{|ߍ\c )7c}8L(Ta#X_.ؿ'(_DCbL;|GqWu{"c`<8 b~t1~:9^:;?X|gzzJK)^糑~س4]:@~Wab2VG<߫>zJf}rxCS{Y6]'^T{^M;v>/OoXNя, ?Wgਈ]ן.nX?p|i^iC|i)75ֻ[05ԟ`?KR>s1Vgq?29s{ao{~ y`nד?+_gZģ𝿽*ң=%;zOt?a/bs_҃w=~6OE!ҽJՂw=^O9sWzMM,Ds vG|O/䛜 z4NsLF=.3gw2W^r7 'b<ˬqX#7yuVX[cEN=h17cƝH]Wa۰?z~\W#uQ03=~ʿX_3;?w8x_N,oz|/vX/ܟ3?40bͨg>ۘihu'Oqџ8^˟O23OyNS 4ω7_oȏ>agy Qhϟ<*s=w?{>? X|% {W>ki>׃Cxoc-nݞM/>k?zeSxq}u{j܏wϻ=K}.g7#ǃ{nWc+^{/u}~Ư}x*TPO99>}:~ {~aXW~_g_{׻1Q G3lŧwk w{wvɧ?nR \/mLρ81q@}}~[ /z1__D |1/6hb?iMￌhKp|1>>~O7 KC6SNurWxw82#Xw|?s~>?}}]yYdOz_y C;Wc3{} =^r~ޢ߯zzB^]{~+{_s?n_Sx==XO/;u>.1gx?3#;OQKk!Vm ݀W(r/ 37'KE6n6EY9w/ >|>[<?:DEwAcnm}?p1|GG}H񈾔3^Xu? MUBmK؎xIGvV}6kl3fxAԠބ:2#yC>3S<_(dk m|?&Qx|_i<̟R>_%CW|!h}|iF|#:/x)?x+yN/Ducj/E|y"7xE|g%soE*j%}}(׷IЌ\YXe`}fF<|/E|.~&][g7K̾Be)in͓Y?SZA|m+ ЕN?&cY髬T㇈g#%Kv#ҥ`('œ,/Bφ4!yx ?K9m꩝|ks K*Z_>[<^J'dxJbׇ֟WRg@r-+3xu78-J$7'd޾\2Vo+۸%3~l5~BXPx>/ Tdoz KG-ףy}m?/X 转w|7{DW_{j{aߣ=/_ v}⿇O!go={6|=o^^\E/#^|=k}&W76z\vkCƇsb>d 7qwx|skmyFd ޯ/AyToz *緽@/Q&@WCG2z<[XbzF<79͢Wi| P[ӥckYjoNpVaVV#5{?MBs No2&T<`ҁ"PaT /-y}ȋ~~խ]dߞ/Uo~]OT6xh}%צR7y[uXKm%hd3ڼ^=?HN=NN?uͼNݿt_To}D{u|`?ov~k;u^1o}zt'3t}^})kq; #qH,ٝ)e9\>XQЗ&פoK)8M'(ڟ>Pݧmf:}fǡOVp5IVpꎃ0YIy2 %8Nu"0ϴO&ƃ y6j)9){N2S WEgwjUx"3o6~c>gź` .}̕711tS\&}QLqmʼl@Wp!NT1NvWjpMP*/cP#zs oRQi \+/9lϳV^D5ԑ5 S"! /8OA#/=KG^e8=ܦH'U-O̼gu |.t.'Z:ʼn>yb{n, ||u ڹO=m!ݹK1*u庎{8 uF\8Kut΍ ~Ͻ@qu^ވS#o5;4]Goqm7灔ԕw=q>L8uک<읝0}I,iywGdو38?{\o8"q~pHʋ6?IӹAW}a^~3$5;'Pͯs yvO6hqݝ{|F pLvpY8,ofs?x.<.P6y;ӯ\gm2O_Ҟȁ~=y<=38\"!z}8= |j W| /R/kP] W;gĦN8sYr78nBK'GWYm0CU toi~\u*.n_Ln>V=×=1Ÿ3{ N(m}{eo-lN Z^bl٠4 }:I1ά6\,w{S+)މDWÛ's4M\Uk6%["3`7yt'v^v _r@ՍE.hÿƮWφ ;-KHJZmXI 9Sx9Z gJp @ZDȰg"L% a*N_gd/R ,A<@-[f`e`Ԛ&Dǀk=Cp>HHBZ8-E` OsEu$PaPpݵptrx\?`t$`":x"a{tDPp@ ̒%4,+ABq G` '=T@`Gn zw9qLPr"0MOjJ^j ؟f>ANzh?_;@GvP v6 <믾8y |)_jnr~ h`' vh`G zYӁ^<@;4` C?G'!zP`GvpH$S`;ܮgvVz̧q}CD`Gs4lJpHP6C !8/TD LhA;'Yǧ & $" jK'n`i8xFOC#!Zީ7':T$@K4Y4Q{t ͈D<JK g m&2ѐb8h>$ڮ i(' v8 0 N [S[rS[p"s#г(Q%4FC$C_yyM~/1S0Ȣ ! `GP ' tFb3 vj V&p:9`C *a`Sed/fLzډlH ?!!2Kd^dCpSa,1M۾ða@ \h z BL񭃝 e8h 6 XmƷ"8[,* Bôs`$efᚵ 0IT d!{Ge`*42Sr(gRn߬΋:o# E4dx$e mL4*Ѱ2aVe3Xڙ+#)yNhEvKDE뉅{U NU`+bwr x*k$)t8vkr½ 8Up:uI)t&d`DyN3PGcS]ZH"mD`m#+00 bSw,, |U^y{;y1r̳pgep*p@e"Fgx +eعg ' Nv"G <_; G GME?;v>Sk; RK x#N<*ty\3Tz6`ǻχ w;x~;p{p;T|~Ϝ$ NEK KvrSŋ `+fc[ 7b}C5V>ڟp8$J@OBGgP6+58Ad:юq^C8k~+{y9u85l?k7V= ΰvרؑ+߅ڢbP;9s䪒.'uޜ+%`=>HSjY CߗJp^r|@Uw^boS)CȪPz\Ti|3lO:c"êE)rǓ #;1c^Nǫy TXJT]0q5YS.[r^`krKy ՒB報|B tGeVT>$V%SVrce]l8#?s^ϝܹfyk^;Z_ϝzfanZm=5dA3{A UVSxALk'^D)>2y, tX\N[FVw TH@YsLw^ZڐgAz'_ASA$ 񉎵҆AWyp^8!8l W%M1ߎ>1?B l;[?X= 9l;_5v*p ,8|dYq'?睘na}@*ޑB$g2~S ~Xyo)^ }Az(R t;iNCJr[ 絩}zݶ@[,M*7yXZ: 4 /TWP5~?OB=[Fw^B6 oi:Ś(+ )tTdsyTeq$j=p@>] I6b1:I!xݩ Hh/Pl{5ga\zWՠ*ԽDE#@4OܞS8or<ź!+s$lɸ!H*J@tc.&jyPUPqU :*l79$5Vu%xv絢y; J1oF&cq}C7μTCiؑ04b]k^$yM89i])5v_7G›s^S\d켆zy-}a5rv^#Ko\C?;u>Ssso\ڿtTS_jh絯ס:|, re5{BNppu( C\E 9\G !g4>ߩU:i~yZ̚=p^fŚ퓜G8O798 +. T8Pg[h# q$Y8ZQ@t*x[$qN˔XoYuaE뮶*ZKÊS9V^8<>-Cn$a^ *M9?Sq yNldp0pRK>y - ]Np2GiuXQ%*tYQg۰Ζۀ 'k:T8u xX`)/3AC40_zB)p2%bEv98/> 2\I^q8,·;s^rK ׳ts*κ x~&GJS&W0Qj¬c& 27HO{s}&?ϟdaO!knd ͷO=ngs@Qg۷-c;g]?y>hs}Bq}h޶/8l|>=?ozOSvYj]l3 ?_=}7}+Ͼ#v6ujg1;>;ykv^S]{Y4 hMP4 1l! ɜY/nWq۝vq%!=2:^~^{2q h5KYi<<:`;OOOʜb7Ǒ| ?VX endstream endobj 473 0 obj << /Alternate /DeviceRGB /N 3 /Length 2596 /Filter /FlateDecode >> stream xwTSϽ7PkhRH H.*1 J"6DTpDQ2(C"QDqpId߼y͛~kg}ֺLX Xňg` lpBF|،l *?Y"1P\8=W%Oɘ4M0J"Y2Vs,[|e92<se'9`2&ctI@o|N6(.sSdl-c(2-yH_/XZ.$&\SM07#1ؙYrfYym";8980m-m(]v^DW~ emi]P`/u}q|^R,g+\Kk)/C_|Rax8t1C^7nfzDp 柇u$/ED˦L L[B@ٹЖX!@~(* {d+} G͋љς}WL$cGD2QZ4 E@@A(q`1D `'u46ptc48.`R0) @Rt CXCP%CBH@Rf[(t CQhz#0 Zl`O828.p|O×X ?:0FBx$ !i@ڐH[EE1PL ⢖V6QP>U(j MFkt,:.FW8c1L&ӎ9ƌaX: rbl1 {{{;}#tp8_\8"Ey.,X%%Gщ1-9ҀKl.oo/O$&'=JvMޞxǥ{=Vs\x ‰N柜>ucKz=s/ol|ϝ?y ^d]ps~:;/;]7|WpQoH!ɻVsnYs}ҽ~4] =>=:`;cܱ'?e~!ańD#G&}'/?^xI֓?+\wx20;5\ӯ_etWf^Qs-mw3+?~O~ endstream endobj 479 0 obj << /Length 2337 /Filter /FlateDecode >> stream xڭkopE*h}h s~Hg%pZe9FǾĕ;gLVd_W7"$ZLJLʼ4̗OQLL\RYP ȇf1ei^Dͪ=9qQi9Q{u|2jC2$Y]Q>gj:K4;abf 2iZ$ C;i~o'8^^v=-!mx+Yk?U2Ͳ4+$RjqUV,Oճ8̉ѭ}ߢ,gw\oilhB ŬdpYns^ K`hW^-Xʢ5l?x]VF]K5Ȫ=UU\VKÓ)-) fkX~jw5' 0xZ3>-g= hp9`URJ|)B.Mhl/|K)<` Vsi@#+fP.s\#;|5E|nB~mmteW]u129uzF}'ƀ|0Fm'"ЁzyPTZ>1{$%bvndߓ|^ f%zN0N@x 3smζ,VA{״P_*&ф9VW06}b5+I~P+LBAvB>=ǽ4sD0#HRRlьL HIhk\}!soFE|w[θ/'H4n3hPJ <#aPf%qD"Y")$O fY 9Z(zHU;)l2ʐ޵q7?vQB'{t4c0 AY޹_q)A*[g?\S0"U ޠ*EǓ+U|P_;&+˰:q!׮tOg0FI0I 2:XfcjZp[MJ=y%ǁ>Ax]@y ^q^aksؗ YUf4|W"3+"l.,u"b:ıw#ϯ~J1 endstream endobj 486 0 obj << /Length 1537 /Filter /FlateDecode >> stream xڽXYoF~ׯ R*{۴H$=P n YB+q_߹\J^A r;;373*ׅٛΌVLvzq Y U^d? M>Ycv9p9"7(ScnkOv0gH)~8,Ŋ辵KQO|k:9 N29Π@z:$DLUegI$CZdy}(2Gr F &Xe˼5pujQG޻%^̙6&1 ڴf|*xjMx?e^_=*@eW1l|"?3 dqzFӍV%Ou  ͆<o).x|Ύ#f.hz BH+fD- Zm#˾ hg49igqWθR1 YJ؆XԀF $-NlWp" (|~2^ _o:h+%Zu/0Nq}]LzBЈHj^[تWqB{8[pt$BSd&3$^z0 po7Qv/D(C1=c@6l]IJK1YCku ĸ2N)ֈ Rc 2,8݆ǝBd:FmcLfS2+K=C`1St2\$lvFAG"DhJg11P=rN?V-G( V|JK/T>gNv"C*)IiӳXTDg-Fȭ(Xg40ZOK*򎤟Ǫ= 3ͬKeFpeHJmEVh.$2AH"Ϩ1t+]k5+2Nkd(:δ6~ФޙQ`mŴu;+Rkf o|QvZȖ34u+[8-Vt7WG*&yO´” E\cJb4Ux+ʼ1c;tNؙ(ioߔ^?K~9aq‘QG4k\Jy纕~p|`?95Łk[_?Kf;Eo/7PZ iqawrЧ /J(+rŘE?쭣paϥcι;cdڪsUS2 wIo~/Er!GZ\?C̶&瘋Ňd48DjAur4%> /ExtGState << >>/ColorSpace << /sRGB 495 0 R >>>> /Length 2046 /Filter /FlateDecode >> stream xKo\7+!Y|n  ‰ A}X*^A鸃,ҧ"l^tt/\t]>d 'ߒKc;}龺9BpWſz ϩEA7pj݇z fP8RsL|L.Vlc%Ø<|8cu)f?{LDH}/?$b(>ry?7l_O٥|@_ኦaiߋy*G>DK8꬏+ׁOW)F*$FeƉrR>ə Dc\Y@ K s]տy ϩop?;RfڟnUvNΑw(/<"m$.Lu tHθ_av|l? OOIȪ1ϷZe> Zgz"uV"[] imlJ:wzwV.'ʋ狻'&_/kPvDxZm)q5S ' 'p Cݽ{ڡ^r޼}Ϋ+wN? >Z Z>~x.X8$i66e/!r!I %χ?R4'~d9~0Y Eg Yf5T~ Xxb/PeY0v~g-~R-E:Ue?s1Rf/sK"Oe?}~s`o{G\7[eY/9M.or짟O9\sϘgu~Ɯ6Ϙ3([gt6(ΞU$%cqf]!ažmS=0Qa5M1Iuyb(XO,ULLxӒVYJє*$H,"YBژUԏ6fhc8ţQdN(pn lY5S4ET" Fb8jQdN(T R3BYtV2}I6x4>k_˦[ fE}SM',VpfEeTOi"}YN#͊BeMbEe"͊ۦ bX߭͊7xˊXqެmVD\6+R+Ċ.V,VŊيŊ/+2f+R+2f+R+R+2f+R+R+2f+R+R+2f+R+2f+ZJa"j>˥+1*n߭hUZ;"\MSzʫnEk۬Cޭowzi֬ozXQ?kEhEhEhEM޲͊{嗛ъ gVG+ъhEp"8ZhofEp-)ъhVG+ъhE0ZyniNoo@}Kj(c(Gy>R<*'%BJQG_QQxKSY;Sȩ3W:uQ⫬o\72 :dOF@ C wo~|x4*<]>DOk5 ӟ endstream endobj 497 0 obj << /Alternate /DeviceRGB /N 3 /Length 2596 /Filter /FlateDecode >> stream xwTSϽ7PkhRH H.*1 J"6DTpDQ2(C"QDqpId߼y͛~kg}ֺLX Xňg` lpBF|،l *?Y"1P\8=W%Oɘ4M0J"Y2Vs,[|e92<se'9`2&ctI@o|N6(.sSdl-c(2-yH_/XZ.$&\SM07#1ؙYrfYym";8980m-m(]v^DW~ emi]P`/u}q|^R,g+\Kk)/C_|Rax8t1C^7nfzDp 柇u$/ED˦L L[B@ٹЖX!@~(* {d+} G͋љς}WL$cGD2QZ4 E@@A(q`1D `'u46ptc48.`R0) @Rt CXCP%CBH@Rf[(t CQhz#0 Zl`O828.p|O×X ?:0FBx$ !i@ڐH[EE1PL ⢖V6QP>U(j MFkt,:.FW8c1L&ӎ9ƌaX: rbl1 {{{;}#tp8_\8"Ey.,X%%Gщ1-9ҀKl.oo/O$&'=JvMޞxǥ{=Vs\x ‰N柜>ucKz=s/ol|ϝ?y ^d]ps~:;/;]7|WpQoH!ɻVsnYs}ҽ~4] =>=:`;cܱ'?e~!ańD#G&}'/?^xI֓?+\wx20;5\ӯ_etWf^Qs-mw3+?~O~ endstream endobj 501 0 obj << /Length 1496 /Filter /FlateDecode >> stream xXKs6Wh|:'>&uNzihC-Ѳ舒. uK&C.X8_)7VRTR͸T2n<[̌=1U5 HOt.&.eyDU"U`ZLT|?-) 8JO)4-zp{ Yv#mD`oH3ޗafq$%8Qr @3H@UU _A%91}i=gw`$I<(rbIP ElT%ܛd!|o} H`p2Bφ;O=>U+9!EߐQ,+"7l?ʙ'Dsdf.re.Ka!tSeՓ_9@ ^Jr+A#V-#5~q+mi($f Tm=aά dh8ZvlxE bŐ6A](wgL zWzx oG(0 WD=tYϞ5a-;c m9YošR+yY?G8l3L(񌖓h$zW֎4Y4J; .vU]L ype뎽OrC ؇ZEC7[˰$-_o7Md 0Q=LT&*{_?Ur(~tiAփZpRťyvvH#uA4n<RNmn~f: !]TYQjki ]{P"il *y2φ<5CqFԛl`ة \* d+H' m-DK+Zop95W sNb80q&8cB)za j3+!]`:ڝwC49jS2eH֬ǨD)rt^H7XIO 7-=%l=ê+ EeuޒUhL1`K߰7ǤMZ7]bݕ['L{jhp8Mh cӢHǃ_u45DC]pwt*?|4w m4 Ω> /ExtGState << >>/ColorSpace << /sRGB 508 0 R >>>> /Length 2949 /Filter /FlateDecode >> stream xKWP S& p$xE _[!>{{<9]OՏ]knwOo:PR2kk~~c{ㇿ훗67uﷰ-bз>)n?FܫePG&P 5س :IQ@ǜul8{$sνC܇6bc@l coڊF`K%=r\략u{S1=j+{ʞ9^7Wi샭qBc7rF7W`羹Cܷ=r- #rR! }r}.sֈ"8y 7bڪ=m>[@qK{Vn>+0o:d=E)و&?~yo^ֹZ*/oc/'IQ9)}gb4>#&Fxhb4̱hbшj411Mbb4%M]`]bAuXbӬY#"&F0<&Fq&Fpx E41iִ`fL3MtMr&F#YTTkb4kL21x.3,vx,1i41ԴI#%F&F%Fr&F1 41v%Fr+KN#%F3Z&FRgMfx#Y41]aڂr9L[d EH \Y.b5GrfI㾘6˒.0q^LIb,Prf㾘6 .n˃ŴYt&Kb,[rf/9.iXLELb,drf!㴘6 ŴYtLbڎⱘ3d:9- Nis!2?BG2=B&ϏˆL!2m?aK(GRAmiCVͱiC:3ِ 9mHufCL͆dfCR}aCi͆{h6*lH=c f̆4u? iNlH׷ ^lȰfC&Rӆ̠lhUA 5\] ͖jCP6E>WEE7HrլHL^'u(Ǡn$9;4?|Ԑ`L {Ifԓr>Mз7\-!]}%2o̗\qYK9?}}yΟbIJ|rg~eV'|¯9,1ǽxx8}/~칎wa#n_w((qQcRo߿;I3;/ 9"~{Ho{1=8@"hL endstream endobj 510 0 obj << /Alternate /DeviceRGB /N 3 /Length 2596 /Filter /FlateDecode >> stream xwTSϽ7PkhRH H.*1 J"6DTpDQ2(C"QDqpId߼y͛~kg}ֺLX Xňg` lpBF|،l *?Y"1P\8=W%Oɘ4M0J"Y2Vs,[|e92<se'9`2&ctI@o|N6(.sSdl-c(2-yH_/XZ.$&\SM07#1ؙYrfYym";8980m-m(]v^DW~ emi]P`/u}q|^R,g+\Kk)/C_|Rax8t1C^7nfzDp 柇u$/ED˦L L[B@ٹЖX!@~(* {d+} G͋љς}WL$cGD2QZ4 E@@A(q`1D `'u46ptc48.`R0) @Rt CXCP%CBH@Rf[(t CQhz#0 Zl`O828.p|O×X ?:0FBx$ !i@ڐH[EE1PL ⢖V6QP>U(j MFkt,:.FW8c1L&ӎ9ƌaX: rbl1 {{{;}#tp8_\8"Ey.,X%%Gщ1-9ҀKl.oo/O$&'=JvMޞxǥ{=Vs\x ‰N柜>ucKz=s/ol|ϝ?y ^d]ps~:;/;]7|WpQoH!ɻVsnYs}ҽ~4] =>=:`;cܱ'?e~!ańD#G&}'/?^xI֓?+\wx20;5\ӯ_etWf^Qs-mw3+?~O~ endstream endobj 514 0 obj << /Length 1754 /Filter /FlateDecode >> stream x]o6=ȓY%YR ֡ݺ=}Pl%6f˞$~xǣDJ =H}tJGtŷWotҤH 6ݍX6MS\I!h}~zoq,>v<SFXl 1Z/y:JBk=ѣ.R<~e͵#P"SD$RQ,T22TI{5lVp-J@߁ۍY)kѦ\k<̄3 Eb.15<NJ -*n՘o06C`]eFfsR6 `sbK2$2KKktWfumD:=\ 񊎡4!M}h:H,<}$'2K_c.4}%a(I2F/C'LcӮ"rX`N% D}s/aai*!_>:p9m-h9sUщj1J˔ >:E𩙶pG)] g Bm˚v bXBW{t`ET6 xʽ=i8VYT0g&F2HvM!o54wtr1>]6' Cmm497젻ΈȊ$*k:j :"9lڢbY:f2=V NT[t$|61t fܱ_3ӕaW̭7&0dJ^:P )zZh4  ֆU=SH ΀3m `Y]$ (?Lf\O~p n0IqP2ְ[(w^B 4?ؼqؐjuAI(\ g,wOͩtFj)I'gNir'4>69.qMY٘ݦ>>:ITQR\uDUV,dHvN!̔ȈMFYT{Bgy_|kKL|V=zM@=Z|sjc7x3:9ˎ؍Dž !cKԅ- VWVjZ"|)&}"G2ũX2ΚlHp?fH"CǾ SxDq#;RŖJr(IMU =$hDmc+GcERJe{+-dBݺ$tNmDȃ{] ݇s͉ㅅ`ݺ}+mHwO.;ge`Wg;9iMi|b~Va3iNS 0'n=ׄQbڒ0鞼scaf:8~";v~j?Lti-Wtaԍlg?{Xet]tx{sQh%`?iޚaD76Vs;`NmĽ)$Y%`k&\ (msO]47Mg'spPR s<)TIp<{@ !YQjРCf  64}`)bN¯6Lk7vx{g l^29+{@dꈬj":$bw4j ۟:Z8Ì1,L dqC+A:uI{c9cˆ˂?| %U!Y/4nv endstream endobj 518 0 obj << /Length 355 /Filter /FlateDecode >> stream xڍRMS0+rL$iSfY[8̒%-L6&sH( K&ayɞ5̝:G9:Zh?E򢮈]([i #Ux!6'a4uI[k)G1/0ǍP(6XId&|tؒTaBCf1V@7_Yk/3C?"&R> /ExtGState << >>/ColorSpace << /sRGB 524 0 R >>>> /Length 7826 /Filter /FlateDecode >> stream x]K%Q.aKefkaX `lO8'*3=tVުG8#=~?~88lt<h|7|_|x}Kztyl8|ɁlpR>tɆ9lpR}CgS1lmpG7} ~68>twbc}glΌa(GEm&m4$LxYF(}@apqw>>2ا!_ Op~űdwgNq}v`[ӱBrUg+sWllp'4~L&l0M6'qf{}|rpBi8㵁 g./+3|T&5;>sx&=힎:'@7ö8{ۋ1R9}< c8o4\}/f8lae ovr7m0͟000h˴v m nF|f1v­݈# nfm]^[;_j_6b?HIag;Z߻>h)vs|L[t$d Fݬ.I NILj%z[j}W{TT{`0 pp:ڃ'LuE:Qa֩϶0j8C$aKsPQC(jXp=Rc=`>/՞66LBLBW/LHΥm=۱0^6ԞG[R{\jі9x2:Y l]Y7cbe>VbeĜ}KgX zt@LbefCQE.X 0yX9+l[ `+bI 0cvbe8DyceEX9Ǯ+&kAYٰbdeôb1]a0Ym쬜%ʆ*beygeÌqaP ױ2aʆbe7V6<{cced12~6m#(V6L+xsT\<+1 [ V^O++z+碘X0G/V'+gI`1J2ia0Y0@M3cbeʆʼn᩷riʆϱrX9GSl92]XɪrH`be|^a/rVN_kX^8YX,?9WYjen L/ '+鋕del#Z /Үg+ <|?qVWrqud莛31%XO $( Uؐ~I@#PiYsOQB"3WϨ9%޸?_}OJJ0L;'_wu =𡏟kx٘xr5`Oתݣ3Nв *ZZKdhm '#n\!/čY!>-J KwC\ٞ |8 $wk];s!Edf݋v^ v// YO8\pXOs$'čxs`x(] Sgn|s>m9p#NW^_}< qs0t+d QBX腘Ϗ@_w|ssBsEX 33[|[؃8d%Pb',!b&v d֫cs\ؿ:>y>n?~ڳFLh=DO\x}s}_@f]f1{ w{s?, Dٙ-CN-P &՝.繘.ēscĴý~`eO1gfB^ezOf睝oz'w"6Q=p$d'HGR2^q+)Z[Wᾮ𺂦i]x]ͷZW?]6Z8_{~uթZͯNպT-vjαof&[ ;<]oSٮ ޮP"Iv]A_6xZWWm !>qЏΞ,w6wEuޓwE2nc+U $wi8{ _ٜ-{@gQZ3n5L$j~tkU%tkЭM"] j8M.n5L.݊ɮ[ s>[kFVҦ[n:hpua֪ xVaiӭUЭ[u+V5ҭҝԭ2* 0ut+tkЭ[Kn:0OIǴ֪,[k[ [ ]F{Z6 7݊8Xt+ptkAЭ8wW6Z [mڸ_[kjV֪$Pڥs[+Kҭ ,Z; [ s>[˦[kg\!tkU*tko)1k"}(߇w7 P7hblgw7&?8J47N5ߩ)N.6!6#i7/sG7hn$k0;3 /9V7;E7mqZa;G6_wΪb .Iw9GwIwQWw~ .*4FnnK> vEGKo() <6./EGK >'oeo7}7D]]t*;PqiwIZ? &/L{au?y _/^x^97S}$o5?oj|qm>EpE4y; D*;Cw~FgR?zOP34yqbϴV([p]3h8V7[0lu8׳v20p4iĠI>ĠA/ HmړF"z\D A&VS`]\Fm0cmTe;F}6F /GtEK$UccU;N}o_V TC< ̷/M$fcŮ Eu6V xƗ9ui>V7S[M+p89]I%)z:aeOqM^%`y~Joޜו9ԸɱC߱Ozm*-֩+t^+=@/!O?qʰyg֧W"دOZLUMgLo1TNm(4lF "k)aT+*Ɠ;ٴ\rϡJn~Z3݊G}P\1>j'6_W2Ti8Fٵ-8 h^·KO/-[{!e?BVGif [/O;( W$\UTǫUD}]i! =㋼jkctї"X >c!lC(q߭TOόժ43J^:?DU`W'jzI}dg#\gA" ~M: ^ta4^XM^Zb+spU0 *FƓ'v?( ^qDc_as_+{FE6-Tm~{ puZ?Fk,5_.rulvzyJMSϳ,/!=jm:A%/ll\\UqH JNT2EJF9Yu# y?$o׽<Mi{=b,{gG̴o QԦ2:7~]FKwvH菗<{OIҪQG_ݕz?2~ endstream endobj 526 0 obj << /Alternate /DeviceRGB /N 3 /Length 2596 /Filter /FlateDecode >> stream xwTSϽ7PkhRH H.*1 J"6DTpDQ2(C"QDqpId߼y͛~kg}ֺLX Xňg` lpBF|،l *?Y"1P\8=W%Oɘ4M0J"Y2Vs,[|e92<se'9`2&ctI@o|N6(.sSdl-c(2-yH_/XZ.$&\SM07#1ؙYrfYym";8980m-m(]v^DW~ emi]P`/u}q|^R,g+\Kk)/C_|Rax8t1C^7nfzDp 柇u$/ED˦L L[B@ٹЖX!@~(* {d+} G͋љς}WL$cGD2QZ4 E@@A(q`1D `'u46ptc48.`R0) @Rt CXCP%CBH@Rf[(t CQhz#0 Zl`O828.p|O×X ?:0FBx$ !i@ڐH[EE1PL ⢖V6QP>U(j MFkt,:.FW8c1L&ӎ9ƌaX: rbl1 {{{;}#tp8_\8"Ey.,X%%Gщ1-9ҀKl.oo/O$&'=JvMޞxǥ{=Vs\x ‰N柜>ucKz=s/ol|ϝ?y ^d]ps~:;/;]7|WpQoH!ɻVsnYs}ҽ~4] =>=:`;cܱ'?e~!ańD#G&}'/?^xI֓?+\wx20;5\ӯ_etWf^Qs-mw3+?~O~ endstream endobj 533 0 obj << /Length 1575 /Filter /FlateDecode >> stream xڍXKs6Wpz&L鴇N>iimHɚKJI_}$d,b߻2Q ]:Ry` t)]T2kJ/~=Z;xmWIi*rM )aSNWs–ˎQ.ID>Ugh=1:́duHo / ӁF9fBK,N^_۟m79{su 4UQbX;};uy ؂_!4Q0F;r Dw{!z>cRrm`Ѵ>xP:3C?Y04+BYx>6zeS:* j_qKr5C@xQ> /ExtGState << >>/ColorSpace << /sRGB 543 0 R >>>> /Length 5163 /Filter /FlateDecode >> stream xO-QS%,8tZ Y2H,+c FAUiͻftguvE:=~H|㏏W}|H=[~}/7߾]?ҳ]}\xK_K8ޟz[Us=|aLH 2?[yG&2d{v;9œ3z9N.Y.SYω3=\s.fyf;?ZNnYd;gvBt_φBx\dF|7܍1j p\τ`v6d.FhqO-&k&质+Grf]-]aZvЋq"zj{~9 R?P|V~j&]ԃڌ4^/MFf*L4xm xmҲwxMO_^fs]q%3޵|kzxM{xM_&*=_ f{,[]ZϣVě1/d<mh< B+_2^| lJ7 x/ xslU`^Owg 4̗^iͷ7%>״g>54{xM7޿O״Z״oKEjb替o5y}{1" ^KE"0^_Ѵ%>o茷?;%z-Hd;|,q/kDdxXe%S7;5LA3ޥ`q.]?ċ׼PwkFWl :m=:p|Όb< /%xMtq[zp)\ol=@Ο7+MkA̟\lAcR7kam=`|-s. HRϬr8*j]ǵ%zg}3;}Wǟg5?XļHcu{ffn}z׏_$-=6`Ļ[.;{_?+ycmԻ{1kZU^]|Il.VU%T}q+q[KN?;'9&V(&ǚX8?d_KX 2l0x~|]'CYjei IZ<#;'s?ސl׬k߸'xM[0 UCOE}T[`XE.Vh֍Ӂo,MqTXt^ΒRHX:m,XjR Vs!RnXjD{v,e$XڲƱ8XjdK-S+0r`i21ԀYecхzRg=;vVcKAec=`]ϱO.7#w +KRdRdE=8KM K؟XjyC,5=恥F7~Rhh+m,V|RА/w9& K5R굱Z KASm, KAWzRhaZ KіFcc)chRۡ:f KIoyc)KQ\Rh&c)t;ZR6BkУn, KAo,v KIBK_ReRm}a)cfSj#Kqt`)4Хm,F K6KɎ"a)4W'Ru`) Kq,v j+]z~el,ec)ZR꾱Ӝ7RύЎR깱zsc)K,>0\XJ7R|KR걱zm, 0iO6+l'm[nU6})æav㔔nf|nfix6mm|mm\v6 m<6m)mdo&{f:lT%t۴eUnexwm26]6 MXݦktsݦ-{dnӦutB(lڲ+Z ͻanӦ,MÝaӦ{>l=MsQMW0aӦ+Vvo6KM66mzclmڴmoGղ&nbb&WlV,k&-\fP 4ݲZx-"=U;{)]a\4jx$5ՊP{yP ?x@Y"tJOk]x͓w$V.7.eG#tZI|5j%"wRVe#$6B*iT#$Cm|ݗ#Yã^`yrv˿ `R!tB˒E'W~u֥¡BBM: $!!u⃎:H#:`+Zt1$Y] 2Œc$׎H&."S"˷T`i.BIpd?v {v%["غ&I_K{K\gV^D]K[)M_Z&$_o0ebL 2eBsH2"I&C+$xW0VVX87ao%ݑc6.p=v޿uGKqnsq|v{}.;si K;U4Wwl;l;x1~zkuS^5rub%'qv}qygHg,l #-X6<T66`K'ǿOo M uL߆]ǍZ!ٱ?uqmן6{]!uWU{u9lrrJ"F '{ }셟{ud{`=g/+uW"`V^茝|2ثe=`{զ "+>~BC`/+5^|9X{{Y,n^wZJ{E<ثW^yX}-t>+^Wn2^uUfr ^oeZlS˴s^U;{;ri{}/psXVQJ!b_FvN΂7'vPj-غaʧ5 - mʹa4Ii[8ƭy,WD 7A pe}86A~e܀̠ի Z)6pBt͝3ngнm@c/mB9A ahMS4.MiIiЂ+5:&Jՠ[b5h`i #7b{+lumfV<6h'Nmׁmʹm9A+>4sG7h7Bvs~nvoo=O{&{ ]O'o|@S8(=|;{s*.Shmzܿwÿ{w0ƲViާ L[w74,y+{ÿSw켅c'pn;lG}mZs`ߨu]w;z]l¿M˿߲ߵתH35NN7vߨ׮ÿMܿMSsZݿCiܿk^w^]e'[^ۿU۴GG=۴Zߦ%~m^ }2xw]pݿ3ioʿQoÿKi{mZZ]ZT|m:ÿoK{{.okV}jhp[ݯ,D_|.]|'5e`ÿ_]¿K7>H鏟ݹMw_́ݒwzL,,vK?/}<-|ixCݎVyaxgjo Yk"^+;K+7?iWC!EWb6be}YUze8]'`[^6ڞ~n}%rBܨ,[&lc;G}l^ZQ-YfG/|e˘?=}?5= endstream endobj 545 0 obj << /Alternate /DeviceRGB /N 3 /Length 2596 /Filter /FlateDecode >> stream xwTSϽ7PkhRH H.*1 J"6DTpDQ2(C"QDqpId߼y͛~kg}ֺLX Xňg` lpBF|،l *?Y"1P\8=W%Oɘ4M0J"Y2Vs,[|e92<se'9`2&ctI@o|N6(.sSdl-c(2-yH_/XZ.$&\SM07#1ؙYrfYym";8980m-m(]v^DW~ emi]P`/u}q|^R,g+\Kk)/C_|Rax8t1C^7nfzDp 柇u$/ED˦L L[B@ٹЖX!@~(* {d+} G͋љς}WL$cGD2QZ4 E@@A(q`1D `'u46ptc48.`R0) @Rt CXCP%CBH@Rf[(t CQhz#0 Zl`O828.p|O×X ?:0FBx$ !i@ڐH[EE1PL ⢖V6QP>U(j MFkt,:.FW8c1L&ӎ9ƌaX: rbl1 {{{;}#tp8_\8"Ey.,X%%Gщ1-9ҀKl.oo/O$&'=JvMޞxǥ{=Vs\x ‰N柜>ucKz=s/ol|ϝ?y ^d]ps~:;/;]7|WpQoH!ɻVsnYs}ҽ~4] =>=:`;cܱ'?e~!ańD#G&}'/?^xI֓?+\wx20;5\ӯ_etWf^Qs-mw3+?~O~ endstream endobj 548 0 obj << /Length 348 /Filter /FlateDecode >> stream xڍRMS WpC( IN[xQMc2Nq2 o#HEnh2VX  :ܪLU^\1KOKSLZ-ǘ ,!hÀ+ng$-UJnX$EpX F@'f;NE*pkcgcd1 msP_l/zr##r"4qpV.Gzt{0bL}C(V<^AY,q~(qAgFV]=nEnOQ]?P> /ExtGState << >>/ColorSpace << /sRGB 554 0 R >>>> /Length 2776 /Filter /FlateDecode >> stream x[M >D[_*mgX'9{z!ERk=x*OEv÷÷ V;/%O?׏O(v=~'| G&@xex/χs \N8OCtny ?| ֐?Ts 4V ~o 0~ۛ= L~ a OCyLe2T7N kxXX 4|c'hxV1*OO1+Ot?;B<5xxo6)nLh.ytu2F:?7NU4:~}HpE#aB,%CKd5uc1tDpyx=M^Des}v]}~9>'zx}483ViH!%Oӧ`U@BQVA7`UԩU]˭0 RXXʇ^^l]_%U8jӃ=H8Н(;鲾3\ϋ7P3wd>+OPy&~Ưs-.v;D{3Xa4|{XKzghx4|xӥ8n\0⹫p%Yn9R0<̵bU06 QPWJ`lݵXnYa]ׄf#`ԂےI]1+p$EڟUHQ xAg{VA׮ ~U±2 FڟMmffNDj#KfO&lنSp:/h5;S`w\MqkZjK]%BO7ѤqFAUU0wFA( F)~t:ڛYAzakMSc춠R׸ }5XV~ 1𖝪*[,8a|MӅUD(J/IPl0Eӥ^aST_ەIx ?вpL'BV6++ W6++wUlԺq qW+u}.ǵf]+4Dck`bKt&FQSWblLte&$(]z)|?u~CV|5uohK+c:ᐖl >-qq T*Qd;Ec KaVASvo*Xy% *^ ׹tmLY2zUå+BøUvdY")i]WZ.R0Yօ.Ͳ)~ cf{fJRJ'6Re6Jc ž",طPeJc ž}",7OK(x̬.2L(62Xcƪ_ڲ~Ė;ӢJm Ka賲 R6/ a )oa+f.H9%dN4tg=njԥFɤi&y]N5]hJÄb8d[.%0J*(3OmDypGSIav\:_pU1w$y<èɚ@aQhj H%Y <$PcB _ zr"xo{Yo(nSpć%/^Z~ A Be.z{${ؚNfOoAN.m^ /JL=J9Hk%~b#7V*b̕Uww?@T endstream endobj 556 0 obj << /Alternate /DeviceRGB /N 3 /Length 2596 /Filter /FlateDecode >> stream xwTSϽ7PkhRH H.*1 J"6DTpDQ2(C"QDqpId߼y͛~kg}ֺLX Xňg` lpBF|،l *?Y"1P\8=W%Oɘ4M0J"Y2Vs,[|e92<se'9`2&ctI@o|N6(.sSdl-c(2-yH_/XZ.$&\SM07#1ؙYrfYym";8980m-m(]v^DW~ emi]P`/u}q|^R,g+\Kk)/C_|Rax8t1C^7nfzDp 柇u$/ED˦L L[B@ٹЖX!@~(* {d+} G͋љς}WL$cGD2QZ4 E@@A(q`1D `'u46ptc48.`R0) @Rt CXCP%CBH@Rf[(t CQhz#0 Zl`O828.p|O×X ?:0FBx$ !i@ڐH[EE1PL ⢖V6QP>U(j MFkt,:.FW8c1L&ӎ9ƌaX: rbl1 {{{;}#tp8_\8"Ey.,X%%Gщ1-9ҀKl.oo/O$&'=JvMޞxǥ{=Vs\x ‰N柜>ucKz=s/ol|ϝ?y ^d]ps~:;/;]7|WpQoH!ɻVsnYs}ҽ~4] =>=:`;cܱ'?e~!ańD#G&}'/?^xI֓?+\wx20;5\ӯ_etWf^Qs-mw3+?~O~ endstream endobj 559 0 obj << /Length 1683 /Filter /FlateDecode >> stream xڵY_o6ϧ;Q-XV-֭F48Fo#QlgEȢǻzs/_\\KCAf̛{l0 8^ 7)}K\xf}?ޯQڛU@3?%`P+/OAǁz&V\G̺rE3+wDA2BOBE{~0Ϗy0 hS)Ţ(Ad+f=лRCܩW[F!{+hW@9[a2d uYu8}Oc^>) eV{K♊gkl0`3QM iXLqR7R6,KJDVȣhY3]P ;gFVhWjdh%ڙiHA>泰GB+6J# c{vNr g qɏqujO1="k[k*dS Zs)VM6?CAb$J8s 2K&L:6ٗ[UԩiiΘsRu*+j]T9Mw3U7ļͭ|D#ӨՖ@?͉7B}4`V0|&Gpt00yذ(xS{jת4F5қ@֏Mhl"E yu \mڮL$g2>Xg) kbdUy/;~ב8k ͚d< ĢfSѲUge{xwjT-Ye>Ik-B)XPtA/>63rkgm(۶Fq8+Gո_S`_t'R/4siM jO8Gƹ3%;CuHƩN0iW&'He| ɮ6̾z )vm+侶OQђq*4ם`-x{Ch-- c+Yf){U5'_ӍCZ԰I H2RL8oԕ.PO?pqyNyzs8Lt]YLmNFLi%1:R<;NtdL.b endstream endobj 564 0 obj << /Length 1800 /Filter /FlateDecode >> stream xڵYKo7WeH Khib(dKʖ"y1apfهr٣T(23-u?p9;_vߝ&K^p{gy5g[]ΙKխ>lnWFv7>OsκMMpXz<_ 7d}n>̗Wwpڹ17~w*SPGyP>*onÑl2zÆhksF Yc%צW\LTvmUIO}9_J-)}~Hb?ܳ "҅}^D\j.#CzG] _N>7_\A.]ص"~^dX'q|~)UH)=c"C*rsЋ|ߥM+ܓjTlNuEN(@RB5HVyb ;ldE_.}iBd*4i~I;~-Cp:g3twƢ4<ҳz(I,c09Al"Šoh+C2 6A*m1]l\dӠ ['; G7HtdlsAΝ2*c8;dk1 ͸-\{BO|BrDۅFN.;l2՟ M H;_17A n% pːv 6dV9bf<5e%E!-!ƴS}SL>?:dBG}ҰX)%j1Vg' RlTMfEa/F٠ȗ_Ϣv%AM0dG7A :jlɉ41BE4FJXDPĶduҥ$ --bѓt]Ǯ4赮EW}[pX B- >faCP+vfEq%paaɄEh5|*_____?GےB#1[0q,B|"OH1HqW6>AniDžSp(%%%ʆWހDW2"A G P($^V (qDPH1~>;?% endstream endobj 449 0 obj << /Type /ObjStm /N 100 /First 882 /Length 1769 /Filter /FlateDecode >> stream xZn7}߯cP.N M`h(y%CZ7ʗeٺ!yK33u&eɃTUdt(ɤx:e %֑v$LgL¨b՘3EN0wȼCUJ_/^,G#PKFtO_mU#䄔jzKjp,-3H_Tn{H/H<36o_m8۶7AՉ*R[ӏ^Vh|rnTz$ ݋ j԰XS[u|Q'RE!SB hkHwgq"tAr߂)M m9<Lʝ~' IgA#WGW^ߢ|9Uf$sZRxA4O6 K U $-ˁ&izW|t ]!o$^sʽ8,jv5ay3qM6l"(Em1K8lul\cJ?rO+ع);Lm\~wZ$vxd8;W,UhNNOبYKZ.9~^9[Yt _Jt3g\x뙟o=kYt:-3|ŋ}PVLk{HkDJyZ59jL}yXuN}W7x1md~1K>s|Z`FRyŝ endstream endobj 570 0 obj << /Length 2606 /Filter /FlateDecode >> stream xڵn=_!dxrzyhq". ْ/d۟/υ3$hHcדI=?xu뉪nrP9&5nrC}{5j ܫ*̢a,i$'*eLvB+$ٷ?Iv%AܱQ8G֧ܫ)WSp^>i[rjXj^~D_Z#|EU` W Uyz@W>+_-_-}H'[H{,>2/ @T߁V\ i( Lw%V;9[[oZKՀG;䡮\_W05U~וj #71U(Unu${[ WtliE qyS6{>:9IՏFԚNb du n n n PF&8/fD OxE l쳪Zm!cj ~e+Y<J,g7ZF$_&()- HTj"j< A}59$iㇷ+i- Ď0\ZCc_d6 BKwРF :(& -l{X8Ǚkk{O{ g]G=4jՃ;.82>SQighXnRM-2nzJ84d--쨧[Ӌԧߠ"w6kұ.k*bWMЊ܎?*@ČPO#Bց5΢% A t 7nCSYcߎqtPGz_[WNDN4EH7q>#HE[sg ]r+^xEm_-RCZA>5MPa \ܳ1<%@<qUVJف dњx_nv%x;M(I@>L>g*@a@=|ޭx@y]cwD2Bd0OZG=vFW ,k#DQʶw|MA܍7~Z66FVpʾ1ΰV)="h\}U~_=ro>;OV"esB]17sA.ozŋ@gMJ5GBvKi2r΀;N[SLt$5_&C=$h)^0dJ>qi93lO_T lej}VKU\xLc "B/˂?>z_WSʹYxZQq\^-n`q2d 2O'G,2f9zT:)zL[X!}zcn\i?J|]R/c}#1صo̗eȅ@! zi HMWV`ZCS:Q$S%:šu:9øM 7Իx a/8۔00UUZU.MjOߦ7^jV4PLZ` 9*Э$r1-赿# orAj IqV#}Vqc{*6Ue^B4hWwWTڳb9rQ3Pզi_i:k)f..{X^;LKeɼ]Y`87QyU}>U6E1VSUoT&åH2u?KGhQ~LUg~XI7v6]͔,+TbtKc6Č"_]cI*22c$lIYeØIT]`m$c1Rs1 eL澽Et$c slv똩lݙszGOS6+a|M U\8 c)ǎ#q|ivӓ}[IQF=iWΛ6ӛT v@6ErFSq\8=v!$}`7{qÄL w,[+*s]"%s'&Æ:ؓ%mqLCqpۥ" W|ǴdqNK)<D9-۷$OSxZm|ᢷCZһ1KSZ8jUxdo:Ǟ~H> stream xڍRMO0 W%NV4N*.C lcm#64$T9vjpm&I*׹ iPMyK|-'E^(gwyj%!zQ5]0;71h-xt( keu#Xt:LbN6=|@!ij,^rp/:;C{GUD0@}f\eǢȇqYh8HD;hW[cʧB=q2ǧ{/G3+|r:῝G endstream endobj 567 0 obj << /Type /XObject /Subtype /Image /Width 672 /Height 672 /BitsPerComponent 8 /ColorSpace [/Indexed /DeviceRGB 255 578 0 R] /Length 33163 /Filter /FlateDecode >> stream x \T/>&ėXJL5E d F. /!"mwk]m{MB&n0Bi$1=k,$f7w?]t{ssyΙA`@0g?{}~Ȉ!B"D!B"D!B"D!B"D!B"D!B"D!B"D!B"D!B"D!B"D!B"D!B"D!B"D!B"D!B"D!B"D!B"D!B"D!B"D!B"D!B"D!B"D!B"D!B"D!BC94{FYȄ~BH haIPm!(TCU{~Bj)9.J4)ZD)I>?F'a"/&P92bƧ$SV& .'ORj>FS甪SLVGSNBGhHsJ))D!B"D!B"D!B"D!B"D!B"D!B"D!B"DeBnVGөPЧvOϘK#O*W^)ķW8㉄>>c,s}n+zAW+sBuB }NK}젫 ^AFz {4s\*vbϩӧgdmU}>6?#9bJXp@,0s+׻[,N;}8][bsir 'UǪ>9*$J+T+4t+U<~:s|4]U_LC&}M2>=&:tUt>o鷀fkd~cq> >> u^ ׾.iOȜ #\b) '8+v>~|F3C?c1 $o¾9}ڥaV!#U5 gVhsC|ЧgT ȞԐWP\bPVT"̭a0`LG$+͍2,#lb$,#̅$,.j{ϙOK#3q̜3!$!<jwwn]B<"7qa>!'@! CFϙϪB,*OE0J/MLM MH}NsF3d>ê>N ȟE{P`T#8 Ih@&$ } zM74@ qȟ 8V&9ֆλ?zڌOW|_Q'4(&**[s'%CCX\χ ~"s'EqаC׳" ? *kېޡ^(ᅮG>g>~(=re.g r]EVm:g/#b[EQA3Sӕz8ğa|&X(w10iR|nTZ_sQV6rGw´tg+C_B%ksYT6DXm#go߼}~ }~3 3Si>(.hޢmqоlRmy1Bm`_]]q\)|"}Nc|QUA|&%lUT eݨχ3*6V Mz[y'& a !g#ЅP7H9CM6ğ CCq CC7>߰p.gzGG_ |G?֬6W& |"lùxBCo.$sRsaAmm}go]OBڶCcm?{!mb9 y P;}|x/u9⳶m#''ս2gWo ] a|Yl31ӧ凫m m JaȾ 'B%' %%`߿Cl9{i%gE}ٖ0 "\Pn(:z PK(>GKJzy-Hw>>ݯOx6C|`(a 1H0.j^=FE/ܰ$km_wp}No|@.Y.ԜmwC ?۞n5R8%%=Pq>F9|>9W8yYu"NğCm"܈RIa|B,!ٓ |ޏzVڢ~sglɹɫ<ApᡍCc6\X6k!g5̟%%YYY\6*}Nw5 yB49"1Ⱦ? sA ;wnt!34O^ֆY!?ֶFd7B|>fΟw!xBճ ڹC;O1LO蓼aaϱޡCon{hF5۹p#. m,-A ^P9kNW}}'=#4:tknGs ބ|艶ޛ hG7znQhh9'$% }7˜w!TğՃ3 Ze%=M*{|q6uL_[}BBƍ?7VW燪7@|A E ܍NT3MMy]w2ぁϾ> 8{7V$(<7ȟ gTϞ.]_C,2'bϼhY߬č1C_H-O$Ot& }c_輹f/'ްp쒞 գ=(h_8Jh @ۋw>3y >Oc|꽣wU/={ '4% g/ zOחc߳3oK{q+-Ճ7k|E-y8}B>RI焖FO@|"ܝ3 ٟUd^yA?V ٳԉ9=㣾b PFiЧר NwL?|{HNωgDf>_;Msa h GKPѨ' z%=0*DJQsdhŸY >;//9§z}ZĿM_[ObpRx"~S1 9C( AH Y'`fs6JCeF{Jz> Q甊1:$%q}ޣ)'Y'.I4_~O? =_ P{EߘQ$$ȟ .AMX;=HԎJsp>4O3e)B|g?E'i=!z6eQ%-׻ǕgV<ۄ.}ssY"|zxUf2~#kYVO zl% ՜'VbϜ? Ş?wu1⣾Zq1^7X>48 igBOdGID=$>"يEԸ`|6* tk{Ғ}Ҕ'M*i75͖9iOȟ Q)T︢YLܜgCC,s\Ͼ{p[?"poV=I=O-'FCs|'&Чg>a|T"ĠP٨5#-!> >Ss4kU}zqEIz]\OGsvA]O߾%H F孨׳]ui&hɁ(;1wRxRtϞo<Ġ.קlߑ߉cx4#,hE;>ϜTly='?AG๥HgXv80Abͼ<ȜS8M'h*E듇OORtכ[ L(%ww>yO4kV#jDnϫg^ӖvDDJ j~ }ZyHMxbHzfnuw>-*ß p΄܌ij(O/*#,/Op> v(ZvCMgxؓb[ f}p#b)>q'Zdܜ_sqRSkk :~0ng>e8}Pq;^Y9xolàM}v\ڊ-isH+MʣRjMM bR3tYOxKr>|E֪D=fȨH=|m-hE=iW—7iWi45'_oA:xP,,w>TH?ճ9ORܜoż[>n:׷bT%>݈$2J$J~EA qn"vp\_=ֻELqgk vu BsqP~姧>gۗ3LO N-k`-hJ D~EPK||]<u ?wz-w윸}OBgno@z xrW"fl)'Er7eMs} %#t"qQ5jiK=KKW/b|:< #aj >e*w3U_;-+Vfkd Gr-Hgy&zD,j,C=UOTjjj2H84r]] _;DE;f'8.AqQ4/' r-0t$nof+V>Ci#MlG"U0yyK)>#545³ƇRCǯ#lfN`zIjUgrW'Cj))\fǂ8bwsHK_UIM+"@5B`|;-C($Q`D V >YD3[X‡&ʟ>. M@{m ^:.y͐AݬOOBUа/%q;,QXWdB!>l+1v}a0Vy6Ѥ|?DM9mNsZAj\4BI8t?B#g*[3\ ^4% 'Ix2tZ 7O. ijxIK⓬Cs@~[NZE Iv{Cb{ ϶&ϷUNnasMSԜYw O@SleYt/heQ.OmȆZiyT4"Ӓ@iz̺nЧCAj󴫹O66ݦ+ bQ||g*WNɆ&v8i#t ,>u?nVjQb #VyħwO@[ WsT1|x%F𙚝JYC=I8*+%ي^; zPgcOe$hgSkw>=b@z(?kRQ`ɳTAkfsL8?g)C|WS? X',- U<>;(>SI^(j+:HGc;_9 D#Z! s{}xQȅ3H[:ͦë8PJ>15d;jfy?]6t|>_ڠ?b'=J cD-_P|2\H+9/lc"FPb>)>r>#H甩Dęi 4}ZtWxW2֊-D;ܠwh9 {D[ ߕ% S͐4ցJogg]SS(ܣO+п"MaY%H2R1]7@Omj2QnzjKЧmAs0y"+e:B'`[}kХ/ԜE?HIvD2eUwrmkÛ'}jsu_(>!<^E N%O3}s(@hBZgT5O`)V?˜);BO? ѧzbM1FgΞ?LD:}5Oğ0.B=bH7 O`߹l鿶܂>m\u>&f&bxd}/ʐ?0u R ק%NJѲGMIDwN~OWT79T5"9ni|h|jlw> >]v &|QWS56$=ٳw#(ta10DSvbp-\ ?5W;tȟ ЍOmXվ(ehBS}Zː?>ڸ(QMW`] K7ycX|sLW85} KxJTBuH &'*q>.|V֓ qQvCOW##Bj >I'ힲ:3 "`PN>>t ${1D3PlC/;:ħ$+tURNd 騴iO_OYO'GNZs󖬫Ξ'Oܛ扌C }jΫ٩0ҼJ_9 plq+>cO9>XS9g ]dn\k"'2h]#||~ r5׉ YY%>QhMo}H_Z}!uʟt1DL&4es:Ӯc:H[ƥNxmeS` ;D'g^ȾrOI¨mZW>xWR'u 9@ ERg .(d|whJ}KK1uʺ}2E>]O55SJ8?i?y:n?*"Ea}B5914jCqf >A&?3s>f}'gefwa7M%иv%6{Oz8@|h<|Gw܅oe#Wg&](IBwx G\O3YP?J{u L#wELv9Q.4}TJ>t)ԾC$9y[Jܴԧjk '.O5L@>!Dg]dbH1E2!K̄\*FϻnJKs>C#!4Ldڻ33+UN ;#KRw:bIV[t-=zhH$jK4ϻ*EJW{nZ3s0$B(YQԖƺ9K1i|6B%Ruw> /R|vC&-!8tz+ozsoCQ| g@ZBͺ`ޡÐWg#P#)TtuTӬUãqs'§,'+2ħrulNu-wӆ`QN?ɺuNi:̟.zE|Od1'|TI6Sx`y41,8>7xk8uS6&"`\W2a3%1Nt>C_Dxn즉y`Z9TzoPo2 LOqe|RxuAU?b'WGd`ZzbJeI:쮓RW'Lq7>]OSJ^̛vJxĞu-H(vNe[^|ߡIr& ܩm$I>?]O?AweWw%t>V!J!םBSɾ0>9 \H2'I|N n'sMࣔ>1g%kC'NbЈ(C;cO>I)_OQt>>u?:V# @oEB8׻'FgNwğg>SwU.CSee`d$LT:SF,naC NbOs%6H>G>%ՙ22y'']JUy~zbCD"g7֨yVŧT3y Rqt'M=S>oY#;w&;T*W4}T*x;]w;|4H@.D׻*Tr>wNl(+cOc}Zs IVe&q'+4"}j{eoN>17sF")g>"{?ω(:]q3%y7٣=59N244>}J85"}~,U5g>wJm>H.}h՜ JaqsTnvjk BJ`ϙOOװȸVTIVnރĐJS>'ELG|B`JK͙O\B#g ?}N>wLO|df@r}sel⃮gd3u3 I)Aɔ.ܵfP*M)9t֧Oψ$b}:e>'rDnP&\sEOǒ"9s_POU5 >g>=/zG Jt$k* _Q*)iID_>ӌ?zVA'3Dss\ix}zF"ѧgg2΄>OO$zgDA.u҄>'YԿ,}F>>w{&z1oBBrz'O#uOX3")Z{O 8ͱi} "$FMЧХЧONZ'\{O{"jRS-$D  ] }SzMGӕ׻p>=yi֧7>"D!B"D!B"D!B"D!B"D!B"D!B"D!B"D!B"D!B"D!B"D!B"D!B"D!B"D!B"D!B"D!B"D!B"D!B"D!B"D!B"D!B"D!B"D!B"D!B"D!B"D!B"D!B"Dx0cy== >=*X(K3ԴE5>GXiy-DE׻ЧЧ%BhJȈYjzxЧЧK9#OO7sDSIӵUOO!B"D!B"D!B"D!B"D!B"D!B"D!!B\Oˁ!B UBBBŸwq|뫪BƠ6= ݹ3D盿Y+wOm-}Kw?wĉт8~/how-;qB}qOgRyu;vN>'*;'=%x 8+-[s_{?;?9 o@QJE2!˲  !-@? {m=ߩSϟ*)/S %t1 Az z;!>bb|VD?;;'rǧOUiZAF73~Gx~3oBzL*>[%+o)^Q.m? >O`§fd xt1d6Yu;'?⺟)at"}b&?#S?xw1'ϹoORǧw0Ҡ,M`>EJP-;ޯ}%="BxW$uC*T>Z\H̴Oi6e,Φo uQN KS͛RIf<"eȈ ɳ:@\o!_{_wu\~X:⳻;SdxP<`,0BX[[RL1MϟP,$F"#O6;PJߔ/$;7*;t?컱ǯdߙ!'deK.3(ŷ|)U-4$ %K,C'G1UvwWh٥w^^'Ƨ_10 oX9Dk<) gH"F7)lXD?yT3K@u?y'eΠy攨RM~+ 8, Mk)f l%$[^l!G!I]?t-;_= ҧ̄:'Ec͍'$xU&c|D`юi%l%g'OG;~R`;뚊Ϲݹ`O/K,{`KrOnE^&KJS(iQG!~ZmG$KSr;D?> fKůgUϢ*nU|"hfݍ)Kn~TeM &/@{D)?h-| }H\  (wic%+K]r[jD?4)3evM88()<~R6'ktċ$ &To#Ev}ܓ]F_w G9 8F2۬dMƛ寧~.E y')3yks,9=G8O1Zܘ\Iͻ"%f<2>fm[[68<"41?iv@;D },b|zn_rt"v)*&%.3cßԄ޻f?Qh 03li7:uZrg1:U(ms\cXthJ,O'֗$𧾰X=s/ʙݚW#s64%J5Ud SftµEV$-YOOMRTI<{Wk]W\-ቒFLD4{\lTfD?#DJvY'yl#.,BjK#NgzE¡@7uB<47:[ߙ*V Vx)^yz m߸@VkGLیi}Ӭo9ï҃X?Ґ׼KVGCPçCR;8f?ӏgi6C!e%S 敏_ 䰫CwG]x[0lSK۰߮O&z#>8ʸ/cѱZCuW%ɮ/WsKvGC\lS缼]%ٮյYG otYֲK[q*5nށѯ4tg8":%iֳrvvul)JN"JXKٶE]bS8- zܬJ+;_Ъ 3t^\p=$jkKvxrs!lƈ?II|qEss'yu %+PےKLauIQxϏk-]'mt&Nv^Sr&ﾰ"z۶Ȼ]:I~ɜF%iiUbi d4S􌫟ֱ ξKapbp$e@42})/̻̘֒wgtS:N$hgb&s~ߔ0WrZ)74NS"Eж`DTA&/*ze֚wL뒽6[wNHQlPv!Pȟi|Z~ڈOJܦ$i(qamie"Ek Ԓ6yBM~'Y̡Xt:ST?DGIN?"$[.\Tsq5>a}I~[s>}nܷuŦBɱ [}t9Y:F=$Wۯ?(w44/Sa#Oɞ>~VTl;YءF)5Eh01s#o^watKܜQId$sOO"g:M򷾋;1}>w;I+3*{rNYflW-56sn`3#M"Et-q}(䭤 N7<Jo׉zb5z/Zf1,k{"aG_ .dEClc/P,CǺGL&M,g";1rty* zҩObvƝukL๩xoN}%kt&EɱssRd)T~oޡ}G܉¤JojRcXlWLh{sߒG,}rfS+J6 d>|/*0&c q{T$CvZBp;4DΟvl5ЦuLocMyxc>?_wVV<z}LnL b:.ڲlaٴ&[ jHv~C_ 6h 3%H*[Rt*C_ _8tLZӺM\/j׽|41;/5?#mycIxiAq )Eĝ-P7!ȼtWʘw.quC~Dsy}tq#~wt#kiԹa7'k>rN14+WSR֬?[ oP=~'0Z,66V<~<-:Fw_+F1o۔N>M)jfZ|p5hwwᅛHr?4ۯغd .%Ȝ\gTdn(S4Au Z#߼g !R$]ԙE?ɭmva _[fҿ=9Ϭ;Rd^Hѝa$gϾSs-y[UIyވZ+ixtmMe{J ;Cc;C:hS 53MRl3輘HxJ O&)yi[{'O|qv4%%ed$.#6y3kuy~[l68SCI$@&30; P> f8ߧU-['OF-u@FǁւO8~o;+FG^_q[f]ř3ZqƱc ?U\Gm3VϽ[J+"h;PHIm=Ek燐. wB=J4#??3hGo2)ZFGm_r[_[CHk2wYc3qae؂ğdJc0?#jwW{̍s c'wzN#ج)Pt$`FwiAU?zae.iL?jފL]1 IMr~^ XgmO'FߝVÕ0wɮO"'S^,}Zvh;9ӷ~O/h-oMH*_ݔ©/}ϋަkuŔ>u4#?ֆY'ʜQ$7l▍b7?DrZM|3 d$<` 7grrEn֭/W22]?EN*Y߸<[wD,v8ռYl~ ߱ >LQֿG/٭?xp%^2A&:L1-,KLKK,{Җݽ{SƦ%%6~=٘` ҏޞ`˜wEQPEUmֵX&ړ02Ũn䜶佖02ч.uLY TJ39.LFHOL+lD2rYaXpkuxTfIr{K6cCwm)LY|7`.kyE ɴ/>84^>xv %kC |ڶ___~R>n_|4uicV.]a##f- ΁?-'0$AKlֿ;nȝᨔC\z2Ⳏ6OG]JE;7,mn.n,(nnnG?}7lXM5}d v~ԼWzGv0&[vKlS%un7E^.&'A爩3$y*HfwJK78wMY6-RDt{g7oIt^}K=S/(('GW0:{7؟O]~گ(Y 4:j{s-ޱ:2+ex5̉|B ze0efSDo.M2cCo$#ocOfi#^F U!Fg {߇L"GG> gAxB=j||u?v272mƉC}1'2bpM1Ϡk6yF*i $TRT,55ӣ?hoFU2QSRҪ3􎍽0eX@ yg]Mk+;v;#nkcb3W6pOcgL!)AɒBɌq_}'7h!){Bs D::2w"AcO}wܟK=NSĞOfV~ݱCm a8K34f MZ瓑?b"Q`wɁAp=f j$ۅR typFo/{E5޺uEֿًwxkFyʯtd]Ș73H=5pܤ/.-n?0:+?K,ޔo~!ئC55΅ˎڦ%! &%3} ɨZ4&6>ȃnK[[oSV=ܞgӬëW lΤwofti}s.*A ( XOC_6@iˢX!;RD:i(dBrZg%d\|4ܝF4QbڞݛvtSR; f5m+ܶm8aqwkv|c>OvaiB !I9 ßؖ)KO} azASNF RP'I@xA Xhi7.P{zW6҄UEzDxG߾G{ Î6dK1Ϧ.G2}Fd2%g0\q$w.)JL/ZvĠ <̟f}:7ੴhǎ ;ŴCa:5lαW}7lHfsJ d?XU _'gV dp&OzuO <{D< |bROtǦmܖ@;U#OF?YļWn_rF.)Ln+~b ɲ[Dc;:DQLAԭH ''<:P; ^nF/?sae 2Ck֌"rM)QAGL˸ nzD׃޲x/dlٲe]1:كxAr88wWG?-mQoy{\iQ;] ,k8o xxK= wMslM#ކ|Ov\y7dEu oi7*=ys6='^njjkjZ*ʸ<83pfpAxL^q. R@UOԙބˏmvDffq4f5p&qOK|Z ܶ~~Cnf mJd":ѡޤoJpȚUIMHd$-ijZ1{pQ tZ#DxZV S @7ww;Kn[V=̨5͠g^&Ri8R5vkyqJ>RRÔG}_ΫWi "OtX DȞ膸s7Qo#>t[r@g~C ֫;vБv$+^t":˴ lZbeɡODi6%8Aw I O!\S 7P^ gIHu?C:F#=$ϦzyB\5*ojμ iOž@F? }i1ޯ>]נؑa٤K!J6y5vԍ-;33<XѦUNi[h>4HRPP^ۑW䗣JK{fl)=uC!ㅏ?R[ݬ@fG\Y3kWȎ݆dC%[yxb93*?J_yi8A/_ B{ y2@2*u{r`$@ٳ[Ić'We+_{Ɏ}=axkmmTAnEG sT$h[Ͻ{TmyЧ9S(L;8̰{0}`'q +z"gm k Z@F%P5 :7xO$'IDcǑ#;vxu~VI־kmBmì$]Xvn3<;Ss~/7G& {d=r6#y5tZ'"M|)9N ZaG)io*&NB{0&!$sRaN!>!"7m)ٝc<^3po"xO˟L33Kՙlpg-:cgxdy2]iZ2i#'fmojߍ^ڔ?''!TɟA c:x};n݃Й yg?ۆA˶Ņ?ƟW_Mō5jxdŴnl:}qoͻ65DN&̓w"<gá2Q1_P[wZ/ jc*<;>q, άM:߹gYIIӳ̈́ϟƞ?U?2\R˯~pUTw>'yϽ%G&+I@n'b F aglMGFו/.!/F'c)$v|p͟XהjyF<,We-oZY}7xbɫ,/\XI7U_1ZKO 8@d`4VѺ U?+ld꺹O)@HO Sm>yCu%{fjOԔs mhZWb7 < >zA} ۽U&Ͽ#95$-/˙ݴy !&԰Ӳ;[;M@3Q޿yHGÎz#WmSb*qflI~yKӖnlْ-p#=iޝ7x㍛*:y>ͱڸZJ{ wb&Sunvwg%@3==}y;Je`FGi_xZCFoSշkT۔N5u5H'N 2sy$C;rx;79 I%B^ȝ{T>e'QOr]w|qE.h= #;";Kr&v ~2C5QOm0%p[#KK HO?o<+zWS3fX?ꡙ_ZqИ߬97nAj½q0{TOKOߛ1w;к8:[aŶc%n uvs2X֚AoJxsM } .IK֕<'5Pǥ=88TɌCϹ!,C '>--Bw䗢V?2f3*}%{|r#lYnqw) eMQ9LRkƑ";]2#bn OvkB]JU֟>%xcϑW[mCkКaH!: Ft{hߵ얯z5gҰ#q?CvnnvnR`;7+o3ܛeߖh l]禎{jё Ɇ;-x۳'׃1cyYk3.IUj`D|=c|Wk_R{>Egv[;Yéطnsd #ɖOK)S{$Ć?i%5h: \P) 2A]*GPґd~O־yk3:y{P}] y_g"x,)+G3!<+VޗwI/gf N﹡ͧ [ LZJ;v%~ņm %f[%SlfJ؃= "O܏|[/]y)gڵ(>}1uIٓ(LUvjd'>z53w.]dA;v!bۃ[,0ͭ u79}l )jjKPk'5񓯖csB'qB!<Fm:{jXvcYQ&rgg>Oz$'}ϓUQ!}vݍD^vzźۘəں8K9iJ9)AS'l ̮gS ;B\mg;@؍JAn˖71:׭\pc>υm']3zNeWOTdٓ'h$z.O-܄ }&T7&n'Z?2 MY .d+<|q}E710joF|IЩ]EIpJ?yyֿw.zn CNRe ̻sQeܩMcJ dXMtIYYI(}%; _gȟy7 ykGRM;dyY%kJ(m";?xtt:D!y*`3NO7[]LX5ziaHǜa䧹i36PliX7=4JRnM&/{oNjmVtmQKBn,| bPF?k|5P6FT{$ɚ<ϰeN+-xqaj Cg֫Tc'0djK,?MIZ( IN]Jd‰o546ɓW髫/g@{7u[} /< x^؈&j?r^((ISR?v/ӾoəC2'5ѭGPm8raUk9]ȸI^wz݁1{湱ޱwmǴY+{w,,,u}jjOn4qgHZb3Y J6;jIO9,Y"=cJ=8Q <%AN}c<y5#gk 8wΧЀO̟qZ#HسBx^ՏȼCm0z^imeyWn;2RN.{z^ 0.[Wك:W+;Sk#[5u> ذÌ;@T♳a3fXw OW])5]'ßqC*^wq^akGM&?|F.,66!!d~DicKutch$ںm{G\-Ԝۮ^=r<ב1/tgedc5Ɛ]?wf>Ad#]5q 6VtR; ^1}'@fe\zܸ3w^^G&'[[Tw2 [c0YsYvfO&-~WnLf7!} :J0Tׯ>xeeeiŋô:ڝ6c_w ƤγJdG#"}~v>-*sI/}O͊Z:3?i@'^망LlnP;Z(?Z3tv=殤;oSN ϲKG.^nlNkNKZE@bIG*_)vBYc+of;|E+743uZ:̭;Rҳf_/O<]+bWLԃ^L=E^;c&&NM; do:֞~O Y':yӂU;JfZs=XuXU5R?v$k%OV})Hɀ=s8sz'0'0[l'5 j<}&O2DNϜӪ'Js+Ž",ax..B:;６N/N~E]ox3<3 IpL[eq)Y?GN)aHXtS藧hsUr|&[\V{Z>]6R޲!"Ԑ#iΟ;DFT@b'eU#N,]IׯIמzZA-=\@EȚ>v3M2"wee3C oHa02CPPJ/8^ ۞1,im+Ȗ`ȗh^#5qvJחl'>ff EGlHϦtM'T21~3L6O:ƼB9c*CtԹ ݼO_~V>ޯF bi8dYk%Z̻Fs~6Ҹ͂@L؀4(SiŞ5}$y(iFo,F& 0y! SKn统G˛WamjK7T SKH+Q"2Ҧ:E&Zmtv@(|p?}cצM޸eʼ~_Fڶ҂={Hmu66 ~m RzfȈx,7>b7th}9 7+Y^| :ɜR8*&*O:lCPt[h"9/-x;:0=;4zFi?xlϋ|tVK`qoB2=CU;jFmxUO:3)!"^wtTHiRb%N}HY -S5uz)R+bOtJ0ē.V^ B㌖-ԵjheQq{T"B_(4zzzs>_reՓNu)Atm紃v=n+;qδC'clȫgnzwgX=1z<8/VhKCh0sf Ԍy X~7]2PU8]c̵'b= eGTBb''ZY\K^wn\>ںBNt)'8M͖ϵش0QRZkrgLDc&qv0{С~3|g3|;OX6BN䳉CDs]b\w`tقՂig{R;:JG qynoUcN^XTЄw~s/Ό?O煔к[|ZCsQSd1dk'013dUkq9ji"KO/pW҈%;>qb_ 6J,zef|n06/*urXjaGD bCr#$H݁5g]PwJ SiLi}=܌Z"<톤֪J\& >R?{NPU}!=?:Vn8?×rzyRʨjt\3^ݐN$X+JvNżou׎fޝTHhл\.k%\֔J+|E-+YQ;:5.fa_`:Z3Τuuk l=QÒ:? 7v+lеn\sXf 3DbR7K偙{ޑgGbJkˈ& lAzp` Gs_DZNg6#(2k'&o.ځVwpG0j\>UwB~l59Z8ڵj֯3 PZ֗8Urv#& tH?=ơ@yyLz2'ƱSOeZp?X"M ?1_"x]{<:55;{BPBϭ9$OZ#3%T>Gԃ{&'hWD>~vt3,OP!ld$O(;7<%6qRslvbp9dW)S!hcO{C]SBt~tD[jѓtuy,~bzj];] V'Jz nOt'OX:!5EtnCoݧGR҉tyɦմ3*+(YyC^帔|";(QpG,%! li = ~ v_uԀv&6Cc슎?khвOFٕ"f.lށ}ҸˋL @y 2fJ,޿gT^sLvH,^+&9DRГCdF7׳?$fIf.ӓQt^7Y5jV|FOO}ޕ⓺(~}fX!Akr^*#%t GO/Wv'\.5\eӣjmyfi)XlWgl|&EEI>r'(`LQ; SS/H8iwߣ?[&ֳ r+.-rճOP}Wrz{OzI>%&BC@Lb/Q|DDBmsQC`g'4KHAV:Dmp ȗIy(#IEŮ ՝ !΢ˢt&*lj*$>`l%z (bB&<=jʊng瀖4OOώ7c~MzK>;ݵTߨ'LWZx Aȩ듘˅O|gAJs_k)*$'ϞS~b^VL'PDO~ފ ͮcҌڽO)# ׿[ ~܉?0E~"Bq.nO*bE d~aT|nkP]?[gq-$rڿP|0CʁI!b%(U>"h~\M__`g7:ڷxX`j{G˙1Rf_i T~)w}~w?ۓг>!$%<5> js߻wc~3.?~{8UB+CMBxJK#JVyV7=Q];"Qyn1=i3d貁K}HpIc;\vE]Пw|קୋ՞ٷ~?L0?~.i{?dN6' ~[O'H|SxnCow ?5wYu{wYo]SݚGx;c{[v7?ysKZ׋~2z̋)XrKˍ筟[b~ ?5?(y~?\rORk>$Ts9Trڋ۞I޲?d'Gɭ=vﮩOM~VSK>[]2ZES>`V@'%'՜v5ŬMMA?ԛV|@{.\B[B{.4 y=О߂s'&'`}fc% endstream endobj 578 0 obj << /Length 779 /Filter /FlateDecode >> stream xψ 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ɟ endstream endobj 582 0 obj << /Length 1531 /Filter /FlateDecode >> stream xڽˎ6_aYqŗ,͡M&m-/hmM!HM=P"glr=&ߞ|sqrv>&2eVD慰Nfv&Jm'ɯ˩L ׄ 0_{0qG|IQ Qe6fys 50@C5"L-`R'1n I!aNTUPWviC+.-oJ'~jsXkVYdE{ۺmuT};uIrXu'4Di c_}?~p :}S']n;.IV:aFHo;ʟ5cOuipwkJ@8u*)\IњM62̮O"l:`Yb= yﻞ4UBoˡĎ.e)`k]iZ8ԏWO՜yTTdb\!n5cCJH~^uW̃v;dQBj,J 1+|[Uϲ+V1fM 6KYd)7"A-SO$KC5 u<Wbω0#فDZrr9TOVKw(itgt-ioOqxpV:J^"ㆠhq8;Gq$:40 m 2ͺf䪫6Ioeup沥BA^{>\9_o=#%k_2Nmq>_Br ]͡H7pDn~ebCy6_b y\gBe28H{YSPPL_ -)Pft/]yފcdkiT(#wE> stream xڍRN0+|qLlЈ pm!Ҙj"?3 C b>-ɌkrT(9Rr^|rvsR0Z/3\5u eiHZߜ_HkTuCR$^ֳ~}5$R9!@b9@ɐZoڟ=l|o߷"]ڡg{ѳacϐi9^f J$ۄf\; d,\䟨sR^`#a gg7$\o }ʭC\Ef6ǻz endstream endobj 579 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (./deSolve-twoD.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 589 0 R /BBox [0 0 720 360] /Resources << /ProcSet [ /PDF /Text ] /Font << /F2 590 0 R/F3 591 0 R>> /ExtGState << >>/ColorSpace << /sRGB 592 0 R >>>> /Length 14365 /Filter /FlateDecode >> stream x}M%;rܾ]J"YUdB 6 ay5tG }33"2~5o:|`[{kso_7_oW{g|ݯ~^oǸ?x?_w_o| ηuX}154o8ϗ_nw_̷>ܾ~gۏ}-~߷ijjc?x=î09Ux78>{a;>F6fG[紐<9/'>l=~?>m~|ߏ{~oװy?>}>o~ž^ǵrqm{{0_ڶhmǼ|#9ᡷ{exG8o sqtcП#> sX>xa4y_p89_rێh׻m߳p{x^(m#m_h9zr<Ǒ5zz^9xr>qFΗ9s|eQ'Aeq\O[V1?;žSd=~=v8=3ƃ3^x;Ǚfqf<Oױ}3ǎy&sڅ^fn mxd}&^ Ãxf~=nl|ؿxh,xiӱ x }s^Q>x/x='q}c|X؏3$[mܹ}^}SGlf_u3^O F3a4 6nOƃ<33",mGƣXkӆB<[Z=lづ1?u';XZ?,;J<4$Y|=-KOv}߄ć=Ȍ#bƈ313#Ō0cŌ1Ō2Ō3#Ɗ0cƊ1Ɗ2Ɗ3#G0c0G1ǑG1ǒQGs d$d,1d4Qd<qdDdLdTd\dddl Uboܡ1Ob|ڬmbmn^yЌG79F:n[ `6 ,[, d] Vm[`YU {^r0U:m#G0HUޯ*Bg{=USUQU@/UWT"4ߪ"hVekTEh=UEhU5, j?Jm?JwŃxQx*&֯x{2^d>괅/̮x2voN'£q90gϪmB*mWaVi;o~&#] }U&VFɁ 'f?Euq2c󷨺=gcC/٫ñ1Z`QumY2223m/*%m%߇**U|#UU'2\oVa0_332wVaX°^gVaXYu_|Ÿꂿe4* phUYgXe¹YU!^oFuៈǬJUx*GUHpqt&ݟ_٭FCߖ}PUwH<4ӥSE-܉f_f u<7ZYX[ ub b62_dZŎf;OZģfTz!݋綽MVߨV*V#RQ墊ՌՌQŌՌՊjՊŊjՊJG1ǨJGqǩJG*ǒцG ǓGDTĐQGDTiAIKFD<+TP1bHG +T PJ&OY1J*UT\R@Ŗ**TP"Lc(GiXS`ERxc_qKTj6j Y`l|u? rXc߾FY*قк|i=9ҷYg2f ~Hx&fEeym=:Dw))l{5B*)DMQdgn ´uk3*)uV\7!"d!zĕd*ªqG@ EbLc>3VQD֭B3Dn7F~|Rv/YE)mǶ!R0./Ċ6l(l=15==ȡ3je<=4^^/O|KzHzIzų[5*qR]IGQ959&*$r(^$j(uxx"!IxQD& ᧊H17~O(Zl"M QEH!4O%Bo(2>hˢ=E}@;>YD5?bkǫ};~OD<GynuL|lçy6ބC Qx]ζϺ0!$Jc)+1B[/ζ_Duu}!Bxs!zBHQ"3E̷ G:Xq)`2RԁJKQ"&*E٫{8"1%ES6Fk+FSDѪI4h.= Z3,hf|'$Z%Z%ZiD4bT"Tb2ژV1TQTq2XVSkV=V\UT1Q$R#YqJGKǫA!QJ#JŊ)"N""WѬR%D`ŗ"E'! +(: XqGIƊ5E'e17Jm_nSt8ʝg lvxpOr4Pј}s4(Cfv壝Pɦ6D:.f_ϱVګ>.٫(GCsh+YVd}j5wmul$zOx{x@sU(8QKp|F%DGG1\sQqn?KYT"oDd $9H ;!HK*'#&o[*TCRliBJIeD/RyT܎?R!A]*TԎSPCi2Z:F*N)(Rb7e|J"mS9jxUPR9i V4˄RHuۭ*mqOSҺf|Jho'عGGuUYZTh#rfL>(2[BDUz&G &e-O|9&4m~kQ8_">1aQ詙hշlC{m#f=4`U !l 4<H8.%&&Չŋ\u܌ePګ|U[W 8&GPu6NU1ʪ5ljqiVũ]SkNZ0UyjZaVqS*T^hVTR{ P-R{v*3TԚƍLtjs`LZ38U'rDHB!!E~~;_HQ!TE"W~H` q|ZHoJ il^PH~ a\| bb-H DYL\"fP=H)(R|p!t/n䏷Wg{6(tkw<ɹ<۟'o`|bVml"Hlt^[#FʯmBe^5S8=5m万lxaS$ Q2>;,[BŞG!~MJ]z*#m]7eq wxp4ܬ]2)6ӃdH+d2B@gy,&Q^ÞG.j %tA  bY 1ۄpY,1e}MPT "jʿ] H%.TM,mTFQ ՔrЩʺQAZ Z`{t7?{4?!u!k C(.Ajg.5P5Cya'57d H5@ C'<1Ԫh0Pr繝}`gP_f=Dw쥍K~O( ' 6\Jh!АN0 `+0tLp4Pu8!`H"6$",{(Jp +/̾3oOľo=<|p`6/G֐$H$H"IE$Һ78DR#IS~5"TD")*D:= IDR4,zH$O߆쉳^XDڦQKIiN$"I**y"RD"M#{@:QyRH*sT.E"mKJPHZKIH9H%V$=ʮXz~C2C)*)f1IWU^ JJȤ)g2.:iJ͗)J)b|RJ4{0IV;<ڍ_:z2KR{vtWl}KZG?^gLz0;X(v犝 k,,Yhם돝0MlڙJFfr(s@ZNNbM(0[80# ͽ?x bEr/+{X\ܛGGGGeDeeDަH(#2XRECCwͽ[1Q"F}s/X\{@[^(-w}^5o}}Q7{颤D5^()={/Jʌ %eF ĩ4d`o()3ZrAT̘+ QR=a(z5DIuua()@ְ7DT$^QR%U(zaDI;#JJT6%խDI#J^F%%;,3oQ}o=z䊝^Pm  y#r@I%7RkMQEo CovB 5oRHmbӫSNRB n;m$B*l:ap~neφUīzSaKFg0T63]fh5sv0eClqo@*q`̶Xve&(|٩^~8ap?G!<ݾv8Ȝk$NJYg,x1mb"KRQT`LoHU'1/޻ r5ﰮ.)GY}Dndmo&&&BQ:m ?4H Hԟv?)8Mn#"RpZ q鏂&> N6-1# NG .Ro7`zd30 L{!xLJyP\(0ݺ-p: L8;(aT߱B"gE-?F@_kan.,o=)?9ύ12%@ |YH>#Ut}cLɇLNɇǡZ*Yv%lvnW1'KnWV6T+YY6T+YGoI`,d4\y3YKt"u).W22.Ȫ-\@RBRݭd]nGeUQuJJVչ  tKVUcΪYT'gj2>25S{,[ )MPupu'^pu,X*CqB#Eq#GUER٪4OZ%a nrkntgyQ~ <r=B9bmˢ,}&\ Ag` Xu)!\o>k*"~O\MM9HW%qQյQGȰqi2:yIs:&;6&vi2dI5[e.Є1cyM-L>IΣYkx1o"$8Sï{$'⁷;?˰&a}-xfy} u=hrWvzfyvf3_n>_O&sݶηl~۷g/3|7K><=_aoMƓ7v?xX~R}z+_[xfy}:av.N~~V9:5e>iL#xyWg_Pf~ڙ~i; ?M?=Gt~e'Fǧ`LӡR›?z.>/{Ԫ*oW* 5mkm+̞ f_YaS^ӑjFIX܆Qxm?.>-foWNhu_wj5Wɇͮ"DEnٹvʳg/ mfl ˑެzRnru>kiW *y >koFi zr|8\_n|5n^^vu>kte9(Ҿ>{c:qn>_'5> ]'5N:m_=V4_=6=OGg]G=f)3,rwY亞gz 5"|-?1pO4qYZ/X,ȵ<|9u|I>\hֆ׃־7C>\`]O?;mlr4|ϳbJͶsdcmc_x9ݖHq]Nz9/",1y #OmbٞiOF|C4_=+)oviW;L@8w;!'0^^10Spon30őx+,g̟X8A<+P'8 B;@!bBƓ"/|F#>,r]g늑rF>\36,r^:3#抌[cŐQsEqső# 1Q|VxAzd`ѝ"ǃdDd4>EGFIKFMOF@!F'D ^*Y/@'=˽Ͷ)M}J$OhYǻ(VjLHTiiusѻ$IֶDRT <$7_OjN2 ^u.t $ $gH?A:Hjmtor$FzIj]II-v ѓwi"'$;)'Rk"AN#hg|xHCc1Byijl?.3$$ FJHCcne·܏wm=+Bx?~p hkDїa%ATNi4,1:zgiW@A@~_ / xW?RMP'Ҷ+3i\UK$7QR"T3;id+&% iY[&QҰkaI48_a;iV*]4,HؠaDа왼ۥHhك-cjаU^(3~ P~R~ON9y.$/$/A6HF':$/փ$/  ד$/$/(/ ,/UgȐ$Ȱ/O$o/甸Q~6`n֗Xf9F=/WX~:_qN>Xl?XafC7`=XG>k-R;|+iŘ'G^~ NϞGeAd)XJ?JsHy qΜJֲRXJ)gd-3R:R{ZXJsݓ#P7xwFIqiCm0˳i%уcx}3o.[x'<ߢKN$xzz83#1Kd̜hrڱ^X6?ppS)*9IOXfNY9xCHqKR78,.q*S 'R oK/rDb XW,֠b挑5Č5ČsEbŀ蹢@\qd(dW͌ˌY/<1"3"%Ccx<5VL|d,wDlwqs-Qa~ӵF Y_(4p7@ёbc5ffdmvhhKJ0XϱgVRUVo^,%VɼY|i ;ޟY ߗY w1,fꟲw]l\|$j0άLQVy՞R(,3y}DIeHe恃2绪U^UZbv+P,v]~f>DDLY&ƫ,AD,@D|)h>9:Z JN'd V-/1DEhD^x qKkaV#sqM~2똰Y3_d ڑ%GVL8gOm 3ҁ)\Jb-Qw$Y7);(G 6Ko|>Pi>MuDa6*x?+>VF{ċRʃt=oZrsc!ub^MLXصZi'12{Χ=(%IE-_}wa6O ki^ﺴKQr0| | 9gGb0\' _ZO>SO'L339~A B ju a51М!Fp #`d [=0DAK% b\jiO9@AgԽqW^\% {< /":":G| qH-mZA~; #g1c JU8waNJ=ˊ\5}_ ~/qI!.R3t3ĉt۔&YR5qbuKX#xpz}?dԋ=^w.c7\PǘlTz *z T!*i1*YRZFd#6֓kLZEz?qۣw1ݶ͉yUP ˖rT119Qvޟ7BRx>f2\gv"dJw>ft0@61+ao:>[Dځ x+{ tie[:RO|iFW+O! w@F SzQ68+UǨSTk<ʦzAqr=0QY#T]cp7&&<wF!V=OȖ:yq+Ji8Q9./3kLV\kg/}$>7|xC}*}:cB"{cݴf9ȍ[0+_ ^<"oD;yc;2 c[9+Oi^'rfn9O^Nrfy~9O sG+fß}x}_q?:O 87zNy_|G9̯w4ޑ_Geۯ9~ݑ_wS_Nl|x9O3ݟrs endstream endobj 594 0 obj << /Alternate /DeviceRGB /N 3 /Length 2596 /Filter /FlateDecode >> stream xwTSϽ7PkhRH H.*1 J"6DTpDQ2(C"QDqpId߼y͛~kg}ֺLX Xňg` lpBF|،l *?Y"1P\8=W%Oɘ4M0J"Y2Vs,[|e92<se'9`2&ctI@o|N6(.sSdl-c(2-yH_/XZ.$&\SM07#1ؙYrfYym";8980m-m(]v^DW~ emi]P`/u}q|^R,g+\Kk)/C_|Rax8t1C^7nfzDp 柇u$/ED˦L L[B@ٹЖX!@~(* {d+} G͋љς}WL$cGD2QZ4 E@@A(q`1D `'u46ptc48.`R0) @Rt CXCP%CBH@Rf[(t CQhz#0 Zl`O828.p|O×X ?:0FBx$ !i@ڐH[EE1PL ⢖V6QP>U(j MFkt,:.FW8c1L&ӎ9ƌaX: rbl1 {{{;}#tp8_\8"Ey.,X%%Gщ1-9ҀKl.oo/O$&'=JvMޞxǥ{=Vs\x ‰N柜>ucKz=s/ol|ϝ?y ^d]ps~:;/;]7|WpQoH!ɻVsnYs}ҽ~4] =>=:`;cܱ'?e~!ańD#G&}'/?^xI֓?+\wx20;5\ӯ_etWf^Qs-mw3+?~O~ endstream endobj 598 0 obj << /Length 1890 /Filter /FlateDecode >> stream xڍXoF _!` oװ>ٺv֬5,':Y}䑧;YrRNwC<%U<+UnabF:A?I+R7qeJJ4o"?# >\ذ~cŕB7Z R H,˼$ vO3Y.M/͆67+t\(a| Pz:CR -Ж3Gd%~M4U~ܶ4>= / \Rnp!C*0d<HJFjv14hzQԈ93aggt2U[mlZq$RCc3-X]@3q9S [Uko~{4Hgs<.SjyW<"g7|T<>\zD0)Ŷl\*v3&ZΤ 6 )3^^ESӈ{Eg)DFg`vi ^itI0Bi?Q \d2ւsT; :w 6Td/^›~w+L{Y𷰲ky'nxzj:-{qF7}=J`%|z D)WeȤ[sߖpq6}0TW$!vG[%E "=Sk_-64|=tIybie(xﳑ=2 k5j &L$28ޖl"0O5<&hGpAy`yB-sd'Yx:Y+i#/uF NK-k΅-2f;_:\lA_heowAs"֚j Z ~ѳLVÐUZŤS磰;`\z]q<掗>:^ K~pnbʹ7NizyUd<6 >fg#sc^>1۶pmۍZc!M=*Gw.okt,bs5a"qkKʳ`^X6Z23=aTٸg;9\[{ʊK6C59ƐK/`*93<&9~dМ) qX$kp>)soQVSd\/{E~Q'%+g &Ed~, jZ@3?Q|g5UŁRx%Y2āzHq8PAնlVs>>C5/y9xNj^\z$1pXs*q}z(|Z:85%_c˛\{>O>s A!!X,7'o'XA5T@<0^oNRB,> stream xڥZIsϯP%dFc$/8S*9>`@b$dIyk/ $OF/򽥑^mҫo_}y72iҤUUTIcՏ<_|Ti82Ina aի[guQmsh$eitfmVoVN9w<=;;n{lcI^{|-!ƞc"tʊXI3BX!'3ubu~$^tJ7*'~SHaZY =:sˆrbKG/dܵeꁠ&eN(|­1xu>"! Z-lL b[8G~Oi-dv* $Y(j)=l{a5菃Cx;K|;v6oMB7I%_xÚ]ho0*xx$z~9:'٢N6>.)ݸ3d3! ր+%(dx$K;ݐ~\_]Rl ")L =9~v 9 u8~hb^0h@|ppDQ⬝J ΏBl*MK%Tt#&Mtfj%qFC_Q+m)}ƺĠvu n۝ag .`ZQ(NK0|ay8|2'UUM_NS7$MhAh\4I#^bpc}κړSQ(T#{kx >T$X"< /RšEH\HhS3Yqm,X`c+RJ`qRID FA"^ M:TQVIuV' /8g2|=jFi L˷$K|u+D>@W2Ii2P\uR56dPѮ!'s<QϞ!?=Tx>"lڱ)tQ5l\NO/N U9%PdE!G9k9va /5gOCFx}򎽼ra!m((q6ͩ5Nwe`0<.~TI~H`Nڏ߲ZU<ɱ|c\A0鋉)I8H%v6iS &ʏp>zׅ'$yJ65Fi-;H:@J_MO8p+r$4- ]F;NUaz]n䠒21/"аF2ŁA&rM/p5K 9бG(#e5gU?hsk$f?Vy(Yo>+hX)M$%W j{ i ?Haq؜BxL_& <-U8zj;է̹@u"lO`B)KAF߲I2g)rȫLa];[Y#;~ik)K*z -UhDi\Lo]zTs\Ie}: 'jw D/ uf2`x$/j Pwꖮ6ݏTQ&b6EKh֕bn452~o UG9PbJnIt$$OPz\eʼn*׆Ew'WA)*kҭ_*a#su KBuHBZEc# qΖ{E5*79|MM5RvനVJKCml q˿OS:Hx}H틜 lAkq[MŽK@!ӒmzBɕkc}?uœp_g'ǃ*QG~j&@pRM`=&vy˄.u7k5 m1xeq/-dmrs?ġdΔY.F+3H!Y"_ D/6 &J_W$<߶CtW22 S6b%L/@1b*`P3yDɢ$\`:^ea1015-h*Č W' i |ԛky^Ҷ~ 9NB 2;v?H FبuD~F֍ձ"TIf~ d $зA¬.Hх g_2qRq ᚾ;9C&ll/ʟ]-/kbf+6BC 59|)|`1EsOw(Rx7\/Eqi֑;R`<pԎ];i'`R%29ù V߯o^ \ endstream endobj 613 0 obj << /Length 2212 /Filter /FlateDecode >> stream xY[۸~ϯ0ڇ#RE 4-`t ڇ}ۍ=JrE{ύ]&qd:$΍<ExOϞ*ⅎUWzq{y2-PU-n7߮nuf%I|*2Ų鑦Wn;$8w_!% ^T}q]t節@$KTZf 'fH,QEds@Vd`$Jrodٳج/Hס \dgH>-8B[-|?8 -܇T(rhANi} Z8&SyQXpph "{kt O\J[5zDeiRgE7s!؜{)aCA W(,ܟOHmobzKcxMj=,y0k̗M gg}RF[1séOq1OmFsւ;w:zlH9\4ʟGFu%"7X6blcWeu&|^IN_! |ޅpy|n 0?IY-d@q@S KG?=$ oaN^}HUG T¨F:2ZA~CV=Խ?qdu`w9*hGdS#}>&Fq[^x4 "v亲#A:pV-x@bm= 95+?3;dN2HwMq'~ ƞ #`n88I4EUaDv =GJАҳ(cpzdpuΣSl6h0i#3d*R89ZXJ5ϽVR|w\{T76m CtI"'ΚWr_5'Syj7*\W֠^ 'qLRL,0ڲ+^|l+-2Fjή11}CBuJr=?c3%Z෼ X>ruϿ}P#6MexQL;~כnRgB?9١[d};g}<-S[ KQ: ? liޣ kEp!B¨5n< L)M DabIq*Z=̗7TV7ƙx~39tO;vuzҝ%G27,%X G֐MZJ4lpg3diѝw J8:8#hsxrۭ-Q+c } xHtA\>ɏ ׃g6~F endstream endobj 619 0 obj << /Length 2177 /Filter /FlateDecode >> stream xێD_Gݸ_*.*P}&h8^z\s&q  {f6g&h1 F?v0_e8^p_h:}lyӗy ObMAތ«f(iU E8C9 , |zǑ8%)2XƓ$wJc]gb<;oxZB%~0V4}ʬԛ7\:2GQQi~ 0[#yH"ˈZ?`'aA.Y:Jк´”[Tly]\v.j?Bh<aOåF\Y/z#raVsöC~HTiY93vT N9B)r"OHspԦN,Kχ9blB9KՖ4;^$:f1$sJw46E'e,kU#N_0͏UyƩ~+ ugiZ53/T^qSTZLgVr#n Z F*0 zÇÎO @}' BoVq(5f6h U;ofBfF1BWVZ tT1ZXDg߸-sq n煹\).\r9}`*A\Weo.3N~&X!T` Դij~ `;(ZCݞEqNY©O"iwx"'I i;^p0c4phŽ$ObJ.a)dG'@鳁 uZns{6jδXb͚rF6)Lao2mSa ~ 0XMcHK ң\_t2 )`6s֚z'%a9ZX%, sj-`3ؘN} Lօ7tnkj0 _406Q!ؿޱ{clgu1 3*2sҁPlH/dz^ԄPus7.P@݄^WƀpC|t@/mBKA:04 t EB\&J8 #H#Z׸`P ӮHz9@"l 2$yOiFneE=;:Hk$60}ύ5C0hƮ0!xSEE`D^1Mj>͑Y+ي(j68]R9jdPmg$cS%xgKl&qW[kI- Ʀ n`f O`@aډ*FvZfrH ]ojtblnFl/sv= 6]2՚U.EUi1ylW|7?";q{q#iaqZ}ńz/$2=_sPBn,C~{Qmt^B%0ZauIm\jڦ7>5o5>+({uuCFL|*!_8d;q4ZwH6N20K= J:w+& ^ ;ca=7+DyX/! ,u8sNif+mkL2n{@d,(MЙR =J6uLn*2 S;o2&޼t·+uŸfsT\u\v} /uƀ5xRZpqnad#u!tAwɋj8GVQ3tKWCSoG\ endstream endobj 623 0 obj << /Length 316 /Filter /FlateDecode >> stream xڍQMO0 WH4krpVP2Md'ir@BU~ysXC"AK35h6hw,R;vCth|BK>]oX@bh vgNɶ>AP7V Ny^JN,W'o[əSӓ1셁ob0f3⸃߭ 븁9^Ejs0,SJғtG"AzH6uXv7^Z>M)ф#s3DzA++. endstream endobj 616 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (./deSolve-err.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 626 0 R /BBox [0 0 576 288] /Resources << /ProcSet [ /PDF /Text ] /Font << /F2 627 0 R/F3 628 0 R>> /ExtGState << >>/ColorSpace << /sRGB 629 0 R >>>> /Length 1299 /Filter /FlateDecode >> stream xW]o5}_F(㯵_[RHPJD%4 sf_J{izDZ, C|~2LE3Z d7߽4.'gsF^q"{z8~"s7Ôxwf?jK\]}U09l8KE`Wp.o:H`kRpV4n Atp#l&!/HO#~q!IJ| ZF_#!zj>zΤqx=|<|<Ͷ<|<,^2Iz?9.jl2Iy ^r!NqCSuںt~ ޚ˃pC-i w-x*i7Ż+U\]o~9W+oWC@i8.8sW wfv77;Y5rnS鈹&PFdd&pdnUMGL^MNؠuYBӨ-Jr-UvO.A^Ea ޡ륖;{X Ěk2XZ _s7)8!'l*y?w;}f3/nߙ۳fwjAِ<|]zިeBb<{y0Ai7ƥO G6A4'øNLl(jx D.lȣb o#|ɸz~&p ,6p݊N[\U'-N[ˋR#鰿L|lܳCtGUhX(ͼhXX^e 5Y<}:t|X'<z'/gke{A7l ʰu:E> stream xwTSϽ7PkhRH H.*1 J"6DTpDQ2(C"QDqpId߼y͛~kg}ֺLX Xňg` lpBF|،l *?Y"1P\8=W%Oɘ4M0J"Y2Vs,[|e92<se'9`2&ctI@o|N6(.sSdl-c(2-yH_/XZ.$&\SM07#1ؙYrfYym";8980m-m(]v^DW~ emi]P`/u}q|^R,g+\Kk)/C_|Rax8t1C^7nfzDp 柇u$/ED˦L L[B@ٹЖX!@~(* {d+} G͋љς}WL$cGD2QZ4 E@@A(q`1D `'u46ptc48.`R0) @Rt CXCP%CBH@Rf[(t CQhz#0 Zl`O828.p|O×X ?:0FBx$ !i@ڐH[EE1PL ⢖V6QP>U(j MFkt,:.FW8c1L&ӎ9ƌaX: rbl1 {{{;}#tp8_\8"Ey.,X%%Gщ1-9ҀKl.oo/O$&'=JvMޞxǥ{=Vs\x ‰N柜>ucKz=s/ol|ϝ?y ^d]ps~:;/;]7|WpQoH!ɻVsnYs}ҽ~4] =>=:`;cܱ'?e~!ańD#G&}'/?^xI֓?+\wx20;5\ӯ_etWf^Qs-mw3+?~O~ endstream endobj 637 0 obj << /Length 3252 /Filter /FlateDecode >> stream xZKoHW{XPf?$x8/ې< =(liG>+L4A:ẗ GL|>%_]o@S4:`FL\~(F,LMKErW#j iduL[皰Ҧ'ů' $uo ٶ=aY d]:Oxk64UwzϦIt`N7-f}PoKyx A,ܵ&TN7fO"I70MM !RXpx%{xkJQTזfdcbNq+'"ÌaS )HN8O#gR֮"^|/kAdePt~3]َsL1R]B_VZMl84 K<0q# Fʱ1 ֈ*Bc7Zb0O r;",8&̋#t+\&TY)o J3#CHJ+r}YiG yNte5]@+@;P+TJΖZ tG1 <GHͦ.icW>efsL`F4 #bħOiS͞/+w;Q$Gc#} Be Adks+`T4'?t F"% msAY/7YrA/,Nt, |,C).Nw4ꄫv-NrVR45KA96f9 EQ@,r]xLS"Ks?B~KZVz&&aPF\091vζ[hK&3iZGkűT :j>.2_>p7BL0/KrDԥT6\&"$ 5)˷2iRɬ٬&}ȷJpD5gF\/cjV^Caa7Cd`:ޗh˩&ov@.vᾍ 0Ϥ|O& _~ #:XW=$ս"a8&ː鮥yUDAVaTX{42C@ghi iKsUDHT,u%mM8[:QNu NQa}ߵ-ㆊpSLBR(#7"uu,T )$ju<,rq5 z}Y%-CZ? ٨д@-[HzUr ZqC]`0 ZΚO+`#~ >;WĆ 6PDjfaZ\^Ʒp9Q4 [0icgJ8&ɓwrݜ(P*&*C5at^o Jl>+A}z˸"~P;eG &MY ^< p]ns ;0 &S)eB(6q.*JeQkNPm)R PHi+$l|vl6B%z  KWg#g#i?tnДf2Yʪ ##$sJpCٮVJ{ZW-, cγE,_r<}\o$l 8oTPQ4FZո k~a<5Ot(VfNItw% z/`T{|m;~IZ&KcpH&Khj+ cq[&0Qdp)- ſx/{}ΣQ`QTă U.LjYA61z=*  ӎ~H91&#DAc dt%7ḳ3#S\pW01e Z,m|DtٮC GR?Lr.>O)W սI֕N:pK>/6*+v4Y"PHcFbc#(d/c;y]KZao.eRJd\|f/ :Qxr?%3 endstream endobj 648 0 obj << /Length 2239 /Filter /FlateDecode >> stream xڽY[s6~ϯ1axl;nXJwv@[Iv^dV>P\|GG^NhUŒ#*1(K2Ud406Q,Ʊs.@6 ThzW?ߏ6_~fs/lE@s/To_ם)'pN:/虖oGfDi3 EJ+8.-4OdN%Vrk~ V]B@[ {ʓ"([RI{s|”8hRxЇ7It7%j_է&wE/غB4ƩD}Ƕ6N@X,Km;`c!]2'd;^oRtD M}$Sdplڐ31QX,ӵ^Qam'?)4G=ZII']"Z2}H0L#%B},o.;M2e8ICUW:*kIU> AE<_dylb8OFg*Z K|ܭ. ޾5HT8*´m1[ɵimzMPfӂ4ҷ6$g%4rVXD!\!tfo58+pA⧨V(r"LקC>9 ]6Z3 `!ډ3Ҝ{9wڟ85YdC LeyhAFV#4*$5j'*B^& 䌟 vȢɦ$XKZ4Fk2e@lo=Iz[Ϙu|nkFA$nYpCۤ1\/ڃ^Y@h#M{)s"n CXvsPS|mRePPŊ{ H*Mf+q~24qpF,Ow2qͬf84c6cgcH& rHTe6oY{C%|lI\O ' ٷfSʚPÛbK:#(S'А7PI^)\`-&N&pi#Ⱦ8r^ۭ_lđPP/!rPɹ}0+I^r9@)̽D] ت:vPe 501H YlJU#*iI)2B STKFn4> stream xZI6ׯ-2f'ALwa.IR KU-[rU`rp{T.ٿys[UdJ nnRe""Ye䅜v۷^v[y%!3]r}qV[s7U9:f*_?{l>όC3YI^ͭ5z}|vw1&7ƂXQmB8%7>U*N^OسJ5]U479֬ui͕6?>`nl7ڪ݅Jm^qk}{|yj;k@5\VOpfo>] .sN ]^VP.„2Zn3(e 7ه Rx YM-[d˳%^b#Nl\ BI5 z!tfEa nDbȗH] w*ڐ|G*߶[V|;r=jO5`O,_Лtl3tx>mɫɍ7 +# xsHjGXE::,d8!1mzK\؂WH'/FQ (|jt UXOȎ붜8_'?%6hKӖ2ЗF yCyxo:fCQ*rD ^a y9WG[Ha喉#WG3i8c$.1k0 aU\!P:~5:;=?V }8FR1ģY9hyIvu:>eS6EM_b/(&#:ZrMLWWms! $71.Kh:Q*\Jr.E>9';]ry "C&Pz6N]gj$ \{ipvBu13:ڶw8UozYh:ȟt)^f^[G.`Wȵh.N2-*Նif vHg0N &Bpf2:*|caJ #ZQXxWM(:ktn_DM^XXDDJ^sk:2 n) 9e!vOˡQ_d[ZUFъɓ+ !tr+iaxN kh\FBN lw)ks. o aWP͕~UAr!8!pZ;q*'TdcDQ/i_I"6`?c[F߭MQ{VX@. tOE_䇧:2E[;RյDkJe7\]1NL)SWգ p.A8!.Id./},!zOᨕjrJGCW?D>OMX)7_S* ld|>!OIFAk3t&S2TBR58V\ |"`7tE6Jb͏DC>))D^<W;Xy0 Le:Q|{ "A]ǔ`ػ꽬 I횓}N *7// HC&zwBswBY؞`hoN;Ed,tMP> stream xZ[o7~ׯc`o-uc`-,ᇱ4vA%iwF-Y=@$߹}$C䍰 ?Ihox- *44;F~w^xewC E4_+ IʣcDRRo0 X&Ye`4[//xJڳeW> : ;+u< Ā9Y1 FEx>I/ѯ/յXѸȫ~9<ΫB9~kFSjQޣm-gq>Nįj4b̭VZsiou d';^U+ԝL'{OC1RTn~v^xS35nr}9m";=:.=|\kc6]pҿo>__u8(v E@J@3$fʁS\sq`p8,+`}~q3Cv]uJ/2$GZJ#sd;8Ro>\e i%K-}Ơ+b JRr>Ef}$-m f긆 (_0%3P*2a(-f=Kj:WkN,G *njbjPKᦏYڰ榖Z;[3~mZm3|G1h LIOU5ze_~g/SoB}Uh"J-vN:k`4BWAڰb鰨dћf> W^1ɪ)E?QAiQ=NWȂr'gzxol(k, o(K*JI:lCYX d@/5%K eֲ f4D7ɂH e3^tp2p=rnwF`YM(~?\}%35|)J!$}(Jm_fJEXvHzפʫIy=Y_pO2::P+AC$ENS3|dG]Rs o*~ǃb\pBA$ZEqPG1 l4[H4!R֠1'rTT`/Qq1C+#}kk83̹r+Z!^cUݳH>9TҪZIGi'K\ޔ_.(bU~{]sey $4]3Y XD&Fϙ;ΓD# 2XdWbAks|XBi},n+= Q endstream endobj 660 0 obj << /Length 2199 /Filter /FlateDecode >> stream xZIϯ!J|Qʊrp|R" h$z& CC"J<|LƘ'xl'S4+l={#c1L +bs:2K+װ@Lb z N᠇T4ZM0q겦:c*MB@P,79--I.Y:<#﹣1Ը#kua'd/M,I--VH#h^!0.vؖe&)ضyS?xLlSVY&4ܒ]/7NvE6$Dq5vֈLzb_53?^>7q, :Q:ѪXUbp^_E{ݓ5]JN?tArsA_i_K&1yqn#gܺ<oxO϶V㨩*?0\ '!} pyeȵ6"9Q2>0@ɀ FN()!Ís݊p$n/ṄP "ߴ7@{Z!x_X;UԨ$,{EU7+'tѱ8?3t.CzHU6)?ՉI%}XM|_CpbҷفG!}!9F@.qZrB.|;muD_4r-g*=_4m(V6\SIʯwlW31PJO0YFD1Mk>Te_㷪Ottf*>WC$\=<-FH$jcjY;xKGcovϪ}4C6O$pI]l D0? &UMfpg˗.w1AJ"UVQw?3ʤɐ 6B5NUӘպ /$Y*u[R`DJjm^|:ے9l\G$ TS#qDB!P?'qVej/e{4 d/BHX?xyWx'{ ɋFtnbs !ҙI>A&.UGWGS}V1{ӯҵf8Xi;D>"lHfay, R?N|  YovA pa0?يSD@z;=%dp|7K {|D'ϻ.ɕaW<"peh,@ra2t5vx73\eR.TLn)US'}ۺϪ0Jխ(90맟;B endstream endobj 666 0 obj << /Length 1170 /Filter /FlateDecode >> stream xڭWK4WZaY.UP,{8ΣHlVl'cv-3Ywśw2d&ʬr9y!JGU>UaӛwE6*0Dx_NT66 +F ke`Z%2nৃgh7s7Iou{zgOIRu#~ƙ=iX\J")̤n}Ÿ-}  ']ӑt.tVNAߑf1} |:WQ H9b^z$R?*ր˲gTjIo[`6pw1G5ѩ?A4/L֒c0 .{ٍd  enN0K) 7(ozR)5{l ^BiaW+`]#}^mo ~NR#gKT-ΒtN[{}*nsb1 HL'l$5v5 Vs?Gj޳y`K+y8g*E>kgλd)wgQ_a=ÄT&L0S&PVOKَڰnb.VH(&XMnD>,ȢC]S"c(e-~e YCPCN1L?WIC9. Tf˜AW"e1XۂLJzrZPљv|-m==fxOuTBgUe) glR}m UHQp 0w'*99g.sAlwZd"oUO`0-v60<4>RjRm&}L3xY<`>ֶV'=RqmFP Y ' ^mk\3 ];Ϳ򭥡# ڏk~7~xŒn )`yW:Ί?>q[Ybλ#B{!Y^[駪 Ġn0գ2N̾t.jϤ'dP!802Pdf \C0sF0}j'8ɖR` k8lа[ҳGѣ\m_˹&hMPCT%Cx&( endstream endobj 694 0 obj << /Length1 1582 /Length2 8576 /Length3 0 /Length 9617 /Filter /FlateDecode >> stream xڍT6  "CI ]!ݝ00Ct7t 4 %!!s9_֬5>~aᒶFZA7.7P &@>n Y%aևȺ@n29۽Pv@|(HH"1D0k7@0"]`vnisB !?ҎP젎!`8@ Aݼ+('7ѕb+ P5wu#θqv0?:H7O p/ P뽇;OQRh8Ai k67pyC @N`7 a Un7/7Na wE=08i-s\]a-s?ey,ps] 7ϟ7@z"|60&ݝx0gw_&"dP7Ďwx]o'?8!6M@`6WAVP[b͟]`^=@'{zY#p_9}C-Y?;['#p x>ha/_%  gcO`w,u=kHn B@TΰH)Y`G/{Һ/~ kjsiep)@a {0WZ+~j"]abA{BG@ֿW@vq{_=7<۽ 9? } xDB0G$ u#a G xF;xCvNv?5LA { {kfwGN? Bpf֋iOgil\>3.ݯ Zr9N"_g=y0CV˵Ez ηQ򞑢ϴ؏t6|o}ޣ+39 h\x~Rfn0lj]k㭠 ͛qXI|쯔 n\X^gĹ#wtʉ8~|>˼q__,TvP1QSҢ=Zbڧ$ftPd|lȧ*T /5)]Bʹe0uzB2]uSz,P2Ej20[FZ$CTkO:v9x/Gu=%J4 +ɱZAeDs%ѐiZ.{o)U2y2X{꾷CT@݄yBjIѵeT쥐"y~knuM,O1^_@[e0 l=ـ$R& ?>M`\5w~pZ䪣no]S` IR);妗|S/Ph8#sV+Yơrݽ{pUvzԇeƜo 5?k`փn,>>X~ MAq3\#(u:v(Zin\YF$kQжbeMFx5k&^ ,L`12#ړܝ̇I';pN S'T/|[D2VSuOqvbG9Ș5$T.8-30Qz+2rX! ,k-mCg%ܷa?̿l{ _Bh3 1t> N?B4<}^z#'4*O:k\|ֽSߜ(D;t"\ѩweʦu9ibAfnhEj:Y=qo4!/R&BXvl/IQ-kd fGT;ؑe+ ob{UW<ҧXLI)ie:$)VXQSۿ|< 91cEip.K"*lB`zW(nF$el 4 n~0Dm¼[l U) m=TbCӝMOE$Ѥɦ-լWXڧ3!b2ʏ Dm޽qbI3k i'<*>b}J3 H'GZt496"ČӃ!&7o=LU:C0:Jt5h|ZWˏf"j&NK: x 𠆣˼?XZU=[CtZߡ0BuwcM@ s|v`CEޤG,S;\s{q%[KzЛK]mԕi[Mr2l$SLFwlˆa>ڝLK _ruZo"O_/$1L(+]s2nf۴0Mw!^5C8L+GZb6mwO,|\8 ?ՆER 5ly1y\5R<  v{_< {zP^K''\yy sqR!@aot/:Ko O1(EF+Nj U\m} " +^no- e#!741{8' oier^z hxp%d@A9G! ۸Tu]||*< 30Ԟ3wYChRRMVte~Cp3 y:l[?n34EC{J?){rQQ͓gcDt!6ş  ~t;vd4k ^ogAL35(zV1kP-rBpH.&y)Z]ywVVtض;r"]Tϔ8)"؟z8H$W0P*OK {BAn@V0DFC_T+R5[v0CC/ɲ&UT1ݍ3Kba %y/~cM[g 1=gVrJ>.ӯv:op*IVګV]< z$ǂq 6.(LisWr:55ȲQ&Gxb‰ FRC6La|+N]ZI&2[\9ym!G1JbA %=nMBZ)G#J'bF\e&?|eNSw0D,<+O͘>ļOM{J3Iu >szS-bHý+́o,Ã7>*M:bXg/1j6>o1mmV; 3nNE3xx*\e!yhS33qHg%N>KGF{CdD^|VQؒ Te ~!,Sux~{z .=#Ƌ1 (%& iӳsWDmd]K-_۱  }*kyܙːza%K|-=O=ϝs85$r⮟Ũ`فF$wy 't+wG,&G<4fOq/a+z+>Cii(vi24O ==mGv,H鴰M^4}~8<([~##? hSe΄3tzP)bQFd$:3#ג2`?fH"n#PǍL=h\oe_lNiO Fz:E*GB'6Ue._q+p0(b.E" _(0ňMGZX2MlEݢ@c@`FlXT9`"b됏IE;p\43viY^M8n]h z37t%O||c`|k'Ɠ3|eB]R„orp·M;?M}J9_Ht N* עh}V A6_{´) *ײs~HKge+jefvj+6tbK/lg&A@c7){y}M(Wk y'QEmECr"ˡ}钑mI3P&jZ :*ouˣlP vYpcRBOQ0)无j@fgư: <>}1*`_b BjGI FGNz2t&M1NUmxm:;K ԉ2#65w˙fViqU9]SaU4ݤO82dWKQl!#)o;f#E}A+[u^kk{i^[^[j/?;c~  L"3DzLG"(J%dR^1;rDM 3`8ׁP8_%RId}y@Z]+z]EbTǑ|E v 2qI#_!ƮS&tk]T˴=KlcO+ػY B[)cYYzmYu0 .ɥʢ >fb_o}zjͥ(H3&u.G0Rڦn+~<;y_sylzk3iw¾5VUX=̤cX:"`NI%-Dcr9~7Y~%"RqSQ>gyTeGWdg+s~V>(Y d$qaZp؞"1㫦μۼG#xqc/yF vD4 }JxΆ>b-P (|`[u6U2CĪ"NU !#F[$Nf:}%7TcMKB"}XЬX|P]c>23f\0ZھQO=YͭTzKw"hdj~2qT{7?̦ubEgV Rݗ,:'sAhqI Z~*LI=%܈R+ 4r8||߱ŐIVg"VQ\4y^. SPIDͅ: 4&_Yd~:8!"j;(#!|bשёK]䔃/?\yOKc\xv!Ľ|<@!qa7}DyUS2׼9Ń"ڥUibw3ثtw?1L=;JYm_ڰ¤$d""K,b]Iee˳X0D-\4z}YDi vcoW-eǛ[EUY9RR}5JIk 6;?zRlv2k}0j垃ӿS5jx3K r/W;7,y{['2Y<֢(Y}a Td--Jq ڄ|" 9QrЎsIQ {ﳎ 'WIW%5~<ǁ2V8UҌMNоKзaE#ULqz\dFnxi,~z ;_qAƠ+gly?p[:M+p瑤]z[cKN4FZ0hٿd4*p/5L~W"<ϕa#D^A:4O,.ǹp6÷9v*IـZXx،J)PPeiH;1Ãc0//y*&_ ll2IRz.$V=+LҜS"cZ.yt$&va׹Z59eqh7̻{ex£8{DsZir26,Fc]g7OWLBŨכ7{Ҋ 4їO/E1 0A ۦ69NgxAQ-`gZI7u^n յ;d,㫏w?kE+δtg4{Şq2i0L!ϞW^TMO=5JBUo1g[a4pEh qn.H%|"omraqgzYfLX'KM>32t۳MP5` (C @pv%=kؘyl\WsOqOԖ>u,7#(|,=S21@CBDMs|C9:Rno{%&1nf- IQO" VP%4\bX5ٝ'k 'AiآMF}g:MX|OӞ.Nᄵh<:%ΉMGXx[ z%wDI2$qso&ڼ$s6Vzn,*lw~p*([}#?M~"s ׬MX 3${vSXKa*CZStM9O|9%_lZJI}*.̩wuESAٰ݃sGhM %͇}>^}z5[zHr웵[x$j8\G3KLa趐<s _a; .1Uvyyu)X T A$kOE36-dv|>1Ϯ>~ݳcaJI>WnwtY|%|xmĭ {t$z%e|~B>t`yrW^GY["TdVkJ# rr}jtJm{,\qկf܅*Xϣ_43؅gnm{^an|xI6PE{g 7l΀ƎϢѳkr%q)]ڇz}/;LwfNMSb/,ax+رj{CI7O5_7μaCZ=5ٖw=ª`;[L]H8kً.!K_"'<9?|˃v< st~V4jr¤τ *x`MQ"*~jEe|8˫Z~$ژ) &ӥwݮr*jc}!1"bP+c֑e b?;8NO8X),,O dBL2Ы^]Z_u1DQTV;󤚭N]?4VٰA[Z&\"WTҭ~|ҔyYHr-:Uu=:I|'"?3X2|V*hf\*Cꋙw) +"q鲵AUvZ?&" 9v(@ҏ0̓LQ2om;ܿy-t>=B>2|cί5AvU.,ލ8\8a[꺮ʹ5m3 endstream endobj 696 0 obj << /Length1 1862 /Length2 13689 /Length3 0 /Length 14848 /Filter /FlateDecode >> stream xڍP,ݝpwww;!8]'-}-hg$j "f&@I{WFf^6 3B;&_b@cG=@`eef23' nneP`:](,,]?'ڔEg:@lejlP0v}hjl Ps0zO j~KWWG^&&Fc;Fg Az%@tvhhl5F8 _5sWcg `ke wHq7:>N@r,,-wL665us4[J򌮞c{?m]>ݍlM>n Qtw.V..VGk7sڻOhq^L?64쭜܀2|Y]\ij^?,?zqtp2~q1v\݀~>v/caYLVpT0w2ȏ?f`oO#fQQW:EE<> Vf ';([_2~(> P#t=ffӏr3*HO?_?~c;+[#> `Cɸ삈Ehljj\khV@e? 3}l?]#%M2֏ ;;{} q|X> L)pLC8D&".?d0_d0@V@7,?HY ~0e/L ?b??8@ uWc,\Ŕ僋?wX>jj ǘ\=1n?:~d0֏^ th%s? zMVLBB;D=)2i|VܞhjsIP 5AGt&t-` O40 9jـR8q#)?z Jy6UM/rV1i(4]!re EDqk-7ly[6kӂF:K/.9!=,q,O-<9M\Rer@t|lg[MiE%q#OEyJ Xa.UZ6]WQFor/Kє/\'(JY)y4sMUE%IB? 1bݡ߅_#|m{rc+O(7\]$Z~ø A1ܛqe}gKiJ/Ê-tQ=*żaB5l}NB0;$4}Q!rv~Tןfr 0$ u8ms+Oѵ2`56~Ȟ}4yUߟXsX12LJ^kY+}z'Uҷڑ0De/aK\ud6lQg>YFE@:'yY:Y]8Or+E]@=7,kx~d0'NhM*SI)2͎'aw1VF _"l 2V6@*mJcoYu yJRCRiUkʏM&6uyAU|fBdt畄` >OOj*H_;^(qUbBCxv79mqMx;ҟ1}"ӥ Ґ&nU(T:Fn`ݑݭѻ~f*J955c*:MQ;S(X 5Xr|M&c-/с݅z= O膿ʿ'7c¼R"Scɺ/ !e8-zlpLL*f>R0 8QEQFg)P6p5l@9r)r6v"N6wߚ[ӥ&ww|u?K`I^+sB7f&$A K9?rgsl,Jd[T,( 8r/U\n8} v>ºx#egaUng9 g]I[Q}֕fKwo끈)b@|VPݟ9+:_sԔ\wlF ˂&RSq/až` !=2YɃ5AmqpI]lĚVmɼG]ΧP*1 Bn+:O3 &(#/eSIaL5uQOv/ `ڈ{ CsYeK ]n.C_US/$ZrbYcEg]m+BQrX=cl,!4AECQJy> Ewsާ UJ)@v3j-ń=VR,'hh &\#յȕ=@s 큝=5F@ox`@9τ;pmVq1K)mt 1~;3f3|Rgh~3ZyΒ\z^ǩ2NUvowDVP@AOhcN\pG%qQdD&<; c&Q``'-yV[H/-,\=&!Wʺ691)ʢ#"casP2cG.m)>Ӵե;Jrt+,l|S^5 xf,Q5s&Ѿ|gpۨb@:D$6pk_H#/D 8c^^>X= ? !3@Q/]֖ږ g;_%b3ݓU"ƬQkr91)LɊG%gDW:DE%EP|F%] HqNNü<SÊ]$'uYЭV!p`G˄TXiNs\\@(dqǗ4VxEh 1rdhW6Ir`[ɝbV^l#mp,#+Slne82G,oEO/ҙ8wy[!wpM\| M}ǘ~N`ĴUcTý;*&N)8_K#{rK]:Ei5=}½81Q<#2 ʷޓB` @S#zj1| Tv nzJK, ) f,LIn謳Y:Kn &~tCcwWfb|Έ鐉4%7^͡$zT+`喅}Wĵb fhNև[hkdO,H9v[T}㢗G^ꘚ)8LdDxFZg!whLokƔ!6U~Xja|91 7(b$O&Tj 4F4pz3(Aʈ9(-J_{R%E<ŏVm`Yui֭~7^b_&[܈`4P.ũkroDh0A;y=>s 4+8""Ogn9/֊Y D2"dCUo| 7m3/{6=#emTdO(nAŌD}31N9]-U$:k rcs}E8#83'mlX# a \id߉TZM5v* w@h_% (zIob*)}"<pȷ5f m8Xd3bA&{΋I#h Ae!~p,5yJl=O9P QR`a{aGVhke(hO>O~ϵ9.7[^c<\k.¬Lvؑ2| ,x]N!UqhKB=~C|3O!a_֜=zOBV3`JǮ,9$x>yi0w9uRdͥ,q.j:uiql]TS:`j[w_TK_x/[P-j,9TZa< I<[4C<(碅3CDmp M ).4xy4L)`*#/a=R|>*61tߍ `q] &KS`*Wթ Cz4tM]wtS[{ L!+>:|.QOH5 Ѹt |E2vmW?_I|{R3fmƙ;o݋poS =fb4"\>2.%RB. Y1 @ ڙ8U괶{ ]I\[LYL㊀3XЭmgHڄf,rb#Z{چ\~M+&d Qs^T7Vkw3^&#JТ̤O<3uIs/KHī|miag9BIN (4 %C hejmr㓼g6_n1`VNǿf4 bP~r4q8'խH@PHvmac9,Aj\{ѻN70Y_B*imi-'"vA0u LMw&'1KfW+|kRBBƲ;^kտ[,o6ja=ޙ􍁜5PQ},Fp7D^ʺi >i^!+~+j~72Oe)e4js8GL=6Eq_7!yZ 8~z@V[dh14]3d;2 ɠd{kev5|o /o &bR7غɵT4R9'9|7ZYop228b9NߌP釫Œl`S)YvyQ6ӁY`,|QїsK?lQ0Fwv/^U =)~0N;K#m\ M1QѠrI*\j==nu8)]S ^nl[s3 "2۶c+7}p7.ݎ Ԡ"tE_:eK3fxbW]BZ91 dԐ=i #:xD؟/RDu#Z2ĤK;@O΢鄧7Gc.;d+=۸qG" q\&ץqyS4%>ѨTA=He"ѣr&voywX810O{P0dh̤g0;A! ,K5~ B56HҘӲ)ɖH%k$.m^ H"yvYBZ,/-|&m;5<+=OyL$0m'6 2y4q@A, &0Rk]c>ҼtpL=N@\seQKFȍߵ"}9T*Z뤟rFa$q֔;H7wd6M|UAPeXr+;L"he#Bڊ4r&0^zsI=i:7IW7%sx.9Q"@ mBZZu$"Ȯ:e ԇSշÝxF^lTo/tԷUwW 酸Aګ]*i7G_FNqB080؇l59jr{(3[>*p| 麹a3vmTnJ*}p2dƦg=P[<6[E_Xi/i PN@FɿC;vPeӥcI Mι0V}+j^-:;%@S8r=p4|tBo=\3?"YH`5H1cXm"ogC YT@loǦJX½cgg>yH8YWU 2'%GB 0(qї=⺃f[zG݉%sf)4~k&)m=N"*ܶE2Ng"}~c}?:erUUѓmBnۑ%-VJʾe\,cwDLvp&(DbxnȨ)sur =m\!ʽRB9º(X)e_U+!)L@¡^RID>gm:09Wȕ0Ꮙc~u[ ËVFvt"ajwTOPǣ/hS70luk\8p~TWP 1v=bCiX:N',ȉsG $=#k* _D85ı`rdl, m: T!dHDEP{$3OLhs7^k71v۱,YQ%TK!4FR!GRΝ4.g1פOl?ץ^FãtW Dm$4do,M^Jaєl836ya1~Z|/\pUoG#ۉ&<-}WHvTtK .'j GNLG']I.ƐD+w3]Z3 x`qUrW0y|g-C{mQ֮"lWFqhKtW*/Lz|3̆G|qH9 Zcbua2ė674 穧Έ}*IE@>'˳ Ԋ۞ |j \]ú̶U_P԰vY?u{0/)[~Iu;O#:`5*쒨 _]Tm(RwQtR/]X5d1,U z̽<jDz͎{NW*ap#usbTNgM`<&H^{D5 xLK =ƕlg- NWwBg$rΆ)p,G 2}1Wi lP&uV/xw"M`ic41QXD_ wT3K+C)27(pvTʿګ)?1N0I4T aK>Pyw^q}+,㺸||VZ@\]Un{GƎ30ޏ}fAH4=E2*en}v,@* iޣϊifc?L.d'%˪dӆGؿV]d}$U =Pȝ۶ӗٱ g|K FX',8o7fh1S6̨'"5g`N__~}O"6(]ZCY7Z]+k]LHpzͅ*Mn[^[w~o xix=4frDYVpI- FΪ˘_<2%/&4S6 m͹!})}6J$n  O#؛=bCԋbnN%Ho_D rߑ" 7 q6Fű~.{dQ0Ȼ@KCPqz(6_}VA.r|%bw,+9AGEd*7S)zKnAah2Ӧ%N0G;J:'iXZD/)y^4r}qREK٭\!>hu)&ł^ֹsCf4z,h0w e$4Ҋ@I)QYq7K&[qֺːFܨwf"m0e v\+0r425.&4qh%߅DĄOu8ˇvr`nė8}uL9}Ry2HiPh fmi.*!.Ҽ5CI/C=gycPVs>OIYi рHBx %vى}'^(c6RQyTͪ_QAţFD>̭ZIc2 CV,ג[t4k zGOq{z` kz*8Ptʟ)yn5ŶJ7*#\ 6ࠓssbƵ5x\_q+Cpe%tUI0o]݅Z 퍴A1Iw?0i|Jg1؉/>z@Zz z]Nj 59Ҕ|S0:S]xpJ_y g3A4M1vIxҏ`[CZ8p)n|uΓ~4J/4nE  & T[ D2;"_)j*7~%򐘩\yNXr %SK}R;X쩴hf1ZmhOy{%{Tq̺CAej!E8PֲGoZ,H8 v-?]}!/x;ᄊ7P(InSA&f^2nCwJo4 QgbMf~Ʃi7iYd߲f $,$՟2ò %XÍ lvrdcK3 ޥr"}.9Łþ!RBwi,mV[*`jO*- z.yOG޿ Y!KDC؀-!dVfBLe x_)=5r`sgOYUd-dɝcE&EW V"VA)%k+b5<)wyG0oB}{嗫nE 4޺J >g'3Z_zG3b'\KL 7b.q9a^v7y6+@i(#RBF8L?m0Ls ~މ ¿M1ŅUr6hkܺbQi2?v7SF3GGJ3>d ^zI YHn:?conINLH p[G=/W9N.j&a_P'TZ 8"zM@1+F:0'dMײj-b-P=\[kfmgҺyX-TkPf>CU%;zjNc?"Z_ Kj9OᐟZ):B« aD-Qsxk~&3yIԻ;Muo;׌JNNoXٻElW5pmQ5 ӤºcL 5V&)TBN|MROcH`F7[HdBN!R$d# ' %+ME@{s^O 5 G\Ʋ} ?;v‰Z$)~'kN0aՐ* )cw<Bye?w@UYM/ IiiiNy'A\HGXRS)V4ܫNc /}}5M=T/l@d%~Jl `Y+q(l]ڌ uE{k~#DSIk aŧS~Yϓ. pCS!PD-]j6+*+­7BPn]X+hhݎ0Wlr#(J?h8!CJ¹$_?%Y50[TIM,iG\a&&0h*qdv@&.Ӡ*Lc=vk3hIk+Fo!Mg&'G:)QѷR! !nS% NM)ET5.O&˝:ݳpMN2!¢_zM().}o F2&$25ksɿ.qD+weر~5t /}U9I4M D#ĝS3z 0oGKhZ U:\^/JӮ> stream xڌPZ CҸh][p=h sg&wzjzmY[4*1H΅ */ `ffcdffPtGGrr.d\m,lN^.^ff+33 xb@7KS<#@ G!jdin?_&4.mAN&@;<dhP7x5/;#֙\nbP9@J(mA.faB l,M@v.v '{t@d7_{Edi/g`fi(J1xvmn@KR$ ]3_52Efq;SQ{[[3_Y:Lõw235 SW&u;KGWؿmEpd 333'yX0@/%_|fe|,@༝n +Ep,,SK1d7~?'K.7 3c#fRTTwU{8 ,63y΃=t=^r)ؿO.@g9M?X?\M_,3po=`M5AIwAmt*YX=.Z4K;_W ޷p~@!LM2VN >Jou4ykLv..|fNp('I/߈ $q +Ib0IA;΢_ `R9UwN?q4E<`G7/xיۼ?v$:&@{"ws@]AnbNh'[x:Xa.G@ߛevVaxw{ߋ̻ߋq~O}brt_MGGX t_p;_#{\,@h{.pxIniD߽^zr;}@ %{OVu5 S4 ޫNH0I4ՙ[NI}({7Bk/ǭ 0am O UfVf  ?0 Y#["ѕI)}@ң~|}"ti_g5,sCz^@Eq") !,-ڹp_LOKf^i ̀X,Hr>Afk UY E~ݒBzW>6 \3 a{Qm5xŴ\4n+k9.Aƪ_x<%b&8Q!h\U] &Sᵄ_)N5̖}eZ-bt)/UߦAdbbg,Y4 z'fe8RpGOHpq+1v2uzo-GR_ݫ.~h*0Qk)I† ,xic[&|WiYm:oJ3t;WD#jQ87"6֫iPB ӳtKvrvO;k_(L;1$c,G[9VNJ9uz _J:Bz=<3dg38MvEBr5ƨI>8bYb ~[k>bc&Nglڸ@i=PP_ģS\\f=39 'ȕ%ȤŁ7_ص1=Ǩ~!>3hr= Q!MCu?;'̐n\Gt.}27鎽@!80icmhzً1W5t{4d~4/)׳`W<3( ~muэkH`dd81:i<76* #.t覑OX`.Y>ɳ0p-Q_8]5j,ot;ČP@VRjg*zRS*>,{B!:, )5*.opuj_TM_Hd `08t˟SY,`NIe'׃:~Ol NLr*AقĔgKp'>[jQyƅ*ܧP`r,ojCsĞ#hf@׈|jF[YiK&jx^mY&hd pMjk{j^y@k7Mc)e xc unD!)Oѝixm%vH>tqN!O O;+&ŵ B%%:E-/.dXr>\MN'v%aDw n?6KqF]"${rg]\vo/&͇_H JP?l-AfT-%YK̮w'³H7Z Sɪ@B:ë] Gd: tLc,’"c<N7b!Z%W,rsKzd>M>qY,B+ zu;&|Un>J`E[sSNd+YH*KT |ɢ QiC ,I0d&-3Sme/H>ᖒfprۺP7>/e|f#[uZQW9Ŏ)~cIφe>J q\A!x94%˯wrevC;hS}yW9͈Q,-og,y.FǴ=_]zw,1y>5& Zo'AϞbz ;]1ǰ];KAGd ~EkBx Mبq*%w|Fir5ҷ/VZPZ/Nx+G 'YrϤ$'f8t$cz1 o?1\cAK?##,7YRgTxIo:7a& Hn6`N x +Cu=&j4i?K0Np&r6% &*R{On5n3dWM1ks',FЦ" 3T밳 .N l(E9E>+#l9b#Fz9N[,[ ~cKΦX(d,D?-c.Ұ'}ANv0z`IOFD7yio(ׯ6ugm43vML`(i~ W:ekĖ!9jAO4Ė9.:` `kO U74`p dԇrujԴBL°"`!YpqO|:ݛ߱zurP!C kqپgx^<.2-s2a^ΡM?"v?nzey; 끩YDz)}$2HJ7D@D36;#! -K-˳K_ֻkF Eqo0T@Y+f]rf0w9qJC@] $mezwZQ:K1oZ(Pe盇`%FRx^x8SlUo}U7O~3|CĹȳ!`{/i7:ށכČ8TM:z' 榈~q{ ߎsB/o#Bo3ߖ>4=T@1وb@x1̅RD4iwA%קAoG…@MCWįeF.Y;\>HXgܮt,jrRV!!a8Ota( βd< G`'.=XiK;fbn,q0IBI0Ɛ4"C 7v"`LTI(mFFa%4+Y`M\sk}IW/vopx.=QB׻uDzq;vKYڨ1L_^җ8 cz\mn{s)hI[`9G/˷1 T P6枱{ O5,l{u W7=8=VJ{4kitlRPSm3g|ߜ瓤iA 'Iv<}C/g1SMIΪ:Oo0ZPEudfPPIeVv1?1NJ.o|*p78 "ydMO`q9vӇc_<3["iPޖSk)|d dE)_fo\s#v+6V[cGj:EBVk }pgHTHpd9cty]ɯ!X]>L?׵aFlHE«|T\~&]hۖ)[BF0Κ5ymr)_*Nf rԩD$|,Xw)U>#B|}yĕx#F\X!d I 3zMGFdQ`1V.E|YS:JzW,i`ӳXlB&e%FQy T'ڻ`oWCPEH]BL_#cSqՓQv7kwCnJ2 n˽<M| Q0 <N< 73"e0q;DXW8V ;_'K&Ys/ñScYYj/W^YC;*SOdM;"eP#5PkZ:&oBs亐'ŞZLiUZګ{B7]\I'CRi iO#@Sv_×;.S e0TP/莳tG{qb--]3\r{D$CJOYwg˩MA2^Ͳ/i"U^h L~Fj<4"=sG~*۴4۲ ߱[?cm ,X-&x)(")Q7j3蒵UE+&lmG C@;|voۖ:VMM斩+sxˉ; homTK!SnD^~;8%WO{ +NY;]ct{JJ%W |:Վ|(*z,l8Cu.͹hfs L04+N̂EW<""9pMF9#dpPE>$VJF)o`NnUMx?Th4 'Ҙ˽?;KEa3+ƿ:;ƽbk(,Tj;ѩHMPĀB v 7}ϕS}NeNϛM@4V@žZ q6w%"Ag(j@%xeNZѽbqH^m78"|3=/#x p5 y{Ȣ.`#>j3 Kt)Trz.zpc>8L0%9pm;TJ7v$#WQbn*#|;4e'cc*҅aB[Ç踘"݉_Plw/L08f RdLl7XmL2^^~hJ[*;3? 85akVc;Jxpyf3K_H8ƩW_׳2pMPŻhРrV~Z.)"S>2q@hq'|yA$#%@-#gF^#B!a!.`8bI‚ALRʜ-n.3ȉo՛PI N) pU9_[d% uZId`y⛈: &VCwGO[@gPN#`+=ګ 'V#C]VցVud_'kw̴@!qG"mmykv]8$ߔr$?gb7"^md29Y5ok@e!-ޏQ>!޽Q، [Ea=DM[|<5>G5eaAؙM7BȬ<\Kj꠼|lnVC9I=?(\q}|ꥨmg@8=UXpm<,{A֎gh\ bp (%n] <j2j㦶xW`op# LhETQ \d*= QI MC%6=gώ&o_i4.P{ f(˨'䂩6QCBR;USh~eދTu $&~>vvF~ 3*InQ!9O2 $y/9v3@饻~_&u}Eg=pHAZ:p!DEDL\O Aѹ`TS6*t2nՎ^S)IqV&Tm^3h{Pnayh2>~wp'%CV__,Y7ĝPhşg^SVwh/AoZ8kYUU|'oC+ Jt97 wüv[@9Q,=F#?6X+eE;^D9ZfUh8'hbDsi` =6]`juR#@7{j<2MFSz#lrWkaߍ :·zvOdρґ-dai: ",D3Kضdh|`aWr #Yqd{a"j&hVn=G SrlV2ie'g ˣPrM܊bDګ:FcY^A5. Mi0v|.InND8ߘ`]x\x8cH{H iW&H3 "ryub ٭1&9es]؎h= tvi$YwP"PeAr5FxJ mc{5y'3X,@m%sۭ WZ~Ah>!яFb{#.6rXmO w9^߾>/۞zKBPUM5~.b"95AnxHָqA Je!qPۈ:*ggD[-j]hm Z@ pqD`Y؋?ڻKNsٶj^験pNΤXt7'lKOG{"x' Jo6tF(9P}B(";}!A?44Q!1;O]!pe, ƺFfCbΙMVyvQR Jt61%h4Dk^l!|E  Jt Oi[z]ݐ;RLD9ҜpOP " .4 #!NDckk`-ozr&>8ctv^HȈb8&1M>eQ &!HF!c5*93C?.u9E-Nc~BEX Nk|4LEYy2xjK eN4'uEOqonY0#Dڑ7SSGkɚ}^ W tȌ&u46(hra,< rzʭ|L;䗢eVi6_0m /\Kn"eڳ ^Ьg&+83/Tm9lx@SGr!;U k`740߶fLS5Hw|Gh"yZT,HI_ e޹Z!˗ϻAGw ń`}EޔS4jpUG[Ǧ?k]emX<V3fs!zh׮:B(niu$b"PqO|>}q}UYw t$PIOcJY[YnQhZGUhzJ`T a3B6ba;$;1.Hl95s1ɴWnb߀܄s9;7BQBM5TТ}YNtn9qtW\3i>7JK"jv#jkZ뿌İG0iL !UJ%h 8[?C J.GT6L<+j'+wQP\߲M2fGݩKHIVD8Y}L(23kZ(H3*O$TRicӽRvkTط/$1U;yltƛl}b U,X# 92Qbx& h]e3)ǎvx4)H*9$b:SG@JG%cC /'(RXՋgE$ڏl\ab1@]&n7a#TGҰB~w5A^m'ICV 7S(ft)DJSQtJͤnm?%xi{ԵuW5u4T}g|Y^8!1q(=!GroƤ#4JB+rͶRE}.UVqMƇ_&OgWI5{r&gh_{Ña9:8G s=ѥvKF:*ʋ|lZ9ϟ@V#βz$r[!Ѧ9.bx"U7Ū`2(PքPKvZċP׵h{Ez@?}V3DE!vFئG0) :O H=I 2#"TOXqr]QEw5i 5 )gTᯟrSZZy/ s&8CR3V!XA2WwQ[#FvJ ?٠ys [ͦk" v`v Le9XٟPEE2{1IW%;8 DXTz;:8 գr-Ő8R+F?0wVQ89Ly;"DJmԥg&nJܦ@lsOh]Ff0JNEtH.Ut<4$~26[ ~Ѱoymp~G#txJ|50r1||jpJL뛹z;Y#mE; tAifM10g_2J#Eq fjAu,Ȏd 2Y⿤yL8P@‚xwu;gވw8T֑/6P>_u3|IX ;xs?K|g@Zg(27Ӵ07P2C k5YN'ɱZBYbJiJ% ˍ=za7NŸQ)(gʯ'믖2!\GBC Tg+RHԲюwcm[vpV"]Of`氋}X*f|SXq/΀YuzHq]љÅ7xn1EH ڎ˘;4%o9&-!x{0D[#1|9lJ|V"`5i.`™ZK0s(L+kO\&/&^,a_$ID4mIRĵm@/o+Ak<9eo )8wHtz@l)&-,7cIpןy•[4 eYtЩT,p}E#-@P]!ju~A?usAUkg&[W@9P3^*32XD&e@E B'ii'53i9e>x/7lZ? I6vn=Bwyob ) Q2SMx1k`ӳo8[iNHs~d<7x\0TVGP%F>E[)#_]MT qL7w(W>qWXEI%%z<@ᲝbS] r*z#\iƞ/6{_B;uQlLx$9^unS<]H& Ɉ׫a2(2b2tn?$P8̢X0cZ OmrKZTF_/+Ф᫟ wv8kXRymDM bqЛ*%MB n)BgzmH?Fi~ؠ2Cɉwc7XF@T65 +B'"ZK'I\qP1s(c5a#L 7A{F58+݌?]p7j6xOGH-O.&BIMK3.W> jͶŖӮ1Ǒ|rbO-mY|Bsj5z~ c[I)ވXƢEx3IΦ|rݻ^CHbE l8.Ŷ3ЬGhݗJnc/Z$nbD?[`?x,R%d?V "MޡMQlw.p%W .OL3=lD {ݜ0`xAHa8iPJW;SH>C|efGJU(k*vZ++_qJY+ Awٕʙ7t)jziQ.$JG QA3 "F&qDq=69Q奏)x@Ζ^d9Bw^6䞪^\"}:s@]"s0V!OAf3o9P?dz"~SN x~zXj(튭U1 p<-qiE 8ڌzFVCOq7 jYJ{CDޅ4π}\ȕӚ~{h ;h &=T6-S*L7/*g`_>=i[ԚYmQ0Ci+PC7vBgURR$Y2h[&rR?]iza 5痣%/Lg 8"5i"<[1Z89M>W~dۮ|<g"̊}ɮo-2H5_nYnEO.2 <*QӾ* Tq3R |/,N}uۘ32% ]M9$q 7DW6y wSY>Ƹ7:=oJr?Pկ(fzu=L_v\F*^ɺ =#h7}09TKuySOm%c%QZ4ŭ$%cdJ;Gpm!ǮS_Ai)B¼ 9.n6:ksc)?k7rs20=6G"B ~*9tjۅ ~ou7kc#Ϸ wN?Q82JT?ߜ;HSzl AbDŏW@ ѫя'pT ׾ ym*!QViilsH0oy@&17Ӣ?v3&vIVO9ԏ%goZ7`]sIA%$ fB*T% Þ/&bW1ְfXS8@4:E?^ U].6skS836>%ئ`Mٓ4Q#U峦*l` bk[}^BW- endstream endobj 700 0 obj << /Length1 1464 /Length2 6758 /Length3 0 /Length 7733 /Filter /FlateDecode >> stream xڍWeT\$nS:a!f`hiFD.P[.߽?f}󜵆IGWMyc}  llaNп#lP F PM @" Q  @J0&@ ) \|0;{۝pB qqQ9g(`w{@A}USEˋƇ@p`= v5.=폐> nN0v"U5.P`?_4<_CGxP^a $ *]g'U"4|{RiO&p).ki!n pMxs0rw_U=~#8_3O-=oUF?d,p;Vrp[f ᆹ)ü6:0woKvN08TxA@nq}Nn;ҿUC64' ,#`˾(Э8m޿ #oSlH_7+&m&)wۼ4?m!Hjsؿ( @@$CB*hxW|(bb rY ercn;ʛK_fi\ԏd6ZEhԭl+J/9C8$ic2ҩ( wPO{'.=dC0vr=&d}Jczl?R>ВD '_V|‡iws}c)gB9gݟ;yyaˮÓ >{f%!DJp02pц:(>{ ܡJπ; oRwڏS2Y͈wd{SNs*eQP*GT)ځ- tQ{`=(5s?VG4`ey{qLJnF;a`v,mG‼"wd}nxE1nn lY:x iYTsL*Ndl৭3$Ćx阴aW8c0%j+697Mk]8FLNŘ~9|!pz0n 6h[4>1mZX4Yfg˘L|b97}%*d-<%{.Ǵ̳o!Czt:*R=):1:_S l2%M#6{T?|'.hxQ{U-u^t˞@TR[*|D3!!c>]-8+Z'r9˗B9zn!SiF>{XSbν? Tf4sϠ ANQG׶Jvm cSRPVK C>%o6=0rp"$B}|ÙI.p/㐄W)ͧ05 Bș ^pզDPvJCש}gJE ͖5NK,}F$lh 1;Xh!͵7/B„vӞ=wO)kR":0%]FiZ5C7 m}2-J;y d RũzY޹!AٷZj*xܾ%0'ڲmr]i  ßw5NZ&>u>;jwTIkn| â-)EPh׈EǖIݏ3Q:Nsd ܝګ9G:E)w8ыR/95a:_%d,5g!0kKvz;G/]ѽ+ ^QĿpș=ĬgDwlN, $ & MfsMdY5eQlO{POć^ke5+@fځ-ndl;0K ͋RIsEE γ-`gJUt㙜;G H=k/)4 QPATY;,>Yܶ!fitp0&\ƛL!\GzAp|hʫF(mS^ KWm;9!$ѝymz9mׂ!2s=l3`Zc>qYqqNvslX.ctPS=0ގG6x$j,Ycx}]FtB#e}\Nߊu9\^x4|1;ŋ{,+?R,f^s m;l<79f2pߓ_׎5?i&ܬkRv Lru!OU(‚@]ၛ%?*awitbEE0?z ݊EۚXW#yg!2C 6IVbp.  qY#'/pA5~%{yLhkO55a]%H!|&F7Ӧ}ٞoF(5g #տcM(׿j]܅6*-=,A`x('^K;'AP[L0<ܺw$K4琮RNIڒJq*i[N1?0"B2g,b0I|Y㾧j.k$v5LGW6Zdžz6w ҖkT ^؈wS}Kv(+ܐߣFJۻfd <4akSudiOK,3t K.5GA61 \26jNOr[~ &o^8e:~J ^QG2z }{!":1W![;{; iRE2O)}v&1:g M m8'!5 aS"463-HDy xrQ:x/܍$閊Oa|%Ϙ>i>tƁoZ/Vr}HTd&4$;*=~ahM%Vs+WBZ.]hk T٢t$$XNCΗe|;KX DDJ /u_\ OH'~6~ci_JV[ϙoD/5xD-u|%%yƬѽuƩė3b6*P]5Pi+FK^3{k["ݎV/NdJV43&~EZp`aUu{?Fۘ=1:QI wp^VaZy:%I>ǛCu߼Iq7qjH~x!A}p/eFȞK&b*w4MFpՉoجJ#ŎH={_ %@:ZS o|UIL=Kmt G;9y-&wMkd$psL2L_$U>՗~}jmCgZFEWĞPm Fw~vm]Aʿ_<7𬮚!u0*EV-(@j.nQ[7GYgdδuP6a2H캡~8)֊ˆzuLuylK{kZh`D؋X獱/k9dudOPCd q+æ-tr)m.tRe2OPl"LdUⓗI dVr鮲0YrYGjs_e#)QGLɁM<۾بS^ߋGε T0MF|XĦq*0^Bmq a"Ѹ0>2E)C^s?" hs]&:Z~#3U^FK!Q[O|6C]SBeNb?4Ewl}4δPGOЊ띃-\;(-X])i{yNǤ۲ Wg*pAcɭKޮh٦3AD%D}! [f\VrkcEzM|ҽpp~aaЇlԚt;B6y53n._Й"U$\\MO6v_!?&?OO;*]\K*ͦ|sU0d#؁hFZyH[dF,M|7ѫ'RB|\rTfJt۔To|q+2<M#I{Fѽ&}\ݺ(p v̈́F'"C%Q&C:pk4pҴ.pF hۤz#2*4! bCVvhZgv&F&^?9CRO.TbԿkKC{Rr95BBY:z'e;f4߹H3<QpW3@НAB~bqK{vEj2WaN6M{_m+}VЊu*6&%y'1i*jʣeŬa G .!QcLU9Eѥc c Lo|̂hGN@RSMB˶bӍ,ބhm]D>fRR?6>}".zSzAJ?p2ON]{x:jW{SWJLӺn͈3ѸQf䣁Ԥ,o>bg2վ{5Bzg%WNs7_Y {ĦE7*]digwi} #dB$/wyfZ;ߌ; QF2I %{_ZNz.1N*\’FÝ|!o;U7J~bgqUgn6?SjFvKMt[VgW%RG˙s]}`P1 vT!GcyKXw0&_:}-^ >l⾨6] ٖHn|]+NrԌ?DԂRy&L{em x%L}ECkmx'?dS^%/AD6+!ݷaT'pw[t\غJSkrbu1>u)k4L;Em{.囜IMLCϯ% ΤlRlFr\q %FV]7C^J} ƭmh4mBS"FKkQ{B3Zey;-_\BPw7?*.,;6:@4CL9I9Nl#-%]k«QFQ+Z[_^Owgbxȳ٘i@p1/f=Z)'c_ttۧ!(d";Q TV~^=3b3RSġ9L*#{ɮb| v1rXՔE,81$O9KQF&'H?v}P:& f%:|y9t7/N)(ٖd*"sl{Ӧ=*t3R /ۋ6 R rܝIKƢ{?kae 雟UHiZj՝VzM#IQ5֤3GGGZcmۇ&qQ #F%2'%mJ q)6\t);[Ӈ5_i;Lwssvх&\I^Ŭ,O;ŸbdxqKpJ{FQr&CrXb~x)Lj0Ӂa{R@3'a)<{/VC].{qSk4FݲC I}͘ k_=MҞ<# r%UJ ?<8"!.iX/Y-= gnLıѣ~lڔ"AbWC~ŀ@焃H5SHLgHxv}XpG'3zHǘO#ll)~$a[5u?cB=a[RdЩ+v@խ>v,qM1H|+?6WpojQ;oWW[MUX6`y.Tv+ epwAof".(ѿt%i?L&_[$~Rem "1HSYJ]#'}y`hr91c׳>;/A endstream endobj 702 0 obj << /Length1 1494 /Length2 7473 /Length3 0 /Length 8468 /Filter /FlateDecode >> stream xڍWuTݷAJQA``KI%iiPAi]Zgs}]}>yDG Z &ja! !0 QP\E$)7T-  ŤťB!"R%#!" G߬OК ()); ABpmqY #Rehg)~~www B pܡh{# t~ ;AjD0p#l`$pcA!pM+ܬW8C5  HtFJ[[#pO(` A:* "a(M< nTe:Q K_in6Znpr(_)A뛝w Պ3! QSuc"fADڞ"ΐ>|ۛV P[͋vHW?F5` ~coTznD(eq37A+jh_nOH'$*|I Īm? ٩ ߹7  ͏[C/פ fC_ 'FîyBLƐ?Xo|3pe DCQ*P.mmr;E( }of2akD`$Ixs7H-x36߂MC_-Ih%L/~@A? ((w!*J?x@  ' |D87^Qw[ T9=~1)2q@-w]hB#h9&Bfᖭ2 mКFsSaͷG=Gr#\.cea}& nOm,V(mRcG}wWeMgRt/&t Qփmbw4F8VڔcG @+TnBFy'7+3}%u(ץjU bG4D.!eͳ \`a֘UD#4UU;.!bM8]"'{/?-+Ǵym,M9fw7x>_K!m75{+2+'h0YQhVG󕧂G&jCZ.NcsPFԅ;Loĝ I"ϹBʭfa~Ys5ĹSE>:NC3W ퟮ*藬Sn,Lf $W}z70 8DZ1a7`'r<2ٸ-b0Ykdf:XlW\>}}xvw6VʘĮ*30k+cw|!{"&H~ *[R *ͷSf'qK /PL=XY9, PmOvM&7A@:j+.܌߷sAKB*uDU=+-KaS{W`=TFZMlrDxAKcx2s]?}z aVσY^w;OE^bTDB"1 dGUiij:8//_? >Dx:|W 4HGSs1<@>3[x"D֡ц)BįVan;Zڏ'DW_M̚evc'qy Њb8UGS!/~Ło>Nmǽ<.h?F:Trщ-alzoêe)_"#*TI8(/uFOϳ va5<>`R@ƓйQTz5e,2Ѳe$Ny gv5q%n쒗{Xoٌ۷EE`읍4tkM<ZKU 3K4Őjp!K!hsJwJ`շc3BMpctbipef_GXu9)b3pMIJcn|kkxy-^2K:Yʐ4ڙOգ{i3~D˜?a.mAB`dBJcx67cC+ԕBˡVshx4! p3A! VYRIȓL_GqAǩ*%N/ )j=V/K^=l `ҥ2ݚֽKH/g'f6)}瞣7Sأ嘶3q9'`xu1̍j=ζ/I' =Ѓ!zeGW$_{gEdBl驯2-ߛVRr̸՞KѠN^/~f}(!SzJC#V ^3JӻAdx:m{. uDBv*dS3TՋwvUPogySӒ>6`_f1=bΟ^\`MOL;)xntgyطla"r{Z.4oLMل2a&5f+|RSEO va Ib5gFC9G\sr ;ptnlDý`/l[UM =\fF9/XSyMaE ,Vc|Uv{[Du9 MN7H&LE򈋟.Gv>g>U9Il8Q7RJec۶2^Lmi}$=/\ɧ=<\/V%$gwZaw_Drz7?Vf$z;b|8aXȖa'dd'[LVzdze7\L{e{3Ә]NÑF8Sfe1W&tY?%-eB QŸF.Eڰ^J GzW븒WjW8tһG^r:_<>l,۩}g{VAx|R;TG #Oh>e޺YliGr1 {(}ty IUF`v[{ j֬t&N|BҶ‘y ۆRK|el Zʸ(ry]4'A^ffŇ3m6+dpP |o''s6C /+d`@&M.g1ڀ`܎5ՙB ̍3I#,"5hiWl|=,PǪzy æ\+u(˭7k8$Tuq>X<+?ͩW6Lu h%~߶pjߕ5BR46{"R~I+6.q:;(x9ڊ_=Ƞ^&?8֑Rtw$XC[*wϾcOLB:(gۓvûsy=2-Lg1yA]=r"W G4W4|<RN;RR,G6"xA9Ğ}H/zZI]N.X1,C%uZG.O#D_w@ع؛wc d9.RzAue4rX떤IzZ@)>#Ƒ|4~z9A@rh'?7Njnɪϭ(2xA싯E3^nU')הc=ϵ];ȅú MO s~9UIuc6chI+^psvՐ(LއΧ~zjty;TzJ;šVpQlͅ(MZÖ)p=ۏ"1Yit?PJj4,?pUWRmjpqR's_f* GBoK͗9.I1hk" zXžM/MU(} obdO/oI3wk|H Ɵu"}a03}5" |_rI 6:ggɕ.k1dE@L?@Qߗ {*qΥCb8KdNgۆu+Emĥ;KXeOyHb>E7#sdCgo#zB} 78[NeܔKX۱iUFjw|$ERwxfL@KۄYCqLdόO,֖֖=V0q9=T*a.v5c/|M3k1k .bXX&rIiS7E4&{wK8 rTWQrd$S&q.Ɣ,U0 ֨f%B'}{EԧrG|~tLj:/ K׫P*.&2qhgx`pϚlfLpH l* V?~ uCO<҇9Py:`ȵ#zb)3{\z W?R7}GGml^+_pB64ܻ i.Vʝ/xnR!ttٍ"l9$d+|w&Fwnц)d[ So2.;!|dgS2=)<`˗KG\*&'yLOgQ*6V~y9TAj|v÷Z.R7 ä)&i!IsӳuF+ihO~ʄrTmPG0E;s2#gW.L?eQ/HԻd"r:NEC5^Ύ.~Y`ԙR}:f+Ij1aTErom)yB5+W~~<97–YZkz^gK$p~k{q-Ww-IR0֛lvPYmxbX M?2rO9>aݥnK_2leVp|աLP<)Ʈ46LHxɴ2hROV,5d8=pHRwH Z&I͖}V 3&BVԦ~2e`fJpq]4p|JJK wjL%# v3L\^QZ:`[iJyuY(o1ٛ—﨩/[[M:uÃ.8NpAe endstream endobj 704 0 obj << /Length1 1812 /Length2 11514 /Length3 0 /Length 12675 /Filter /FlateDecode >> stream xڍP Aw tap  8,;KdbղyV5SkIZBArG6.vN!"'^b^sC! ]l2@@#൫=/% |@L t[T! g ziqyG+ֿ P؀*ZZ 0(El\\B@gvZvhA07%U16`Z+w x2؃-@O) :@KQ9w+psD`ǿ(h ۃjr..@3)͟j&g>g  =#ocu88]1~',ݓ˵s;zY-~a q;ey2aY\|<|aa񻀶'i_o( z =}ax;@+ߎE\\K d vdYr>ɏ ''YB=urJ**,_ `pq |G*:ZA~tP0!L%SN?\W?fUH/??~'麺< ioUY]WOfev{,.6o;!߯,N{2 ׈6vV寋AOK}:Z@,o7?=1. ̾+ E 8d~B?H=E >!?˛?=AOyE|Ӷ}BA /T -8@ ho }R,Oe'jn'2g{͟j\](&u|b|/?7o =I㯕}_/admb!l[~]#Iζ5*|~6Zh/;i.{A\[muܙGzOK6*]k*K$+ YfzR/J`pQxZ>/>'3 iW)V&x㻦K9qAFi4J"7xk_({^nӅ QV.疸dxJXXeJS=<=0fL1KuC]"JlGZ.Q!6 %]9~+T~{0ibU)Mpl U%Qbo}GU(B˚TMYl}_:wK!z܆6bK[yxU:8 ;E^gR NQ1^k|2 qq|ȨrwXX7VtVz;FCT9e]1$4}/*-JU>ܞ`Dx:@b@뽐՟ NvYc"}c}<kMS 9KqhȻ%uzukL%ySMƗp1;Hc(h/1.]r%7i|T4UN959Y(a)գ#ٱn@0j !)f㻬5䍜ZSpr!%i{j[唂؅1⻄~Z.7UA֥8(]\-ٯˁ>f61%oz , 8m<1mHB@&fMYS~r{^/ݽ]Gͳ.JDGf/Ԅ=0{ӫ,PUg8!2-<:/PH]N/Vs o e/{l35"8X077x^Kкܬw ԺWKԍ–EX7n݈h-☗fYƞGWxajLbo[FBA3W V-"ǶJStv+tx6ߒ-ݤksy9E-xkw[~?̫P<`Ɨ۫ b yCSBa/@-G=$Ğw8ya. A4N.kVL5HZS) DmSL׃Z軱t޵yMpUTI;@V8G+|C[xEDK4-q`K 5q4(G.@Etwb qRbo\6dBg7Z(! ](ؿ!wMC"\׏50KrՃPnc 0pQ+,sƄGA[A;aA+sC_/{yѫ54z|^o<"ROSѶhnS;b+" bj<:}7h̉d44]?6T%䭜B8_h+ɜef=Q^[X#<PC, 5*!|IhAΐ1 #>&X|$yjz^?i2Q[zù|cǑXPwyaf=mU@M^N[b1i::jn :i5Y0[m!Ϭ>s$Rv$$jǘ PmMZŐB,?% AxpB~L+_gC ~Ίi-ݷ6PA#3y]RA'cѶgGAVG:gs׍/nPX!y^K#VisVˆV*\(e5_ǔXY]9Mr_F"MbXjVklMd08OBKxUڐ$jkߟrL0(XŹă0f%W=7[\t ~E& 1L|M*~QHO͚m!u'FaMT@yAfUcrE.;3 ]_|zJ>^gi> .R{!U^xg_ou6Iļ%{RuZrRڔ^T9D-KJܞ~:MJ Bw1D鎁 WG`/%Itvd٩*LG2X ]mL{L*-_㟤:[۷# PBɏ-z5=hfi+ā8bz[~rF/[tPDJ=O.!,pU霦i@NQA;| ^}ԣ/7/280dַm_н c|zٽ,j9c KJJLMp,-OSqcZ}Rȃ\Ცβ%!jotOyBb簢{X^>]uV ]|*Z#{B(Uh曨rDKجt 2Ś[gy# ;.H-[U$0(V*O  ӑ`Fi fn0PcUV3ңPjf[/gv(ACyTxߌU6Iq.M*'fRj=E)KMdH-W8"q6%0g̐p3_[Femvş תRmHNI('ӌ5]0zuU$ce Ii_۬nNCÉSgSʬq 9p΂md#n5"\FJ iz{l' *뒣^f9~}rn 2Mrn@Hِ UKf3jHB0qtD)~hLã[WT>\xzҰ$T6{P wUHG}W}z95`qͅ+vc0\$4%iǖ*D2$k408Ə"Ayzh烁&[_tZ|9)$BS6eЧh޾?OX=B15Nj=7Trl_L@:%3+ ԓ,&!u:BxwRJS6}}pEk(\[0\!oc] i:kA<}HRB7/;7D5ho `rͣGFVt0$8NnxwŽLZE]o^1h˳EG3n 1I×_B}էt;V&:b?0玜dZdԎ%b Me祤/)iD+9 ź^>#GTe ulUKϸtYTf@NgFb*DoPʞi%1ȈtMqۙ2qN:T>髪`}=tyC`F:DZ*o=jHt?azJmTmܕ "x$+$&#ͶyVG7:\4,ແ f<J2IGp` uƢ-+1p`9LvI &mWio^IW; ztN TV˻ bY ̤OD/"J^Ng8ZI܋G@`_)EkQ 9`Bk#(H x`SiANX1w<釦Ui|smXׯb#>M z{sLN*Q鶸,퉦U ryVޭkLs#$r"_I7q&#¬_?Sڎ+ɏ$!5ej*\{Fe rP4u抚 # '` }yE1Im% gy!,$  ZGawUb8= ޛK.ܼ L,0Zδ/>cSj/VƷR\Sr D=ZME~UO !yoi*aA-{=Z†xxΖ r[ \a칧L.TbSD(c;n'0p`cNJ3$))qH}*%;q2A遙rv2B,x0fz!rN qn/R6U!6N*9)2bS--^~ȷƠ姗EyAwvB93uC: 6*Q%+k|~DA3@0f8]RU2!@^&pŔX; M\OzHUl'"6|X%b2Ӿ騦n;\ d{*f89Ҡ4OozA>|@ē}tQ<@I[vqe-3i,@'vf!qy&R״2Y㢭fJ1yˮA豃{LW1l-$Od#u,ܫX/xd,4r~V})L& gמذ./lPCPB–1*$5^* 洦9$?}W,{oЏ)]-C٠;WuRF)kI//zr(8U. 6 =-x6|=fWLf'ei{WI|$)MJVTV!h|f_5TJ>?̌XoCV:p-+ [ 1<륺>I$ ¿Gw1+q@NQ.,a3[$xT(eQ&ǘĞaqܧe^<=:ڡH4jR(|z&T" FGүAS[q^K[Y#ncP*uvf v$7>as؏G׍J)s,Mb vHT4i).R/xGF~,>ARe2CW<nv>ILb\k^ظEeC31Y4$EլJ;+@KӁ/g/>usSN^GU+$}9-2}g 9feQ JX ;{[xFGOEo/3:1i Wi2LaoK0bMH3<->0Qҗ+Xn_FfW&G|@[I؎|mǜJǗq|(0ԭc=?"CՠŕY">UØfj ͆ZtWw{+?՝Xz#D9].8U[>9jk_ sp*{`I뎞%!y5q*c4& ]U+@|#M+ـJ*j܀@]`P2t(j n߷_#i<^,z3c]^@ ХQ~+ 6֚"ppC^֕ǵGC0NП*)5|$ĢWuZIXjybM/)=Qe7Os)[*Yq͛?%펷sz-ں,蜛BKrW4D#ƚz9Xk҂ql@ 31QYZ 8pC Y6{cd*K7e&,- B,9]:qqȂS5!' ʚoPuRT* ˸.ZX/ F r bky7ӑu{VL^P<>98 XN=fPAp?/(oC蛺R{7 ?D^R_go -Hi7$хy6\.Kh$p{~1' @4+ y^':[A?m :죯~c8'\34V' O[;x`}$jăezy@\3,i>o=>^|SeJSI\s6P73c2lMPβ1Hh , SpP$O>fk XI[/kd2ӥ֊]ȒdtaP$J(.VPWX"?]o/J&aD6vc3RA)CnvG [fV<:1:ET ÍgGL{Qw}eLOT1 Mv.oʷ3L䰛 $Z&#w Mr9ꉁ.5M*N- ԡ0N1T"\XK)Qs' BtMu<#t8&_BtetLO;Y+v(o8HJTN##djtZc[o ON<_[+vhI {gaL }3I)M*Y۳T Vg6)sykOb*4wo~J`~BA q6hd\hl$s=ڢ5>*8G( =Y/~=8h&*u O@<>'{ GLs 1ԝDbg.^ $&rYRT:AOVn2S.6iփt%y]TmC{\9M@^Hx!qѸ .:aПMJ!~H4.=8Gc-65xJ'&GR8Lx5Ș!M* (it@羬N~ѢyV=n("ۑF4uS#Dy0!Ma#S&^ⴭvZxԁ 怏߽ׄÊqus<Ы `Ϯ7gLTύeFI::Pe moqVRxj Яc?dHH"z,ťn*mI~wC&=k ց(zj=X +e7(CCJO-[y ؓp|/Q7:EIf~ >. 4ğirߎuu,`7cMԬJt1*3 *b٭8ŷ&Bz6R5(o[s5mc}y6O:DWsjtBɺłġ!,=x{Hv"G?X܊|p~.Tςx~(- o0Dzja%} KGb1'xE{'OKJȟE\OZT-1J[ždAdyˢBŏs*6 HD LGu5MQ 3Ͳ]3[4]Y{;doO*ORvv^_Qf4a+z-}Rޭ&KZ2\ه"l\0o'ԅ.naSJ=CYBpYs+[MZyad&x,*8[U۾dn)ࢃMTpI⩎.L}x? ܓ{L9֪MD+&=\[VH3e/,:@J+= ig*= !Ʌ|Ip/9(j̶eбbSחUHUmfwiVzKzbu)Ϙe}_kEqHK}u1H#͊+)AؼO W6yW/>0H"h^mE V dfBތDWܽvL> 6С39.RLkӫ}l͞,H2x~@squdx"å95.!3w)|lTn`yGoNq/VJl^{TUU¸O 2jB ¬b^F?QLVX?^(Or\p)Cwy)Ejf&oymnVowT-m-72ZEb&47BRko@3[g&xϯϯY& ݇Ke/s}Y|?o֧P~}tԶ.g1ixdr#ezr@vq'n]*8<#<̙Fұ'/_\Ӝ9K,qN{ c3xDnw{"=5ÅC:a ߚ̌tI+V%āY( Y_+ƫ>Vɬ?̍iޤ=ՔT%!GI׽yȳJX{F3h׈hY{ĆZxy~Jm57 סWg/Տ{3 s `N*"`|a1P/4טGfsnv$loC{ٟHYL F8le6].uʏZIbXq[:m).= K_phIu\-{MĄɮGOF93n8UC~4C(ى5o<+n^Rxyiu //T %w:XBCDN)rK%?"^ojlwG'yXb^R;\$~nsْ_=+F">8~\GY 9K&V?@%nBgܽBH7=FnڶUȵԱ&Gnƒ%#ʉw(S$-}yGT!q:msK뭣m{CC}7U4jV| hz} A: ܸF_> س#ugt_#{oN boՕHq=lۊ gl1hLxsWcU[}.C $Gku/|GX۽c su2H?CwRZ$e}G" |,smƎe9A^ܡOs LI/mԩyj~&cs5Q쎮z(Xje`3}7>U.@h3c5^t.tfW}1VJ# Իp'eyhLuGS- g_ d'H֠nOEФגcG^y-pO,0PjX!C ǰ O./. 4F#PWga F'`6% endstream endobj 706 0 obj << /Length1 1419 /Length2 6466 /Length3 0 /Length 7440 /Filter /FlateDecode >> stream xڍTTEiJ&@&{^ Х.* EH{;[Y?3{f5Bbx| 1YYu/71> G!@`}rP BT\ ,,~ @ Q.b9PA!ahbVY =_+NXTt#nEԡ;#D+(0(!a8󻻻A|([IN;cІa.n0kPG؟Yvpu Dc3\0p@ Vu70U B9:Ap-40i EQ|Zb;Pr;a|h8׈`oYi-rt!1h_]`VkY$aGZՉ_ wv)0H䁠 yX*rc'vB9lC|607`\\a>=O Xí0K-Iwuf.xr K/k7~ U L + `0x}gP_mUFڠXvb_ K[o +⿪_,φ\a:u`PժìᮎU@JFb  pc8g~i G_l14BP4VmkeðzgH+/ @P'1vX cj Mm?3lP.Ŀ c ~ߦV..~տ<`VPV5M't+$wN x?bt2gU>v[4dO?O{/ޯ:⽯f{ѵDcz)78y)2b%.]8[Yv鰒=eItg*UxҤZ]v^T6e 䀆=g1.kIDF:D)q{BOE'C[T[P x/A\>ENf:mٻ:yL4ĽIowhL.vě4dӿ١SO!A"9a oǨ?//#HZG92O^HD٧UZ¦nuRr[H*S%< ҚC"΅R<-Kođҹ*;RHŸD/CEvPN1VM~}J$LdԻJ#2޷KF*h҇J ޖKRR ]` q'Y/:g\xɑbI鐬t8v~#'#wyio[Z,^R<|p`]vtj_>I{ Ho,"g'"Zy~57]m'C!tr9 QdiG1`(|NbZr|9K)MFŖTӓLI9-fDsGd:r>M9.M'E)[qec.v>Fn0Gݞ O?u"C׏VJp3W8Ǟ$%t)5FtW[4Zn5 /3НMcn˕0|_ yQ/cLӪ hx*|uXPd kX`GL T#e޳Fݎ0x=~45p\յSwN_#D|XƵ?᭗DfW1?ܦFkUKnkS߼6M6v>HLNIk)1hWv,_gp԰GDŽ8oƒBq쥴D؃`1KH%9}J}ԇ5stvqTtpBsB5nZܝPd{(P{ft&cl,:ǢGj;U8].^Jv[sC/1`ܓ,Z_&Gˇ=dib=.YG3y۔pQ -s9w6ks5[>j@Z$CC)֜QTGzǞo8Y< 9ko"U Ffz˖k a@*GooU ]-o-ëAJu9xGp0ǍVx&>*Uʩ2i7&Ϥc]b=劜~A\(ƅ=Ȁ@g2 {/>?CؘCf|(Bl_<͗4`qI gKgܬz=/ԭ::߃.nNSLXWC3;/UJ0 C<]6<06wU6 N+/=l MCd]?J=(xVWi^cԻ nD%?d< u8opP{ h91 gLgu>ea \fS Sؔ]pLDkis);a}w8iTc/$a:;̐n13o`kωU"*FdϞ&'~WQ cؙs$0/DRz%yq3hOA?Unkl2mJ4*SmX} v(ٛZq!?ESe51=fjFĀA m vÍox"c+ép -ƥ$Di36jrFw< TA%\))ܧsGS95$Ci) '"Lۅgdϲ M/AtMgZqCJAYy5&)Ve\r0"ƧD6չHol2atA@v`q 6ܸ; z w!(&_oK܄{zja$;M1$yP&@~` *6|.Ki[͖!w2*a!)ϯaNwV,jg.ncKl"* ^ \#!1Bq@ A↗}C pm'ҴJ֟->c}X[AL`|ja綹Jxo{das ݴ_Ԇ\t <|Y:&D+tqrqgZ-NQ5MDA?|mN oH%rIY嵢'W`SI^ E}j@oUZcVoP/X~~mרoݵ@qt"A6`O\GrY*!jtZ)g+#Rn=Q,NL/uEPgcɬu_yq}쒞n7}s4DKi@@f=2ڲo%ӓuf[*wΎ4( /iB}qoDnz\i4pb j eY1R~εy)-%0lF#~7 LAqOP[C /̷R ˣMGrUr6\t_ ƩyM J}Q"gS94LjH >d"H oW$ ޑYv9_mZ[$fގ8gkƟVxv/j}+?kZlT__x;iZRϾolJ.QnaG)&.}g'ό˾7SiT/LdO#vǭЩH-`G+5yɯv4͚q&s >7,z-OAb@E  1$6#4} zb'%a"jɎKU;*|w,f`dO4Λt|[hPU=G5B!V96^r_kvi 5'nȠB A)|kBmO̭SktzV8@?EqzA}B%f9(ʥAZv!(I\)SifGD;U*ՁfCQQQN;*Ro+qXRpPTs1tuoV++Z-3 @azט ?nd<1;mN"E#Ȩw>ϯ&5ڴML-[0. 1 q~xD,,|{*@]G 23|)!6ڳTV~ʗtqSCDҬ-x卉wqs J%P992TJ4i{CY3"Y|)Uz{n^} f e +V -Zlw?ӝ5܌rh&,'ﰌAS>͞O Shy&ŏF~M{sn9cdrc-;<,NuF׏%/]JY93ł&/=65jpjh>s=JghC*DƦ[sy:%7VNڂ8cR mWD5ђNûZAQIFWIZ]\N3Q^%I;#IHba'~6GκXnn_ i+=9۸5۩Sa \h>+zlJ])CVTUv.^?a*m"/u Z.J\٩A1{; MJz<>Cֿ_:iC#tT'\ [V]i#c?LϙMٝ~#S`L1\<`CA͐ޒ=#h;dZnj]֣׏iuM639EU4g!vZZ9céfLףs*NJ+Uʹ.>хL !'ߣ閖gᄽt 1ƒ;~xlf` yv:۞ `(Ef>^@5{\vI v~CFt[xhT9^bpvNn+$},';Y8&FrX89x} )[S;5G߉=2( wJYfVڻ[csCwI^L;GvU`IKGoRfĸun5r+vAڣlělj۾<T-j0>u(=$D]NK3dbVN _ۑa aq!>@"TqG] e2t.ܳ>UTYѪfSIa* Ǽ^$KYx5ᇈm[, ,mΏ"!y IL\Y֯I"}D|Oj[,3\0LжfVC($e`jĩZcv%nQTW敖]?+̗苇QȩSٷ4mS'"b,on`M'o/Ft G i4M/Lx۪ݧݽYh$US ćYuo˒xj@֫ij $m~7c)d<xDL%Ie#ayYI5o0MPN^S{Rd+;D߯?xFP9գӪ)ɠC5~>)#..ܷ|HJn{&u U_tбqxq pxd%,0Sԛ;k'gA"}?s Aj]'EaVfXq˩{_: _fB^R ^27O zG> \z,*yBr{%gGR\9:5!ԌF$Fu%o= endstream endobj 708 0 obj << /Length1 2765 /Length2 23703 /Length3 0 /Length 25249 /Filter /FlateDecode >> stream xڌt .4hޱm۶hh4Vc1mywgL;׺wed?߷CNJ/l`pwgf`ʫ03XXլ\m5.V<:]A21cW=@ `aab01q3@ q:8z9[YXG)5/w oj e45:Z]ՑÃ΅Baj P݁f_ wGPr[`a V@{JP(:6ۀl W +MM-V@+엡dW ae1s1urtuap"0)ۛ:]]~'f 4݋;x̭5aȨno$-ؙ8Y@'ԒWx5/G_J_bP>sP@_+s ;S_ 02u-~Gc<L 1~ID/3{[QMMEGMՉ8x|٘,L_$}o%cWw1O7@o13~1?S/?#.H/5_i\A :m hfVnv[+j :a{ h"a 4Sr5-]=Pc@ZҁNpQ/t9M)no`X9^p%;tf@ϿH `dwp@~m(K70FF߈ (/bo57Q_`@֒ Q7b0JFlFTo*N7'S@(@(F*(oʮF(oʧ/@ t?#ed"oGo 2w-gWd/b3uߜl$vvkE?E1*7:]@FBウO^fPE X/'7qj7~A?bo wp_ndXAWڳ% L6A5h 4ߑACw1 gA8V9^!?R T5jV0 4G[?kvN7 ]z K%_BWV/q=?3b w 'AA\@[MO232bttft]=ppUIAޞ@Px? h޿E:?tS7g"]z__@O)¬)oאֻja<1)O> mno2֜oĩ}j߆5'*<2WiQp$^Mh{@&v'7.D<;IoK#;ʻUO1zE&3$Ю04gH7S?^di|cX }tYbgWX\:ppt QG&(|DSd| = RYҫTkG3o$B(жkJ I1Z \kXmEVZo4:ͭS'-;}kVoCS:}5{-2g끪̡jҞzvVc*nJ.GX7\x^ VE$>OV&-ٽ3W9e}ϝpQ=_x8~t.p@$CMYƁYG`gHnw4I7_nfaMH5!i?lv|y+#,\= {?/V؍S qM ]J,ya` ]:Xm^[O#=: 6xn+?Utyd㪺p"~Mtpx`Rm+ر2cUu61z;S(E*5߇2~mp51pC'IO\e2ϑ8VUIYspr,`X5YQ ?hDmP|K9WASb%ADYFAbZ**3&Z F 4Pc{hfVj/2dQbƒD=)\5}k2X*<_=_&!3S{WچA˳՜tA#KΔ#LxÑ(\J|l3?x9Қ}eݘX?AY}Ƭr:1{M8gJHtܼ˦Nnx+ݜW} o4 iB^^>[|$݇c ;iV9i3 +-DRڤ,ò, u'䐬qdV!b,eh7"ӔFj%Cy#}"ֺn4pt0Gvd"ɤ;Vf'O{-!-'ls .W5|$LSjzgٮ%[?zՎ<w[rD ofjxs9˙MVn9m3k0F \=$fJu'y?~@S>1ᱱPڽ4|Fr;cFO1) X\H `ٳ^xPMUWeIzsbP&lSjМ .[6!gZE`mOnZ"uwm8K.0._) ;Zhpm-op<it L'.y5,mCͳ7&/ fR5Q^_9rj n]`r3$ΉYIӶL%{uWt!_DKCâږޗtT!5D4E}4?B.,Yb6bHC)e2ANxA~6G꿼RΩBPSzvι%8,;[&>4&a 6*~42`ŕZS2vQ0E)c&)A7q Y) Pfm BD@TdPZk*% >`ͯǿ.D" +qk)F`-EegdE q~L̰123V{Ihb`3,6;mE^,\7~,Y3|da^i(yINn2i9Dy {[/08 ź >Y؝#Xaa!DI<;흹Zʅ10`<@Y gF+XI7X,.Q8oa™lVp8/ ϦWfaw?tUYLj2Kx8O]Xyjx]-Ldza9_t"dƧ38pGa7jV2? s(MGVLwN'JPyzMh}XwmC%mhTFUWir l`rrM鲕y̾0_( T\B,g\ J챮saӀu/Om'ok<¨y0+1 pu˗)$hʯu:BcH ۯ)Ԝ=ߟr,3hSN/wիuSj9O1'CbP} WQ@#+Qtf`neH*_fɸ@=)}Tnmy7-?K2zW兽MZ C:O,< (Q) N).= Ofdz7Ucr|퐨Hh7r?0 Ӛ{{m~ btn~sxz=֭nO̅3S`m@sGV[KUC{[كDXLwbHw+k'%kƺAwJlRr0|]$EGF#ab_|ڽې#*ӅcNKiʮp]()"|YqYoAuU≡L*[5(CBƭρN`UImU>x`uY%ף"b@"bl~0gN;+|Qi[ؖ :EeJydCe6bܗu-%hKdI Ji"-MgߧFힺ9r~bQR0DQa_.7es/‘--EZ dO Q~&h9\y.X ٸ6=M42AV"thn^zɈwJfJiۜgڧ)c]|6w:|maB81u_eǬ7œ$>b*|,W.;_mK2& 6_MKmp׹W O 1ZHEΑX}jo>'$)BELLū4 J>>L'BBv?T!HMs*>Tf0$m%b$R)6AD*Q`(W$Yc5 S Uz4N?6;^/2E1%UI^r8QOyS=WZ+L5|-뚳ЁmlMb qK PBM~}Qh׆QywMߜNϻ|y`7Ò3L PzEP")>! G|#3afP` 74/T<)w۶D9Bk!j\HAOԕghNI&Co&a"v={a}{//8#2]tDa/j?HX1SrH*z>d⒠) z OeUvлo1Y$ݳ=,ZW LJ4{aҐ=1">+;Wtk{R`9 I1[9m/F#3dpiFeqV4 UwF+K%){0{ȌK)qvbU*1*.?y@$b3 LOiwo`p`?t싣DՃ! s⨺/%O:5@rnQ䭢C"G)YF\꾰n%֞,|h/F]UFNF\;1)R)&8"?{xqR4HIVm3{^y/p)VemDK]LQ l0//Z׵R6( ªYÓ @}h2|)Ӽn(-!z#[h%.vh~Ootь}aI>ArCNe괼\-hQxP5 EǷ.!4\{}ͳgk̡XȎ4g#ǔn85p@HV>Riv}xOUMoGHD2x}Coۛ~96s%#yuNj2wL9㗧:-MVؿt=GjXƋAʪ1&j]|st+y]oVO-bbvӼC>T!|QTU>lhƫ5 RdŠnu<2: XanS 粬b ynmm6߷pkȕso:n.r?tX1gqޱb: RIT{3>R-r; L6yc 66)Ć3mI `dй qlS$ *2Ǻ/b ƢS$149l\]5J׽D={;».ή_L=@JRT80wa:s̃KӠPs7չQyXGrTO 1DgoҚ"wn=v;Ik.:,m>ax$5 S´ґ&ޅZ4oc9 _,%h*ѽWcG39ש(*%0mWVۓ烁2< CZ:2):yh&{QE"V^k&7%ˍQVBJe7g6kpF[ 3+=;k"Yk%TK?1=-Kh,Ig 32Zh i#y2>TF :V@u푿 1Ҡ2ՙ|e*w(2)<|05 -HCS6pa_Ǽ҆UH9g>Tn~Fy^$#b&:鎿-K9[ǩj/Dí|;-`]X j/~2,Mo3hgߩ|+N' Y{AVwZ*:}{߆$6tː>u k#y/0aGTt&H)sT-OkR-x-tevf6*V^=Aug00EtfHE*vrIzQ%ǒ/ 6z_6unx[j:NPEsJJ PߺEr5r.hm!+FSWsdM+?|rP]9Ele9$ie&O :҈>jZ* *+[!/Xr к$vex"-S<ܻj ; n5\yhsZf q-Ʒ#{U흌a$Ė1r)3։bJ$(*K֦rCG4e_$s͝f&G$^ OM9|I7&!h epZq*prZ랪r圳1'^E}dXn^9O=U=r"̌'q~p5Ic !(Ib6^+H J ߘbД_L-]gahU2WZ $rxjgNoy;Q@km1C.3]o֯TIެȱ1%rBOi)6HtX("%NywX'az|-bvd}BDF&6~ %Tl;i.<0<X=c~FT]N3;'F}.Z(R{k+(ןb]\+/,/~b搀`mꕌD!]er'x4@w U][v`n )bqyZ5<} Gxw5ACpq)M[G)\݊"U2^9ynCMWWoak3]bpJg0{B p.#!jJ?& n75RJ<LGf3Y_¹%q4ҏ P NyMԛ#Jz]@7 ~4N"6q\a.p$P0:|Rh Řfњi|. m]*d^ f݈;G3'/-EY\qLx}ߩͮt,xU ؓ0cY@SU\!X`ٛHP| ҲhwD;'+(nPYWt_ƕZpz0+L;w\K Rt: |]$_䌅o4Nɍ$XܪDBb%9Z=M25|izE9Oz%9~,'F~Iq, SH`R@x``(-E~Rh<=B+e.b?ʅ.Є:૧&QIs,R`̴bbaq^0qDnAUןcY1*$ rg,&&RLIH`bGk2VA-p0j*Fd(VG 1ooOV vxӧ1ĩF]ن {0_#_c쌀/sš57Q-gTx#{j-Ljpy_,9x邶G X(C^_6GˏwH-5yeNћq]o9-ݮ/1%a.pGz& ՊQs)ҥa+79ç>e!o+E.o *$bacә>ѧ3+K5C0)j2K:7Xʏ3aۂױN31D,JE{Q4j߲K-+"-l5ģ,>J M(-!ک G剅?@ @/|##@gm>fX[~}ԃT̖leq(BbI^a~uY0 0%aN.g1?[r+`/ ϶u=[RF8X]/#uR,6u3@:Cdՙ;ejrgĘJE*>ۙjO囊5gĚ ?fL\Rx-Ӵ'+| = E I 1`-OP6fv!@>)Yjn-VCjK| vŲ@[#"<1d{CۉRo/!x"Rv-٪m૟y l㦐_޳vdV1:tx_O*42)I^ZV_OF\TDG}X1'0QS@JeXL F[£CS9ho3q u{խt*sx@K٣9sjõP^&2̣Z5s"+?}눳B"2+gma+lSdouݽ} ͌zWؔiyg93cwZjقI֧ST9[]ڱ1fGX["7532ͱ#Cg '? MD7dp^cH!ЮoyUiV( *pRŽB?<ķχI~:B#)7' e72Ol%Et eԼ/ְi8W'⏦Щ%}ݱhoؼkx$ܼ_4Ӧoyo,LJ@V$TEWbA|RZ)YુA4ncsaeSr?j"R\Ӄ4<ͫvGWt05%Gøj M䊕m*=k Pl. *U #>7e#7ɪyV|2{51IwRK"!h :=a).|1ج!^弚Kv-{ri 5;M:]F(WN`Uuhl]gO>Gpk茤$(=yljg?SS"}bw %:ΟP^{!:`SK lf# >;$Vd$ֆ/wR%*xYqo8c1ާVv(>44"1oz&.&fAlwꖯZ}T|b|i8jF9c'vPd#fv3ӗ8Sb)ޢ&|%PĖXBX I()_Ka=Q݊EZoГ P&|xzTNFMNYN +U쥟o6Ճ}w3jcW8 zh֋ 5$V.cxy.A69\Q`G+=d(9s^g${ d [TFɜ<;,r:].->v]^ Wv3SKڮgו ~jv5!e!tbv4Dm3J^5LlW*uswE j$W SG;HǓ6%cjC(%xI_!CM«Gs*U˺u e&w1|G*E,S%wOOh/ԫZwHfc?z׽';P. 뵏j֞5xƼ` wtZ I٧=]+ڭ(H ,݇lFP-y;>;Sn>꾬 k@iO/ܗ9x-pfmFf7pt´:Gϻ\Jvy,|VrmyVr!/ anNTz1G/BUZaQm2b=0 ;e: +XTW2:-7v<(jR]7<߰a!nFX`P~8b O.ƍ52Ho#YMZ_A>ח͌$+Uёy9]_mˍKi8#RS {xR7R㺇NJPF? { /$30~[LyWX T6}LwCͩ<h.kN7w҃TNzx:;R^S_%<5<{vc B)F Riӣro߯UV9{7έP$VL3iSKjE<[EnVZKNTB ^6{[] L=Fq&2L;+.p ,dm& cp'5Ե,ŏ%5Im jn p2cJR xs N7ۢq-Ojhͮ]~`:ߛ?ߢՂRQ8JwK|im;~t;5kQZgWFjN4|B">o=E7EC*LqqoϢRM\ozegbc[/3g}E#|pJ\DX Fc+%;J;zǓG;M! ,aLm 1q"2"ԪVZ ;f-rh^ܧ kf<?fu[ި񄑸\GU ǘ\ oYSRF "k3 FXPٻŻ%tL]3B QO//v'휷wx9! txޡ={ T)*da N.fn]0yu ?1CM0|uAű }3H~Z8!<lk:9gznP0.u}ENѻ tT__*}p'} =jҕ s."Zz H -ٍ, [Sw>FC:NH^4 #(bx0v٥ ՂDRgbg+{3K#U|ƣEnDa[֮ =KM~)cQlQɻX1B:zʅXk1*mǧar=0eEl?+(!8[ @SK2 v2F˸Rנ L Mr@|œCAjP})5E(.;GNJ2™ooe(Bo/%q+=g#/%bmJ8h:A;{:?,9QtHIk*ϕ[^Ds^[]H/%P(7cK5:74 Ma!B|\unΤ>S1pɾC[?#a>}U&|zjO}Fa3Pv2_/Ԩkzhte%0%Kpw#(5$9 T67#* HR3Üشq `.|js-Lm. W pΫw g_)(Pz}B?{O?Zi.3+-z.IF:c΢{dVN*!vspUc3wT(rahHك")I/ ]RGEDTAMRJnJ7RAR<3զ'..3BꈜQ254v?Q$z6= %^fZ;] +Nÿ10QM`.VR.Uɿm=…-WP7vP\KF Jcf]? FTC;)yq!ުbTuqH ;wOMm88{ C^ 1EIZ6_S@2Ԣ#`DF뉴vDeG3Z} j-F"gz NsncpUDɮ8Ccrq ?$RgrԐ\Ҝt # qUGoTC5DׅSfbٝ:/ż1uqUJ@=u0ïa-1$漘:|D6]d) UdC6{X% !Wr'c<7ϷĂ If$s |G7 .B$){f}z䙲Ro%wGT>E'pKoK!f$YoAU| ڷZdE8K[z-|! ߙjmUUdɫn5").B vSjipr^l |Q̓`:nqҎ0 ݨIv{!w6Y6>a+~6y`Wzw$9)9Ӧozy(_: uU6Fߎ:=aq^ӺXk"n5roF,|hj unI4vy]$VZ"TvmvY^8)0Y Ļ[>PCqz~5 U9w9E3^VmITE7%dQh.g4PA"9Ԁu f:Kڗme4rDI1mvU.R Ԧ*8wc܃a\%7-l ?W䖤V91;` #`Y9n j6$EI~l, 仢lߴUCBs4])re*#vKG N4XIJ_);em=e=^Qˌf H[!'4CN! 2LC»)M"|0PJRAM }ثCg QWUGbeh}CzO;Ч3I$`o͍#Hcl큩V#WޢSFmmz6 f@NqPC5vTK#qH7M!!滫NJdw,B֓i+H/t/ 7=~ !bbP\iA0׍[Cvy&M}/VݷK6iNeX=E!î pͤwj l6SLwGC,D"ň鳣:,af? `!VH֖Y9S!&=Α)zp xo˵z̆)vJ+l$#]rv|Zsż9jj[y=D};!?rvLdR,2:wlA)N* ]AuZ=ˈҹ0;So!Cw'(/syafONBwgaRpb0}؜@M:hB݉.LLuvAױzQɋot u}#IWL"ı#l(!~]/;D:KNֹH'.-۝=,}׎5lAEAP4Ol\G8x*#,bѬ|:AFeMQ=u]A|3ĘY ߍJK.VVkmLd=,(n=mٷ:uzyh14k3ǚ*Z 5f@5aD/ٕJ;;2!rV]t\ )YsG09"%<Ef#o%ǃkkL^i{ya], p9?3RMAAi^zWF{|-ūTn妊`aaTO̢Yr6cΏ۪D_#3 0$Gf#w!S9(&Setl=ɰwl<π8+PP>wth^X4GV=*VV`oGG4܊s$hZ)-gڣK^2?lmzTL]=:C?F~&oxIvNftaο"sw Iޭ $#GH$ ހ# $R:0IZƖPUgSA0ަVApf5Kz[2n1@+},uZ6UvՌ<|&!<먫SË9%<&0*I&@JCVrg-B2ZL"X_PkbL:Û /@5,+އuA̞v\R%-KvG smAk0;k < tJO\>(:iEބE#.ހF~KVYLN{D.Dĕ/tn.G 5iIS6HıTf1$Lg/g4 }Y‹^qp#r), .)6Z׍d6)nwf2k_!&{Z1'&!(xR}]lўGYY:ih焴m$D]|w,ઌzԠ"kZSUVUӤY0bMW Ȼ[Mrf %P_/@{y ]^P*q] Gbu+8p04A%dj12qE IHQiL,gH|ȳXϯqǀ'|E ez:V֫kQD1Ci!2ik*m; }2 +ċcJ5Z+v4!JSgeߌ9XH( 0*[P":_ ^U +FkQmbUe j-2a{p§ NJ7qƼC>OpS.:ZPA *aQ,rs<IF>Su^#n#XN,݅MA͕ 8'F0#;s:)T}&[݌hMH(#7.`yH;3PG׈ؒfWYcWh2C]"bx0ŧL.[4ka?Fe>O_fF]D(f t닎JKܺ}TpZڤ|H&+JK zl iƠSc";ߕ-H}Cp k FY %ͲF  r'=뫇9pѽDG)SêqlJjAp>@> stream xڍwTl?JH0atww0ƀ l8lt7HtAJKI4 H|S}s]q_slh¯waH~!4@EX$PJnAxB0Ы $S!1fzp@ $@Կ i*haOvuvAbnIIIv(CP0!]  7  %DzH =gyn>0xBGr wH.P? B@ <1^0G` 01п+=@04 pAH92y1 o 18da:O0PWL`*pww I+?U(t-{0 stU "s b@ PBR y.= B`L~pH !yCH$?HP0qH!NdP!-[po44125]Up_DC?eW HIӥ%Z n?c1& P | i_Qw>^nn\uC 6YW=#ZHf`nn"S8B`?TZ07( bzPB@0[v<>VA0K+``3b$¬#Aq` 8$)*H? q5 ,oj`{!L2?˄?l 8Wÿ6*7žf7:'#L ]A|WJ|EYDӥN[aT{˟vk/IiJvG|Tqy+nv6{#/I2bS7o+Eά׉^TN'ۄg/rțc!@#u"}V5v2/InHժpٴRg==ܓ[&873o=+]A˜&廦o|}LNZ+.~]3Ž9@4`Q{M zm&шW=UƼ@}wD(,M{Ph}}&z}^Q$+!tI`b>ްT` zz$%, { Z*lb5__i}}Y&_H$#aJ9ЪrgdVSe` (h Qz` CNk5%;>|:5idpy=&zD V>5fƤ(sJWj9~mcIyC,1z"F;Z(ИaăTvөݠ{Rl=VߨѶnHDE!\]Nΐ|<N0IP3c hP=wyfdfU@~ʗ9]N$ $Cj{PJ 6agྎŬ⼼-ӧyɍ ;iհ9[-$xHu@ M|Bs?|[pc/,`Cv(nšr2#[x}z'lI?7D:'oSYy L42 m~RzG% bd3]/ř s4b%oLtID w9ըA4B^ aEc82lw6>d9\/zoSݪ#wi-j,g)v$1)T+s k6OfZP) :ƽu1Arvl ]v$UG \]`X$ dԵpKZU7tqNve.l)g\^|]I7ϭcZ!ysuWNڑ[b|l>%Fo>SILLQk K[w:4qrIc=ppB;k`F x2͘O"e%$}cEͬ*&N|>äKCW#hшv*YK)T43Z{[$CWb}kb2.l(7 {vgpؾmk@ )\tsL}>eR]plf\aO'̛F1uP/;2ېƳ8rf\*^ s{<⤖"vn;΀}Ht`\;jǰTY5*8^ly1;|RؔcD:S_uRkSO&FoJaUk=B*k~!НG$,pW_zͱSoS/Jj댁msw .#L3,ʻ:ɵ5 ƙ/G|5Xbn'{9 n*2hw!dU~>JØ,yYT֖{|\pS#--Y^Wr>9e+լ] B IVC^[0iBv =hIu1IB 2}rFn3LflG3 a@RНQ0~wՊE/ޜ.~o tO^vj;1<~b[cMbkKtf;p _9_1Dtxx3~x7kjVkq9i:9Ycy+ϰ'NXʿفef>OZN`R[{_$*1rZY+1I1.vsaxLכ%+"%iKxzic>yYWRp%Ch}jLe; =}1P Ekex.&Ffګ>\Σl<,,9Dcs(XQV CLPءOw7?-j "YR>Ɉϕ5FF?,7Bj3U֮Nw,Cu jA  |*oS,cEӆ&e_o#mFԍU<*Mw  óɈ#4Rzk5kGk"I9{z K5k Qw^]s pMy֟ˬLߙgqfh1_;\sRc_b@Z~;_1cMd㋙R|ߞ(4^<+a^;aĬEyk٧֜6۲S٧R)gtb8f!dpќI^_Is 7\|9e!>[E0pRq;4o_n5oKf-H Z؜E{' Pࠃh^9rUx(}݇zR^`,V7%-Aɾ5fWkJykn02AHh^(u~ىfB~ɘҀMW^WcY"#d [cpU\I e fPsB?(#yo8G0ګnUBŬ5wsͬjG&^_0f$x}*j~l39S8󚑎oȀ(J>&J[MWqx7/{"sT+ssd<ǏqS=~pQpzɡr3!Nsxʹ[rAs#޵^poA{dӊ&jCЫhs r%KL~\xz;8]J\[9ʹೳ]'.bvoeS{2rY3jf?<^Hoh:Js/W6M^gN 5U:"'iez >$۽ SkA@;=̲=C7' 4eIEx7z<%W#ՇQIΥ]VBя#ס\)n\Ղzȿ-sJp,ۊ2B7t@a+uɰcRX h|" +S I^b/>:;753IbvMÔ^*U)]͹&}fPyp=7B^uA~]sBh./q5 2CL#P(5&t([*WHe\U^:ϕ-oVy7LH*B盔t dž+ۃGÓ[cOkxq9Ǿ/vu N&k>g]y!7* QTpW|@#d->`&şZ(F5Ju_-9K4I߇ VHۮ ?VRߺ,e44?$r+mw}XGa-xU2O*(℀k흁WDT /[[U߮6%'u9.|_(޻{"_arDaΚ%-d?Fb1weUĞ!>`=9T7\,nql\mMr|xpׇ<K Sn?$V)x$4RH.P-U\&xx~Fsêܠ_<@+gs/=DӆoY:ivUO "p ٍTWj7=RUh)5ZDvLTOٴԲﴮF\S,lE*Z}Q&} +r@>e-c- ա (tSZ~<<ؓUdll؞BRms8lgX4Q贇K=KwL_db~tzuSa+S ($=R}w3먥k*,ӍG=븺`TM mpq8g*T}0rM##*qeXwNgt_0":uoijCn 4) 9>3Xˮ=C4 匈7y]~Jcג&-)v_j `~3],e,GL_XfFpi{.$z^F9e9_? OY7r> stream xڍtTk/Ht2t!ݝR " ݍH#-%! H}uߎgo?̌z260+" 4tE||yHl#0AH&oDiUW D6n`@!`Ξp=uG5;(** - K= u% &aD:򺻻X:!x`p'\w0 Bn rN߅3?n Pl "PPrA1py v99[B=P;-h) =\K/CKtC,P(,QUvF"x`ȯ yA5Yj#srA_Ƀ kT=y sz9ۂ6Jqu5]\A*Y 0; ', \ k{_=AaT0g-/FXH++-5`CAd`)x@߯NPܲA!. y @>a>0(ږ࿲Wj Iեvkl-;߱4a(Ƃl܌Oݿ?(B l K+} jmg]5@6`W֪ -Q; `"d FZׂAP6 ||Cm#@[B-ͿTZl~mG% 5yf0 C\|08y  WTQoD1"߀(r# !<U#b"\P"azc 7P-~:@ 5 ZCjZwI捧s6ןD8IU/2IH(H3\{k mNih4F;ZM[_z0 C9UH;ܽ[ɣla(dfCgJHl; ,d9*k MAvApܓD9)tY3E\hW <ڤ+}U 9xQeAq% "] Ev۪FXnJ=&x1ebbi?c(^o^ (:?_ KKŃjL%圷e ݲz@ߴ;Vӱ:ݹZ͎[h`OJfe/A>aZ)VAU4.wv ̛CDB[$5*G|㴌]*>59.WDo' afvT_ -;Z.zhMdd;|gCwQ %t`U-'ӂdFd&tvO? 5Qldݡ{=4WL\m,9$uH뗬4aMk$sJٞG<Ȭթ0π[ڗ&wS5*nkhڱGB1w[5ȇ d5+ڍNb;0B ]B7szLF#3;k i>G4f>; gvܡzX#n\pXA3ItInZ41KMB]3(I!`WK{|~C¶\ 3e<&] *B{k0Y\5y6{?M3hgnW)3dkz/Ŋ|L3>u)o('c&ѧqw|fwD{߼W n'_7w9{*_4!+#Vx6:#g8wWfăΐ0c(еtp؉]w; &kݲx>KDe3KI^k+Em"9A3d:ZETV\m[*3»:'k:wFǃ}Mr+}DT6SoՎ5(B@p]Iң-zS>j}-gf2CÉ'1Ir ?ׁςZ,S IO{N ;GVyDkh̥AVޣ2?}.ܫouyEzD u;%S*F:SP TҞh #nz,4R!>r~;+Nadudžx Hjjc bXqs6B*]=MOMvMmq^ZjmuP c, xD, /YanL1%:RGyeIv,yJ(HVQ|* qp, sĂ zS]LX1Vl0ϡFk&n|۞t䂾q,=[#_{]H+R:E2che:5'n0O*߫WuI2 gV/驊\^ap& k@*[jrS̑\+KX0i~37D :Wy =J#FfCW:QJCnhϹٻ$z+k Zf\O*] jV9K_Z'qv+G~Yڇeկʻ߬>^m:%xjP]'t;lHL1[:P%V7}F[Gx^U5sC(!Ely53ʕDAA,3'5R[?vdlSͽ+4Bxdib3Lr!|QՆ'3|D_ri:-ܡۭ:2ﰠ%U(^T{ nm }/4fAHt6$wi6Ik#fhς$gJ^&Pf1CBHz*9xCqVkzs)2GЂnՊo rU8P($$iTX9L4uh؛h)A.gSϐ[lq$|əIyϱڻOzg:}amHZM0Ai5|c?}![^At]ꧠwUX(m|8Qy@f)[`ޑ$},M Št@8/;Ϗfc{:pf iqYݱzœ D?FqECW_`69 "ˬ~f\q,Zʗʨ0eGHťt±p~ZNxbŒ ]Wiy#mx6݅= A@ϵ{7)† X{e5C.@N\ JOKdY_o5G)c]37ְݵU b 5;B]@=plV}c2Ƽkq`.<I/>yǓmdTK,YdTPK.GfV= gm(R<;aIpqGWtJ=M)&[HeFt6R얲 'r)@e8\ +%@y'#|D؛w%]R"4sQ[b_yɤuj6u!#ybNe; R] Q2An]L|@'ևpo-mUQ3L2̭JӺʶ-I'fjBeo—+>,Y~!nѝ ɚkڞ+Gm euA$]41)GzƘ`1c2ՙ٭.FjuV`G\jug48gʻ)o/b$ZR2 ΘȺ x W*Y?-^^+d!G7!meH*U-kkq(0[Lcx9mA}?B+>2)aY|l(:"292dbs1L9kwI;lkW6x%ccyMѻ#]bDhe E#q_ ^{ȶC~P ϺҢJ_-aeL2 zZJsn4f|*.@9{`ץ0> nލ p&R<(*\c vØLw!#06BK1W6Kzѷ,fynnF;\b%9o4rZV棪GΏ]GT5UQ,Quinua%AUM"\E8gT} @MCӶ)!Zl j3BMJ49]8? 2Z&QOw 3zFAQI7Mr`jHl\f8󱡊iRt+ F(y:'#d.Mu9Gb[ԗ?+If\/.tGM!;d(+B1,|)/:NROse oѲr}F> z"v-e)9#)rQڳ~YyO,AIJľ,8NT]WQ1t"EaX2t}eIOL09߲uh'ϒg濧UvfĝW_LиwKA5+'@%`U\`.SW5!VHb- zvq`/;ٳ2[eO4 2Ulp=D3C:BԸX)/F3: :>5Rv!++ ?a=p;Xs7nԗ[ɰZk#2dڌFt.t=j/7HB,u&;eЌ_zx G )u9,DI7~$_rqsj2 B9+V{- oC,j;8Jم{R\B9KaȧףsCg>LG>6B&KHn,9qRƧ:߳8\4ru{^܁.oy>wZ?i¼-0"}#G京o^g).yfvX?qP6yq <6!'/?,*ƒUDQT,r\G]mytdӪF2J-^^c<}#+'2$/cؕ#ݜjh9"%}qrgL-BUu4ItJ(E3f3GVpۥ!]ץjޏJZ2U ۦO))`S^U:T{ZHڎ{Q4JO 3<EئV jv U^4i`3ᗮZ|*\MIxA%q*HKưtz< endstream endobj 714 0 obj << /Length1 1855 /Length2 12898 /Length3 0 /Length 14043 /Filter /FlateDecode >> stream xڍPX.kpи; 4Ҹ[p ߱&{ YX-޾O#eZ?_yuw{}%Ƿ uUZW+fb`k* Z,lZ,= TutXYGUvo<-_)pcعf..fHo-~C\_5z9fۛ -= ! X$F| >ofi޶o?2cdolijv-77ΜoIx;ټ=Z[-!m+l^ߨ:r  ??7o=yo{MW:5J..o\nj^@ yG PZ1"O ]tLK.)t5Y.b)#R7ˤ/ǭߒڞMԧvېN5 3i8iABvS}qvEUǺj(_ U۫V@~.fՊ1 *3Ϟ'sc"ALE'V@'kh[:yv;`I}׊L?{2LyhlFӡ)_~O:˨Atp}ڵ7꽵%@Z.EiP>7GSpݳ*xߞʆ=C݋*JO"pDQ0[eq>T0s I:_!Īs+dG󘶵&)#h^҃f_VUXS[(탇~S 柜(?= k)QmJ79 ȮoE@m. ]î\ -_#!b-AՁ&8L oۮ/aMX2զ5db&Hfw"`B7L+%I>ˏJA\i_=(&˜,a\ȺItr'GW EMx]"۹Ym+ Q>poFSTwR;l/"n+{lqm]m#حF|B7_#3kC`+WzY2^[k,]+rͥ)6? !zHOm0OSqRb6 9/2V R[ſ>fSj RR2"SDZl%N>6כ|١̄b|ΉK^5-ߜA.]תti#3O ¦p]O";|lĨncnVf: |AnB? !b^+! 9Q`I} ;kHth#z0RQr/ˑ kٿ.g9./8_p?B8[A56$+kgmx5xd/!2f} 5܇JұkA>S6|?:*Lq ҥ 4ƞ }/[8*6?*4+)RU)!tO"2ؠ "h/DX,shΨi{hYn>~d ,oqgw{+456"S߈CC|c dKA>ID&OxsgGa* ; EN,*N^0ծWNd8Okw @PTz&䔥"{LmkWc ,2 2x0B&ʭJd}bbV/y$(2"dcS Ni(c+?(̌Uv<-(oA=l_nB7yPe5 Zo䝱sMu|B(|UT8VtdNrX=۞8~S`5`bT3A=cs ^aeYv\_GdF2g^+L%1AÖ7v(LL*1YƎR-=hOej^<7"Fb?3Ϳ:W ,؇_uy jGFDĿ4n$B||3Hf*@(UTB!߲40@I\n9/&{0ήЇݚg+$T>xOBt-a`eVj/% OKgUg4k?W;xNȄpe;泎 ~XbѩIL h.f' M9 v}X*Ve jTTVmMmDG+h=ĺp@-4.c$C?U.Ώ%Cys =Hfg+dPE&NW v u41Hd9<뙖N@/l/wX{cl#_YqI+U87.C2U< DYҀ"qL(NWʃCr4[k;n@= 6eǓŏk9B^b^3r-\շ-Z"|g]Zf 뱉Y j=,$j_o|m6fRcX0np _IbF3C@+{Ēq 07T/Cέ! 4CGshQ}G"TAS,#/)LZn#2)C6fLcHF f Zc{p,9FF,Bԯ# 'B+1I1aI";Nvy2i$';7rѮd1RRƖbw15z=jцF9O)}&t̴])E*+^m}( Kn0F? Tgf`Dk#.Z+ji-] KCQ[_gIz8ld1g~N jc#e%dM>~#B_mPk3}oRڅW09|ϴ=T|l@0§ W. `}zĐBլ3%& |Ȥ<-2:]b'+Dz=Y,nWTB$R!dJNX]TPssbHyM) ]k u͵.٤qύҐ5pLӖ ]?8^("94{mTpۅ[|HF[3Жv×+Y{?ﬢ "Q2{n'IOԜQ%>w@O)R_Up|Grױ#J9NwD ^/c6ZdP_/cUQ_Ӻkħw@2 +}Bm5#yJHtgE 5cϣJ襂uTZC'v䇗E"JKpSV}!bޓ ɫCbߜ5-*Ԑ҂jl&Nv ?%L^+BXwwk LccXP/ cc`% ue _ƫ6ѧt%%]tl­{}wá? bV!ַP35Hp")]Zί(ƮcOdߣ„u8rq֛׮u?v{{VN-\Eh0xL-]$:',V`"tɘ`NF\*k(6?zlpdXmU2B0ԡk~twQک_6BUwObדOvnlE>| 3spD]h%5xD/3+?V*WQFfRNT7Nbp1i:Sc\-.hELH1) %0^Z+aF&ׁYU{_i;L5|8ۼ%]דs?uB~?ƖCu#PڲfZR޺+Ȗ UO|8.4ԉ?zUW#Př) hg>#QM[<OM gy`j~d6v3tri]vx* mx'!M:=Z` H!bD##:Uw\\߽N9K&>}6A3ŵ(1 &)@D4{`X6!ˎ],Sx8ĸ~@gJ #0Vl-+\\Rfx:q /cnaY,^EjJHi_`EcQA9|BQ&3ZČr$v> >NL)¾0Gf.ZGa69Rusgz_ۓo+IL1bR.ȊJnԵ\-)1lc*<ߪbOiMo/QܺL/#snl64 P= J-R8g;=EtvoJ^gZI ˅ 8auO _ٵދ >q fude9Xw\I'B.HqEٚD|SW:ٖv6Ā_p3h/\vn)͡lq3ԭ֑Dl!)괸GNd~ bG2v,U(\`ޮWڐt`{KnDh#ZB038%{!ɂƴO%vJҸHZJ4jKY@ ]h^_T=ЭJEn_ !*Oh K|C+^A;=B1OK[/z. 4@C*̴ X}ScOw>lLg"UTiҾ0f!Ӝ|WO_D>0O?ĩx_z_ei^òϋ[qH6fwcB_ajH: )LWN)D;a umH/>}ϭ.sp>RF5y_փ x!}ySݪ^jk/_0Ar t2,c]`Ys DPR gfo-1L& }2q_mzxuxYMv'n4X697J~,:.8ΰ청j qZqt] hɦ8{b:* f!<_F6g="i@yz1_H-vM)=pO'yڀ#%K~LB~k^mrc [\kZ)'f+FRaqVMB"0>mP)R| lj Yn ̟ɰQ_ODHg]R ΀/M>4*TP/[7fiG!v;-JY`:ߦF8Hzw֭YRD[2%0@93-Fc:qWJrTS4 ORr\: >G2p\y}< <}VL:WѲVFBN(_`/D+x5Dq@pcrƞb-< rؖی6meM"g\r`[(,% mgm 9Ia;O:y!FYhebCPJ,j]:RR{>_4u^VńbetJyڶņYٟ`Th}KgcFLX ¶t71}$ rI8Ă8n.1K', DžODvn!O`URz.$J/h{bĨc9(o)ۖ/Nq%T Rq9r};m ^樛 Gr8 |]Ey(@ t8٘0Ԅ^)>ҡ^QUt|4]+ 5*vy*Ikh%g_-M𻶜3O 4 SVWOf zK٤ǘp s dc[\N&ZAaq)0{޸R"}}{MV)|zV" -SIL#qYԔے< x\iY>Es,ytdBW`^r*̀R$f 2 eݩ=SȨnv|bKmBձ-L}ϔ L&K b5(,v4EZ8V9t|#ːߍ"w9auO} l5aykOxB%,fE1¯~Y l{Dz]lX803:+c߮i,M>#ơR  X!pB:9yV^ j e+uc:i$S}"SfTQ>zqP)wwR%2|dr/Y)gvC—͍13CZCZZ+B#E;XSNhէP'5CUe%}PhơM4j6}׽F!nĄWۿy'9x4Qe5'OѹAxa uwmQq,IXvM2)QOZ˜~Kly^c&j↻gbڭ[toFW{n3 |܊E-E3چ|C| J.3y+"J?5k߁}^}e_NzvH^5| 17CBhR}'-) Sˬl~-:6ۭ5A0` -PAoJbUY!D9rܼN,d9^ʺCSō@Jࡇ!@݅81LBrگ-9#pgJetF-.[QV ?y )wc«k_450cUܒEO~~S뻙<'(d:[VNi*4ta4}J4uހ'zc!ii?#[wp-h'tlT<$kk1lQlͩUD(^`ӗ,1ORE8TIevQed Kwt:6G,{T-鉡Hdcc%k7: >4a;"٘hS1qCuOWu5Jr7)vgQym3)s)=nd\p#/4/G*>t SncC}ς#`m*?*Kt)/rxSd6%O2`lZI#~PI7)`\ӿfװ\Xb8cYS EKR=,kf6ZkId1ԧΉ)K2p>#0SO z0:֥mVU`ۍ; 2:QA&81II1ɽp/aW TťOF?淪Ϻ#Y4'pI0Qb6" "ҽo bOg¤aaГh~Q5VRnkj?]9#1EE\ֵ b~=A%qG\s[35Wr(=!# c*-"q--pUt~,>a @f1s-'-z4 $̧aoA؜q-JmΩi;K" Cˁ2bd-Q`*ni<2h ѻӚjiЪ.u&Ǎ O׷xLTK UGKPhYYĵ?Ps+9x[z:$w" ._i|6c*rhf܇TBȀB?ߊXgBv9=,X/U~eZ`J6Pי/w}o~1^dqP Ha];n!l4rTQ&m!JG3uiJP;N{4Q52ɮH>`q6*L؋FխΪw`+e4.RTBMZf>o#<d$'2|raxSO/J.*>zGOMOUZ5MK~*Lz~>61_zcVTA!:\PVa1ܨo^>{^eŢP`c 8:Z!w0(FE~w{cN',XcIK7lK#+URɷWi):NK dǙ0sₛUqg. ֟ڛ.A(ᦊO2JeNCv,ӈAvXM?n_of2?|'o_=gW8JvV;8(܃vWQE Yӓg5(B5e:gaUlGUHQAn"?/ɣQw;d3Šx~]/? Ӻ?ֻDqԻl`^pfhCBO*m3#z5ztlF ȝK'-yfU}+ڤ'+iG»[(i5["nA'z+h9`3Tb\ydL?N13]&?^4 ;8Sp%O#M"{a< j'_ >98̌7XL4uvl~@JRxꮳns;hNnbI B>Qӑ#''lt@.[Ď t Zo87n*j㨕9Q(Jvbk62) _UGqcWV/kUwGSK-}r{7 Jq-PY\EYd碱pI9aG(~XO_ Y0چY p] A|䁥fQve@mU?kw#Z bi#I4{!WN?Zc9*l^ٓ>`ޘhя(CGɗV e, u4U-\GR j{jםREycjFǯ,jQRFy#_!Td8;z $ ݷEC }bil6+/a_C̑ ú+2zdc]XUF]n},[/o>WBPn:MP>"*1Qc^ 5F@O[=nm؄ZTm lVt>9xZg*ee(6l }9dQFrYӊaKHOci@«bě:)G+WHQm\8]ndR(*o8Ƅ=IL:,PDOh{\kx3 `K{eDT&Јw(57nPt6]0c7bJNcTSOQ/]_KV q'ݒ>?:C?%Hw>w1j(j{Dh]2=qSm4+rް\+}؂A٬mX$A71u |=#=JJ>/#ғQϕTI7qmva%Q,L? *[5_Upw{VhIOKE|=3-?L^[e+_,Sc1\"vs^ O_Gv'盺ޮRjNFmEIA[2-J kˇ:d='or72X3 d@mcdա$Lui*W+]M|\~\Jfzĵ?қ` ruAHØhiFYiИpФ 4dw1$Mk(dr9#:].y{Zz6Wt9j~a'/O9& ᶪ=ͣ9g6Qdc{ fϜb`q"&'8PdphMG'(&13~ݝ:i̋|yeFhI}aq֜_dp:y4s܁v~&ހ2$_|<}&D=,1!@sDS/Lzo K~.mNv}-JƗuKtc?Y^ endstream endobj 716 0 obj << /Length1 1869 /Length2 13138 /Length3 0 /Length 14301 /Filter /FlateDecode >> stream xڍt GIw۶mcضձm;wձml5ZSz)2!PƉ ,,```c``%%U1wKtp4&b(kkr02ٸٹL qudR6@GXRa[;wsS3}00rr:d ̀;XḿNɎՕڑjdP:\ƀ?JX.bfׂa278~8%ev@er}8F:;D6ZظۘḼy1:'7'V.VJ7 * >*>G#s;'G:Gs?j#1 Z[ma'b48ww/?dbnclGv6@I}>LLNVvNt32cw;?j|67~z:N@o//22͍@Ss&;>ڏO:flkcWL"(+.Nw]uxҲ1hXLͣ``Jژ8qNwP= %gѹ@?` dmHu ͭ\g)ktewUcmL?:/X쯦ˮǸYlxhnjY~D?:%ﶢ6F+?1@?{@Ogc(`bǽqE0Ez;3^bK8 ^SX*^bЫ8?b_bidkqLa'72kC#ٿZ4Tm!_??m%߄_!_!____d'?tϷ74]5 j.ٕvoa:Z}W@1@醹 bQ{v?iRRw+- s$*󉣌3ӾtW>)![J,#qUfPMt`QP`AB3$g xbGOiL4[io3R{p'3/AcYY S1O24p 6m̻q,-Js_[#ָ,nt.Z4UkW*&'eJSqK3T i V߻:jI8.t{ɣ@"7!5% 0E ܚPJ:hݛui7rLSe Dan}>mzSζV}u[A7W,{Kw\ _}zqMݢW)GKvFofMπy&{HBy2J V',ӭvvE\,ʖV޾\]}|)u0SpyoGSzCwh|]JK\o/ʢ՝0[Nj@V%LM9#? 3F%b6.F6d2&;3~+OT'Ub^Kb= vȦ\8ͤzD8 bƖtb$[J#Кf 9uÜJ֢\`XֹxIXʹMS6HlTQ4:o Q4殝Fc"rPq%boqp`],9pT ?mpqoHgt>2J.+Zifc?؞R^ <}DjF~7SJ{m~Aڿ$bzq?%#V"m;߭,՚Q4[/=_Yy .Ծdc0` >7!o 1|JP DԇG0E$L=Q~\vK 1C5wcп#~!Pds>~ЙD⣖rDbcЫYbUfݼL-svvM3A6#J'8wSǝ}G2FyR(bI"t7RU.ZP`nM}rlUihWaEMhtcoqT[őMڵ>. RRV`Q‰EQᮕD˕FO n43W< S&@n/] Je('r|T_K"#r_Au`6*t,ѱ"OJt`*W'ꙸZi ǞX(瀽L;Ɠ%z11-:l &&t㝕= X*(EV_Qs wJ(d$3Bq{J^Z !Z&${ThSG1+f\FfXA QF+ep;!X]o٠FPI(pqdJ,ڣbP-\+rޣVAhP-=l2asরpg$]jVN lB=HyW/DIHC;xM"ی|\Y䐤^hG9{`ugv:y t.uY](F~SID8%C@ElA-Gzυ$M]O6k܍t榋^Ŧ~HtcdvBZEkgbFj:C7PHSg_fhzzk)$C5Kf3s--_]jD0NOب- DFޒ|D +& moϾV+^IgjRis3LZ g;fd|2F_akԋiFt-[z5)Y䪙> >J01z i*Y b\^w9$X^awpOzs_1~T*_vz] CWryzePFpYƣ 1,_&E/E\a~rFwǎul ujirĽ4u4=B8'3}a}Ouu#IN##[g+2_sO(-"rAGV+w!K,h Zpk}xϘ:KJ!JSX 1g377W}蒭"mt^w[fӉ~y OA:WqGȽv!Ͱdy`Yu| e*f+.NJSD+DAVP!3~ @}EدD:w>NW[S.آVd^&4ڴK3_E5w@,3lj5SI'M;x?Yz2@3}\UоCO5@:zaN[ -4 *Ϩqm2&{7$S4a?hDW)-p|tf|Gt6%T>=ccVŤ/Y8禃2_eH?N:&ܼLaB9U^Mj: %TFS-LCJP"b Ǧ>Ay^PdLqL钌χThTĞs*ħkԣ" sggi}";!A>کc!͹x7zSI=j A)8Z{5˞TGó4@oلgf!.!٤8ގe9%ґM'H,䡌"cP3Wv@n*|l8)ށvV|DI_({ܝhc\{4۲E##&بD͔or8[Ex}練!E 'YHjԙ|jdz .ХVקQTkt<Ҙ.oӪ=nUn(1 ƌ?/XdBvpťE ~Č`?b@׿Q5hƾ%~|'D3IL˝ֆҭdG45H@~xo!jx䗥3?wgyETݼy\l|zdOmVPpRpغpɃ+쀂'2f="z;59n-]AKS[0:ڔ@j.Zc[()'m8c?Z'?͍}}ʫ_]P]wEqՒj+ִ}4;}LPT_i 6PBӃ<|L>a68̾\u(b]LZD6)RVtͺ$7x?;6@fa#@G0Oiҕ)ΪFX/ 0JTrǮ/3 |jvwLz[NH͙y=?Rv@ )YUف m)w}AjxzHͺ6 E 虗.:NiՔxK ^Wc26w qt fùexä z [ EdvVR2ˍW~1r D6x  /l7 G`q&qÁb~ɻY|+I,rVm&VxE(.`A֍)]XRG+P'-ژSX I|65̀;h܇ VUb>ItYߧ: v3>CsnFC@:$YzHbM3vO7HTRf0{ SQR-f)ևP`bXN۴Bl|<[ug=Yܶ`$U} 9n[qSHtp.O7Lqh"^" lp/B _VToΜ;1}=JVJ+BT*: (YwBaMdBqg'P c {ޕ҆6ō_J.(>oAXiUDkW@M(ֱ!ua 2JٻX k`XC#9njG5ڜml}Xaל!i߽4ڽP|uQ^ȡ5^5pkWZErL%>|OgW˯~=6/!s[?(AdwV^q.iԗw,~%,YɃA,)NQFta@(/~Z#,ƃtr¯ݯ `{7o*ykVnC^ŭ!vӻeC( %pi􈊿 &‚YRk4ъ7g~WH8F=? aP'|DAyGk?Tk(w^嘶 %vs< >$xd Wd 겳v_bvgjV{r uD^RU5KsU%Tb(VG~&< yz QnDdj i^e|mnJy;(81i<}L FT:qSښ=S|͙FSn7yLrWg\CMSd.:# ]PY#1bSvLM^ n&pCnIR8ؾgO&bd8&1 M5NpIÈi/'VA:Y)@iE8`y_I" bwUxk׫EL$b ]ߤ]j3i$߭.RQfIR;;ODftf"jAHJվjqIe{wԆo֪pehDo^q܅)ogP:0?D]bZqYx"\L Cr7Թ[9K=e7IV9k̺ݾ*єqrc.|k֧\Q^ WJlCWq3 TEkި {ȥMzU:P CC>↡J #˃c"8'VF83D]`lծ=75Zl($FdQ)j"痜H 1ܟƣIp X(뗡);Lf<IMopeWy=U$+6ںH+ȅBOUvj}jDA:oq=!Wi+'Vnĵ0mR#x1_hKGg&]焔 ɮw!alj:ԍ+c)]< XJ n%~B'6ܫVew:f WWRjΪWx]j[X2bS|z5W$4"f"uS"AD%$7[`hN'KjSGc)D% 56o n]3"4xbu'JpB| \,"t /c 96dn+F{kf8)H0MG 0wJAT пQkY&>rK= e%eh}`tL^Մ$2dyOw巿LQҨDZ"JPKދ|iА]vN"Cز:_>: Sbk's*.S5fd1($J5͂Ybn(.w퉤Ldr1~8%:u C+Z r((wlaH:İ /")B^Ko5{ ^ X3pnnD1Zʨ Q_cgBaGkGH6G]9!FAz=UyH:Zk nVs;}G` "1/χrWoQ2fF,'#e'-jO z2'%~1xq|㈠iƋu5l b^=jAz'p7i%'oB,N0Dlܧ@X  w_w}.yŊw `5t29s(S@Zr#bƻOz3:Rgdnq|\Js,_X?8쩙3I?AYy(h %$12v!> юX_L:rt3/i5i=;85hf:7FQϰs#U~o3цFy٢{_t'=SULj$b,`d+n :D)c%)cqIMYEjMxuf{T9 PTxQ+i u{ք@gB7Q30nnR'^ %FR,SF}@QG1x50_ X&Ky˰zں)e8c:AݰڒxC^hUvɼqNlrvBOAVVhSpF8̕ 9ld52 "['#>|Ջ n%CX-vPg`Τ3탮'?=]NQ207rT<$ jߢ}IhXr4y ؾ:x~V '56Ug;ߝx.%Tkᕯ7w Rg\wW$B3K* MP ̖S*h;.ԇ0LRY%\ݮ̀, hhVPE"j}I*YwPq¾Mq*Gi5*FYXݢ% ׊ r2A'j;V)\7K(Gk@W/I a-ϦuXvt^sD H RczEnH6/cglE.x_g7v Y=,EiOt&_Н0J&"P:i.4OF"22Yہm\՝e\`[wxR)+uG+ѧC\$O+x֪M`ce )D݂JHhE ,$XqPt_}9*(cȔI -^B*-]gzPT?to ¼ GڢW,KHiy|ɢ ؒ>L`wlLvos*1}Zd7Z 5Rge'ANTM.g'afƌCڞ^Y e[?nM ,d[Y6#+-+K2ȗs͡9Cgk>'YGm~˽hLDW:ʡu\ʂD ?J$P9eIJH,me-W;^F8rq)_~2ݸMzSnݒRTu@&.w`ڙk ôg G/ENc uY^ÏEriW\;AN-38Fd&WZԺ"J8n*1}~`VDH0:. ֻW'B3uQJc%↘OxM#XU{9_g@X8{Id`axԝ6Ͼb3ZJlFM%/).5cIF+Y)+TtcN!VPHsd4ቂ1vk\%$/]l}]5¢zW޹NkkLDa*oKhU Sɰ7vu }i_;򊑮nfON7BZRXN>/5zWxT~kW`X{$Ǖ=C,;&1d3h8Q(w\0 2EFxcn _ -yezSM׵gN8><1IJt KB#5&r.jqQ4d߈ׁ<aLFnxs/No$Qqu.Cm35f+Dc8xibZ}SG@i =GS80'RJk^[."E0RbF%*$~T4!٭Wnkp|{@$P8<,J=[ם!Ά U8ȻyiĀ;|N&ȑ/x+cE\t qI[.!7Gp1RLi b#~GokJ8D %[6%H*PʃCO$gʣ*.黈$kH,B@P\{dVZ<1Y`[aEYmf@Ə3+6E%C]?iWEӣgL[CA♶=#6rqwBI}+#dMh q^7b : B(ne'7=[hƲfkTwoeme~_~x݌}EjPh6YmGP9eJmIbAT’GQᐮd#oY9o&dh+(A=%;E'"'[cH^O5{C!>4}Om 6N ,]v;Xs4˂N#pkMzT5[g]i ;Hv+}rYqV(^d~~=2)S|v|-(䷧wH94bn.Y.R΄Dm4XO6M[Pe*{V!3(4uR a]‚+!j+OZ db{MW߼?|lHf043&ΜNHI1Rl[%Ql-{Widlh df"S~tJ^bY{+Ô(U"Q3#g4;1e:; ,ьC؜*%Űܝx,$ ЄR+"YE.]5NWDo2vYRYN 4^_X9xCHJd_iH~x/c@Z9:\+vA.uf7эojEdZ^ vo8קeF޶&|]Ӭ#O?$N3qlIbl1_e | ]Lk }v]3)-^p)E@](sbC"|D-Uxm[HfRڵ3Iѿ8Ilw15.bmUo3 J;Rj\kJR1v^lJ Ŷ^$f'T65?LY Ȁ(j]bqm l<A4RPbrJ(WZ.DIW+lH:`n gM/? ӈ"@QWQnXG9og6KOr l;4*k n;'  " .;/ J+]Z*H`k3IԈJp/+ȍ~Nsb8\۝7.373u]ڠIW(hx,yܻ&y.wٴ;gb9s!mNS".aebA۴"F5ktM'zf|`~Ⱦ ρ؊ԝ܈6SAiF)D(bkG0l˝^~mc Lz!1RWLʠ.nn56)Si/m})UzkrAz'kLUnT1"(Ŭ-ci$Z^5-x;3͠SBf1F3t-#նߡj3 IvLt z%C]sjRJb%'XG rE?C_(0f`aE Viiп҉8,ߊPT>DDn5¯\#W[*~i籐 2S*}p sUaK&gQhv^Yw tMN"zuҰ<B#ȥ(?4vꥣR8B:wSiOsƽ"_ 2ZO2='0ej6riڶ \/־f8z3eY ?[< endstream endobj 718 0 obj << /Length1 2727 /Length2 18049 /Length3 0 /Length 19603 /Filter /FlateDecode >> stream xڌveT%܂b!;wwww s^'f~b-`ש]zGNL'hlkqcg*˨01YU̝OՀ6; @2' @ `bffd032rWց bbn HɅmM͜@L@iD` h t0728AFVe[#s\P~0srf`puu7vu0壢;@1W9k?ÓT>R5qr5p@+s##%ev@eV<&z#s l lmL&V@ --W1AE(dh`nHhn+K_n@189Oh;?-uMmM~blǠjcn H[f t122r ݌~:d%igk067{:N@o?FNC o 1o s76#h~O4gƶ6Vj4 ?Is,$dcf1ؙ8\;R00O JژTAϞPK4@yadc4bL_ǼoLbVViPW06rh@ k Z UUŲ@csg=t2)hY;̝Ū`h112h׌,A׉#h::V߬6Fƿv``*f66'h9n3 de 0uZv6/߈ q#No`q0~#&o `X ]7F v.A vĮؕ~#o `P@FX~#obqص~#P9+/9h-+H AL̠X  V@?la3-:K0l@SO$ֿ5 @%Pb`un &M~b31wǯc[g? @*=M=?U@T3w;3 1? #flk~L7ȗ hom ݜz l i(Q ;гmβ2GﾲB:?T+vV$aTU{g['cI(=(@Y8=Glt.  (bG+G?>`p2s1(8a{A}8:YVPo]],S? jA<G Nm_4_5 j{wgaW{u&bߡñ,g͹L"0bW ) /j%Nm0:D8)}9n XKH#a~s;Mr>1t[L_C{y|² 8y*.%|af:D-BS5N=RHi!4޿hGןBb w0,ì]Z "`~I2އׁC5ܝX("66r+%k71K=jgR`&=#dȏ}F< }>TܧX!9d‹G_Nq^>i>%8m"Hi Ef ޝyLRJochs1}5pKܡXʛ6vպ*߯tb+8%t` }i%Gԝ\?%q9#EFi~ְݣtrv7#U Tpҽ (qxѢ6sF` ~2]Tڒ =)E xXyV9,r=H*^n:)Dt V¼PP&{]0#oo \GԧKl&q m,K.zs}hXVP@~=MB5TeН%Q7r!KHgEf|9 &, - C0}vFbʊggtW{R S ɆWt ޗĭECQWX9&#JsyNl,e 2e !,=CWǙn?g1]vzzzh;r^iR0SUN{.ISsq5Q8.!@aS#yZ]N^zC)Z>}1^0OU@Bha:ŁDz"4eFkm2_J` "ISxruLڭG>!;h- &—R0;MY΅Łp$נ19J;S /ijm Fy`#9LhLf6^N%)X %0U RoIAP.`IQZ@GTц$;o(JW#ԕV"2 "\7wL:(ؑ@Bӫe>\Tִ"7ܴ 2eV*ؑ)zAj9 .F1 j.*ڝQ yQ DkfRbjPވ')h_䄚?/t#"|ٰ |%+k؈p+7Nm;ߟP5߽:ޅ$t{% YQ3>=ikPldB'7,|I9&qPDMw+[M$fspĞk vNXqQI@_(a}Yf$ǩb<vfG@arVF]d\SYJq.qk]ư mXYyMmf3} ,q #tlC(YcZ(0qneȄcѯTxrU,i]a \8 c$X||:ΟyNa?ϟN2yWɧmn+?r(At$*|I^>/dO5G5kK sw+#OaGMH2Cr޺)^^O_UF>2SMϠ ّcVOQԹ=+= Ub@sꩢ60=9ۈ"\պOmuI.wQF/JC.yXeE \a`t2<;LK6],4. }V&߄oƱ-K6g:-[Ʒgսi8ҵܪW]&|*י)%jdW ďhh>=^LtUDwbIr3-7:\*k4xLyd/OQgud|#IܐdvhȥJ(O)_taۦ9B+bl/mƍ'dGޚcѭFT b:#LHu,3rd{%P6Q8ȴ8$`&Y) aPo 45 ͤ_1hL"x?Ĝ>wiZ I_˥\S7F9ʷyV U *;w,Ʈ~&t250Tߑ<"Q`yiԡ|g=S#4{soù;AnvE I(~E݂%VrJFoLoE=ܷ$%GSI/־ց-4zcef8#nX>SK*x;4&Fi١dL!ͰD6KYW8V̥5m42ӋFN)ِq,,q{EHW3zeiB3Z}0|M3%kɽ>qF\GzuqV͙#v*U &ohryRV*ooy;_ކ龧7z1+r"[h,N]%v|.|_@!'t*(Č$.ny[APŰki@/(Aܾo0.K`_k(俿`)Md<:ܜfz($"}]-J!֓WEH5UJnYNs9_64t5RIrwhO_qeZ<_VҺ%9 ]Ӡ8ڜwkKJnd{Ь]}sb {r@ȁ2+e.}`fctɕHh @:֏AÖ> |>/t}v c9 yWT yt|,R IW e T=SuT i5vKA3lMbSB! LJ2p>#,K7?_-#|$'zfH.SǞ<򬐍;\0ozw_Ru3*,x{;  b'J"l// O/h2_j<;\E{e"/ن9M"1W|߸ ;2kuD[nʋ~dl|6ji:N2>X\ z\׺9tLXhwvy ǎͥaOxa:LC|;kkA+ҍ2š({JY#.o&7Զ\(5df1||%T>@*jws t"S3⣼iPPag\u1z2"iFp$? ~nbi? b ȀFWr Qsd˜$&q2"8נTTtzoU\>_REF%t|ԓ!T1",4L#>WOa̦%tC1c__F}xR 4~{zD9n}ϸ ~6ӆƏ SŬ S*`\_ 3ށҪr=Aiݜ-#.  vAuxzxX`-'vм O%jgQ$UM~]!u)V}{SħqUmgԹnu`W/KtrXYtfU#<\t|VR.3 Y `P sڌo2 П9!)". ĩ,i*u1s#,Y9$3̯r,{jM[Lk"qsI1M8Q` {Hesrc<*lAL0yޖ%G,8 >y'+WUyzyG0z̞i'bI48bSxK'ەfd,h|FB{L:άز~X9WBL1u(K؛H=O??j$L:c#QW}Ǚɔ B*SClP|=i+q?8v7~/S 8%C=Rwї.oXt<蹍Ցe^;i a7NX_7Lϧ.lOتsO䣗>c#[u$V9U HQ?AP]C̢ѣ\)o5f)PKh&,Pq; EpJooqt8s4qR=?%ecG6"JWF@⊹)H ٮ_%Ysr iʃxmdz{¤G1]q &]WHWp̀x%ZcwUhd[*jDiZڧX)rZc,l,+ S7vBNhюl;va/c8VsJFg%6RϋZ:sc[۔f^\>6ñhPL O A]'Sfӛ"xaBDوb0#7{<6kIb2tƊw̴_bfwrq,EJpUo7XyzL✆N1u ԰"LyVޱIHH}AՁ{wr˕Ov앉T~ljz➸m=C ޶o;Y;~S$`&Π\~j4."ab_ٻU%PO]:ɐ/mb{{ۍ,RxgGgu9֦+!b^q|%<-tHS2Y1ԛU5=ιq0kVH- uZu&$z2i[!ܱެ`0mųBpG;h1` ,=%Uw]ܕɤ%Eu+{c#m\"k=Dp9.ŪyS#HEI0Q:(3)I$ &dջseo<{ }ܐCm]OgmN ixw8ٓ׌$8%F XZ42? ((K u4<4qޣX)Ŭǃܖ|{4xUU}>{g Wx+VLuҮ/Yrc E}TIH™&x!8tWSYM)I7`hކlEÖ8{$d)tZ+9jKq\*R|_9si!}ͭly$]fq8hbgČɾnyz WjRUY$GR2/jSBì=imT-o0x*Ĝ9qOI f4&+4ʉVǂk!0_? Jzk<2ɤ/ij $qarGKEؑ}mLP1j%, vь`?awYZ@p+^۬k5*C :%[bMM%_ǓrJ ,,вd_[f{j2p}~Ʒbpn dH Xy{gEA}SS87Y"MvqԬ%6%cȔTnx"LyR]{[Ϩ*sK,Zut9gt8j 1:zIqr yCbOO!rx!_e̓ \D2Y|| zlTќܞ<Yb;! '^z?vύێpQX.#ASA)R'wO7n?.ؒ֔a0kn6 p&y.w} nfihh\+Xk;S ,nzKz&B-mfIۓMQyBJig1 {k.]^ rhhC>,>]G̫ *QiO)!(~6%WlS-Oiqg bcyAr7,uh 9j 5.WPav100JLcjl·g7O[g6R-jA{O޳^F6iIc8፤]WHaV<ŗ$ZXYP>!xuILupji< Nb$@ҵE4˺AWT )n6(Q[ZҰ8ts1g$B>3S; KBQ;Տf ۱xyE+ɹg!ˆ>'yk:qE.%<`{ NTrya @͏zEE~(!T?kώxCaMPq4غv7On`8}& .Hr;?;#VXqh9.ht|s-?DZ2+< Ai#&}|JٔtXB Fq֝?$qM tւcƬGO KUݎj\7`x^s`mB ^cfFIF֤ėN m'4λbn1\H2:X3ٚzRƮHi%+r>*֪*G+,{d:p+(2Ŗ J䝟6댑}x /d։ -SdƆ4D/5-A'99)9TPRcU7TI$z)~i)mTc` "ew/YDήGѓK XÏ;cVvu\On4 ;T1V'C*cXr)(sۗmˠæZ/WyNp-/F |tK \iLhkӅ짃һ,i^ʊ_RTYADZbZ'nShIY|o9].MTufy4) 2y} 夬OPx-x WQ _ĄwN1q֎kFړ `>9f~S<.hfrI Y3D$zgiL|7Zf%5{-fk-bC8n@G,|z1Lb0C'.8lj.H6R(f %&/~p:ZVSL-E`xbvC+'՛ݓfs>aDKjCSbg!CC_;Ƿ*ǼUR1\CXGl ?}i ǯ&A'¡UZͮ|Lޝ^&ֆ& W7\R[Vm!!Xm8a(s}z*ʦ9u=@ o?ʆo񐁌tC6׸]K*$sYbҳTРe@˧R|/-[ҦS}l4G8h,n]A<1N?HI|v[<ҰOSVE+,,e5>^zpE1%݁w`ڄ $јX:;5Ŝ$9:Q'VRr?"+w[f"Wbk$w hXO'B`y{KQ;prUZv 0$afIN@$-rDHRlJ:yNac}?|a<4'.A{J8JG  Aڟ&\Ke%;T"+JÀm3g;' ;^Rnv SV"gх(745 zV(1nSIŁO:u%o{K'˨i?MA"A^e"P'j[I 6Sҥ;4q Zwl1Oom޾pPU_bH~  +Ml_á_vbC)hh$xMT(^.3SLRUC{Snk>k[E/Ah>C!<-_/dy!ӊx|9nO/:TĵyuO~atxjAr9pXJCd7:KA1qZ mXdÙ[&z&o,apdiN8M*HJ ]G%տ08a >#`6ɅG(@q6>Eˠ uvZ"S6#s[bOûDan Ḷ +M_cA񨡤Xۊ]@4!%kzq.M7ndOqɘ:P idLfwO,suj#uz⬢^rx3AJW&dPfUQCĂѼ\;( J薛-tZ;|T8=u#17ab\R*՚KA mO "bf_]H}zNMw})7C(e/S Iv?!Xʃ7w|r&Z p3 yu2Ҭ?+z[̰ؑjB`'LZFD{,ԭÊ8mV6vrH)G2")6J^[~2mte&}6Ll<w$]Um~cakנDЀԯN7.ƃiB#"AH1n-;|7C\Zog`y2ɛXCB5=1D>kޢ}#1P:r֏p-~uXgQ]m? %w:)amI}_ Tn$D[#3lA4:lxi6BKFP:u@hqe5sXHTxPkqGϵ h" cA7"Iuvg/4]'*I"uj4h6;c&ܳr-_#HN"ƥDgZGIMƂkzq9 ?{n+iAnViɽ͈OTr37yP }16"V -MR j?so?QU_PɥjTS5Yo P6Gs :7#\dy̑; '긄mbb]Ϻ|yD_4"-ՙζ"8ĩȧ;߷ՐBE:ڎyIJ=-R~|!iGY e1TJV7&.M?V7A\Izq8m6ERIT֪¢w]m/3`̥|#^DK}/: L@~OU,J`-|v, ~@0KY~G9ِXVߧG2+e#jkzҫyT 6),F+:)!eZ<;[1ϣwCMU'k.C} z>9zё8tI*$FT&.ށ#}kbOcH0t,$>׶ET+cμ};[Wa>N D{jXN`ʮN>v*27yʂ /w&e%Kw]|K ظH{aU,W +Q]~!M g—;lX#JUȜm:OwmTU4;>A2ڣ <(Zv`8~)K9ȹT@Ay.)xZPg"ֽ˚,DG/[ZYn09Ϗlng{ {OHǢQ lma8/,1o7Pzʊ }dgZtMQd q\9{r=͘4rF̘^HX ]tb^S [Ms`LPyucm<3-3#FVx8L *t@(. _@px^z0Q6' Sjt4,w0DD"05f-sᑿҨf@q$wW7/nekC*xHek$iKų鸢1<5ȍ{G? X4T.B+?b=6 ɱ{zG|J$ÛӜ|; k([7~f[eA̦f,8AojRhpInDh7xFt%.Y$^$9w' $c"POe^aIV㙸5P㑇)3J1\p[hlIw1_  w&j3~(]4|]0x#e-Ѥxfd:>$sPOgo:֔%8h -݊E)M=if;`Im#8$. q)w%gb!\j%/|.~ԇCx@F_쳜Ć0ߥ8ՙ+ݝz'OiHC@Mi-yoI:C 3IKNu(Uv<~Yy(>rxk.p=zU`w>d h;˨b*m}ti>*VX }=BX.孧W9-T 'vTxc󑿡 3a[;pA0  FHjCtm*e_kH;SP,F녳Ij,ZfƇд Gs{BwYqwLvʊ$62f%6GXjQ4v"9 #ۚEʖ|D4w:|v"EBQ"buWϐ=7+I':]5sYk =Zk_桜jVRZB{n[ݛC7Y2jP x6 k z}wZF¥܏JPz2C9|s=#N,$7 yɟc!?? d`[&PZΕMos̛H|+R4P =K-֚@FDZ=QuiKKyǎu5)=nnôXr[@apJ؜6WSIJj7P簒[m ?V y}|˜ߌap.WØNV*~ھfj(cw}Ćk ΰ,|{ߒ(Rֶ0!O J [3uPV"e 9o* \YFQlzK:&mUCB ٛ]x$Lv?̌Oӏ".”z}(veiFsV[fz2;DZUm6dPՁ -?^];6[-\ঋZ9YL:p/+rlv2Zfwԏ,.k9&E3C ù*s-&Ox3 ~ Wy۳UVXy㫇 T #|SQŨʹ` GM&u}X 7~(џDtr0,_l/m'4$%^0UoZ%n0hz X[qֱv<= rI"?=$:[4ގUWkvae2r46L y(Z+#)S9CFQq }[e\vwb^xg@"E\=*v#qZ3o_;eoΖY[^鞰Av-ۆߒ'mQ@?i".bq=Ak(e Y86 fT%q6#0;LlWѮ!.Fb,SGI\@>=κ (^P'{LK\D cLL E6+'p߉NUܢ.[+J< 4 EFЀ$p DTY?VE RAFze˻I&WS4+O#:XUr~+&$h :L&u3 TCjNEM^t قBqd촫a/;s>qu$lM12×:,Fu)x<0j6ЃM0}j܄X nYZasu+cz$P7&ej+a[tΫCnfV)@T9pkݻudZ?yu/b.(dN<;\Gs|: ow?"-GUE{]aGA΃oN-xJYxr+GrW E+ZJKed %W72(m cB#"M[ؾT`^ _^bl ҂ xSc hG]ml G2vcN_DIo׺4ΛL$2p9:2@V.zW[85cW|JĈt/cGR].&:RDy Inځ#rG )rA 2ҵ|4T>'(}皋*01 a{4dVR:0<ݏ֓t@eX:!K fF|R`0]wXO.M!H]mbe–s--p}\$,U ?Ft~KͨZQ#ɩ5 YeQC1{SQ܂7H*ybv_ 56@ Pd`1= <կ*lsLl[W?;%`8pvBY } 5E#3sKeIȻDѽaq{x<vO>4N-:e2'Tg\E H%>z в*(1!a(ՇI%KS^#]O6VRi \/tma a8ooZ%|rdCxU)%5P{28ڏFg&KcY.= h15L6zxB? #Awc&WQ;惐tQ/`7LC%SGkQT?B-]dn__Ͷ_`sà$bLs;Q@: ȆҺ(X=;EmI3;ѝ<OB17ҲbLC4ND5oNŴgBD S fm4aZ^)A]lK4-d 6(f''pkvTtrUCP769SS_i"mܩt\wA[-^3% lqMڂXCv Pl`4Z'S}Cqr#Hffr"M6ՕfS_߬M$vk]Ui)NNRle[>V r K نt;h>z:‹<N%~-@I8 endstream endobj 720 0 obj << /Length1 1503 /Length2 6912 /Length3 0 /Length 7913 /Filter /FlateDecode >> stream xڍwT]6-%t)H*5C3tI7 ݍR4HK()ݍOk}ߚfkkss}5zrpk2I zz qYYHg_q\V; ICF[z8B$@"j hp˪wq; o$$x~r.w hm΀ A*vAe8y/(Ѕ [d@S.+EЃ!6 %0[;p:hB`  'w?5~ml.`fA!:a`g :o t?!lܡHK#6ǬU@`H)B!6:^0fkK+c'6OD@ 8Ho_ B~'~o5][HwH&p[ Cat CLA@>?:sUTwR^ " @BBF sQڱs>8҄ps3K%?w;Ƀ]>2n끼 (jcr5 PΪ w e7Vq/4g( G@[^ret@ܚw r;=^R f5f" 'p;6`pm p+/SQ_W$+@?HIZ#qA_$~mwHww_lOMڈ@a9S(OڟF5`}~筍:ͶACzS6$\5 !o96xHJ{M̚?&nOpSde=1kUo o@"q1>i͗Ȏ[{Çul,.,%a!U3 56$ +E* 2QEuPx rhc8,|nw^YDh] {6%&O~۸w\%m.|cDNi,. <.|` >b>d|ƃ?jU S{~iYVSzED k,|YJ0F~4sFe9V~tcp=$P׆`S؆dDf\2'wp?DJiy.]u ]-PK2l]HC~G=k|pg}%X~:upsr\w!iNwz26;[۞w?Ŭry-nxԑښ2,4'%_/-P~WЗV$e  TWA9C073Q7vԳYwjD}vAN\2d"ViU*,R$uJ'hvdN4h(br扃CY8(C*72uGާ]{WkF?;y5̺0G@ofqID@@aG7zblg~k59RUf~5ca-꺥d'|gqwc{m5uY I*GXFfs@ Qr+jJ fc2R-ZǔDdM_o4,rO }E#,UB:%7+H"0'VD؝%֣tHPw~UkL*w- ?z!)[Rϵm8 ݠ183rL}_sc tms>w2 ]RM9%W1߻ :eCI4B|0:dRL>FN8ŃmV]ώ ƲO-נ4=1Fr\_9N6KgsN$~Ta #-O_ zߕ] Jp4nZ{6 pRC:ؿiڽK:f1Pm[ե7?uHhSضWQz#?GQ)"l4)`ʇU$?3x0j{mJXݪ 5I^-vH_"m+sj/ÐL iJ?_'sBVޭF,c7Wdl?{PceDz}m7o΁0s%ɇ/Tb+xY6]R4 A_ʒb"fE;~nTџI+i_јrӑO(JW~ % ռ_k&kT8Τ24튤'9zxxN39yb1@GHL8Гcq?{ vxp,/dGIcYKS/%[ vz-F|z>[SQ†CypHShx&fŤ8$o's0bXb0LrKvƛnJRVսbdyvWlSxfLPjTj~J=,pr hkYxU5 KRyQ2m@IQ[K|\Haƞ6taKw7Ȗ^_S^SasMOõ .!/ sThOe9*!Cr*{ӂ[Lu~l( ~_Gՠ2Fwd'xHP}3JV Xw0fL좆yc2'5^ }`{f}β`o^e-OXl&DͨhZ5RoE(# ?:KZ=@L<:!~9u$;AP.Pinw UQX'en=rW3-ˀy3gM7KwHgUICk  ,P)eo;i)oA 䊈 &.yn*,ۂgRL-\%U-,S9VL&fl7,K=䓩4q]ufbYh;fv?\|_XU^V.Y&`2mI0c!~]V7 П'vNa/-6X ԥ>0aՑѿ{e: )' 7OV{a\6b9ݕ#zCF9k ^OWZ2Z`BT!Xw2\0 :ci860 R{vJ@FCXH"M$oUVJ uJhb5ع}qXUܩDeŪa?xPtP) L⑂sZY،Ȱ.D*bn8D}QXA%Ilͮd *Tf%&_kzjqyєkrDc-"u6ܿ!K%pFzibBQݼ1F[{2*H ϮOD4Jȹjy 2Q4a4s䉻| `IJw%o0ԋ8&]Gji1Ba7sQN^,;s.!Z8:2Aws*]/WL<ʑ¾tyvz^V,w"7Е7.ЛO;\c*KGndO):!/R[$d dX2/V^o~{Jr16}ӚБ@>M{{Z:-[:oU0#q$J|>u@EwiC9$ycnR y6N/>ׇ8[qPB e (+NlKdΫץZ&]r6ߕaUϏw3^\H Ѥ R 1'Oʼy&WU"CϽGp\>1ߕCu2zYθ$ ;|?@3 xk<KOuo2{rBӭI㒯)gvͣʵgΫQ98ն]ڏC/^W7>i$vHvEj5m:" ؼգ^e,>6ott3g:5"Ze"N X3AearU4 FJr}TK $[Cq!ӑsW럅']Q XmU|7;7 τYi\Ȋ5/z˖fj x>1g"tyf 8P$N.y&cm\ K(kW i 0W)S+a/+pFT*Dv#o'>2h㓛ⱥG"},QB;ƉN,P+ba6za%\(2Rk?Iahҥd9<Ɔ8"p;jvde"gI,1+}4d Jn=J\ .o8< g+q+%n_M_qߵ ufΌ$.zr3`5ՊbJ͔V1cL";fXQ h =uRhvE.F&kYA S}X,*1tlE{@j1 uHb/%~gNl}NOGRjLE'fF=]TbϲͧGX,1xr}:YM@yq~ +IfFGEa]uۜWJ"yQ;k'3Lf읽}jgwh˷N`mt 4 קvDعjK3>oU٢+6wQg|ȘY; ydj#3, unxԂpٗ!OO-JɞRN?#4m@QP JI 1sh. ;KfjW d^Lw.04Wt2'`0=9|,CU|Z$oJ%}s3kwՋQo!m3/{?ch:! Cjʦjk)^ [=zG`+0dʀ^{-z7bL:'7.-UΉDQNNM1K,"Y'/cu :Fz'^d+LH, dΜC \}7nI1RgN냒zVNĎًk^mikDg!+ӈCϗPQ@P,T=ϣҞkcYk qw>mD*ۼy{r Kj|JX\Q^joZR:oBI!gK1fJzF2$F9QI9+~n*c=uƜrQij)K hiwHßh ̾&1O&>#v f![wP|il35/F>cM弒{T>'81a=L׀PknMMlGbfal ͚-'[ hFثe24%&b*";hOUp 3sh %-QS,W7{ =P~ܰaXZyW2jJel9NOAډz_}N)$<ݲX G >\`ޤsMCDf]}!"nu6KD=pF_/&~ٓrSvr籕C*T!+,\ў ߈-F\v6igLk\ _hZ&jO &8v"nt[k]_@hzsQ(CS^Ӳk.[j+>\I;9r[::e-j Q>ZXW|-*( G"3JXXoѹKT}]>~J_,+A= f `J ONDoEn\P`q** GE8ol2=-Cvy]SD6ob&gƩ̍:3Ex_cGH@dVli@ҽ_;06oAl/8_P~Al[^#ǟki"Up&XJݩ@aH8ˉ*$W@Od=h{PDCކp*U'Eo]Z7#F_tۗxàn"4~< >Eƺ$v#*~>ʆ˥VTyjmpyܨ2E9ܵ r*ϮvN#ho7m۶!j#k ߌjddH` '/)˃į:W2QF.LDaI6dvX!I4+WU!9륢hIX<*<ʣ09 ;bF^_Fjʶ> stream xڍteXj6(""")Kww7,K.KHHwJJ(H7H  )ss~ߏ{yfaz)m* ஜ .@V]WW9y@\&&=#.CEőEA69-U9@HP!"P"9;PA.L fkz{X!l i'( `W;#@A]++Rà …@Jq<`v nv.@KaFAG w r[CQjM$'YO@\; G0A8!p/`s4Ը\=]9`o"qvV?!]]\`vpkY>9 WGx`w+nHn}8 ,ք B@q>D mD 6@}a6\  pEA}v70+ j ߪoEgv3kmawed4 A! 3iaUXe  gO)Eaw. ĭo Bn@߲#Y?5)9:`b`^qn5zۭ/ ק iߣ(HX  Anw 7_6xWn-/x[_$Կm*? B>HvbHP';5W7\M9}9X`~ߵS~b1N73cZXa`n߬!|5zƋ^aݖ*fkeyjT܏D+M^!Sxε ᎅWj.wkDȀ6 ޔஙfM"Xo:)zJ] tJqqT3t.۫y<ߊE镘Tjbi0BWYwaћ56ްТÑC31%z0.*sEәau+t/fq{/FO|#wĦS6.,Y 6i# 0HS0q/cw&'I!ıc}?-jZ(Ke3l/\=J㉎&m -|EQyd!KɶU.(ߧth ƪ2(c| U¹B`]zQ9-/bƣzB򬃻f|@&=Ft _᪳%ؓv ov {d&+Fdv hpW% O\dVXd%%&.YfNH||) YX̑!ESLyg=Tm?Nb~`C݇)3,ޡGɇ{1xr3W*{YMȅ Sp =s0 ;,7]z|hrEhDOϭܽL;"VZCX1 ͅm(z >\PƌX5J=z' ңd3vvD&O*  O-y-ZCFg[;B"aqe˗gjis9 uΈ$k,GsOcf`ב򰄓\*u6-P8>$7/LoѵST+5xW=<T%eե= uEʾM5ZHv-m |Y_ڡm(*9){|6 ؊A!S+X L/0@VJ KYwyqKo/]m UUY̿9,Q^hs}#Y,K2x(SR%l^F(7nʞY]`bM kE TPG҇S)+~x-Zm1'$"̘/KD(H7*Uce$4U𤏠{G;!vv^]_x\7mJzfK>Y%Ը}Xam1q\(] 8"mSRW>ܡ8/O,ߓp v "kɢ./)+y?L)J1ŷ+$?}} RFgSR:ak=c 0tpw pWj@m7\^Kڸ*=_丰[tk {5*UStV= m'>L(dyWt\H,Rc2]7i\3az|\EW^"+I9*[ef4j[dO΄UאG$S64JLjl#~|z+)ß)A jT`'E*ٷbfmR🗢_{^$ߋ ڛ'Y/w ƙ' l~;Y&޺D/3g|e "Kyq)jIsNQC;? %8p; kbTc77~x*;'x9HbAGcMDf[oU\"kPYg:W))ղ o\kSUn,n 4Ij*=`&B{"t+jkl6Glp,Bu&B61ϨF)rU<  ׭Z|}P 6KNdKp1q/6uǦљN1#h =.wJ`ţ^uo"S_9רv7{rx0ᄘ>?K4o2 zhQ#sqQnHs؏#l7r7eѡGjXDx/ wuIU7#/K3Tc'"l{L};;t7?~_ [I>(D2'}x8f5y#Tlb714RʳAFWpV/ElEB ™k\FZ b?;i׉p,+|s>77}HiUn{3":RA&d鞞տOvo9{S-ǧx:.P8<֬Ш? VL䗭2O3;Ufs`er?#Qvhۯ|B.\,|MR;ОbkQNUdg~O,?(dUso9/BpFXp͙d ytFO_b]L39ivvjbwlf_q5 U`225'!_Eرȉ%LmPV;SqV#?>I{%#,==KIIdRK/zZ!I"vbR QR3'y^;`U5`|Dpb3ĹBe/ad?t>q0n@1EoJKV>~(uvqPŗZ;iŰP{2 J#K'Fʝg4u18,$엱H(EmHt¹T'Û}(46x H;mV!;+pޥaC1#{j ex57g%44렽<7SGF< >u0*÷ϙv=sy}mn@鷍BTz|3aނ.S;՚  .j ^n .d '#T7:1L>2ت"Vr~[p]LIa^_k~*Qja84*a7wW/) {Dedn)4M2(3]{ɃG%$HBp+ 9I7칬V<-%~(`wi?&|už/$΄ixgpş7!<4qe" d&]6V&RjM=GY{V 6#?s8tQE*JIP?BK1c@"D4Ie=[@Br3 Ç]9̧o#c/MM;AM>X<_Iz[XCɷ^OGy:"NNay2okKjT?iMû8?GꏥZ}:2u?<P$,4wrtMBK]B$Chm.Mc/iԫf:xR91&_'Ys,τ?F|4i-HK=, Зm7>u-!_؋[[1NۅdpO2*ȉGalH.Fx|gK¸ sˍ:/#7GwEvkdLuoOiTZl#%Kd5`8> ~uIڶڦM?]S5##{(bn"I 3 P֔Qy+Z[yZ]ڊߣymzű%H&^aU]4*7NGTA?C)##8xԅrl7?k7Z52X&2QaOpX}uuZo"=g^d NIcx4ՓƢ]6#^iݶR90桜9V5߻: ?.E~yݧ֡zJm4 endstream endobj 724 0 obj << /Length1 1381 /Length2 5936 /Length3 0 /Length 6878 /Filter /FlateDecode >> stream xڍwX>!C 0J;G+1ƀQ҈ Ғ]M8q<{:|E'o h>A~$PQ VA a~HnG;v؍a(w8!E ؔ h Rjx8%$A $*A<@m~s+"]}Pp{4_@N(PPBBw8PC!6sTB`$C+*) qqGex^pCyl@\``:vh/ Pば@PNgDp`tq |{UG{y/ xB w>ݡ(+ڝkH_i0UDhw(>{iGUw+ ˜ah(D܀0o>N_fHWf?Ce ecmECf۫IDA@APLTDzG: _Fճ4S$\Ab rCG Qs?Sw鿲dT<8D? OhA jC0[{$Z aazp4a78g8tz`B@adu113č\a%3Tc$+0IڰHl$~e-c^( U444fhQ3Ho-kl: Epd/>Y~Ϊ)p H*!1E{7 M,$rxEvf:*ŃM۶wc/ _sąΒ|5S5Kmu~ƌ=t` M͉4D zTs8a.GÄO!tHxd)B3gNOkJijH'&lF 嫡 /ҙ-X-?@@ 0$ ~LJˀ_XN)\JB훗,ݥy%Zb`6 _K T@%׳YFFf^9a?Es4RrJ]|0,~gyDpL XmgvW5jQ:&^QPO鄲wmN~ԧ),xϤˬ>JۨGZMTxطWEŢ7kh"Ljp_=xxI Ȫ]&e.~@ieI^8MƔ&LK>a+SIiheGO蛐jAvMOM1Q7aͬr8#o 58)b²83[] b$ʶ y9u}iy]3Pa)$JeXطqwdP'[M2/+KB)L^P",euPZO^煩OwayzIvb`oq_uߨOZ$($eJyj8%3pQXc6~v ټEh6 &ZsE)5_LG}*4>/Z 7Zdpuze1Mُw'oUn>).ZEв,%m=I@Hϊ7 Yd(O(w QOMO[Ac]7=|}<(dDSP7WUJ1@h7]$zT#wiT/Mpj޶oy#wTDiT$?L 󢂚y]a=2;ѧJԍU9Օ+L[@by g1V@#Ƀ2S%Jo,YgڭRrjvLE(aKL]7=[Fl.D4qÉ!P2QvMVg ~2yl=W=CH¸KkT`Z*akguDibA̋F-_83XXNHo6߭Y|Wdi.⑒RDcQ*PkIDU6 z5Sij.zjji_s~{qg~*qaA\>msy㵠 0ᚄķecl8ʃW(U2,8>XK'1~8sȸCRE꣠Wc @O"1Ss1jc5a R O+捖I +.m21)J}u{]4+fKnp}6(aNE,w2FSNvׂ/srX9Uf_hn0]|;qQ=]9}{]ijA5ys-́k0q93ȝ穂,A/8<³VdĴ2`5~-ާJ?X>dP$D q+M--LhY2)H- :W[9b Ӓ {\l~:sd~+£O^AuHAF#y=$ fzs2lWQo64.=Un&3GoUh, V.۷]dxmed4iO<ܩAMz+^^ |Ѫ4W7eu1;<2<&݌9|şp 3U{Vⷌ'RxIkxfZ<56=I!*k }84'=UcX"L<"-n Y[#3ɗz3' hAɳn$/k4eΪ6.IgE@ԺTKš~~8 0E-2X?Nyw[hea%3ntpոΏm\PE)kwlxWMEэPE9SBq+'F 'T}ȳdH.kq^Ys vByÌ6%qd>imܵBؽίVRG ,4w(Kd1$Tv|#cpR7',d,r 'gLO4\xžLyZʩIe  nGb&j!.z}ƛU(,h_--$0fDfocfaY)kMQ>JһOAɚ:/&iTGdSUn (6HVi>EkD {$UpYLgӄMȥ^;cc:ptA؍Kw/dݲ4C*Y͓ 󪓱TFz3 V26m*c0O➒@R'OH1} EVv_>n!,bUm͠0!ҾSksKSiG۔Rۀ/f dо5EFh@m7;ŰݼB_fIOAZ#|̈fY|$J<ߙa`6HV$els|2|g)mvMVˋ 2(ARIǟ ^*epm.;dB?_X^?㪍 QЦϹfJm ` FДM#On>ۢs?8Rng/'WI/I cv7;?7 /ް8F$Yn=Ͳ)="14\xt}ON~)?Sm&ueyR ̍R !\W4jZ97_IEN[ J~ -i|onQLYgCI|ѳBcŸ7X)9;VthvUfnUohMGUe5#/WmOr2 㟅h $i 'x;!ZK.l(ΰL\wNWi6ξ[!GS<ѐdG|E,[%Q:;GxjK]tх'w}6RY?/Rx~8Ǣ9JAdfv,ٽk@*'k40  * &o6EjLٶ#1hZabjc/ 7T3v5}L̅BR x2`0RPv%$,cםk[BRN Eh|YB@[xBHH{]yl.w2*mz\Kþ&ϭE? =eBUPz9u;D'm:/o-gbZ-8rۨbb?M<_ƖJ?Zg >:D尢hS`GbDMAb&*K˓4TKt*]]dXф5nߧ"R:ZZXDCZܔk}fkWJڼ1_ʎi=S$AJK7 /OoP'np◛z!_ukzÁ7_! Տ,Y,̈́!o(fytwt O_2Q } . -JY 5KfQ&Lwa!qe$.hlb7v٦';IjYàw)?$e3)vNKVw{RӗfS[OB-F&'_2?o472p8*r K:ؖ0G`2%itq` F:qE}N!~oZ,umо낵 {S׾ $H@dr"fK2HNWS SHEUKJ鿀f}urDv:V9 rny.[gD]| endstream endobj 726 0 obj << /Length1 1453 /Length2 6357 /Length3 0 /Length 7353 /Filter /FlateDecode >> stream xڍxT6"ҤW{Dj  *7A^wJo#M/z qJh8CƇ 0t" v(O7mAA8Cj/_ +_6  0@GY60$oaآ S(l r|H(W Y V@8;C($nܽ4 v5? 6{ @\/ ] ft . ?Ex@(7w\ P ` mF 0'z007w Ԍ/P^"QQa?@jp;@tw4g@8@+П Y]*g9"?3V; =Z,jkt `j(4ъx|TzAP/e75o0(@B0h/ 0з-=CW B kJ+J0뷘|p @Cj CoquG P;_~8U ]D7=#G-&t0I:m^]J0FͽuRrWNם/ :z6'h%M5Է!̛?=M @lmeΞl2{&-jXl (>'aJCvc>3cbYC =!#s3p7T3|oa9ûtjpr u&$BYj3Ms8mkѕ!{m:OG³R+'Vن 5'E9ԤȳV1·2>W zuK?%f18OC,']Zf% ZJ ||)/ ct3YLӲfr\s~e~2l]Pw1刁r*(#kw/IM=1Vce?֩"XVl~9X8ߐtPs#CLª)B%ȕvWK1-L Th1Fԥ/y$tץܗHɩ^ (|\15zRB|V> ѴOpqUlGNR.s!6 J` :02U+E҆Ux7ogldɗT O&\eS98R`T%sV/5*A4G-+P!N-N<J2ܪ{d+i 'NoOᅪ~OyI~zj7b’TaLr73s]>uxo\©zW GɵpZQW[tTJa<tJV0gr6_d>46;l9uzbAلla }˟nədhCxVy0QFa/zna/'|)"/ET_4ʌog(# ͛N~F%uSs.mO-'. V82]HUi96eSeq+3Cyxbʇ%g8$ԉ*4R'`{Ȥr6MDQݮMyF1'o8$o Z @#͡@΄~El[f`?ȇ"OڴQ"}]9;+{x[ bXG,t/S8U?-$z4l!4|0XT-zߪ|vژ˙5{n d7V} Jk$ƚWHf}C~3^;q^2(,$|5"1 p6i0{saV'(> <˵hȗNxSñbXč{F3,S70 Bi0Fqտ@;1<#1^ pCc'z>W@Ȣ|NwuI:zf4;lѸ+ $&~ӚuKNۖaJ/ikb_FaXLڳ|cѡ9c~+%@/=j0Ezo ]4g'fK<Ѡ.%/4_ ri|&"^"Z18Fվ :-B<Գ%`IN7|{@8ٻח΄01B V>b넶2WzMPM7}qC88$Lao>ӐS8lb4 **F?T>*F5۔}b e޴[ |ɇ5 L𻅤SBLſvHgsh2aR%$9Jp3R#8'{j4L51}1,rd&,i>d-1/>GJ>_nfBb/#7a}I=W )?1Y3:~=ػ,/%q[\ .r<5lf(L8xkw=^)ϬA_Fn%zX$ho> PaGZ72vw$zySy43TS,u\|;ؽQZ9de;d{Ԝs?6ez 2$;"2V%wRrdB N r4 V.-UOE kw\:hj(oIiI"AaHT ź“VN*s9VH 8kg8Zg5jo %t`kPXh|4uMB\>}^Uo,Vѥ.sXx8wEY'D\Xz eiK;ሽ%0SMYz$a=C-7*^Ś*@rzogȀd  i 'ƴ2.'8ޓ-+Rm *uO͛Ԇ"p |Vv$RbnY?D++ ̪߬}`&Y xRH-dW`spWz@Wⱶud⛣5"$3[ubM܄F~BIu;JLt$d #|wTύ,6_$IMF{$\&:-P %-Uεdp%aNέ6xWz}z| f~Hn2( Ey#apt2QɝSeԴn OdCEj;ؘgzӡ@I/O+!^urk|rQ¤euܕEMUoD댐Yfwzq bU׍{IGX#cjq~P)ߜG_屵H* X~/9̶13HL2O߼z"-`{No@< aOf9!2a32jDG`vVfmΙY54?8qW I"?e }$w3[ҶcK!P!.dJOԔweQ) F:c~"GAg:AN&ߝ :0MC^1SSvK^z;.!爄H" 2~ID)ŸDk7q31|,Nb[GB6GYyfmv'…S&SRsQeĽ^G]b*ct$-uʒuq qfiZU'g a~˛U`^1J=ޢ-:H`ہ[$-mn>UX JN^scksj#ij%|"D7{`C0UҍhcW+CQ^3`D*V /mw[ê>xlV R`yaa/iaWl9mt?F@'FKb9!JuljF[>߷ W>P>8Ͼe=4Â\rNXs&H6:ܔX-h;zT%@iǒe0&6;e?:7`tbn3g\ Q2I/ ]c{_ZμJ9ۤR3]D>H>3OylrXDKm;o\Jde!lo^fzP۽ A.+ oʙ 6g(A/{j%Oiq)j[Jf|ܱ{M{v\c#s;$x`?e#yMsqAó1"ҢFsR?O-N6K DνKf&3i}su2!U+Ravy~nuD{n:'\=kn7G%CnU ̓d̷ ) J>;n,e`֋ \>(rmV1n5 Rpx3@B[u4x>FOF6U5>zf/s\%zˤfF62~#;H+ʬadws׿#z+ZT"tȀݕ ,^'e^d!nfߐƙpE:sH)^܇ᰩګ+i z䛌;N .6jMPt{d?];[)L5͏(+|vpjMsW,Ա ~)Kali8Í2PP̂y~n(bm~b;Ƈl֠@7.}q4ikMTR%B"48L=G]n^|pd*]̜:rp5ɛ"zخ1Ԃj:}z^uyIhݥI``4tY!iJB֍1;euk-,fAÝ8KletfIg*@1M\IUH} :u~zE~d?p< endstream endobj 728 0 obj << /Length1 1389 /Length2 5998 /Length3 0 /Length 6956 /Filter /FlateDecode >> stream xڍuTݶ-A@%Bґ.А%$ޫHQR Ht)"IX9?ɷk 2mFD@`Y4 ..$p!0X$%Ԡ8A4B`Ok`]+d q^P \0 @ ~s.P CC=Hf*DN`hW7(r#]@; 7NE.X4> E@ߝCw P0H7EQW)hWW O A#fQh/߅=5Mt@h!0("܁o&>nA_0~?7?"iPO@?W  H?07kO ^^p4?+lnvJC~Bb`PDDZ(%% g(oj@?_{_sY.Z?"Ka/oN)W;..üGtK7oSL#=\;⍠rYHD#ws#?/ Q4݂+u;`h/JH I~"xC޿ 8| ?cV0PB@a7 `- |#Z68ፀ'0pMGU,^B_ߓ~d-|{9Kc]>zTIȄ? Ѡu[N\zעʶP^n0$H&}1YTJry vJ;-@9;a%;Kk $Dt0ptI|7;ۛݕ.Q)YID͖۟D0GK"qZ5{1 ix2\~pN6b%HԨJ@ 0naH.qQsg ;(*kK^m~}wYg ?ΓWnw cOHg(|P7Ꭹv0߷/S4L =|zd7QTpu0IGOC2MQK i]— #@߅|v\ܛ?CʂbIBD7 EG߽|_kKMעM;>ATXG6:ax>P;M c,c6M(#CpII̝,3M ueV `~[gEm`R\=H%Ss+ufov' xÔզ6Em&CgpL.ktڿHd6?8v͒-v6b.H} 5)" Rl7f<&?ur*'k`)gͷ9M^бK5?WX|T [£eI( Fnc{|0:3"OX;ApdpKV2KgVefA Gu'- ZJ^z? AN%|Ʋh^w16lx'qj9L^1=߅04i,v_ H]-%%_~- 38{P,0l1[ۋpRR  1ȎKS% ȺaPHsS,YOw=6(~Wާb[MDV-Xsa{d3Eŵ_J;"sajAmNuVDՆ?f*:b 3WxEqBXn=4<mO xuӓgD _ɑn@b{'yxAU,]IfRCaW.-O>DBis^|Q{Z2)ґ{:$&~jy-RsJ$Pʬ|+M%,tXOMTrR!O:ln [T<5"P֕cg71\h9<`U8di}i>2 b6w˗6ߣB Ip7]d?9p@mpj5i`(\ҝmYx%9^{;4rHiaY)\Mwr%Ϗ^\&RZhstt74_l ? OeZ@7W?GK $KWk$*RYà|PyRR@]NZSMR63mhU7C7^J ~;GtNg/oEru's`HuIƺ}ɓY'K̭x4ͭEvr>N_bTD"6wޏ-8Ky;VNu$8BsӰ9Cwl[.۲/rwNNsFavf!VyxbY*--J4 j$?e YGs8\!pheIk?gѹg:Ee;ӟ4od98̮y@KuFQSONEN}HgQafk_ d}X2o}iqhS]EgbyiL&*m}e>^F(_lDBN3ioc@{ZܴXL.a8_Hx'Cu bG0ʁ|C%yEu:(CQWkH(ty m| xeAԭY(µ@ڵ全)to,hkhR3j>69t.-/ICQ7Mla0MoUIyBqekVzEv)fET`꧸e!!qk[KikNdS]RK hu9yaDJ݂1T4C 3 F )bb4([;)"8bPP]~<W}]tsIF:FN mh˂(flѡb9~̉θq[_qm{>rJxh,c;x =1eI.g] .w'Ie=⶜算Wod4(3`+yamk:iZmzHUc&?/1t|H_Ɩ"N6|tI$ڍ<>|/vץɖ{bK`M~d E{@X'6р&ͦSτ]߀J*ǩf.WIp]7ߍ\rFz?Aha(ß_&ϓm:j0*Xjj̢VWbs,F6%# Yz?A-3=sQKKʉ7ekuҨ_"1 ZvBd&՞VB:i`8 ?z zX45&7PJ.?̮k'@Z<^l94nS2>yP3N_,{Z\+W !*PVںvc-\Q c֒"S({4G>WZy7M䖒(4Lǘśbд0@W47Pw[:2 4|'l^M "'ӎJn{D5?s!Qj͈ 8x$N.{h$+;ѵTK,R%Ty '`9"* }j~lރ[+93ܭŖZ^Ma-RWC}.UߋNdH,"x(G ) wU@1HU=-:" h j}A |dmvfojivzh˶']S|6to_nzn]Snڭ+"%ȼf̎}[|~j_̩} 2w#"*уϯKik?-wk]b=F5y]eO~rQ,pdAPʈa|OW({GU WOf&}? ^n}OZBf ?Xnc%N `Y}5R. y ۿ7}ۺ ]畇yV*P4EMQpr¯'<{m~4 @R\fWqcDISY53Ǥ;g3O`=Ԩ ].o5  d<8Έ.C逵23Nj$2y9m3_>xyhY ܇Az HkWLQg (?"XY՛G+;;%M\ٍiyGTh;5<[ݹԚ[BB <.#}q#vm2,]ޅնޫ`Ik7,/d~`Ns r~sݟޜq@;G Twb⽆J Xy79tmj zfhK\żd xZw 8lnA_!*xIIVBߐ+ Vc&mR}<۵tXZ E!ODN\!i˸-u*OdbZ >.TL(Tu)ȭyuѭ\a?>V]wo.n.bv[Ltob;,]fI;{"/*aXY;RZ3N}.-y5xs2(Q%6] hv=z8ݫQIRTb΢ &{~ endstream endobj 730 0 obj << /Length1 2197 /Length2 18520 /Length3 0 /Length 19828 /Filter /FlateDecode >> stream xڌPҀ Np'0;5hݝ we#{kiYݽVz e53= . `ffcdffEP#G:X9Bh z 6 '/ /33?μqc7+3#@@!lea zG) ow` ڽG459ZA5%hll!HCpYT.@g7௒vƈ@PrBn  lL..f@g{t<@h/c9F.o`ne (I3<@c{ m]݌lM N )0~:[9\]le޷YLhrA+?q+g{2pmCVfaȤao ͻp033srN%_=+Y0/ke|Bv1v@ή@_*XXfV b<`'3sc3ijh*EE< lVf +;Q6w7w+}On Rtx\ O1s0aVmzl=m޹)Ppxk*ͬ\Vd> "/L dj\y*;Xuü{13ڼ". >CWac;;{";qYާ w3@.},'I/ѿ$Lb$xL%.fb0I!6b0r=zޣ+J%ޣ=zޣkxbs1/qLlߏ?v$vv:g&~w?/?@KOGK?,e?6?+5?mxPGұHY-m_Y8إw.?R{Y.,~0,{'&?nqy34?[",;[w׈3N#^F\iH?\G.|@?b-ykf1XI^l67٦.x"[Ykzݹ)~ʖJ3XcF$HX\nn6$N*Z.rKቓ[KeVȎr)}rF?3;}Oߨ;?S e܉QhڀHFz/aBeG-^^AUW^.! ؿ/9u\ǘ&#_;<g9ZH?Ѥve~429ڊ^㶿jXV/[IPFAwiD '#@B1)\'*qLG`xCsYF# #g#ɓ:C=&1Y5.7(Kd ,繠MYϼnC|z=zKO+eygkx脑/z_~]Qv~MZqXsF˙RD3HG;sgI ЗR2z]*9'|R0x̟'iD)C.W[jj2siMs@x*zI"vo$X% ?}L1@*za~NncRvы(7ݣޜ+zx6틙Fx_ZS`>3Z ݠ v:XGen)PkCrdVcv֧cciтn9 ekl8|Y6I#o69WfLYWYGo)'09\e)e ̵j:@]l7&YК nJ)^,7]DH)PbǓI,O5Ы,rRa''#rAHPbDm/ly˾ F}I/SJ,=y3p}c?d#"uߚԯj*)<->1jikAbVg RHCJV.N{A>T֑驗 (Q+@$"~t1UdO?ܖ-L|Mw50]ZuhUS@If&`=:cvw+¶l+BC&I^Y1g?a۬&a4#u#59㷇X ea{3\>qq|Rb2ϸRGrP`\P;!쳓ia^faJP իJa{=iU{W['i8ǛIpuK"JG$v4b<$x'qӁǀ d^EN&E}vE[|G w%n`"J +7@ m yLS Nx@֫E:95s+ZW&#X* ̑^@KlgNVOOwKpF ur/܈y٪{M Z ` ^X2 ^'|H$j}Eg tT1WQ:^ɥw^ًu΃y=`tpO;.u瓓~8f=A}E#B0H;=Sv^_ >L_я2`^gsSШRr/Zq۝a7:J0#$5ϾlԫPez4$Y>iWR3Ȥ9gVYG*UG$sqB(s)rSaIZ N]}MæDu^r7 dSDgO^jnQ,um#tf0\KWZrrx=ưpU3zyйR%nW~o&}HgV(FZ^zԅbR1YܛƬCC֤+_Ģ,q`Wi$Bp2AB3.8/Igx6]WJ iB@ϣβBE)ۡf[mw^u+MxFZUK(7Ά;MRż#蕱\Ox(HYЮ 4dZKw6\JS%ܥ(YGL cPn~JOuC^" j'^ Rnݺ4.r[m6>ř>I[:*bs}S޼ewx(2< C=&EÊJ-tK B*^_m5p;Esp | }{iaB5i@/y4 d3kޱS] ꑹi&4W3s|^[E!djrFo :9(Y/.;?iMv+*OvLݶ3] [Lm' ޕWn \1k8u}6AfPb=)Ą_+=iM%0:~SSD({"\F^q]IaƗp͏PlOYh(XAt !w]__ނH,̿ 9ջ~e}{PBOA󓁽l{< xE쎂]TMBX6TSE: H6Vuf)Yv~~ F4lF5m0FˁϼQ,DH֋I6|"JU~!@n>_SwF|+Brq#O)WF f:ǭGfFԛuH~FOY:Ńf=~i: ?Vzs1(xnTid1uZtvԻ ާXEqgPMLr|#דGHeCMُ\H"nBB 9sۭ6.n&k>u?uRxO RRzbe|zT{:̧[#!q#u 0AНl8FfH65ȸšruӹ{尺\ @6wu ;>3/PjE.G #ޕe֔y)<Aę x G4:z?Xˏb JsU3ȗ`aݐ]sQl!=)[EGfa/.E{US_>as(Y:RJ$7HT_ 6_aO;**\Gg헢e\(q]ߏE([A_Mz%7kSL F:q?DU?ˠZ=6-]ׅ̄sIǩ:CU/Dw nah}F물1V=at "Q*='}&?8iPs~wh;to3;pЇ &E}r)66MBqM 7` rgX@{/fpÕϛ h %O9RBvSCo{.`l?5-9 {cx(7fi="ECܩ\au c>.bK_yK)~ֈfZ%#!{1L[{d%}?D^E3م[ܞWȅaP&wrٙ#k赪?0i&^ -ggOBaBe S*~S[pRi!̱H?9yʆ[sx0Rm $vE2W˞mOO/}NJ IB}cqSճL++{~1Z$qwOt2:n+u|C)A_p{W[/C'WiWao?ekp8S (݆\}˝\j{JUj$T3W6w<L/+]yV(CkuXR+@qJV-b 38+ImDt R`댠P`LERl]m^s8d8o7M+Pz*)JLApls'x%AY?'IdE妦xm]fC&̃Ihik~שaig%cĨ2v40μTʭ< +{<(FUqP`]Y0@kG9Z)@ Ƿ'!$dDqY껅&ol]yL1_\hh 0JVnnK"3XTnԓIUC1-SuLڪt?}dMs-'$rsӧpUt΁k*~mNH^5jz^Y!(ܞuyE#?'!ڷ2}6R2 /KU`Z|~ p15p3Cy*+W6)M_a4>I#YX7齁#K(_8i9;zcLZKeұ w0s\>W!2A"Ujƌ#=<Nkjdo#賋0I=+ݿT` l'M̡di8<KvpS"nO" r, $fsns w\?0 );s23޺p_ L}ޞ Ɔ%]ėf3w~`w;sL9;~$^jIJVD12r5htGIU"Ia=oFus,UԶPY!Y QS!iBgod D.!ԉ-W>D)~(x  UBzws٣Z*܆5 c9R/2 >X)&}O%Csd>鿲C8jE= LW8xEhLy? /:o(KewLƣqI;ɑ9 lHS@ ɶF,XM%? M݃xnDw6}+-ZJi Nǡޤ' &T4) H'SCa~&˙}UIvq&mEZ~6Ǽ\^P KjMe{Z>Q)+Qޟt V#LdD@G e9lZ<>&Mҍk ݬ3y*3ad=F"nDr2=dYwψkd?~D~ftb.[=JZgz$q#! ]<ͽ*$s>b20c(/\w!=}D<s+ށ9;zn}ܳVvl(3sz`Fʍq|_{b'yCk*3]NBojS8p9Hg9ǐ*]u{P,N ۸tVBL̻>u:x\xb|>YAx VجLMC4$ }X2ѾXl]"~[H¸;0'4 k%Җ*y?^}2N j%r[A ؘCWxHqڲ"jCfn=ʝ~=\62X%ԩ@1mWFl=ko ԅxIfuǍ!F4 y6PKzO=3Ff?R~jB뚹 >ؼ㺄Q?qt1bmVώCo}T8aUԧ6!FţB*n))Ɯ (#CO }lY=h!3u6GN,$, WS5 Ϲq:,( jSױ&<7IQ)92nn }jn?gU>Ʊ~¥& szPӋB)ɰx!WȤĶJ}lqۣ/BzhP/BK扈1\HgSu]:XΛ8o8'Lp7϶+ˈap@N d8`ٯ)Po/jO8;z$g#btj!/v _% @\W S@>9ѱҐx>T\dXGY9g/׀W^'%4_mkC;'Coƽ\ư.y,EZ&47R=XF6ZGaqKėjj,\d WFC Μ73$l4{Z5\HN΋[v `8اߍG3 ov-kl]"Ɂ)/V^F ͸l3#DGsK36OP r:0L2~dsn|ii6иʑǎqoAANE͍ W{SeE>T 244 mW{=W B DGFaz+0f1ￓX.Rʶ]!uFee!^G&IH(6 yIEyL u'(Y>Cc|(mG;K =n2LiAC wMnT8q2滏k3Q\?;Cp|:yzU@Ey{|8Q!WL8nMīܦfPv^8<. #WQnu վ3[7z-XG%(YLm+F]sD̀ۘ>pGNC=BDUP6OlkCEKCrya:,6dr1h p$ח_ٍiLN5ӆ!r-įt{ʿjfRbi 9\k7<#;5"[#d9=V |!qnn|53lN*`:{6McBZh][==(1@0=Gg Ocv`L it ̡, C8LBغ(@O=6cTo)bB4򖳼~Ѱ3JzT_:o>]ԊˤLDGǯ/_#!}هba{g  ļR)׵os`gAۡnCbGto6K|1> 7EyQ:H6,L\,OWuJ?(olSq⨀ *ByiJ\02OI$|oqwzJx?#eJseR(Np^lqȷ.y'άs6|s5]yDcW~r.g/ߡWCba$g GΧFahGBh{Gpݤ rsf4¯:ãC3`cB 90ZX:gN2 |"LiQ[6 UW^\zkuo,dSmAH}9P#aF?{к(@] _G-1Cjf4cF؉XEE>8}SZz8?1SzN,\qF g0}fbxވwJXܕ6I< b\[UĂJ/9o QZspHWjEO3zh0xɃuqy(?|^ $hU l!Qt3}(!QR5A$蛻]HK>'*h4AΪEm+,£iKţe b4|hNn9Di=|B㩋UoMCgJ#cJR. V(3I,pW,Y-ş+ ʒ5sh]>qHfչw'%$gM{&):H9ttAWDcQ9@KH1bDc"90%+>Z@+!A"" rOKV^q-A"NZn`Vܨ1:'0lBTm"VӔ›-^2;"aɥLsDAq9H@/‡W{3(^,6MHD^:w[9"%rH~$ [D حy~ma>< ]Mʽ0.ƥ"" zXf:P f!S eLqd'!YVe tE ?3z/|$T5 *f#OgʩEn,.2\`IɳrQS>g HuT3XqO$ՆI$11L {to5<7T\ 숧qT-¾Ljuƺңw 2%ϻ#EKٱ̩e6Lg.2OI=ڕ%泈T^` D1U#J=%Z3->2C}"D0[ZBMBWlBP|7`is_Q?/Lt>> qL:hqI b[o2ܴ- &K}VBɀE 9o۩1í|v"_EfFQč5Ls>-Dlv7#P}$zʉECC3?b;ͳx !g9^JJS5m=lx .K)f׸=Uʐv:6vyP^A$|G7dd7ZY2.-xi_l&ԕ@ 0T*P{;*{D9|pJ7 UOdR>u xEyuB eEhYdX^B.Rwkbn@C oGUm=OϰEWŧ wLͅ2>'mEIeFuޑC*<\|&[KͶjVhUTU\@g!\C4B B!+[ elxvs\_BL o"{)8{ {/nZM԰ak縞=A4x=$fr^b~%b"2tZʿjچmfoE5LcJSMC@O{=LSzD1U?m{{V * NA'V bC':=tep{s C^yύ_ˢKch[6+`a 4(/&) Hlx`i֖ׄ{c rg#|-] /?+ahbz"*DD]nGx(e~F2R54\qIUsv 1Cԇr \N&^g)_iYÇ_h:4-+ bpD1L#b2w²X Cֽ4FoU}F,W~q*gn#G,|IBEɱYQ9ӖA~uU14w,](N i9%b6ٴCYn2]a5&_o¾R^q **G[^"ϰlk~NmO]XZ&꾫y%n(Z})7p'-C׸Gʐ-ǕM(ט9oF39"b+6!mTPUkON7X2Uۅ"ύЏ+.⺋ YVCoeΖt2lK!PtOLI[>f0{Z%0%@b}0ﲿ=Gh(a%J4;=ۄ+k*!JZ쵯_,9xqB % J2F8P0|)_*=vdaS!7'z6m. S`=SXG|, zPAV,i)IWS6l7 Ǵ>ثe2˯yi_S6!J{_@ @'do>2F3 'GumT}l٘E ah|Ska)61 7;/$3m S6c %sIrքj=(Y =887 A6{63zwc@:i8XxS/OhWU 0YM Lӷ-L po8#B(;TF{5rN x19-"1VͰJΟX:- 7Ü,ȃX6 ZKݘDҝ>e՗{zHJa)/?53m(w˧u2i煗͉]0+U OJ"f+>6r5}I{ m-Ī9vϳYʚ&iaLI|MؤV+q|TkbdFՌIW=]W- PubUfD\O!ޔtnV128^RzzO8vq[ <vL_+4!@pBŁBֳN^M@ZEI6I\Fd%&y(vfM?oDJi}HVd2^3:.50o?VƋGjڜ&gE Tyk-.=0M#&i, IYĜ̦B?ЙGQPX3mu!{j0*bϽ#G{yA "j2RkWS1Kl;0wx c\daT!c'˪jd ٘{޶v3[ut#PaTa՝PH㲠ήl MvxugPMt#/は ;wp̆zLWH2TVs< JFph/*tJ$LIS֫9IW&~9`fGokCPDMgE nPcD3rkK1z&CW9s-ԄrgF˜=Ny))P5g {BƘmَٷMr_^t+^s)_AcD DZzs="o[54e.(eߢpZQ5[=Ź=黨 E:+t!: Îtʬ8)AbDQTppW;@^0!]gr 𻘕[iWe2!޽ - )m*(YN!r[G1尠k"`,T5 + `:)̑z/E\qErue2w\ncs|e *nnȪju7ֲV(u]cepps5?Y^w,Lk:]śVdR~1wZb! J 53"=ʛ"aU$'0RC33l>BgѪR{goW[H0@Lfԛʺn?Wf&QzmCM܎O>D[|8 ?ǸId K \=ZڅN5f{ ,5]#sB*9ހR)Kf:.YHz؊Ê!҂>$-GYe' ߰+`gL@r}*JA6=<6_sRmAL*^D0۠'O \?xJ+gH^ޛQ mKhS̋;$EnG;\߬Z+8|nHd)1-y؞Q4inO+DСj"MMOTu;-KCmFgu޳Wߩ| C7vjti&ۓRӿXɔ\Oc+{/[{m'ϧ^ RrIwu9 `X<+5>Ǵovf6:n;)I/t8v-D{t3Xp (R)Up"̾[BFǛ}ONP Q9|D<!L6 ke H?"ުLdE2ՍkᩴzC-;upAqة^L~=>6%h~.ԙTȼ \apo-ETX`-,짇)'QR/?}wODRGl*Wjơ֑JeY`$!{p3G'D7<X5qbw*"m_zdJpOnm5u8Š׽U{Uw=jDVIHEe/^ȸfDۣU#6LIF4Exͭ#f9x~F9 Fw+ezD:P52a;_56DT| 4xwYrP Oq$AsnO oCT '"!.=U5Dӑتc큙7U[px'vT x@W @#FdpT@ gr - 6$ņrZa n~-*ZQv)29UJ%-us[ͺSU1;hPH6ÍI0ߦ_Qߣv@ HynI\ ? DqH_ n[o@Qu^:=n4EK 'd쮵ldhMG r+7n{ey^$Ȁ )}'F *.J5hllubP\=0bN`b֤ijr$jRݬ?*`uMQyj6o~ܹ!HK\.JK(~[uh 9-X*X?uNҒĦo6Cׇ,/e)FMHDD%k1 ٦x'[j§B7 =b3DLKտ5b%!@M9SZ\SF0ܢCi>פոIE-nq}:g6A=FX.k3;櫿kFgi9gYvAF[S]c):c[wq٠< bz FIXRt[-uă3jQ bYr= MXas/1$TE[>{?GqKp;ҥQl~)隱j \r~Ph(uyg@9vf`fcC Hb-~UӋtIN<`_rv_AN8ӱQ݇w@U F|2 E#^qaL_tG Ë >udK,HPgC9N^U f!g7 #:oԚ4n,Vy:IQ8Z`Ll}`Kze'#ZoVO%YW5JH⢲ N N9kL 'n]qppNoeI6%r!$.2Cxwr&5veAtVtcFQ6DOLJKž1ũIʹjy8zH mhrNeFHF!$ ԙ7L{"wyO$]6}CՠkfNIR<}j V>S?-ji`OeiY,bDZeKI-Fڅ[dzO4Bsݰ^'"tЇٰPWt.j{S(MBh =uia&2DOweEg#$5VJzyޘ DY3"9Vɻ-W%CšŁЛ'S *~0D%F;,`1BKg09 8ӇM`ts=%#{;b&+]u yDS9~SX$c"/˂-|T^sDž6ٗK)<+z W QӃOuoeI ߭SEs\xo('=Rv=Ram|'^2@ 2 VZzn1C"}P!\V> stream xڍP |p dpww\Cp'[p .-ȽޫbfuWoUՙ,̀`W&6fV~;ZjZ r! 4u}Iy7;3?@dPb;.H^ +k׷: 30:M%SWk[EsS;9?)]]YX<< 4f#O'|oc@/$Sw o"$66`fZ g})l+fQPVP|u;x|8L\l66V+󨚂X9v?-𿹔ޔ #tV.V?lg?U#i7;?t ;ous}%]_6UZWmVofbdfry-TA/fU\@0oQdo˛4tvJ,X6v.n뛢ع>lo[iSf[mF?3 `'aHx,JEo>E `/{3U0X_ X,Aմ|+j_ޭoǿub/֊?ž-+?߸oo9 /֚[.·eqpߺvי=s7gGυ}/0 4GZ`.jS~_#F;Ή:p}#E!XBGA̢X^Mc&[|֡ Ms]v?"^?dTDn'}5 o,Z亙|=%Ls ?jҳ211.7*sgvޱ(, %\5!mGv}1ǻMQ- uۥ ηB)N/ϟ ;aǘ.T(iY@R}F LO'4d;NT8W}fEɋ èpjP{ې{КX((jC͉>T(;)ͨoB ')$$ql{V=͗#&D0p6NP'!bw|Fv!B"r *){|U:q)燯.bctmv4ELkG u#1'Dc-Ԧf٭OTn5GLOGvv̻.ʙ'0!;dڧm(>܄}Y *;RXJ0"ߖIR뱰 qnAS 7TAr;N^ȗri[qGK@C膹J<TP(EIpN\:#M!P]ahu,AkQ+ r+ZK;& g:FÙDC:J~ Vcɚ'_'0UXωW7%~D sZ2$f`3L"HÞoR3)&A[M_QOhj!$A~ODb-j.~[B4& (Rlɇ# !A\mDŽ5<6CO>*y|[,% i BTT:](G:jX pmOsiNh#`\A j\ysW ^L頬wFvm$PHf$`4Ăh.(\fy h(5Ʋ2Jdۜ HגlJtWf 2"CFJd2=TB $aҷB11%yc ߉-g9l$|i-" W+&SjpkK߁N6_XD$ɳrN-H58 kK'V z$W.00@miRXrBCS&^(?wسWnd((\m٩GÑi˼5jPA.Π1Vd۰cS0+de84&9lɶOHu|0m0<>zn >Y4&Z]4z\z=(4K`ernt7h-b&trtU2:#[1.3\2;mG*y[N@`AznX׃ckΟdl(wv"m8J-'E+Mʆ:aQP+*4< iKh O~Aѩ?ڨAhG헠{YC#.Jf 1 tROb0}nGk/u\H~Qi禿urdУvW50*;@o=ғpƖ";9)cXg['~156Q֭]Kִ>W%!EN .7DVȌ7 x:[S Vjr vNc[cnƵXk4uZ7u+B%8|-޶(<0 `(n[f!Tp<+sqUrBj )jQ?.)HMn_O?#1n! 5 r.x/*]}CzޝZd0,G\ˎwۀ-NX0RpU)O_Ju, l'r16AK}Snw2LXsvc @t.v~2l;#޻پ;=`]c 8hQEH78'8O4W&ȃZIȗW4{M۱4?' Y8uTc0QLP`T)8;n( ;]p=əڑgӪ_odNcJXb6Uޕ0})tTrˈr϶ dO592rtɍ^SyAI ft:{ : gjxP\_,# T^x5!\n}U44e-~==j9)z@"?}JW?f~dWyiz D}0K25=pA(x SA XFۢd8chmV4V+b`<Ӣgt0 >lNBf?=D0? W %CC -ᐖ.Q>xq gc}URdcOq[/GA#0L9<r$]DqZsy/Nh5(O[̇=h9>_2]0 lcܓ 'u9+U3rҜAQv߫iU(Fd#k"B埻#(jq[vG COv*% ~-FY`u[V+yc&9OrrQ,ne%nph-A*O%^jj=)E7z Zz8qENfqx:>JVo)E2jfͤ&<̩b; x & %/M"T( *4 )sLŞQTϔ8>  G_C$ %/򛻙UsȒ~h~g[ݓrM#%7MR~k|-[Bއ%ZcaYͻUQٍ&lʑç:DmTB|tv#c"Ņ _{+VN 5GZ\P, Q9bÔ4oVa]0Q yx^z͠n&1R` VOp~lb!F 'LN`,L=z #i]%90cq;t]u5J;nI'ҕ K ]w{Tzet#›#  1 &i(bLV/.X4Ȑ;"P$aeH$Sފt.H0QoeiJނf+qs`,Dhp.iܞrn=eUѸJѝzڊ9m:&>LoL}P/i[Bem*%d8cC&)&b#6LYR#pt[yNiO[붓/&u+^G̹j;19gSڝZ̦u%#~_mM!of9`#/~:ф[o: >D!4eelv4_T;W~T|_}0 &آvs!tl"tGb>di#pj5*NVdXwr$[}{h?qso\4:PȉPk(\I 96)wЯ:(cm$H{saA4{ eJa9ejA4woCPdϔP<8݃jOa06-}msC墊c\qR|+xጷ0<_*uP{/H>ƒ`adM!9S(_hX@mo:~{tOFjsbGg=} '` TrvrƘ MX#`(Z#MWΨ+j2 rhȬ*S`jD@QFg#v^5Nz`؄vW;hf]aOlLHYXM,XIٚh`Rq1$eEm~MH53mfMh(6eG\Ac9h c_p0g 'ؽԘ((e`q#Ρw&&{{}VC䉯p; {1l& JTceG8_X%_C mפ_M'ñY.W՗؋984twz|#T,Y,DMnื`&%uLQ? cuA[q-`ic3H蹜-9ބlsb^#y e|'TXF7?ǎ^H?AMRsEO{nlPצ`և>h:\F"Q=hcʻ72R*v,+A怶*E04m-$ewPZԱ-M8cZFhZKL$ 4*a ij- [ S>堤0l=wMSz9MțE\Fﳘ, \nmX-lOܤJLZ6BHnw{L@ucHA;ٸ.ͳ^p!|+NP)6Qqoc6Gk!X:26>+Ғf>jEP)f B@{qGe#ggyNsVGeمp= \S _ 'sEFȼ%PkMrP/'6/j7;1ƥ],4[=(?zb~Vkq V%ÒPWbZ"G7c\d +r7)e۱wJ <>zPyO0:#jRe].3yP։`;ߏiQ")_6QutJk|e 3bI{;[OW*Z1H\Oz/߿%Mb*ц$``NqRQDM+eq ,IgDg`9Z\b0Zݵ Კόe<}X.tG7&jwrϠڌF,E>E2t*Y&2ClPS=nU$Uê B)ȌGMȔqb6C=%r7F-ԩP rZcF-UC`PctM9U6xt3X9 _/S_}>U48D1ho^vk+ VVe/uFpӋ۩׾F.[TgXfUm~Gj$Fjr%4݀9&8Z `y'2 TQqVb+,k!R^PiYh IM(seZu-^+zYK$zֵ,3~@f!%\]<~GOۃjŠFkb!U=AeXT :/š 32v t4޸xޛN I>Xp"ߗս)ʃKfHe?,*??ķ2 D~ /D}D79gB}.(=?at}3A=AüZ@Ji1i$ 5ihQY țfAC(FN=q'g?%?yٿJ0{//~̸+̑U+,RZ* ayXLA%F”]!M0sX}CՌZTha3Nڐ xɭl莚Zb,jf7#57c!nVl/. 1Rzdxڰj㻛W OAu \8D\2Sqj7k!&`Ƌ;-Bdx/lBo薻zk2H~% kj-%Jݝ;wz3bGo@IFr_(S,C L].v -wڍLeEC!cU² 9BTtay l֘NteL B `ge%WyMz`'a/w*Ji͠X1|o:,gD}7|00% gϒ9Þ.{E˹CyxTNSHVitĉ/.ReFɚaa :(g= (Q]{X@[.+)A'xS&x$‚yfR#'~悳R\V͞yzNqp5OC}d)Sd82C&a~]z1AZ~Մ꼧w2Q隅a``$ NhkT*J/s~.}wg DfB*Uk]> ɰdC h $&wCyM0DTFdjq'3$Ѩ =?}U a'E|SX>{p,ޝVAG0k•UӧIjKhv)\ h>mBҫ;LEz= ~:\&ܙO|N!nۃE( U[7h.㜤[_^YNCZB*>,|5/JZSúZZIOйeY_K- E?Dl39_SY #<* 2td#͊9~w`׽usRV"(/њI_>uj,h&.u]R w輖ΉZ] JX^FڒEظ3+%Tu䫅4b&9ܻ_B0/<OM8;*4߄&6x>Nù -(+ykzaX #m  ۡ SM CFf'=L,!b}ssKd[*fVmx$GOe1%-vkAaZ\y#Oeӟq;OlPDǞ52Z ̹ =nSW2ɪž7 nh(2Bƽrũ?[!p WS"WHW/5[v!Žr[Fe +ϼ:xN0SR#/&*16BK<&@|ZP,Fh>;d!o񝀚Ӵ` aF+0ezmjs-R?jf94JEe[|`O܅uE uwGF΢` B(mȼwE4Dm(J7`)~q sz)K`b%K-H4cX8 : ±kc  `kt̽4Y~ !jDg,? {~65&;wjx<}JizfTAE53b)vUhÀO~ _6Ur<3űUJ I GؖT89N;#rS= <#9(77!{L WtQ,_lj\X(E5.92AaS7DpTx`ʜ*ieʉbAX};\ %X-P@㼯$No, (9tnlyڮ`2}_Ū=FTq0KCsÅJ פOt<0Bm8t~G &\Aw:4MNC Ν`"ۄ77>eN}a'?*5޾4Y%#5VJ;O%^BZ軬wO[S-^g eehIEnlo;fi&yXAPݾ/ =,RwL܅" >֍QLS{3R$8[!,U-?4~uLV{DYiEE_C5ߩLs;#Y7"bbbP1;Gg`T,e& \FIY{ɿ-\7]t|d ^vg).}5 m/\ 懦p:;[Lbpr<۝veW7ú z^N_#E8%UZdn[ gc2`;@I>#ma7v2.oK=J%RUKFã!>h45!8Br¼fڈ߻^i t(v/J !+X:Nۢ~0a;K[)RKkMΑgn33_}X&UBxa٧e\FSMk9 ڵ][| =E}(R"dĹv; pN#|^?y]ʷ*G)JS8Z6"5qrh5Iȵ'8~%QRɣn'kr=*pz45X+}7jLE4{VNFףK3BjRDLqXd;;?mR|(o}U=^'.X ת膋X& r /6Η|TzGeDe[,g/S2+3=J$<1kU&ǑenJY*%nf*λȷ [P[7wUꫭ>" Li4۸sĮ`K#wZ$s9u}xd)]e3ykCxYOJ|5e)~V+5T^ǶDErRhB`3l=mK3ύɸ6k?TI/gî6@c5$NJ9e}#U3븑ÑCs*# ؼY5;~C%_K:Qs Iz 9dQ{/r5ݓ Ga0w)CQC^&Z&Ox6 &Ё47ci¿w ต6T(.9́lSПk|eEPgCJ-=fzV1*$>ʳIs endstream endobj 734 0 obj << /Length1 2628 /Length2 18923 /Length3 0 /Length 20437 /Filter /FlateDecode >> stream xڌP  6Xpwwwwgp  kg-yڞ^}DI^(`BWScf01201 PPY+G:9[9a!4vČ]@W[3+ _C'@ `tFuptt+ʔI;@dejl7vځMmV@ Ag`ld!@MprNn@3_%ƀ@PrB  lL W{3P(:c,:?030Yllj`hlieo0%\<\f:;݌lM@n V*>gS'+Ggg+ۿjd+ fvv@{gr;{[ٛU#GW?6 o~=L-"PtdK `*keCv6v\\*!03̬L]&@ +{Ab0<Lc07}Є9z65h)_ @ `gpps|7?Y)moO.7a&o,T\yv7Ezl=ͭ h@`M5Y\yJvAFZ9KXy͔\L-3[+{_7 @ej=A# ڝe7u0kX9NNƞLIbagx3 \@.Pus'(?(qE#.o `q2%~#fo߈(e~#ob@ ]_bW@ʿ]7F v Įص~#ĮE,M@'lk=o'PxT P2Ê__(;(-h+acKbgG^Ic44s5vAR]Ak.tͭO _OO&-W:#KOGK t6@Ps~g_[joFSbك= 9;To5(#qk?ϔ T#~t}Jln9ں-jB@// 䏓bIh23ònd z ζΖ;{EbAŻ;{Ay8:8AyAvc@A= V? ^sE:'BM]@w)_~i= ! !w'g)v5ө齗:]aS벃6SFPWwĩn~>nm oKRny1LPmGX*>n 'WG#["+R!ƃ{G@x®^컗1zes&90.p4(swySo2 '%:,֪X{tp !og>x,zl/2Q3muI0:-sK72j}CU5rip^s>{4{&OJ[&`UC gD%q/T< ɬ ʹKOȇV/>Q;6!?V]ROT\KGݚl lѫ:>A يFȉx>Y=o(q%ۺߒ?,yz 4j~M=޼6KMەmvdl1)5XAYY{ڵi'H NLb=>BUy9Gu]>S e*P#e m V?hD y^v^EӔ֍c>c5^BO;S[SxUYQ 9Z|(UV}.oCC.֭kqGPJtGVA*"Q3\*cnU][jfnKE1Mق7Q_M^i !KJYePi0[Q`*}NJU_GXlf }6BUz9Vf #[63.=)ۆ+#$LX;aL1ݙc_XLóz=6|dPPz{tY\nnqBXguIHDE]70^ ̢{nd% /wmK80 M;)̓ywF_ =#x+Ks8a}-XNxn6_cqkm(18׈@ !O ϟwzUT*EKD qn Q %6QiRA HV";%ck[@@@'rl_|0:@10"kJx"|'K"=D)-@#*ɢ,ġ)H1oKrp/26~ճmqeBDQMvN`?DkH~ux8n?[.OuFf:G1ΎOޫF If>!H2o^-R]:!`K\śuP#>qnx9}נ@:]e 9Ps(~ehysӫ-^0'YC`ccP!vjjO97b`%밈 &sh]X [X C-Sjuc<'ktA0٧TKx/XE'@xqSȸ葺o"/@:6z~yVj!d ˭KHN]QQI˘ɞ0u$.0ƀ'$"hۧ7q[(pnǝ& LI*p]z5S6Om0#J_TjNG1H bHiZeUŇ闳q@!^ ZRs}b1F5KM"ichpAmbd j}`޵EVدۥs,PsU>phY%lo+Q`bHļN;:zTf=@Is[5 M.tX0+')nD$ojreguEr*w}\M ~p Ɣ%b΃Xk3Dgk 5uۅ& E}EHj7P+38 ݰN{;A ?Q pr-2 h2\3rZAԳO,}rP .YH  wW,Ԉvw: ;M݃ tEITByU6C4DEljC/NY-aͭ.RIj)1=D89!x|&H< S9bg+x~i,{b_ DΙUG8{QvNk 7Uf"(ew!RzI*j1=ROW$٥Lƣ1kqxV`eG{uM+Ⱅ7"%Oo>(LA5z*WDMuûF.E?h`5秝+5Ң+S{7a+e.5.DzNz{1c b7 bd+"wL95uֽ㳰=OK`׮Tݽ?6C(0er z]iho4ftq^j N.3 <8 Q5t { ^RO9"9^: E{J.ʚZsa؀QJkcA>Al#iIwTRedwI,yK-F^i&ҏ(|STO=B\Ɠ hmH8>9i(`ǛäUZoX0fx|V9Ug=T$sDՖ z뚽N?WQ'UTM*G<6pTHT̴ScR{7AD1,c7_!A)9U)YX̮q SbҼޣYWeZo[;f#Q[6;_\Ŕ_ ͹jE+5sn.: sWN_?[ʧF5s}x valwsO J>mc`*D1jX|M 'f[@8}2"("j +k"}BԐ%Zx{|4xs~BUXEʮ )R Hx&{@$..ka7~Hƃ ˛FWBKJixm֕3ghsN;nWp|N^sԀ~-H~%oBҠѯC @v{}wSI;Tl,k29y 'Qڏ _D/ٔ۴j@[<n$@ +yz% ab(wPOwS/ú3DVQwI6y߳'xIlii.HlRaRdv) ~Sqha/$ 8Hւ3:}qeVv/s ˊ5FB-#{S"!s'oh`^99EgFTJ#⩹Nr6pK.ip[Iqy#O_ɣlQAjU7-w$\"lGV!n]#d[BT't* ; r!Γ"̌H~C-$]|vnLeMḊz5j/h#"j-1snWbxv7[r`3N;ROn^YK8q`}z`eb6Px_Madm-wRL|IU=Ϻss|$Ф^瓥Ȳe>dHA,>m|1iA-Zд7 Rv0Ql q74aqwXIP *] .(*PU4aW,cu 7t Oj^ً)Q#(`iybFIC VWo%z`Ni#~2jC^W8oZ}c?J,կ^ 7|O&.Sǝ`qIM\d{NW.h5Sq 0A+$hꈎ fE)35M.쪆ԳOrF b/f|fn Jh [礘@% }::1fG\! /b"Jw>$$]:kҔC0MFOIsGtaRa3_:$uCO>$U(x|m v\gO2 $?zXo*ؗuTY~1% rAkq;c fZZwu<]-fzAID+|:zCҎguM]@K`uDR7s@x/m8wA<u!+I)K1Y[=0tg?" 2Fx 使q' `@sͬ$;nt^gMC ӟR5wiYmff@,7pY yOLY%5,I" 臒ĨC0j M 1}dϯ8:-ӊv :'9`*sk Iwӽ'$˔=:?:a nWlͦ6޹sknn,ݟՑS挣W7oIA;5@%s;Y)| PӀQrZU=b6ϮNEH҈(%0THBwx(Ô6|XÂÌzX؄l l*SRzH(Y}+gMR9Jl)e$^ľeZA+aP>Eg\ןeJdYG>IH#Az%+i&if`h:'/'ygU3i2/Q e>,$#e#) UX~ԆFџ1K|6sMibF5-vs&Ԟ1w'krh+~?~C, TKy˗U^9[$Qg9p'TQ] ED{Q@jK럹f-;Cy1EPн(B5Nd ;!}?O5>!3aE#zz^u+0xu44o>-ʈ|P4L^6T(N,F0*fo*zbv]ܸ.-u^_C t}6v*&/GՄ%WKd9'Q ~p}: .C(M:ْmq:Ep ;O\+d?xۋ= ^]q0G:!6aYCv~4&S*dtYHX~FZ:AWYb0sBK@ ďeLfF#1 gTrN1&tw4˙#tmd^/[xp%4/-ADnCPql-މU' .oǦh~N\nBV^zLj ̒HEm {*|'-=!9j6za3Byz=!+hS$ȨkٚWbCmw,%-lr[hfN;iK1H6 n T*p^C72O6TιFX(3]4 EYBys&l]=ʤv c ke2%.mXm-bRx!dx!ܝ(& 野 }V՚,wwq/y0u,ь Q[wo%&UĨj`͕{e<] znGSLj2ԯ'EfW_YL=7Y|sҌb67[v9c6W#R>Ug&6c? `vjILDk~E2k 3 4x1\ki%otaB\5 ҳȬ ^[Q0i=x1]b\^\m 7;8uk HzRk{хZ=`*\?ԗvoQVj -2G!1xy=RtUk렁LF%,aj-}6}`w9PI]6F hP^Wi*7 #U,BBLqZ`7=Ĝ.kG ;n~pl%D|d?O눮Lgک8*Vؖm5B$lC$0ȮaHӗq%k :<]OD8]oH^-`tMV:ΕV ]]ZpI8? ޤ*p Ϡ5C y 0uL/ 8_!)7]-<Ɩqp ޿l(I?+ь9%ΏȫVG~RRnN-V5@M0aPsl!#Y;<>16˖PtfƋPńqx\p IsiJ]<o7LWUᯮ\LA'/Bi] }+ЏAQ Ze/98o2d65Ϻƻ 3#j1@JF'Y]N9v FW T;k Bئz,N1ӉS֚CLKH59ޤDҒ>Bl4iPCđ%vmY+ /oϕ Ȅ7u]i{2ru6P7JO3/\qOС5_RoYAnP;}椰ݨv`0hޚv]fɃuͬڋra\!)f=(_ ޿#5X`=& 2N$ks.XϔػEB} oYӻ`ۅ^%r`RHL )Ww0к]ru `O7Vz,.++L2^bbIrת u?6yd"x&]=`wgCo1ĐRTp4){ ڢh>$`\yc_VrpKzJx 1fuR|*a0^I=?bke7^z232Πi5KVTJijv vVPS"sH2`\i#dF]Cg:x4hQ+|,t.{<q8ثa" }*2JRpiLaɍ|+`z%Vy=b҄e. ]`v0u[,Yj.T4 yaw"_TƔT^AFn$ }r07KGZV p-{1 :l2FBdU#!Z̟)rre_B)iIj*cCY-?Kv|Tl~&}x ],Cvgʊ W!|rU@6pY;7tw`7Ur&AxoU %һu1ɳ>=جҌc4^e5 V/dg8!r~C31 epF8=Hڠ\^p0IxXva3o 9siQlUJ7 %A85M g>Bkr@T2lޟ :?6=xnv"qDM(vhMrj[Kb`0d$3an.P8i|[tБwyxLRn|L׆zDio V˴\sN\,JL|mkzNZo?U;/U 67ۨTKVd'}cF'sBj JٵʖH4h, ulM7k 9+lڗƅxOȫ*Z||Ճ8x.yݴq őƝ m∠CR,2lK%7+ ]0~>H坆sm6G|_)pT,c10R'?i9B;Q꼄y ŰH%U2!y]y,CSA=;jn57>)%2t(PuLCD@D&DlRikMr_ܝqZky$>Vm%{=53ep*7_`6G78u;aX%B}'u N6÷׳|48[Z@i{ "kj y!AџgycS?MY6kh?Fxmbk0+I{_| M@VtSݩ0;w嬼$erYe˒ixWł4rS6JKg7S[ڡCYc&"2hh+F#S y8=5̵J#$.lx*t<= Yt( ?M&~Ղz8gﺗ{(9w@G|l"o6gzgP],b38%$KBr嗭DZ!QT/.znZMW@V2< $H5׫W,:DNGOlPDV(כE-_ĴaOyfvR(&߉$iuPRs>3$EïHyagsC ) k=VЭ܆Ic;)s\"aG մ v݄Mw]쯷? ~*̵ܵc>!ښZJr=^HZ@w^ZÈpuR/!Y862 S"9 5{r ?}p4l2{sE 36jf_B*֤ճ[/eߓ [s-RU31_ԑNLnREf6;Ycyf $)ܩ25a &;GkpB)[\9BO=rj%hE7uȽpxn]d^D HZ3צ6HZ/Sa?8i=޹ÐNlAаO7ad&Q؞k8TEfȪ*CPGמQl7nBǎHUQ6ށE녢DWy닊L#c|1SѰ-CτZUHLAo{|bL6F:$Šf_\I&WJ'c\Xܾ'pp`wS ؼ\>M~zzosx&ɘK*b%̟$E(.|ռ|HxSI϶Eh6U/+!ɐQyCAn^J-{T%:P~{B&㝋~(uPOPID#5N4__AkYjlzaoQ@}xW>MiyQ9T=?烓@bw-T79 /Gu^{!Rgu}JsBtV 9a.G!7:.Yq5S}muf][7)5ט}-R5p \qtc_}ile3;J >8p2?$N eIҀI89,z4l%9MV9'Gg.-5;S:Xq Ն䈉$Kp3KZ{ iK4l Aℱ16(b qZC}ժj 3)Qoi%+d5M c֍,_uuaI{pU9q3'#UTiZ2?Eh`>}lWCЧ-g֦%䄏=k7c4YgI"YJɚbk 1*ah3|* <u&rKwHʟhbJ(} n@:#X5ePi٠Á,B""/BgRGlJ弪=H',l>g;4,76%ސO v:M" R)ߴBE Uɫ<JXtǩ+t1"n%W"F&CqvЃΓT|kF-z)0XͥA!Hkqo1D'*7Gy`r;LcֿC?.$̙ޤ_hiJAt2NS1{|lW11w,ig\jjpfH`Cd.\Kg?$F]%݈fKqLjNÅ/bE()5젉2} RZ7g.J&sO k>'SywGy$Zםͧ!Ť]F""V\ƢuFG;ۮU{ u20ӗJ-)B.D< 0&GU|e~ c8h}k+:VK70\]wv>p8"h0a䚪wj뇙o@O{Q֒0rnvOayu.w\ies1햰`01FmX5ҝ/i)LCﮟzF]j|7x}%]Fݰbf K"4_/oj+["%w=cht(%O4D:2fgU]پD>iՋlDwMD\utVvkfI{6& xV9KzTƮL'cS5h* ]6 i)ihȚW\24nj.+ X44o@=\ѐL"m(k6sʒ8ǯ4!: xY~٨0 Vtk-kaMKb"tt?5QTȧaOw՗7G,S33(s3Cب*u:T>}#J-2wBL~ڥsg9skBg_YVf?U=] k,LTA@N/=H۶o,*i)YQ wO #1)o83/ A܆:Hn y?vnā x".E8kQB eyv~^?/]%51uwK̈c Z ` q,i>( F.#&`)HI O0SHLY}HlY]o=k!BP*&k s!xLӉy =E:Un.W,|#xwGS,qugnr+;-pAuEkz}⺩q?3} Me&;vA :AH'E1eLD9?N;bl L]ssWK;ZMrEi֋hDHeCG~ዓYPIOGvM')`hfN"6lU~il{ɶ~%{;Ϲvj Ý+ejZ3 igEPqT.t7 櫂1Nt!p5e`3# [U6*+AۆC"9[yKA~Jg_P;ƃ-cóDjqC;v-k :oh[m&嗓:H14+ƜcusVMvLӽ/߈, q͊5` ,7ucVȒf ?ZÎUsk|epҺ^ھZ-[%% VJ0WFC:c5?Y-8VBܯW&*%ª$=A7BT\4Y eKʑ64O͉E@- pOkN rM̘.B],u~IvR>!7ޯïw}-l`'ڑ&h21dKpeG(#0MXU%@U\8;]`̩UcB;z);rEPS^M."}H|?Wdժ-Om rb}B,"&q3㝟!kSr;_tDBOmvM5Mc}qY.-jo]~VQ0~<""k)GV}fI gB&Qy:1B:-IW>{6.L <06-s }[(gSItwʇH4vL}pS$૪V %/"P3U!ϡ03EM vd1T>XqUk? q!$6чtXbmfNFpw=RtPtuc(C4'bߺ&|Y}}1N^(k!Wպwԗht<;'?I#wY6cd@+ؓ N廃l8."qX0)k5=VC.#m`A#EA!+ˆMD{> Fg)$dx6s`FqAErYdCaA@N_Ӭ'kg [y{_VͪȽ?rG5s/|.$؉r()1OWg&u4zVQ`\$lVGȟ68" I*PD# S8SӞCO~g c Wqq3$&eڥ6ȺOf#pjpn`=C MsrZSf^95mzzPm2ͦ .q3#f&]IŊ$ wZ2FC(XLgEщ}V3JNbz^ i!EJr/0!0$I6j VOvpj1?C5f9J n:=vv7x5m>]V0@yZ2(fR$ 9:!\è$rg-[<%(K9џ>sf,CŶ>;>h냟E endstream endobj 736 0 obj << /Length1 1421 /Length2 6399 /Length3 0 /Length 7363 /Filter /FlateDecode >> stream xڍtTTm6)0R@KBBAbafFRBB@CD)VZ))A@?}y[gsy_7TEQHXPѽwOń`Q7= G 6](T0B \tQH D$dD$e`@ T!8-+A!a n\/p HKK vaht!{EF( 0BA0?Bܔ`\d܄ ήB(460W~5 Aau&#\0n4 P8!0i C#- X/g6ȿ BQ. N0஺#@'Wԅ?A8Al.+J?B+W¿\LY irv!1_"0=:YG$ GC m~5auD<´T@.TupRb"s [}с h惰]|@^ 04S(H/0G#sDE!<>_aM%3cmm:MYx Jbb-Q@BZ g}O=v(@Z/zqKuYpo?/3+F.H|1CNb.诋XCM`.uorJHӿLjpUGlobkŜH>NE]pobmQ E/Qq FC<@ ^"h s`@X\v(4ׁ)lKGa<F(EEa?jb苝M%`0wa r z{\&2 ?ʽb+݈NE[>RnmHXt;VJ?ح]uGLߓ2 m_qgۤ3r^Sfdٌ{e(u29W|OԵɌoKy=äWA~ĂdWo ْlky$CTPcw/fO5wϕ0#7JfWLH*}_/+:MGk=wZl᏶>p f/*Uf>FU&ӂNKAZWk FYu#E6_)&pL&64-nǼ>-#19P\9ՠJά5@1WzHlJMd*Ah# I|ِwh}䖔d=47$+Gҽ,q/8>3aOwRtc Fu7t fG>x4P 48$o]R #09F*e޼L:R";`mq_>C.D~59QIW?wu5q,Nl0h2#X65r\WU.MSwo1c\il+pP JYp/Mޡ6i9Tfs c4ǝwH~bk`1PP!&*YQsrDV1Uobuō0ܜ%#ޮ !3'#m"1 )B"\#e^7D}0`W1E5EBNj kW 19UgԾ*ki5<@zK<ߛhPv5.U$chUg3*a d\7XCJ:=$,琼N7r$!x` N޵ yο'a>\׎܆LOxjq S}M ?ɚU$`_XS`=͒_-bs>O3aQO/PLgP}{F妨J("ʓ-s KN~vjXsRityP%d<{j}MhCWW?eAwJ)KoD'=~D[thQz 3jLDJpA'́ܮ8mнscR*tzsn]=|lr_mQ "s~?:P+R]&a=5>stʼyR;w)w[wY]20stluvK=k DZ^dL §Ⱥ_4M6vH>a:J:wipfdZ{>+'ͪɼ{kRwKrMْz)SS0*޹p>1{}\3zۃ TiRRǗ$_j]ǴPCD8^I\7vټј kY"NqB/{ur)GZ^Q & tW_p} ˣ\ߎ2`$;E[:|)*&a9=Ʃ6F-@>[rWs/B^P>:Q+W,^5&_?ר֯ ep%aIh̚D@^ΥICOxPrWp[ )y9y/f+I^!2yvqrͻ֭>+\]oCR[ϫ+C/u* ~v(\FkG:~^1㮃>`^p*8:|:Y9x\*O 悺]wm‰:TW~6JgE@@/* T_I1 lYSfX9b_7g?i"*ߊ}Lz4mU[7RS=.I*;})u.SA~t\vGVKA1/9-,+;>3i^jSnn >*$PY*~GjM'Oebԛ#"yWDBNc\ЅhvM5с}zb4Ta2':ip*e彰PKjkCXQݥ=q tťj='ܻz _&( #6{h7\$zyϯB@z|V6eٲtDGd~/sDP\Oh"?8Bl 3|\IQD5դrRYd;qP.Nͪh-*9-& rc PB(`uSP:|CYybbLRoJ *֐%Ѻ#/yTmb,On,I)XxCZp:%IJZa2IݕyyaCĬdm>ЗR:*@إ"bRS`aC~Tm#G;Z|gyM$Ypw;M#bDq~Y\. 2$>+9ݚV CoBt_cb΋S){ ^g2UYQ6m i1hlz g|c:etp;dתgߨ$Ijˆ 6 zVY f\oFWf|RYqbXqr{zt9J]g̎y}B$Jݕ-hhT6L[ UamǪ\{@,ÀM$ nf5#1^CǢeߩ0de0IX|CუڛS̥ob:yL 6HwxԶ1*Mnpxk'!uռ>-(gn"y^՞k0=(IR|i}j~A/ vθT Y"ViTpbs> 7데vWwGuƖk俻Q;;^[!KpO&waʕ4 \vjUZ=#*%zi4I؞*j^rRS1~4y4R廍xK$*s|n`RiQԀD m$ UGwF鈴Dd^q >ֲdщ!(Dq#{}e71ɌJ똍6V5(富Is& ^%* 1\4'| Xws*@Vc['[G1ٺՓlp?p {{AF*vY,lLKzȖO1DddTCh1cn£z 3v&$b 6n [tiZi1dURCl 6-æ rr[={Lg (nEW8Cbxc0z}~z|?BXn [.WƲ8{,0hL.BTcF 7V2 T/7 C11 =?|>\Ow)T݉\#UN&!nY|~y158,%(ӥT*7aAGv&{QK`.8*h b,t֟<, UiS^ÈRo9;7܊s1,/gY߭z;(}ͷ/OsZu4-YّSsf-x "}YnXNDfc=%rolj.{#3s@ {3-!zhp6ceGi9UG7^&T0+sPI)ʳxY'f(oozY ~e2BrdzOζ*M$su*` d݂s% kRrzIp2hFlO.RW[ռK ب}V]/U\RF8C>tX~|y%kA+[NJ-R;_%T鵞~3؄Jh9l 1"#Tʯ'() eM?}(nj^DZ^4FR 'oМot-brNݴ2 ҎPJE9EвXtR2(MjO+TJK;stlEcXSr^Zh&ð֫57^'_[M ݛDȗ=O>um( A˧]7CJZe Yosؓƴty6*GE ^wQa9 (!,/ }D~12ΨUN7֨9Lh:sk9pXQ%OY[K\Nk|Vh߳1TzC \T 1F=npf]tLgfK(np)y'fL0 6ܭS¢RI<*ZlJ_A endstream endobj 738 0 obj << /Length1 721 /Length2 4672 /Length3 0 /Length 5264 /Filter /FlateDecode >> stream xmrg4ju :ѣ D%.E13 3ѣN"D'щ5DF^7]Zz>쳟˥A!0HDT`n `P<V2`pb 2^ `@D!c ȹ*➋`+\7"=`tBTʹ @F`N6NH@ CqA- p'0h8oM8?Ю,Z-A t4x5â>_//u'!p$ A!dM m<?wt-w p f?wrCQ t1p 0YP_z9 $N醀#VB- ]O?ڏcN;z?<50 ⯽bP? \""X7Oa#i|žc4׻9$ #d |r o Y {igKX /(lok} (V{"B-XOΞuZjuӘ'OM{$ަ,}'OίmE3;1|KyzI!TB3`eda0$3;6/3?=KqrytnEGu2rHtn%MbԈpsڧ BJ ;`e`FX(8WD"Q/]*\ұaRƨoV@~CM…bԙe3'3'>]}TJT!{QyŦr؞{ } 2%.Evpz#J, Jc9u}-*;\pf4ѫ&wϯ,3o;!@ LGl** 7$WWpYQ5Ϛ5# o9-ͰEq?sHf =R=]q'b."_{88  8ixxs=e26R>-MԜy$l$Hr*ReK\w:(_``M:ǦBԲmhR@NP >ѝU%' 13atLjgt4O ")<u@VoYA38IG 4_?)o~[u.ᅬpLw$,ttQ[ \6Qb})Ŏ72K@w>T8~5,N乁c-Tlv#$I2<-fJLZ摳lru^Pd<=.m1MMf+km(=[3/71,(m}!\.·ڔe=D{ωM^ E2 !w/3+H6= M4A'Z,Dƞi*s\F. ONޜՍ 6 ۹,W!#%Xfo߷90 )!Us*@>i}ޟ|Gv-z C-d9Du1N,tA po%ǞMݩvIeʾ&Ĵ6flVk;;v^-YlM.#&l^D3 KYOhlu9ZM:IQtf\jwwŶLaG|-;+qm@٧ N4 8$ZTcg3-KVn*?CmY;S^cyס8'"R\R.E(/^,j&Ny[뙧}x0Q;>vdJKo7f>!ʏs5hr\TesnX͈S)lY,W%!%?b:I9;D>b60*/꘤p&8y\/+5D 8ǒܚsϩRXKIHdݢxN m& V}ih6{͎Q z|yń'<3reh;Xy3E ="A`.jbZ_+2f%vI^ف7Ҥz3q|Po_-g畈 eWGߚ&PJ/$/32pDqDwu&:`O#4) =lp7X\~\m+r-]hQ"eG>xTh "#Ud5i\*!' xAE@}oU4gnş5Y,tl:/IZo8io'"v){gdXߟ;ٺE+u7{</&Uiѝ*v|0l (kN1S#k>w?{Y9Ay|'?8*Yf dW(jP ]~:e!=0iټ౱]PEf-|ѝ6%~R)'ryhz`v,z5bphѵ1[$1ʪ{Jb~Կ s;_<9|9t*ʝX|Jy~>M۩^L(ݡ ֣KHڪzԴDjt³ޘy&m=t9+r[lS3΄QDgy+3f^x_hiޠdd357hm Oڻ;=F!}7;\+9n"jqK5T灁?"(l ,A]Dn,,fhaP)Feɻ3o52i@{;H8dg%lo VUÜ{#gZ#K 2f}{UZIݴzEW1M;7I^_w󱛍^1cŐ=!m endstream endobj 740 0 obj << /Length1 721 /Length2 6909 /Length3 0 /Length 7498 /Filter /FlateDecode >> stream xmwuTk5R5t 30 2tJ ]t4 HJIy}}׻ַ~>g?g=k8X5'TD@DPX`a/",##PCAAh,  " !!=Q0W4ۉo`A`0 G>9>}G( ]g P3Zih5 P>`8 s"<g$ '8!_x EsF!=*u5!S5iiGeN("U? sBPH/ߴH?0Ax@}pACQ}$B Ŀ, C s@0o X oϽC!0s$?G􍍁f|-euCL  ? >lZ῾#e"Dbqq hBA 3˿ߋAfNrn!E|㣎f|"s#G6^WS|_0I(Jy85nᲘ%jڨ6Ϝ(ݭ*Us,k'_y5?u̴M{G>tFrAZX5TIfuYx*h6h'gg~ʧd(MK~ 2@4KZ*,bfIvjA:7"I쮿eW3}ݔ0`o~ϔiRm.*2ua-ɗ!FYicD'jz>+dDBKx|'V6_x_w'ȽiB&Jw'M* {b#"߼p7)T)M¹hkXw6=Y,* ׷]ٌq or>+'~\"&3P"><_{3z `<,G/oM >+f4h,h3Ʈ V=6dEMo1dnhe>/ȍrf SN`f]ȃ)%IFڪڕEi,n]t!T>sffVx]ͭ](pxu8^\Efa }0iOO nMl: 9]%iL #ǥdOxԓ4Vu|K* eOtn>ʿ1ډ6fWqiڄ︯OBٛn0?tZUc7$GdXP*=kDɠyBe/r-r8wlt9*[ /{#NI53~rݡ0&xͮ >،}*6qDg%ҿG@j3KC 'eԩ 6짹3 '0wτ-}0|KH)'QAɸ nGCK=vrȐ޷?6j `#i9Iݝ“0u ^iV)g=qAp-`j*ǔAoS5ѝۆ>F:!jkTOTwq7OS7KD]a =Hh"xS#%o~+#+R:иa T<.l3_|V{{4.9jV Q^C)}RWG͖ P$a6]mM_42TUjj͆m~KNT]16RR q->hlsFcs~ ~OAɳ<z*}oLsGKa[@h;U1o9Uxqeb~gf/^$@:W=CZ J";K 8 EAgzE.M/1!ݑmН=<2+gեrPɛQh4c|& Ͼ'|aׇeޤ/ZEԌYk>!wn?Zʡ9l e/2@g;?z2$铵ЦO4~C.iJؔrIkRDP4*PWw+TO8!CՓ$S&O,o]ULUh2v͐N9Ռs&вĭMhc&WwڌRlu'~p晻 1g2p˒>(+4v$ pie`"!\3okWɥUT|NS?j K&?Rf ߠIeS[b[}{\w_SG'!Q31~XWΪwqjV cOtg[}i*`Aw9nd!.b :pr3oX!S1Qyez1H1;ۗ3>NN+ᭆld 6Ufi YB3VMZⷀga%ڵwL^O88 xP̷w-7;kKj},cv&ub:qD{qӦ95"  \YH${#)s`AXKn6Kݝ;c804rdYA74MAѡQ]$AJ'ݸ!􄕝M[KXeI͉tE"Tr}~is :u<1x=CmVyn25:A7|%55@x=dǍH>`ϱvBA}csoTur>KmY0s0G\ K-o9evVb*>䢻pKrZAf,LF ݄IՖ4;S)!Q޼񣮍@X=ah>c`"](umX^A"1Y2%L@ z߯wMK'ԎP&+b QLK /pb1Kk^1aaO145gZS瞍Q:Lc7slT6 Ҁ,1k3;KY6PvŷJY,L] D^\}K*̍bWQp [GCYgm9U2sd% FO;P/w wo"6{^Bgʨ$e%XP<֦mx4;5 ɱJռHg?:S0k.O=Œ7&I} +1{]o}yHwwK: wlyzMtg؏jx6[݆)Qƾ5-JzVansf8Gfϥaos/Q=e}ւc1T1˨ ߏ1`hWg@FLuyn %T]|,J9? -fZY0$atӫMG7<MNX2 +t0jАUU@5%)r`%6.tY29=E/wlaE ӤY&(Zuj>Y"l_я 1b}Tϓ)Ks,И nUoDnJTl~H 7z2UaӬm'a^kn~Yz?#4n.E/zMGR^Od,JJZΊ؉C-ا H5wk?\sutVrlm ;gפj 8߅}@9 (]jG2Ucًq|*1YݾfdE5läkFZ{1mDɝWjs3Ud4f5rv_JJi ď/<7ewt$|x >n{Ł#٥ 2?Z_iy\q^(P'6Х{+a8sY|:0Lx@ p}l^4)dh>`6A<3]oVŊ}%+ӟ=y[0 ." 3M-IY)^߫G{|+q"IbYLpp @Z-^: %4d L߉mcדm*}r<KwZ*_{f=uF\e&G'WfE ;R(nkK=$J0}]BuU~ ἅuֵiU;r .COvIM=*GE+ xOW-n"~_{z ?7 :Oԍ>~ZMMف9H~+yo* ƒ0n;)o.B춬u^# 8P˶8':wDO*3~6U'gs)>hN.{4|~Nc0FVhՎh&NB MٻȚl.cg+U1C,44#'`Lk)u*T/MFeIu:i8HQV$ 'ށOI@eBEwK2G?Z}N!V5W{ٟrf(Cm%ɧ Q v o%5akeO(kR![{Ma`s4s~L鲲>YQmyq3F6˒>v?eoJ]kfdU5  `7&b]rBYOm_Kv_Y}~7fŖ'‘Y S69v2~hu"^nRSm]7ٔ|޵ *Օ?ڱyg&mb|u_&> ӣfDt6rW\{t9Iܐt̺u_Uo nbVsnG թ9 C0]_ !<=ۼ a:q1aa7 T{Ү(kF3 2J,B*Kn> 3䑆Z-ZSGFJS endstream endobj 663 0 obj << /Type /ObjStm /N 100 /First 951 /Length 5078 /Filter /FlateDecode >> stream xBp*$`ÚVt[ 9pү@2xikCzZXQB" FM| xug⑪|b-½AQoD0Hsj!WUBbB~)-c<*j|ru9.3H|UUY5#c| ,|[ݙX_:0)LbYr&}Fm"X2:. T\z#z_vnFlKnZmZ \ڙI h̶!fP&8\|X/[r0S$o[꫔R8EqںW.=9nOgj . r$1m9 = xa{J:N@!L!p۔@GC2lc4zJX`p\ H]Z1Y e{HAE3Q,+qQV:`iڑ)ZEq9P>Gkb/Jsk,O0w <7 z.D:5nf\F:"KLH^JCOKeS-L'MDg>1 iȅ1lW' 1d.'^yMlXwܨI_M֛Q Cv$B-aƶ$9e 6R=m '/ ׿׾ 8&I5PӐdid Q Q`Joq&8kcfm:Og?c3^a{w\i9Z:VivIYy Bu ]b>W!ZtoXGֵhq&qh3Zil1T51+*NV)!ؽRq{kmyu6t\.g@WMs0,KK/0yՒ"xVGZ.P+O!NܚQi6`3>tሽr#g!)^L*>![]f,c*7y&ᒳ .3skZcV-eV )97bNPEʌZ>s. c<`W/\EZ-yk.%s27!$A( =*txQ̔.1"U&^q355fe?f@Ojy:[.եHޔ:t$=gDGM'x."rLS,,YTryf3KJbADփ/cX%9"%XцeAyX N5H`={Ej3bd2HTdBLU$%դD7kqkH6I$.5*yJk`tR %)MdFק{ 6nl #z;7m&AhjWJ f+# 򧦾NGCOPG&FFL;oi30bT:j@Q!d.!TF*.B<97rIa$('rb[;R|+׌~cyz;C\O%:|E`M)2zt=O>ǓR@d}V^nxx($KHxX݆#W?VXd|s}Rx^]@a$]M./ rnRq?1??oPGh+uawWCJ Tp? 1qc{d žd;y1D ah}fcjK(vݧNCӽ@ mq.i*#M˜rLuyZ~,?5F Ldt|T^hr>cIz=.ghy]yN^=%ћJP aV]''GN!Q\ԸI))ܭ&x˽y̗3_*~yNV|6lOn.ajF+ǒ&Ա#ؿOY j6kcWfw\pcpsyϮղH!znŋ]ԐAl=aUM)+qX!Q7>y 8HeR|sG]jr_x|\x>É{=_lp-7˗@\&Hڕb Zwԇg?Y|?e?xasY-ˑ>CqYq4psw˳ņ1%}^%>]pc8^ɏ(yykǓ+_M&C9"17OiZΧ$􁭓K27K̗lPݯn׊^<8>]$ ҿ9NKU'&"1@@f2]Z֊GG-vl?S[˳w5 %ogH/sFЈǣYE= c?x:Z!u*_ |cVgn2R}H^}?飏 eʨ_|]~<?l'6@AA>|.Z^wǾ|>=>l\;Sn3fq/U7y{A0̘3ޯo|_<~/`At~7a~t^ɥ&#?}ॏ۩h/ۥC. m}ADn97w6!˳ >6^ߑafo:62P/3 n,෗h0'9odn)|bUGVOIcnU1enf߶:bҫg5v&g#CZƫ.91[E0 endstream endobj 784 0 obj << /Author(Karline Soetaert, Thomas Petzoldt, R. Woodrow Setzer)/Title(Package deSolve: Solving Initial Value Differential Equations in R)/Subject()/Creator(LaTeX with hyperref package)/Producer(pdfTeX-1.40.16)/Keywords(differential equations, ordinary differential equations, differential algebraic equations, partial differential equations, initial value problems, R) /CreationDate (D:20160905125347+02'00') /ModDate (D:20160905125347+02'00') /Trapped /False /PTEX.Fullbanner (This is pdfTeX, Version 3.14159265-2.6-1.40.16 (TeX Live 2015/W32TeX) kpathsea version 6.2.1) >> endobj 746 0 obj << /Type /ObjStm /N 68 /First 573 /Length 2884 /Filter /FlateDecode >> stream xڵZ[۶~_d;]K'k3c}j32D6v~}@ AŵۗwspPK(HA)+(UU>Y-(1>EOR TO )WFZ0 th[(9|J0SP%q ' '@^Vp0@PZzj-?G !b[PW`B qq 0!  - 8AI A1$֒J TQ0s"!&&<DCJ+dQ\PM45c FaՕVȡFag3pA"T \sGXa4:[B4`)ЩXy15∆L2 n,qkCp rTB > rwW>%gwe[zW[GfܷOMMMDVO@ݷWuۡ0SٝM?{ќ@MP}v".:a ` E0"l S[Qy[Aēx-d$Ig @$IScѪa%dnjXqIL>fcPv2gF򍺠f`,54F2%2uLMVA7HDG5`GL}bUtHbYMSeW#2&\'EńMGKtp9.SEL%FEJqVxdUP&lu :1?R/Q/6|d̳?Z#ל,kLmxffy/l0 - jxSS,+Ɲ#s7N{|S(Dz88hN[h*a BW]oo]_5߾~hՊ^CF5LG5tG=* ' u?A02EyW9? ]?*|z{/~,lX. =US{hZ]uǧrwrFmsNypM}(O*HP}*|<ډK6'0=maRT ɃL5v"^}[Xpm[".qC_9~b pv>lN?b՛_޶i6ysim#z1zrx˃3BixIڕ\vv@Ut޻=ĺ ]5@rkeWq: KtߍޠGcu"]*'A̓+ҳby<",,G1OoNe~y7jSs4Q{ꏧ~GvWO!MhҜ;mA[yn6P=|5a6OM 6`U-pkmrVGxgZ5_,Yʳ`;`**հXF8CuaԻj'l8,p*{'aLC^KY)Hc0' co$0u:&al(a ֙b=|*1Yp &vFaԑ+xJ,ؔ2XDz!¢G8߹{o+ U4ș]d!HO!K#E"[xWNF973FT.}bFi(~?G^#e DFbgX FVL|"`$K^ByXۜp$g~2 丐iL2eEEz;R$p $0,v}Rg<.M9HOB@zl]|=u/\'R 4' ^@JHHO̠z[)ǥRy\ob*6q2W;g bTpcݟ\'>Nc$%M * " fjs}u"R^MD"E@H c !)/n1F&aeK.:%KhL琓:'>C܋pθ#r3`z>R& gJ/)(_0Cs=y.{tf5]lpt)&!iF"Ҙ,Kn[4NF1nE7%+fYLZuhu䢞jB-q]#XjvGŏ$o_:ux_-}8/i 4_Na~xD>:[ntpħCuTd@ԭp\ҡ(xá\ks4t@wZ)mȥY:Έ_?ً/wB(ޞ]}p#na0m+gAԎṋr?4n endstream endobj 785 0 obj << /Type /XRef /Index [0 786] /Size 786 /W [1 3 1] /Root 783 0 R /Info 784 0 R /ID [<30F8C2C5A935334C4BF6C6A1998DD1EB> <30F8C2C5A935334C4BF6C6A1998DD1EB>] /Length 1968 /Filter /FlateDecode >> stream xilW{wKbvı38oY$؉"* EEP O4-X$"RG ~ 84Rsf3M 4 dLz@f>@O9 Z+i"><(U%E(U&5hh- 4hHA QF8/i.WhBE0;Oiv4fB@D@; tNshzE4<.iIhZͣi9ͩFxf T!pje1h*E;F3AuNh.ɌShsA[D΂4/69pm/] 0Ɯ- Yd.!hgn΀Y0.+*X nnueAPgi0ϖ4*&Iĺ$4^\*s.o9YU˻^ +S%k KC˾9X-hR"X&m}Yg༆h[5XRgy6o:U6[k|e8?|7`W^}cgQO}en %Ο$w,cװ ~`eR@+~ `QO)~iVsT:a4bY^{FñeT|YOHSqe~Xc`jH{gM^7n_RĖ2oD,|J%fT;~ɲNArQZeoU,QiePmE-rWthu4Fd'Ը=`/ѻn}:!^nRŕ0{G,{P#`rIcu"^Q}]Z9 ^ȕpeŽ5nߔpM. SS-rI"p)s ,|q,V xDzE&Xpy.Gnu]Xz6d- _|`p -|)ChIM`?VZte"j-pM79pMɢmMnE 5Jin&f0nr8aa# o8}{X:=8\tm}Y#s_>I_Y9܄E'w~ j䨑b?3rx-%;x͂9~3 ~׹uWn?fQ:qXݶo)buoRs9lۢLV(yKi2/^WG3_8owt,;4Yd+A_ِFtq m=`hߒnp-n?? ,^൸ ҽVP:6CVN0> /xZGp Q~(VC_72PZaN)Z3+A|M+|FTd9;U Zb cWT$rVXRJP&$}YI`BU@JPDuKM(mB͓@ꖨxZ*mV5ͥ o({wO*겪=۪?E-zX EVxϊStĊWoIEVA+ YijMQ+=a+}zH1+VE#VZyFq+ߛQ[yEgHw +M`T?]x7կNqvp{S\}@.%86ű)Mql: 0ufRX4)M^J꟎0'L VJ`n+> endstream endobj startxref 836701 %%EOF deSolve/src/0000755000175100001440000000000012763247274012476 5ustar hornikusersdeSolve/src/lags.c0000644000175100001440000003707112763247274013600 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" /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 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; /* ----------------- 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 (*)/*(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); } /* give name to data types */ 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*); /* 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_ExternalPtrAddr(resfunc); if(isForcing==1) { DLL_res_func = (C_res_func_type *) R_ExternalPtrAddr(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_ExternalPtrAddr(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_ExternalPtrAddr(jacfunc); } else { /*krylov*/ kryljac_func = (C_kryljac_func_type *) R_ExternalPtrAddr(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_ExternalPtrAddr(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, 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, 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.c0000644000175100001440000004577412763247274014752 0ustar hornikusers#include #include #include "deSolve.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_ExternalPtrAddr(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_ExternalPtrAddr(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_ExternalPtrAddr(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.h0000644000175100001440000001060712763247274014324 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/Makevars0000644000175100001440000000003712763247274014172 0ustar hornikusersPKG_LIBS=$(BLAS_LIBS) $(FLIBS) deSolve/src/dlinpk.f0000644000175100001440000003516312763247274014136 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.f0000644000175100001440000124603712763247274014464 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 80 RWORK(I+LSAVF-1) = RWORK(I+LWM-1) 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 95 RWORK(I) = 0.0D0 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 115 RWORK(I+LYH-1) = Y(I) 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 120 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 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 130 TOL = MAX(TOL,RTOL(I)) 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 190 RWORK(I+LF0-1) = H0*RWORK(I+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 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 260 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 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 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 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 410 Y(I) = RWORK(I+LYH-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) = 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 590 Y(I) = RWORK(I+LYH-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 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 72 RWORK(J) = RWORK(J+LYHD) ENDIF IF (LYHD .GT. 0) THEN DO 76 I = LYHN,IMAX 76 RWORK(I) = RWORK(I+LYHD) ENDIF 80 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 82 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 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 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 95 RWORK(I) = 0.0D0 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 105 RWORK(I+LYH-1) = Y(I) 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 110 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 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 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 130 TOL = MAX(TOL,RTOL(I)) 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 190 RWORK(I+LF0-1) = H0*RWORK(I+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 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 260 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 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 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 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 410 Y(I) = RWORK(I+LYH-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) = 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 590 Y(I) = RWORK(I+LYH-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) = 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 95 RWORK(I) = 0.0D0 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 115 RWORK(I+LYH-1) = Y(I) 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 120 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 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 130 TOL = MAX(TOL,RTOL(I)) 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 190 RWORK(I+LF0-1) = H0*RWORK(I+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 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 260 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 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 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 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 410 Y(I) = RWORK(I+LYH-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) = 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 590 Y(I) = RWORK(I+LYH-1) 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 95 RWORK(I) = 0.0D0 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 115 RWORK(I+LYH-1) = Y(I) 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 120 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 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 130 TOL = MAX(TOL,RTOL(I)) 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 190 RWORK(I+LF0-1) = H0*RWORK(I+LF0-1) 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 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 260 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 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 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 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 410 Y(I) = RWORK(I+LYH-1) 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 590 Y(I) = RWORK(I+LYH-1) 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.f0000644000175100001440000031700012763247274013747 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 700 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.c0000644000175100001440000001440212763247274014752 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.c0000644000175100001440000002177412763247274014321 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.c0000644000175100001440000003266212763247274015474 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" /*================================================== 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_ExternalPtrAddr(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.c0000644000175100001440000000643512763247274013764 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.c0000644000175100001440000002340212763247274015232 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.f0000644000175100001440000026230512763247274014177 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 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 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 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 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 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 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 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 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 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 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 623 SUM=SUM+FMAS(I,J)*YNEW(J) 624 AK(I)=AK(I)+SUM 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 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 30 A(I,K) = -A(I,K)*T 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 40 A(I,J) = A(I,J) + A(I,K)*T 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 10 B(I) = B(I) + A(I,K)*T 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 30 B(I) = B(I) + A(I,K)*T 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 30 A(I,K) = -A(I,K)*T 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 40 A(I,J) = A(I,J) + A(I,K)*T 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 10 B(I) = B(I) + A(I,K)*T 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 30 B(I) = B(I) + A(I,K)*T 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 5 J = MU+2,N DO 5 I = 1,ML 5 A(I,J) = 0.D0 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 30 A(I,K) = -A(I,K)*T 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 40 A(IJK,J) = A(IJK,J) + A(I,K)*T 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 10 B(IMD) = B(IMD) + A(I,K)*T 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 30 B(IMD) = B(IMD) + A(I,K)*T 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 5 J = MU+2,N DO 5 I = 1,ML AR(I,J) = 0.D0 AI(I,J) = 0.D0 5 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 140 a(i,j) = a(i,j) - y * a(m,j) C do 150 j = 1, igh 150 a(j,m) = a(j,m) + y * a(j,i) C 160 continue C 180 continue C 200 return C :::::::::: last card of elmhes :::::::::: end deSolve/src/radau5.f0000644000175100001440000013322412763247274014033 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) 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.c0000644000175100001440000001536612763247274014761 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.h0000644000175100001440000000321112763247274013773 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.f0000644000175100001440000104744112763247274014037 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 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 110 PC(I) = PC(I-1) + FNQM1*PC(I) 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 120 XPIN = XPIN + TSIGN*PC(I)/(I+1) C Store coefficients in ELCO and TESCO. -------------------------------- ELCO(1,NQ) = PINT*RQ1FAC ELCO(2,NQ) = 1.0D0 DO 130 I = 2,NQ 130 ELCO(I+1,NQ) = RQ1FAC*PC(I)/I 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 210 PC(I) = PC(I-1) + FNQ*PC(I) PC(1) = FNQ*PC(1) C Store coefficients in ELCO and TESCO. -------------------------------- DO 220 I = 1,NQP1 220 ELCO(I,NQ) = PC(I)/PC(2) 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 10 IC = IC*JJ 15 C = IC DO 20 I = 1,N 20 DKY(I) = C*YH(I,L) 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 30 IC = IC*JJ 35 C = IC DO 40 I = 1,N 40 DKY(I) = C*YH(I,JP1) + S*DKY(I) 50 CONTINUE IF (K .EQ. 0) RETURN 55 R = H**(-K) DO 60 I = 1,N 60 DKY(I) = R*DKY(I) 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 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 110 WM(I+2) = 0.0D0 CKS CALL JAC (NEQ, TN, Y, 0, 0, WM(3), N,RPAR,IPAR) CON = -HL0 DO 120 I = 1,LENP 120 WM(I+2) = WM(I+2)*CON 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 220 WM(I+J1) = (FTEM(I) - SAVF(I))*FAC 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 250 J = J + NP1 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 310 Y(I) = Y(I) + R*(H*SAVF(I) - YH(I,2)) 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 410 WM(I+2) = 0.0D0 CKS CALL JAC (NEQ, TN, Y, ML, MU, WM(ML3), MEBAND,RPAR,IPAR) CON = -HL0 DO 420 I = 1,LENP 420 WM(I+2) = WM(I+2)*CON 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)) 530 Y(I) = Y(I) + R 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 540 WM(II+I) = (FTEM(I) - SAVF(I))*FAC 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 580 II = II + MEBAND 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 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 320 WM(I+2) = 1.0D0/DI 330 DO 340 I = 1,N 340 X(I) = WM(I+2)*X(I) 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 125 EL(I) = ELCO(I,NQ) 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 155 EL(I) = ELCO(I,NQ) NQNYH = NQ*NYH RC = RC*EL(1)/EL0 EL0 = EL(1) CONIT = 0.5D0/(NQ+2) 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 180 J = 2,L R = R*RH DO 180 I = 1,N 180 YH(I,J) = YH(I,J)*R 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 210 YH1(I) = YH1(I) + YH1(I+NYH) 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 230 Y(I) = YH(I,1) 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 260 ACOR(I) = 0.0D0 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) 290 Y(I) = SAVF(I) - ACOR(I) DEL = DVNORM (N, Y, EWT) DO 300 I = 1,N Y(I) = YH(I,1) + EL(1)*SAVF(I) 300 ACOR(I) = SAVF(I) 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 360 Y(I) = H*SAVF(I) - (YH(I,2) + ACOR(I)) 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) 380 Y(I) = YH(I,1) + EL(1)*ACOR(I) 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 440 YH1(I) = YH1(I) - YH1(I+NYH) 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 470 J = 1,L DO 470 I = 1,N 470 YH(I,J) = YH(I,J) + EL(J)*ACOR(I) 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 490 YH(I,LMAX) = ACOR(I) 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 510 YH1(I) = YH1(I) - YH1(I+NYH) 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 530 SAVF(I) = ACOR(I) - YH(I,LMAX) 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 600 YH(I,NEWQ+1) = ACOR(I)*R 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 645 Y(I) = YH(I,1) CKS CALL F (NEQ, TN, Y, SAVF, rpar, ipar) NFE = NFE + 1 DO 650 I = 1,N 650 YH(I,2) = H*SAVF(I) 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 710 ACOR(I) = ACOR(I)*R 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 GO TO (10, 20, 30, 40), ITOL 10 CONTINUE DO 15 I = 1,N 15 EWT(I) = RTOL(1)*ABS(YCUR(I)) + ATOL(1) RETURN 20 CONTINUE DO 25 I = 1,N 25 EWT(I) = RTOL(1)*ABS(YCUR(I)) + ATOL(I) RETURN 30 CONTINUE DO 35 I = 1,N 35 EWT(I) = RTOL(I)*ABS(YCUR(I)) + ATOL(1) RETURN 40 CONTINUE DO 45 I = 1,N 45 EWT(I) = RTOL(I)*ABS(YCUR(I)) + ATOL(I) 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 10 SUM = SUM + (V(I)*W(I))**2 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 10 RWORK(I) = RWORK(I+LYHD) 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 30 RWORK(I+LEWTN-1) = RWORK(I+LEWT-1) 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 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 25 Y(I) = YH(I) 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 75 SAVF(I) = 0.0D0 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 145 Y(I) = YH(I) 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 170 IWK(IBR+I) = I 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 180 WK(IBA+I) = 0.0D0 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 10 JDONE(J) = 0 NCOL = 1 DO 60 NG = 1,MAXG IGP(NG) = NCOL DO 20 I = 1,N 20 INCL(I) = 0 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) 40 INCL(I) = 1 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) 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) 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 110 FTEM(I) = 0.0D0 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)) 210 Y(JJ) = Y(JJ) + R 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 295 FTEM(I) = 0.0D0 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 310 Y(I) = Y(I) + R*(H*SAVF(I) - YH(I,2)) 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 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 320 WK(I+2) = 1.0D0/DI 330 DO 340 I = 1,N 340 X(I) = WK(I+2)*X(I) 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) 5 last(next(k)) = k 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 1 head(vi) = 0 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) 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 7 mark(vi) = tag 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)) 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 1 q(i) = 0 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 2 q(k) = q(k) + 1 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) 4 q(i) = ia(i+1) 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 6 j = j-1 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 4 isp(ju+j-1) = isp(jutmp+j-1) 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) 4 a(j) = ar(i) 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 1 jru(k) = 0 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 2 ira(k) = iak 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) 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) 16 jl(j) = qm 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) 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) 33 ju(j) = qm 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 4 row(ju(j)) = 0 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 8 row(ju(mu+j)) = row(ju(mu+j)) + lki * u(j) 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 11 u(j) = row(ju(mu+j)) * dk 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 20 sum = sum - u(j) * tmp(ju(mu+j)) 21 tmp(k) = sum z(c(k)) = sum 22 k = k-1 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 1 tmp(k) = b(r(k)) 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 2 tmp(jl(ml+j)) = tmp(jl(ml+j)) + tmpk * l(j) 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 4 sum = sum + u(j) * tmp(ju(mu+j)) 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 1 tmp(k) = b(c(k)) 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 2 tmp(ju(mu+j)) = tmp(ju(mu+j)) + tmpk * u(j) 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 4 sum = sum + l(j) * tmp(jl(ml+j)) 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 10 CM2(I) = TESCO(2,I)*ELCO(I+1,I) CALL DCFODE (1, ELCO, TESCO) DO 20 I = 1,12 20 CM1(I) = TESCO(2,I)*ELCO(I+1,I) 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 155 EL(I) = ELCO(I,NQ) NQNYH = NQ*NYH RC = RC*EL(1)/EL0 EL0 = EL(1) CONIT = 0.5D0/(NQ+2) 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 180 J = 2,L R = R*RH DO 180 I = 1,N 180 YH(I,J) = YH(I,J)*R 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 210 YH1(I) = YH1(I) + YH1(I+NYH) 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 230 Y(I) = YH(I,1) 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 260 ACOR(I) = 0.0D0 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) 290 Y(I) = SAVF(I) - ACOR(I) DEL = DMNORM (N, Y, EWT) DO 300 I = 1,N Y(I) = YH(I,1) + EL(1)*SAVF(I) 300 ACOR(I) = SAVF(I) 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 360 Y(I) = H*SAVF(I) - (YH(I,2) + ACOR(I)) 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) 380 Y(I) = YH(I,1) + EL(1)*ACOR(I) 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 440 YH1(I) = YH1(I) - YH1(I+NYH) 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 460 J = 1,L DO 460 I = 1,N 460 YH(I,J) = YH(I,J) + EL(J)*ACOR(I) 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 490 YH(I,LMAX) = ACOR(I) 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 510 YH1(I) = YH1(I) - YH1(I+NYH) 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 530 SAVF(I) = ACOR(I) - YH(I,LMAX) 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 600 YH(I,NEWQ+1) = ACOR(I)*R 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 645 Y(I) = YH(I,1) CKS CALL F (NEQ, TN, Y, SAVF, rpar, ipar) NFE = NFE + 1 DO 650 I = 1,N 650 YH(I,2) = H*SAVF(I) 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 710 ACOR(I) = ACOR(I)*R 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 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 110 WM(I+2) = 0.0D0 CALL JAC (NEQ, TN, Y, 0, 0, WM(3), N,rpar,ipar) CON = -HL0 DO 120 I = 1,LENP 120 WM(I+2) = WM(I+2)*CON 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 220 WM(I+J1) = (FTEM(I) - SAVF(I))*FAC 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 250 J = J + NP1 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 410 WM(I+2) = 0.0D0 CALL JAC (NEQ, TN, Y, ML, MU, WM(ML3), MEBAND,rpar,ipar) CON = -HL0 DO 420 I = 1,LENP 420 WM(I+2) = WM(I+2)*CON 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)) 530 Y(I) = Y(I) + R 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 540 WM(II+I) = (FTEM(I) - SAVF(I))*FAC 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 580 II = II + MEBAND 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 10 VM = MAX(VM,ABS(V(I))*W(I)) 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 10 SUM = SUM + ABS(A(I,J))/W(J) 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 10 SUM = SUM + ABS(A(I1-J,J))/W(J) 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 10 JROOT(I) = 0 HMING = (ABS(TN) + ABS(H))*UROUND*100.0D0 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 110 IF (ABS(G0(I)) .LE. 0.0D0) ZROOT = .TRUE. 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 120 Y(I) = Y(I) + TEMP2*YH(I,2) CALL G (NEQ, T0, Y, NGC, G0, rpar, ipar) NGE = NGE + 1 ZROOT = .FALSE. DO 130 I = 1,NGC 130 IF (ABS(G0(I)) .LE. 0.0D0) ZROOT = .TRUE. 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 210 IF (ABS(G0(I)) .LE. 0.0D0) ZROOT = .TRUE. 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 220 Y(I) = Y(I) + TEMP2*YH(I,2) 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 320 Y(I) = YH(I,1) 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 125 EL(I) = ELCO(I,NQ) 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 155 EL(I) = ELCO(I,NQ) NQNYH = NQ*NYH RC = RC*EL(1)/EL0 EL0 = EL(1) CONIT = 0.5D0/(NQ+2) EPCON = CONIT*TESCO(2,NQ) 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 180 J = 2,L R = R*RH DO 180 I = 1,N 180 YH(I,J) = YH(I,J)*R 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 210 YH1(I) = YH1(I) + YH1(I+NYH) 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 230 Y(I) = YH(I,1) 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 260 ACOR(I) = 0.0D0 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) 290 Y(I) = SAVF(I) - ACOR(I) DEL = DVNORM (N, Y, EWT) DO 300 I = 1,N Y(I) = YH(I,1) + EL(1)*SAVF(I) 300 ACOR(I) = SAVF(I) 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 360 SAVX(I) = H*SAVF(I) - (YH(I,2) + ACOR(I)) 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) 380 Y(I) = YH(I,1) + EL(1)*ACOR(I) 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 440 YH1(I) = YH1(I) - YH1(I+NYH) 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 470 J = 1,L DO 470 I = 1,N 470 YH(I,J) = YH(I,J) + EL(J)*ACOR(I) 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 490 YH(I,LMAX) = ACOR(I) 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 510 YH1(I) = YH1(I) - YH1(I+NYH) 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 530 SAVF(I) = ACOR(I) - YH(I,LMAX) 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 600 YH(I,NEWQ+1) = ACOR(I)*R 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 645 Y(I) = YH(I,1) CKS CALL F (NEQ, TN, Y, SAVF, rpar, ipar) NFE = NFE + 1 DO 650 I = 1,N 650 YH(I,2) = H*SAVF(I) 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 710 ACOR(I) = ACOR(I)*R 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 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 10 V(I,1) = B(I)*WGHT(I) 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 25 X(I) = 0.0D0 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 50 V(I,1) = B(I)*WGHT(I) 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 60 HES(I,J) = 0.0D0 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 210 B(K) = 0.0D0 B(1) = BNRM CALL DHESL (HES, MAXL, LL, IPVT, B) DO 220 K = 1,N 220 X(K) = 0.0D0 DO 230 I = 1,LL CALL DAXPY (N, B(I), V(1,I), 1, X, 1) 230 CONTINUE DO 240 I = 1,N 240 X(I) = X(I)/WGHT(I) 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 10 VTEM(I) = V(I)/WGHT(I) 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 20 Y(I) = Z(I) + VTEM(I) 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 40 Z(I) = VTEM(I)*WGHT(I) 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 50 Y(I) = Z(I) + VTEM(I)*RNORM 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 70 Z(I) = FTEM(I) - SAVF(I) DO 80 I = 1,N 80 Z(I) = VTEM(I) - FAC*Z(I) 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 90 Z(I) = Z(I)*WGHT(I) 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 10 V(I,1) = B(I)*WGHT(I) 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 25 X(I) = 0.0D0 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 50 V(I,1) = B(I)*WGHT(I) 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 60 HES(I,J) = 0.0D0 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 70 DL(K) = S*DL(K) + C*V(K,IP1) 75 CONTINUE ENDIF S = Q(2*LL) C = Q(2*LL-1)/SNORMW LLP1 = LL + 1 DO 80 K = 1,N 80 DL(K) = S*DL(K) + C*V(K,LLP1) 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 210 B(K) = 0.0D0 B(1) = BNRM CALL DHELS (HES, MAXLP1, LL, Q, B) DO 220 K = 1,N 220 X(K) = 0.0D0 DO 230 I = 1,LL CALL DAXPY (N, B(I), V(1,I), 1, X, 1) 230 CONTINUE DO 240 I = 1,N 240 X(I) = X(I)/WGHT(I) 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 10 X(I) = 0.0D0 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 60 P(I) = Z(I) + BETA*P(I) 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 10 X(I) = 0.0D0 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 45 ZTR = ZTR + Z(I)*R(I)*WGHT(I)**2 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 60 P(I) = Z(I) + BETA*P(I) 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 80 PTW = PTW + P(I)*W(I)*WGHT(I)**2 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 20 Y(I) = W(I) + P(I)*RPNRM 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 40 W(I) = P(I) - FAC*(WK(I) - SAVF(I)) 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 20 X(I) = 0.0D0 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 60 Y(I) = Y0(I) + HG*YDOT(I) CKS CALL F (NEQ, T1, Y, TEMP, rpar, ipar) DO 70 I = 1,N 70 TEMP(I) = (TEMP(I) - YDOT(I))/HG 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.c0000644000175100001440000000116212763247274015547 0ustar hornikusers#include #include #include "deSolve.h" 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}; void R_init_deSolve(DllInfo *info) { // R_RegisterCCallable("deSolve", "get_deSolve_gparms", (DL_FUNC) get_deSolve_gparms); // thpe: macro from package Matrix #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.c0000644000175100001440000001541712763247274015643 0ustar hornikusers/*==========================================================================*/ /* Fixed Step time stepping routine - NO Integration */ /*==========================================================================*/ #include "rk_util.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_ExternalPtrAddr(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.c0000644000175100001440000002511612763247274014320 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 /*============================================================================*/ /* 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_ExternalPtrAddr(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.c0000644000175100001440000002047612763247274015161 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.f0000644000175100001440000010117012763247274014314 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----------------------------------------------------------------------- 13 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----------------------------------------------------------------------- 3 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.f0000644000175100001440000017637512763247274014324 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 80 RWORK(I+LSAVF-1) = RWORK(I+LWM-1) 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 95 RWORK(I) = 0.0D0 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 115 RWORK(I+LYH-1) = Y(I) 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 120 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 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 130 TOL = MAX(TOL,RTOL(I)) 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 190 RWORK(I+LF0-1) = H0*RWORK(I+LF0-1) 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 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 260 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 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 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 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 410 Y(I) = RWORK(I+LYH-1) 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 590 Y(I) = RWORK(I+LYH-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 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 72 RWORK(J) = RWORK(J+LYHD) ENDIF IF (LYHD .GT. 0) THEN DO 76 I = LYHN,IMAX 76 RWORK(I) = RWORK(I+LYHD) ENDIF 80 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 82 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 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 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 95 RWORK(I) = 0.0D0 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 105 RWORK(I+LYH-1) = Y(I) 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 110 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 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 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 130 TOL = MAX(TOL,RTOL(I)) 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 190 RWORK(I+LF0-1) = H0*RWORK(I+LF0-1) 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 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 260 RWORK(I+LEWT-1) = 1.0D0/RWORK(I+LEWT-1) 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 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 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 410 Y(I) = RWORK(I+LYH-1) 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 590 Y(I) = RWORK(I+LYH-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) = 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.c0000644000175100001440000001323612763247274014262 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.c0000644000175100001440000002711612763247274015111 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.c0000644000175100001440000000775012763247274015055 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.c0000644000175100001440000006027612763247274014752 0ustar hornikusers#include #include #include "deSolve.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_ExternalPtrAddr(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_ExternalPtrAddr(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_ExternalPtrAddr(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.c0000644000175100001440000001233312763247274014437 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.c0000644000175100001440000002275112763247274014463 0ustar hornikusers/* deals with forcing functions and events; Karline Soetaert */ #include "deSolve.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_ExternalPtrAddr(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_ExternalPtrAddr(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.c0000644000175100001440000001701012763247274014334 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.c0000644000175100001440000000347312763247274014162 0ustar hornikusers/* Functions to test compiled code implementation of ODE and DAE */ #include #include #include "deSolve.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_ExternalPtrAddr(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_ExternalPtrAddr(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.f0000644000175100001440000000121212763247274013602 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.f0000644000175100001440000072720212763247274014125 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 300 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 305 RWORK(LVT+I-1) = MAX(IWORK(LID+I-1),0)*RWORK(LWT+I-1) 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 357 RWORK(LVT+I-1) = MAX(IWORK(LID+I-1),0)*RWORK(LWT+I-1) 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) 380 RWORK(ITEMP + I - 1) = H*YPRIME(I) 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 515 RWORK(LVT+I-1) = MAX(IWORK(LID+I-1),0)*RWORK(LWT+I-1) 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) 524 ATOL(I)=R*ATOL(I) 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 GO TO (610,620,630,700,655,640,650,660,670,675, * 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)) 770 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 260 PHI(I,J)=BETA(J)*PHI(I,J) 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 405 DELTA(I) = PHI(I,KP1) + E(I) 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 415 DELTA(I) = PHI(I,K) + DELTA(I) 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 510 DELTA(I)=E(I)-PHI(I,KP2) 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 580 PHI(I,KP2)=E(I) 585 CONTINUE DO 590 I=1,NEQ 590 PHI(I,KP1)=PHI(I,KP1)+E(I) DO 595 J1=2,KP1 J=KP1-J1+1 DO 595 I=1,NEQ 595 PHI(I,J)=PHI(I,J)+PHI(I,J+1) 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 610 PHI(I,J)=TEMP1*PHI(I,J) 620 CONTINUE 630 CONTINUE DO 640 I=2,KP1 640 PSI(I-1)=PSI(I)-H 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 695 PHI(I,2) = R*PHI(I,2) 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 20 WT(I) = 1.0D0/WT(I) 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) 10 YPOUT(I)=0.0D0 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) 20 YPOUT(I)=YPOUT(I)+D*PHI(I,J) 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 20 SUM = SUM + ((V(I)*RWT(I))/VMAX)**2 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 20 P(I) = P(I)*RATIO1 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) 310 YPRIME(I)=0.0D0 DO 330 J=2,KP1 DO 320 I=1,NEQ Y(I)=Y(I)+PHI(I,J) 320 YPRIME(I)=YPRIME(I)+GAMMA(J)*PHI(I,J) 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 375 IF(NONNEG .EQ. 0) GO TO 390 DO 377 I = 1,NEQ 377 DELTA(I) = MIN(Y(I),0.0D0) DELNRM = DDWNRM(NEQ,DELTA,WT,RPAR,IPAR) IF(DELNRM .GT. EPCON) GO TO 380 DO 378 I = 1,NEQ 378 E(I) = E(I) - DELTA(I) 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 100 E(I)=0.0D0 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 320 DELTA(I) = DELTA(I) * CONFAC 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) 340 YPRIME(I)=YPRIME(I)-CJ*DELTA(I) 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) 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 110 WM(I)=0.0D0 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 220 WM(NROW+L)=(E(L)-DELTA(L))*DELINV 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 410 WM(I)=0.0D0 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 510 YPRIME(N)=YPRIME(N)+CJ*DEL 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 520 WM(II+I)=(E(I)-DELTA(I))*DELINV 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) 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 20 P(I) = P(I)*RATIO1 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) 310 YPRIME(I)=0.0D0 DO 330 J=2,KP1 DO 320 I=1,NEQ Y(I)=Y(I)+PHI(I,J) 320 YPRIME(I)=YPRIME(I)+GAMMA(J)*PHI(I,J) 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 360 DELTA(I) = MIN(Y(I),0.0D0) DELNRM = DDWNRM(NEQ,DELTA,WT,RPAR,IPAR) IF(DELNRM .GT. EPCON) GO TO 380 DO 370 I = 1,NEQ 370 E(I) = E(I) - DELTA(I) 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 100 E(I) = 0.0D0 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 320 DELTA(I) = DELTA(I) * CONFAC ENDIF C C Save residual in SAVR. C DO 340 I = 1,NEQ 340 SAVR(I) = DELTA(I) 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) 360 YPRIME(I) = YPRIME(I) - CJ*DELTA(I) 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 110 X(I) = 0.D0 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 120 X(I) = X(I) + WM(LZ+I-1) 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 10 Z(I) = 0.0D0 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 30 V(I,1) = R(I)*WGHT(I) ELSE DO 35 I = 1,NEQ 35 V(I,1) = R(I) 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 60 HES(I,J) = 0.0D0 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 70 DL(K) = S*DL(K) + C*V(K,IP1) 75 CONTINUE ENDIF S = Q(2*LL) C = Q(2*LL-1)/SNORMW LLP1 = LL + 1 DO 80 K = 1,NEQ 80 DL(K) = S*DL(K) + C*V(K,LLP1) 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 130 Z(I) = 0.D0 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 170 DL(K) = S*DL(K) + C*V(K,IP1) 175 CONTINUE S = Q(2*MAXL) C = Q(2*MAXL-1)/SNORMW DO 180 K = 1,NEQ 180 DL(K) = S*DL(K) + C*V(K,MAXLP1) 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 210 R(K) = 0.0D0 R(1) = RNRM CALL DHELS (HES, MAXLP1, LL, Q, R) DO 220 K = 1,NEQ 220 Z(K) = 0.0D0 DO 230 I = 1,LL CALL DAXPY (NEQ, R(I), V(1,I), 1, Z, 1) 230 CONTINUE DO 240 I = 1,NEQ 240 Z(I) = Z(I)/WGHT(I) 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.c0000644000175100001440000000176612763247274014340 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.c0000644000175100001440000000156112763247274014070 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.h0000644000175100001440000001201012763247274014242 0ustar hornikusers#include #include #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.c0000644000175100001440000000344012763247274015356 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.f0000644000175100001440000000350512763247274014225 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, TP, 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 10 IC = IC*JJ 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 30 IC = IC*JJ 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.c0000644000175100001440000002576612763247274015004 0ustar hornikusers/* complex number vode */ #include #include #include "deSolve.h" #include "zvode.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_ExternalPtrAddr(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_ExternalPtrAddr(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_ExternalPtrAddr(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.c0000644000175100001440000002371112763247274015750 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/zvode.f0000644000175100001440000052211112763247274013776 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 120 RWORK(I+LEWT-1) = ONE/RWORK(I+LEWT-1) 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 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 260 RWORK(I+LEWT-1) = ONE/RWORK(I+LEWT-1) 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 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 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 60 Y(I) = Y0(I) + H*YDOT(I) CALL F (N, T1, Y, TEMP, RPAR, IPAR) DO 70 I = 1, N 70 TEMP(I) = (TEMP(I) - YDOT(I))/H 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 10 IC = IC*JJ 15 C = REAL(IC) DO 20 I = 1, N 20 DKY(I) = C*YH(I,L) 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 30 IC = IC*JJ 35 C = REAL(IC) DO 40 I = 1, N 40 DKY(I) = C*YH(I,JP1) + S*DKY(I) 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 110 YH1(I) = ZERO 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 210 YH1(I) = YH1(I) + YH1(I+LDYH) 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 420 YH1(I) = YH1(I) - YH1(I+LDYH) 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 470 TAU(I+1) = TAU(I) 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 510 YH1(I) = YH1(I) - YH1(I+LDYH) 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 550 YH(I,2) = H*SAVF(I) 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 575 SAVF(I) = ACOR(I) - CNQUOT*YH(I,LMAX) 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 700 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 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 115 EM(I) = ZERO 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) 120 S = -S TQ(1) = EM(NQM1)/(FLOTNQ*CSUM) 130 RXI = H/HSUM DO 140 IBACK = 1, J I = (J + 2) - IBACK 140 EM(I) = EM(I) + EM(I-1)*RXI 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) 160 S = -S C In EL, form coefficients of normalized integrated polynomial. -------- S = ONE/EM0 EL(1) = ONE DO 170 I = 1, NQ 170 EL(I+1) = S*EM(I)/REAL(I) 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 180 EM(I) = EM(I) + EM(I-1)*RXI C Compute integral of polynomial. -------------------------------------- S = ONE CSUM = ZERO DO 190 I = 1, L CSUM = CSUM + S*EM(I)/REAL(I+1) 190 S = -S TQ(3) = FLOTL*EM0/CSUM GO TO 300 C C Set coefficients for BDF methods. ------------------------------------ 200 DO 210 I = 3, L 210 EL(I) = ZERO 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 220 EL(I) = EL(I) + EL(I-1)*RXI 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 235 EL(I) = EL(I) + EL(I-1)*RXIS 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 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 110 EL(J) = ZERO 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 120 EL(I) = EL(I)*XI + EL(I-1) 130 CONTINUE C Construct coefficients of integrated polynomial. --------------------- DO 140 J = 2, NQM1 140 EL(J+1) = REAL(NQ)*EL(J)/REAL(J) C Subtract correction terms from YH array. ----------------------------- DO 170 J = 3, NQ DO 160 I = 1, N 160 YH(I,J) = YH(I,J) - YH(I,L)*EL(J) 170 CONTINUE RETURN C Order increase. ------------------------------------------------------ C Zero out next column in YH array. ------------------------------------ 180 CONTINUE LP1 = L + 1 DO 190 I = 1, N 190 YH(I,LP1) = ZERO 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 210 EL(J) = ZERO 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 220 EL(I) = EL(I)*XI + EL(I-1) 230 CONTINUE C Subtract correction terms from YH array. ----------------------------- DO 250 J = 3,NQ DO 240 I = 1, N 240 YH(I,J) = YH(I,J) - YH(I,L)*EL(J) 250 CONTINUE RETURN C Order increase. ------------------------------------------------------ 300 DO 310 J = 1, LMAX 310 EL(J) = ZERO 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 320 EL(I) = EL(I)*XIOLD + EL(I-1) 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 350 YH(I,LP1) = T1*YH(I,LMAX) 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 260 ACOR(I) = ZERO 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 280 SAVF(I) = RL1*(H*SAVF(I) - YH(I,2)) DO 290 I = 1,N 290 Y(I) = SAVF(I) - ACOR(I) DEL = ZVNORM (N, Y, EWT) DO 300 I = 1,N 300 Y(I) = YH(I,1) + SAVF(I) 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 360 Y(I) = (RL1*H)*SAVF(I) - (RL1*YH(I,2) + ACOR(I)) 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 380 Y(I) = YH(I,1) + ACOR(I) 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 110 WM(I) = ZERO 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 220 WM(I+J1) = (FTEM(I) - SAVF(I))*FAC 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 250 J = J + NP1 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 310 Y(I) = Y(I) + R*(H*SAVF(I) - YH(I,2)) 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 410 WM(I) = ZERO 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)) 530 Y(I) = Y(I) + R 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 540 WM(II+I) = (FTEM(I) - SAVF(I))*FAC 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 580 II = II + MEBAND 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 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 320 WM(I) = ONE/DI C 330 DO 340 I = 1,N 340 X(I) = WM(I)*X(I) 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 10 RSAV(I) = RVOD1(I) DO 15 I = 1,LENRV2 15 RSAV(LENRV1+I) = RVOD2(I) C DO 20 I = 1,LENIV1 20 ISAV(I) = IVOD1(I) DO 25 I = 1,LENIV2 25 ISAV(LENIV1+I) = IVOD2(I) C RETURN C 100 CONTINUE DO 110 I = 1,LENRV1 110 RVOD1(I) = RSAV(I) DO 115 I = 1,LENRV2 115 RVOD2(I) = RSAV(LENRV1+I) C DO 120 I = 1,LENIV1 120 IVOD1(I) = ISAV(I) DO 125 I = 1,LENIV2 125 IVOD2(I) = ISAV(LENIV1+I) 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 GO TO (10, 20, 30, 40), ITOL 10 CONTINUE DO 15 I = 1,N 15 EWT(I) = RTOL(1)*ABS(YCUR(I)) + ATOL(1) RETURN 20 CONTINUE DO 25 I = 1,N 25 EWT(I) = RTOL(1)*ABS(YCUR(I)) + ATOL(I) RETURN 30 CONTINUE DO 35 I = 1,N 35 EWT(I) = RTOL(I)*ABS(YCUR(I)) + ATOL(1) RETURN 40 CONTINUE DO 45 I = 1,N 45 EWT(I) = RTOL(I)*ABS(YCUR(I)) + ATOL(I) 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 10 SUM = SUM + ZABSSQ(V(I)) * W(I)**2 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 double precision dreal,dimag COMPLEX(KIND=8) zdumr,zdumi dreal(zdumr) = zdumr 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 COMPLEX(KIND=8) zdum double precision cabs1 double precision dreal,dimag COMPLEX(KIND=8) zdumr,zdumi dreal(zdumr) = zdumr dimag(zdumi) = (0.0d0,-1.0d0)*zdumi 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 double precision dreal,dimag COMPLEX(KIND=8) zdumr,zdumi dreal(zdumr) = zdumr 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 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 COMPLEX(KIND=8) zdum double precision cabs1 double precision dreal,dimag COMPLEX(KIND=8) zdumr,zdumi dreal(zdumr) = zdumr dimag(zdumi) = (0.0d0,-1.0d0)*zdumi 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.f0000644000175100001440000000721012763247274014144 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 I, NMES, NERR, LEVEL, NI, I1, I2, NR, Ivec(2) CHARACTER(LEN=*) MSG INTEGER LUNIT, IXSAV, MESFLG 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") 100 RETURN END deSolve/NAMESPACE0000644000175100001440000000124212763247225013121 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/0000755000175100001440000000000012763247225012627 5ustar hornikusersdeSolve/demo/odedim.R0000644000175100001440000001411512763247225014215 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.R0000644000175100001440000002562512763247225014472 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/00Index0000644000175100001440000000022112763247225013754 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/NEWS0000644000175100001440000001437112763247225012410 0ustar hornikusersChanges 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/0000755000175100001440000000000012763247225012614 5ustar hornikusersdeSolve/data/ccl4data.rda0000644000175100001440000001212412763247274014767 0ustar hornikuserswTTGW5* (Xan"ߥ"(:uYJGP!BǞGcXcػ1UccMl_|k7(RVKQUr[}^E!Qpcҷj݆qCoQ .`;(<=0zV-:-ڇ&YEz$2{f^q"{o:N$NjՄٗQSPӡhDR( ~ԡ„|=]u coNp #یE߬w;b];_ǎrJCns3>.|0>Z;Pge0~/mn~ DH;w>mדCn|$N5 -/4M*_Waӕs3ː~ -/˹;,Ig8zzB-ߗUnGJ)fȐe-~DrQH7$}cdBҔnH?,:WaWELMGIl64]$PA͍cČf ,uȜ\s {:o˶+t-IdyA`yOe8h_6N\Ց> |ާa%һib4ߟ 'ńTO ?eu󁅔L<'xd$/yM}GMFE3|,?Wv7`H K|s$0/0$b3_M9Ȁ8ۂDGv2|s$G.;q`<Rߑ/\s!! 0 P~ojcy߉_KxaA襃7?^7?GڂaAyoĴ4&:zwuٰ> x]#naDDF*,o?}igDh^ N1>;Fooa~_AؐEݶA__F[?v^ uҥ|`괯{K||l~7 ThLEs31>~ HXRD޹mŶL[s"曧 C^η~p֨ÛphO<<8 ڲb{GbVo?oߺ%rǭZLL81Ʀ@yϜ5%{G3?< ѝoG %i2x]~]^4k[WømsKaF.U4S(*şsK_9x ;rV-SzTbx O_mz#8u&۹VXs6W-^/z~:UZ1hСx:eӼ>f;!kgо!ϋ}sև׷fg=z~DGr>īn?[>k&]eW/O߮U@>!a5<_k>z-x^ +[>={A9!,l%xٔ/b`lif7waW!R{B &Z-O 4νot\"^oDV/8rFz]X~G}ڸe,1\y_T-Aet{vLu wٿ%څto/۟gH=}5&9?xZ>}2'x\?V;P&xmh*WN??|/[渙QegnI|Cv_r zSv1dֿg鲇f䆛7{ι^g/0[m` @i T@m 4.8HI"AR"Hb0$Lb0$Lb0$\bp%\bp%\bC$ 1!H AbC     JJJJJ*****jjjjj1샃( Q)(TPPEB-hD &Z0тL`-hhhhhhhhhhhhhhhhhhhhh D]]]vԮFQ( h )$hJ)$hJ)$h*"h*"h*&hj&hj&hi!hi!h5Y5Y5Y5Y5Y5Y5Y5Y5Y5Y5Y5Y5Y5Y5Y5Y5Y5Y5Y5Y5Y5Y DF.aF.aF.aF.aF.aF.aF.aF.aF.aF.aF.aF.aF.aFa$Fa$Fa$Fa$Fa$Fa$Fa$Fa$Fa$Fa$Fa$Fa$Fa$Fa$N$N$N$N$N$N$N$N$N$N$N$N$N$N$N$N$N$N$N$N$N$N$N$N$N$N$N$N$N$N$N$N$N$N$N$Nt1%\%\%\%\%\%\%\%\%\%\%\%\%\%\"Kr@.%D \"Kr@.%D \"Kr@.%D \"Kr@.%D \".yFdFo&\]v?"u|)GVo{M qWm`G_>; o#^Wo?3odM1?ӹ:sLyxq 4ʃ\LurAn~vfn'zs3y^~kq\CN(,ԉrɓ FA-rޫIFVRt9k1 yј#o!6 #G z+XiKMFpqsD&fu:=CNFA/3 0֌4\;T q\,)0,<~tbfIM7k:FvxW`SN\ ]l[ Lֿ FC˺#L9SJ HGն?38k EdeSolve/R/0000755000175100001440000000000012763247274012110 5ustar hornikusersdeSolve/R/radau.R0000644000175100001440000002404312763247225013326 0ustar hornikusers ### ============================================================================ ### radau, implicit runge-kutta ### ============================================================================ radau <- function(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,...) { ### 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(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) } jacfunc <- func$jacfunc rootfunc <- func$rootfunc initfunc <- func$initfunc initforc <- func$initforc func <- func$func } hmax <- checkInput (y, times, func, rtol, atol, NULL, NULL, 0, hmax, hini, dllname) n <- length(y) if (is.null(hini)) hini <- 0 if (hini <= 0) hini <- 0 ### atol and rtol have to be of same length here... if (length(rtol) != length(atol)) { if (length(rtol) > 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.R0000644000175100001440000001577512763247225013535 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.R0000644000175100001440000001712612763247225014540 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])) } ## 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.R0000644000175100001440000012667212763247225014220 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.R0000644000175100001440000002347012763247225012651 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.R0000644000175100001440000000064212763247225014077 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.R0000644000175100001440000004502412763247225013003 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.R0000644000175100001440000001236612763247225014051 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.R0000644000175100001440000002442212763247225013517 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.R0000644000175100001440000002372612763247225014550 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.R0000644000175100001440000001445212763247225013351 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.R0000644000175100001440000002747212763247225013723 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.R0000644000175100001440000002541712763247225013367 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.R0000644000175100001440000000120312763247225014724 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.R0000644000175100001440000003143412763247225014244 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.R0000644000175100001440000000126312763247225013641 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.R0000644000175100001440000002172512763247225013340 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.R0000644000175100001440000000215312763247225015316 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.R0000644000175100001440000001112712763247225012731 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.R0000644000175100001440000002754712763247225013354 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.R0000644000175100001440000002546512763247225013200 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.R0000644000175100001440000003532112763247225014010 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.R0000644000175100001440000000670212763247225014232 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.R0000644000175100001440000000107312763247225012757 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.R0000644000175100001440000000426212763247225013134 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.R0000644000175100001440000004000712763247225013521 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.R0000644000175100001440000005233512763247225013341 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/0000755000175100001440000000000012763247274013717 5ustar hornikusersdeSolve/vignettes/mymod.f0000644000175100001440000000221212763247226015205 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.c0000644000175100001440000000200112763247226015176 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_extras0000644000175100001440000000001012763247226016740 0ustar hornikusersmymod.* deSolve/vignettes/compiledCode.Rnw0000644000175100001440000017231712763247226017006 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.Rnw0000644000175100001440000020043212763247226016006 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.png0000644000175100001440000010735212763247226015701 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.png0000644000175100001440000010157012763247226015513 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.bib0000644000175100001440000002033512763247226016720 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/MD50000644000175100001440000002341012763274452012215 0ustar hornikusersc698ddc8d653512454b3dbeb0b49b547 *DESCRIPTION 316262d3be55a7fcb10ac5ceebfd7658 *NAMESPACE 3e09365562c3e28fd83e9ebc1f670088 *NEWS 4df6c896706646b5793cc6357b15574a *R/Aquaphy.R 6fe538f8f31e8a207a38958e02e2e70a *R/DLLfunc.R 31be22a79645487f5441d15c21de881d *R/SCOC.R 4a1d5aa97330fab3a064dceeca668c53 *R/Utilities.R 0b7bc04c247655f2319113eb0670bbf1 *R/ccl4model.R 4700d39e3b9420ae880dee2b42c0a942 *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 853d0d6bb24846e0a50b5777cb5af953 *build/vignette.rds 7f77d7c3b5de90ac9892f6986bb5a735 *data/ccl4data.rda be157a942988018a45e577923b2b66e6 *demo/00Index c0c0293b16490375a893937ef11f398b *demo/CCL4model.R 5b936a490bc9ea9aebc3f80cb6ce1fa5 *demo/odedim.R 88e241464aebb08e7d4a2d10e6f4525d *inst/CITATION 5606e440a6699af0408a1f719da3e3dc *inst/doc/compiledCode.R a7f37878e8888219d66d4f40a700279c *inst/doc/compiledCode.Rnw f7197d4361db19be1800df6cc1120e29 *inst/doc/compiledCode.pdf f3b9458fc662add393afdc8faccffe7c *inst/doc/deSolve.R 86ed9ab9c5415bb141eb2cc78b03db66 *inst/doc/deSolve.Rnw d34f22751025313a0c65e4dcb6241f65 *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 9530ccee5ed63dc008cdb986f5c10fb5 *man/daspk.Rd 9f4d51956e88cadb78088e438eaa3ba7 *man/deSolve-internal.Rd d5fd5c6bba52e46934bc58e8b577368b *man/deSolve.Rd 1fe2df2daf98e02daa8ebff3b4c09b0d *man/dede.Rd 96ce499ae3f2afa326764086c3cf4919 *man/diagnostics.Rd c9cbad59d0970aeb3fbdd0ee5b02d5d6 *man/diagnostics.deSolve.Rd b8555d81ffcf5615b9d2f218f2e41ea0 *man/events.Rd e41906e4c2bcc40fcebab691945e5922 *man/forcings.Rd b1c5506acd8d462fcc6689d114e28201 *man/lsoda.Rd bef4d9c77f07916afe88cf0792744385 *man/lsodar.Rd 03da1cdeb0c51f120f986227611358d1 *man/lsode.Rd 33fb78f0e6fa8dd02aab7633f98501af *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 89ebc37cc243262666efc74c1338f299 *man/radau.Rd d0591027af7706dfe4539477920cf561 *man/rk.Rd 4be167bbf27a629c53e7b9b224672e5e *man/rk4.Rd d5eee8ad629d907fe7101ad1a8f08568 *man/rkMethod.Rd 6418431865799b3674dd0730affa8818 *man/timelags.Rd 7f9272d4f4bb04e0c78639a0167dfd9e *man/vode.Rd 88ecf456ed7f62f4d09e5afd5489d5a2 *man/zvode.Rd b371b55d0041d8d19ce9131ceceb0dfa *src/DLLutil.c 8290d2e9740414e315237f0d5d4024bb *src/Makevars 284ec4afe9e8a2f6eb23abe8ef10711c *src/R_init_deSolve.c cf4b58246d69335dd7eb21173b338752 *src/brent.c 7077c3c301c629c1f1fbd76b83e6c714 *src/call_daspk.c f0de9c69746d891eac5785fd2472077e *src/call_euler.c 07f0e5934bb58acbffaaa467d405c906 *src/call_iteration.c 9162159f0bb6d976d1b9349eaba50a9a *src/call_lsoda.c 6576aba10c4b0fdad5d6b0448adda94c *src/call_radau.c f2a32e9ee386aae1651e6f795e7274cb *src/call_rk4.c 17a7cfe4ee8451ce23927d8ca2412acf *src/call_rkAuto.c 78820c0715bc97e5790c325ca62b4974 *src/call_rkFixed.c dcb45e43002ab1267dcc2a78e47bf222 *src/call_rkImplicit.c 4d93d97b44881f19fe13915969949fb6 *src/call_zvode.c 39445cfb088cca51104f28ea6c989193 *src/daux.f 340063f2d764d7a3829a21b9be4be991 *src/ddaspk.f da6a1112789de236f0e88b72c7dfb09f *src/deSolve.h af3a430eea461c7342453092c8dfcea1 *src/deSolve_utils.c 6735f08e18f9a01bcfa52d2a788280f8 *src/dintdy2.f 336b1f06200a19859d3e7ee8aa6687c8 *src/dlinpk.f 6acca8e6c31724aadb532d09ee0a825d *src/dlsoder.f d7426350e3d8031af87419a66099888d *src/dsparsk.f b192bd0df78b40d35d3967175430fb6c *src/dvode.f 350319d809aa4ef18aef66dfdebcd024 *src/errmsg.f 10a5fda2ed498a58743c1886a13d61da *src/ex_Aquaphy.c 586850d15e2be94fbe27eb7df0898ce8 *src/ex_CCL4model.c ce974c6cfe3334a319ff9ff519d599dd *src/ex_ChemicalDAE.c 1815d64fc1a6e9032baeadcfc0d4da01 *src/ex_SCOC.c a5d2a4d8f0511de613a6062da618c4aa *src/forcings.c 9f957cabb904a0082098e442c67ce73c *src/lags.c 05eb87eef6080def2d32f922024185ba *src/opkda1.f ddc646a38351368345aab014308873e5 *src/opkdmain.f 4f96399aa440c3c35e83da3a3854221a *src/radau5.f 77129bdd3fd0ff0583dbf19705e3b818 *src/radau5a.f 0b5fb5a8a8673f23a7733f8be222a729 *src/rk_auto.c 08b6c0746edb392937ff797c2f87a504 *src/rk_fixed.c 9f058aa8acd4b3b63577ef33410b1735 *src/rk_implicit.c f30ff8ecac95acd9ea5546da371bdf53 *src/rk_util.c 06245a83dd68eb332301f756f9afd420 *src/rk_util.h e0593ab7bbcf13bbd3c3584f00313981 *src/rprintf.c fa1db7b8006e5a4a0c397af62d5b80d0 *src/twoDmap.c 325558820fe1eb9ac35aa0f5cb975dec *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/0000755000175100001440000000000012763247273013005 5ustar hornikusersdeSolve/build/vignette.rds0000644000175100001440000000051412763247273015344 0ustar hornikusers}QN1-,`4&$_͋WWFMci旃Y$:ok(jvDe4KUwXՉRx0W5ԔM/Ȑ{=:΅KM{_@gs^͉4chQWJit'G3"ۣࠦmh: *z-c;! n QZTS 2ǻVnOuQM5fpn[Ҵ 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 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: 2016-09-05 10:53:48 UTC; thpe Repository: CRAN Date/Publication: 2016-09-05 15:54:49 deSolve/man/0000755000175100001440000000000012763247274012462 5ustar hornikusersdeSolve/man/timelags.Rd0000644000175100001440000001152412763247225014555 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.Rd0000644000175100001440000006357612763247225014070 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 list 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.Rd0000644000175100001440000000313612763247225016163 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.Rd0000644000175100001440000000465412763247225013505 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.Rd0000644000175100001440000003241412763247225014100 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.Rd0000644000175100001440000003614712763247225013374 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 list 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.Rd0000644000175100001440000003100312763247225013511 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.Rd0000644000175100001440000001550012763247225014560 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.Rd0000644000175100001440000005730712763247225014252 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 list 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.Rd0000644000175100001440000000326012763247225016655 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.Rd0000644000175100001440000004413112763247225014234 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 list 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.Rd0000644000175100001440000001503312763247225014421 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.Rd0000644000175100001440000001530012763247225014414 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.Rd0000644000175100001440000005035112763247225014057 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 list 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.Rd0000644000175100001440000004600212763247225013704 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 list 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.Rd0000644000175100001440000001061212763247225014234 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.Rd0000644000175100001440000000234012763247225014423 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.Rd0000644000175100001440000000402012763247225016027 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.Rd0000644000175100001440000001312012763247225014343 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.14\cr Date: \tab 2016-06-20\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{http://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{http://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.Rd0000644000175100001440000002760312763247225014532 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.Rd0000644000175100001440000004625412763247225014062 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 list 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.Rd0000644000175100001440000000207112763247225015254 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.Rd0000644000175100001440000003144612763247225013767 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.Rd0000644000175100001440000004555312763247225014055 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 list 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.Rd0000644000175100001440000002043712763247225013767 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.Rd0000644000175100001440000002011012763247225013640 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.Rd0000644000175100001440000000771312763247225014102 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.Rd0000644000175100001440000000770612763247225014625 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.Rd0000644000175100001440000003037012763247225014254 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.Rd0000644000175100001440000002335712763247225013457 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.Rd0000644000175100001440000003504712763247225015334 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.Rd0000644000175100001440000003141012763247225013757 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/.Rinstignore0000644000175100001440000000005112763247225014203 0ustar hornikusersinst/doc/aphid.png inst/doc/image1D.png

aY 劮}!~_\$7bcy8@k7GgrQD~&>\껔mJ0+CXnDS /kJEoBXI7y2Iut[F[:w5N5i;Aѭx[zqtlvvH~28C{#pohhL'+e7wCPg*Xy^} <(4]*㫢,~Uxt :8tydBe u7 w1~5 DS?WJoTx|^vŔ.H"f[X37HB&, Cڱ /D?{@ϩf^K= ȅLsKkOWdc֊t/(*_'R1JLqO8l ?]=tW I"? 쑐.m]Pvɓ Dr"$͛Ɛ74֥0) F&z#>2'aeOzrAfŅC\!/JhrȩdLJ_.HhN 29̻ _1\PjI>U5LhoaKsP;y3qPz'i'?YXz؝0qG#FzUs:([SsnQ!~'m3 fZbAʾ4sr+v H&5GՍljFk$>矍χso=ɾf=4ŎU-8OC wl{|d{uDɝ'V{+|j6Y>'J[Cv d'^`o9P~?HZk [F)ޠ5܂`},mw3)wx2|_7M SuՓ{&b4%:TrK\i4lf@dH7fhzO=Tfh+խYBS D`KS.φa ; $3tC.z۵ͥ2>E?>1Bw=$zP,<y{ :tbFuf*?Z!MGNJ ΋T;[R,d֟=WEj.E _\&uy_%e'?m,=u8~q;,f) Ha˷9g&‡JV`ly[mLY{vʦ m-x?«qNrft:݃I wXٖd7e-AF)\L::~{|ᒏ& <ѐܞZǏj2TJoqo۫ R~z*"!Xz% <[/𶋫{i S0K7Y ќ^ lO_fF ̬ =|OAZ.Nf1>%+>r_CɎj6JeŁ/J r.b[)o> stream xڍvP-ҫ4Ԑ{E!$"$:JҋtPRW JSH)_,ߛyo2k9k&\"p=B Ɖ Y$@b&H /Lkp"1hEPvG@qxLt1h ,KʂdA $/"]D@R*c\}ܑN86z`)E Puc`H%p8WYQQ/// bo 8'pD(e@ ^78༠pAh,> G5u0@U 0(W(v8 ]}5 ' ῈP,"]xΡ5EC/<,H_E*AhW*Hw >nB]8 p_"hBS/QsD@xÜD7qEx~W^"Pa\Q8#hT?k# ЯϿǠ]|C}ZƦB;HDd$vHIKY?h @OSWÞlYK7-ۀ  )77;;(_޳8u1)@7gfup꿣8(~юx/% ?8F 8MM 0`^-,b9_X-羪hk ;ԇwmd(Sx;ůkB)QqF 0i L.~uHq"0R[dew.I`acl_Gm:ΧjT?+tD\c9JL-ΚfiTjӳ6쪕&(>Je*mF[rX X]qN04}{F;Rja:.c`n/;M|@udy+W`b/+SBV=O r<%7O߈{ BJ*"#.%k)\ߺ_"0~>z6# vVwAzpqۚ,}ɬVط< sb/7sO?'h $!Zu];4ؿ4F̗L]zS1}%aSBI -Fy+cv`>T:%ɿf| <7|pdO%fDP2'Kڕ4Xk>->al8|j{)ԔƼ֒mǴՈ~Ϡn9miI^Y˯Ez_6fJq_ZoK0s:ptl캣6wwWZd~%Z/JTT F\/SmWZdpOxl%>xx {ꥌpqB"Xl"cd5 M+E^?t ]XKUM0{`QA~Nӻ/M\/E%ڧ- Փ4Gl3X:1_bxmtCeŬfI|1ʯ2}`().Y2Cw^籐Nsfm Bonc.8 wƚ5m?Q?rNQ[;ٔrIa] XOͯ*ٹ!\c]YeF}:U4N+QBJgējviEli(!n-&Js+x Y5ZKl '!ڠܩ-*0Gc*YdA![Xތt|e oƓ9 _snHtI=փi?WѐCtL)Xj_#ؑF^毮jLzN6vbi;Xۀ˩E}4%JedkdپOO Qܸ]ݑ1%8!{V:{8y#$c)$E6EY.\f'yT0S*UfZuIl*A"/Mn'{=yP]_Pt}kp|ͣB2{C]=%ʗI _Ωv nEkO:\W#+:;!1Pv14BYbq3%zjXbLjk^7{ysB@x-_ޠoFFWVVXs:"/Z| /PU%DvB1"^Ʊc]Ǟ:Vـ;7roY|zuT܁iYg'/XF9kCdဥ8xջ6v1N/?sf$pئjcL1-(9FR1gQdz4C°F~Αj^^n=q5޳ks v*s g ,#L=.j zu2n"bF(QEF]yY`en*};8yH\S/bYSj¬Rߊm=rŗ@E'mhV*ҍ[b@5)Out`@xZFwUN.h`T+#64Bv=oS(=uyr^{R9 oTl>Br\}VSi_Q.).HeiZc2 -Uذċt#%и6)|QtH(9۪ $3%q Tx _Sq/Ԍexn,4MZ6A>^7p/#E-{ށ^T_ԟMf2#eЎy "VB1Y}ą>2,og3DcN-mơf YCm:ߨ< <%5gaSImmFGQߕT&fVS2Agg_S'"[N.%80 Z߻fϨ+-UA>er#ė쓇'rϒ[H$)#EJOZC">%Q<-'z#;f>8IӋ q̕uĀ(sS Jrc}#몑VnLIdu |bm1zʟ>g.(M5(`/>?aq|U%'5krMɛɫޭL$oy?s %k784PGm}CQH1՜t)-eȖBjA#O[WJ鋳/)Gf/]7n.DY͇{w"%rOT"e|kQK8i/P% 8W !ϦR+׿sxg31M*ȜD\Y%:2q9[!~ I[Q?5_>T|w{])M{v2e~(fŧqeOT廏r⑧l^c* ,oEțE׸@V˵zw{erlae생&K>,ъ"4*%~o_tZ2 >]wE.47M.yE[sM,v5/i(yrC/zvd*H6:f\m Dx~)=>mR }Ȕ6at=Hp6 b,;H-i/W(mdUa+e+}j0)=O6OImtc,MSZy9m^ڎ7o=<&4y[Km~RZ]`@וIbB6'>#ĨIpټ jKZ6-sdڒVioa:|GrCJ&x]v#zU\4'0D/3yuGbg\&$n\32~RkqOXE~KvͪFI$h[+qzE!s!c+] .PD=BrGM fIw=/:O ZE!G%&Oɒ"b<q #&4>ܓ7̴o#1 g'VaFUw$q4~vp-b<"{pJ1zL#oBZI 3<1T In_O3f7Pm:>t%3ۙ }0 :j3$eDHݴ|@3bC(H_H M /CӘ~A.:QT3fyLف&^Qհ}2Ytk+[Ajո NǓDm~>󣇨X۟nFf1N LNW950at FR7#LG|O2] Z-QڮGܵe}0(D2ax)@4EE+U rfNS,`stc}[ZZ}G_ec?Ky ȡ+aQdF2XjƽT}yKFLS5.}Jd ^^Y¦bF;f݆eqY_ |Fj'=|]HbKnu1B!+s ubIv7Hel$GM)OjtEP!#}J2Y{u4K tQkbOI;%__:.!j(Yb/KK o]c Bkʍ9.dKW~|4G(R/wd|84GjǵL0JkB{1A9_sLǵw%&J{&ZFfG9+^ $^lT/kAk) VcƋ:y¸@w=ʨ϶IQޔ.Sal6ૅ:ovn׍~Z\|ͣb2v'OX3d?.{kDC {βڎb$CjpO];6Xw^-3͕Vo_H۱s^.O"8ưx/3d]fޯ#g?]^БtMۊi~h_ 3œ sr<0bxG3M2Ts_St8YaoCq>t=Dk+v[֏]e**Ƚpp=*'/.;n({].wC7ڧ4G}NxcDSYXG=[杦U\?7K7LܔN ~"ܱ='((rJ 3B;W|yYº$9X}'lEp`T壊cNtޞU O۝bwugdrBlRi019>xҙV?&;P =Vq> stream xڍuTݶ-A@%Bґ.А%$A JEDtKA91#\ss~b30Rw(, T3b 0XeĹ .3DdAQ@mPDRVDJ 2"1@5'(v qmEdd]$ AqW0  C"p>(+ù {yyX'BF,㉀ uE 8"pc= A @a(8o4!PȺg_P E Q@{ G (/"C=Hs(!xXÂH_# *?eu\@ᰀ_!1}ܬ3 G{ -<%22@; sU ;( Ov@ 0 "#a8:FY/Bx>~ F~Z 17OH HKd,cEm\-=([1cϿk>?kEUG` 0 %-)77twwC].> xzCmo9ipGpPQx1 p$7@`$7e5$ a"[Y`9X.xs_u 3Q I x9OoH8 Og ڣ1_*. v a?J<0~+ֿ@x#` 4L.ܩ:RK{_Zb-%pܓu/gj܇]O3z92¿q8mݖ2G޵%w怸G3; I,Po>2IyB yl>q!.\Tpւ]Y RYpsZc-8YZS` &ZCg8#H|ƻ4< ɲHZ&:_m&GXn})L]#爠]8(S凛va#VbLj 춺g8Ј4G’g7WyH)Z$ vn+憯rǁw)e%md$"t2tթjܞwKT(]y7w{0!ט>Vxb quC 5~fҶfgwYߎkuz_<ٿ5v1vZ4[:mϧ)~x[~鞰0lFaP`y{s%I:|ڕiZxUH|V?*/}i;`R$1QKA^zCLtog;UD~+3 DEpd㧏h^@idJrM\UC4 e5k6AeLWwK`9w)B |E r!n+uw7NJUԀ4t/X 6L6 ^xV٩"j@ټ0;ŸkjXGLJ3=(N\G&7inzha?7r[:ikz|c| d#q2|PPgmKqS%PDYٯ{>o={1)]="&njyXE`9P^xN(e?>ޕ}@:G&*9rd٧Z6'b-*]m(GʱCИa `rv* RYelptcq>2h?|wBuuZT!<,z,w5IGj'ƒ*˟Oi8fsNCzorIw.`gd؟Kx^x0#ye)p6yIʗ4?{~rKkG#4 Gdn>y,ȼa<AҾ4PN""1 7/JI딖a f&l^- &v^^ao@ug(3$#5#x ;X{O>}:Ktxqqc Ng)6gAKig/+޾~c9ψw7A`P "E] nS̴SPTb)sc,RG0ϟGd6M~䗆(o:0X BEO>ȯ fMtCdh킻 `"y'*f:DflYd&eK.a Ob]^}2jD;"޴&:<ǛTnupEWf5³ &N9)+yi+Jn+d~= .-1桽έhetn~Z^ƒcXi_x-0=آKCIQ秛ȟĂmHnEOZd08vwvxg "Y;#6>ݲ&8a_bEvYi:,$#IzCmַ  acx9R]4naK %nS nQ'}o{uyKCiqő($I_c gng^ËՏ-'8Pzf&I.1 LRV,xF( ܋^R;}OX5s#(|ijCf&{=ɅĪx bO 5[2 !PǍD5=3eXUhRqS3g;j T PV3Q֟}+mфC#-_GFoQ;e:GuҢW!{YɶZ8n6#gَVe[<5߼S.%gpg'sPpH)TR{ )h/|/xEY'Q2n?իo#|$%um%=K_'S_v4ײyE8+m~!q(O4Uԍ~a a{ RYd]~S.(@d Of.AblMJ]fԗo7Ǐ]b5?i,/HH|ꄻ^ Xtl0ZЖQ$KC{kĨUqfb7Iv7}|j3VY9>#rUw{bmYˢ\8Lo-Y#yH Ѽtӿlx8cXl MN~e˛{r]^UҤb6`Lg.Okx1^|? Hm!UJtkѠu@RdavK"n,qqg1O̸.mSM#]ܛk="Z$IAua ( nl: ˯|b~(v:S4JigS 0b,ktm73%`SPF~F$ImtV:"3I˔ {0kHmťQ1QMsɬvEaRTE|!v//ˆvGEZ]U(*b P[9ZTu EݥTdU{$/Ȗ~!۞WLv}J&hݺ}N`+<`vsrN])AU0fv_Umۓn1c=3Y*ȼ [G^#Җ~|[,ּďpԖwZku>yIEmvc*|7tAZ#6qrxYh%Y ǜGqAzؐrHɢkWL%Qg (?"XۤY}՛y۷%M\ ٍizGTok95<[پԚSLB8*%yy#vm2,]Ֆޫ`Ik7,/*d~`N~D9IP|›<x'k"U q^C%t7J Wܠ/\hѩmn>ҋe{ŕOL>}7ڄ 1b!O7I0i.*'?2\E5ʰPi/U:Sv`nɋ5@OWg.4kfqqzqaEDBQR3}uPO{.pAOUћl֊J$v=g;`kՁ[p)\2'e WzVt<T' Ru endstream endobj 490 0 obj << /Length1 2124 /Length2 17249 /Length3 0 /Length 18526 /Filter /FlateDecode >> stream xڌP]҆  Ywwww_CР %e#{|{w9I 啾 Emm2sd%L􌰤NVaIU6r8}؄ >elmV&+''==?asc -@K*dk`nj? #J@s##@?[Pp99qѹX;:R\͝@G d5haIfr(ٚ88+s#gc#;@IB gWh>-62{) ursh`h#  h`nHhnF8fc![kk#_ ;>ݝߗkicj2116K3PB1&?6S݌JnCCprpz{067rMm`a? E~ aƶ6Vb:AeAMKSP 𕑅 `x} ]?Jؘ8U9dſ{~t.@ѵY>~?Ku_6Ho?ſV\g)͝WclL?:+3-=探n@cys'#uͿ*͛ P7*z2#ˏGk~15kYXwA,O4:Z[%[ؿ.@'_C:?/1N1$G? CdG;=N}dPCG?A}dP/q|g>X>|FV 3_k?/:Ǚ:?4,9mOfvf@D|,QGlk񹰱829>񵤳~(n ltN,C?C?CdX(o2rvc@7ҼWEM`Cׯ{̟n`vE]rf7QN-1-u791 M wh&QxN:;5lM1Λ\og(1i/Ҏĸɚ*ΡNi#áٙ+ff;$H=&0l,Ѐo%9>l'uvGJ0C#MqT+]bwJj7RBѴI|p? \h3b@!.UpQKRr yIOi*'OS5R^Sʎ 34# Jמ SFFiv|@2"-'UzH .OUpX'F8̳ѓF隇PbN@ϰ{lFľfTH+=%~-*1=hvj&K(ԘM ZqD27ym yR}jh~R=jW=mkD_v|/LR$ƼF.6' SuI!d䪴9hd\' d|'7sxLڄjftǷ |IY")/(O%dmZ Th\}b8PHh($Gs.8Tj'oK6Tpi Y<}e=:n- 0Rta+ %0S;hd4 ?ɃC!07"# Y0RsM(ex;4xWM*s}"j 9/x(E1RtE\GA6,{R*ҸLD\I&Qhˬiic:?R o#wϡq6jh,dƹLԪڜJuu ; n 3 U꧔|n+?m;  %MrGTg%IVv7MmQT|eY1J{,V\Mg6e3VA ni3OyθxRuK8W0"y<lLiJށfQ3q>0%`I[ʶv6C$Oӝ(:]Ar< f>%%3OɁ4r_.e5'}o<:*>[h"H?.kf.ɀ7ftBJXZ]nTY]SY+U@q'<') Tac].l1a]"bʕ'R`G@, f|\h)܇{B'}+#o"f-~6vg歝Vya`O05rVq<'(x/#)]9@Z v}89dtL~B/Y\~}ZjJG){tI3ƪ0ZyM?w'Wl#4M)Y~qjW!fj;&48z@ M=J*6l'~a)Tfh:t#['{py-gybg)Mx7we2r |q-]j y2-X+>EM܄4r3A,x HX rB~AnC}K AKK9*Bcg(jFQNaJ.I攩: 0; rcv'NL6E1jМԥ8+KdA# 2AD[#v: 9~5?*;KlE)$ yȣ;怃 %He@[lARAXh.\5yܪq<$/N5w#ce-̭vR|ev W=9 K,K հ}vsO4rS3Z"TOk̀4ȨecA)62z|٘Hፕ1fc)ʣ _M H` 8^1GDC;wmrW$չ+zjށ7a%UYym^X//Or05&H:e8'FϺ] Z]-x7K\{eEWչ`c~f^JQ2گ +G"uCBI#.҅FR}m|CHG:cĦ#>P/w~{}< 1Gng_괐&9tK9EM JcGdg$$~A%)aB`VCUm @сhc _(N7Sֻ.}Apʹ\'`3FWxl,eE'^"1HG| _qp;tX >U3ԫݮGy1]TKF+v[ڮd"yK2K2$ v+vr1BPܴE Oѿk,iѦ}(f9ԊW ѝME6Xŷ|]ͧ7賶g49R n$[g21&vAW贉)O]4׊j&k| D01Egr&h&G V0J^rryKT[no݁m[^ u [nHs!+U2gs wer{-׶ڷEVӶ D̛Ƀwb9&:EDi]+YwlR) 4Ƀ`R#jRm';,1tk2K(+yo P+%v64=c8dS1 `a\)^l!5u; 46:&z\*tkDsNMP#~]殡nxB7kB^XpH\; lqyR'J W?w% 8=ԺsG' aşPҴWc-:|)VIm^ɭ RrO֊hk,vr>,+, 8S=M qu/AwU4=q`'G̲%0W];N:veCDQ|=StVZVkdih8(>?\ sobmtة%X\5t]PWkڹTlFbcuB4_0_OQAxj&[yzdֺ  ;{;Vw(lWV)vYAv>oeûM`JGPCVG VYZ\9ZjnHp T3v8km޺i՜Ә^,Ȼw,Sg!Vl3#$_1vF^!`5 pg`jocLVעh-bאϿF,V.~f[N> !ivF<3x߲/K9I@DQ`dC'_UrJ\>FCFFI-҃y#)f 5h^Y8K;\B@+ #uk2Mbk|2vuҵ 6D$@0$d?1Y V+x P-='j3̘m,W`7:ƕ))uQV!oX?b L j'$L =EhФzW e` ΁Qk6'WSDC f\]SJω/#N()8~*NV[zys"kp**7,KJk;BpqTذw4J gɂwӔs)Xăl: K',Z_GW^W#%p_doFxJgFE}Ĥ\eB L­e9_z&(!g=aNf""v- ]σ9M]6$`|Da`Ҕ1h-r/f1uՊ댇IG VS㟔ΛށfRPK7etX@Axy6sc2  _)[#]vzt Y[}m;wK&.ELgޛ7, amJOzet5߻oVANg|ǃ/OOh2Ʌ+܎>m'. )!- \`uc|${̑Me.;_6bX/_EпT%3\I.B`O :?vƐN9g#zFebo(}i䯾cIؔ.)D(pRA73=RǕ8!)Ps;|F];Qk{Á:JOe,ϴbRliт;qk~tWiN&PK 5J=Yp ès}xurv((--&!̸;NP#)'69tQ0юey8z9))qP+~3>ѩWŵ"(m&l?m0X;DkruH`蚳s/ *nΚP' IjGǗ~!϶e!lmFO~fcu%va`>DH`~$ȩlr\&3+cʘS/ >`D tңRg?{T =NCbC}eS [Vfn;#?Y뒃xSatU,bhDon]:̋K+v@Z` $ESR&:~18`t1ԋR5X#LӐfMEpbĭa$LJd<^WH32a4/z55/FZ/j*{,].l; FJX_E@AN4њBҨ`mDM6!5pAnżĔ~ŠąMl"k#UX٭S1x?#bK]1f8`ӓrcXFqܻl;pL=@ldѕ5xXyS@ӨoQ} :j/ |K״=4\y"kt3&+Ǡ:1?*"n Uz &.Xr)6[wG|~fO!=ʻc'+8ÜW_̫nq&-r6*x!>P  b(&UITɈ CN29B5}FwȪ`az2t$܃ERB' |_5T(?#=\xZ(k¡.Ҵ?<6l}Tz].0UՒTc1+پFG~w]ԃTdDEa;*P'cw&UEuz  2 zlfҽ$5ثF'8'I!apwY$h;1UpC a3='L_r)?`r.{Y!Ү*>/?[=Ɠ Ui -`2('o;^5#)`k!|zH-+( J 0zQN&\FЯ͆ڬ o<%%.Yޱ^!((|>}A>ߔHZfE'⻽B_XJi{X;)b= v\4S`ķ-L.TE^_'nMعՁ ݕr0wogO. ]s~gcB62J`I.h!K<ė@i*(IR|sX9\v723+!x?[]dXo#ot {bj1{猚G37kJNoITsz0:s +ES+TpW1'PQ*288>~<"#o~Cq#{`6˦zmZ,iD~8G,}D.whGyDjQ}Mgޥ(lKUk}t9X/</Nl6ίIU}0~4|v7ʃM[ɯ]q|fсU.%p4?{H&E{;CΗS3$rT8034dT@l2ޑE](!} B"lM~&1֦##)͏ϡ?DTL#vR!C):1|wD5̕'^Oz/y]*tlyŠ׆=Rx) &m^iS&bKP8Gɺp* ;=܏ caKRe@||Y"2 86\/K}F¬:TUc?drLy6Фt p[j/a$v'E$S3w9EnjŞya -^f۹&Z4$ŜF :58ћ6gO6حiEK |BMCHքSƄ0im݀ʀD-~Aѭ, ;{J>,ӺePD¼ Yۂ/ TPLXNA9%:_M>+.O?J_ΪxT+FԒrrgU`c.:͋²0K̒N/(f)1nm@Qg|V54`.=#U+BcQn*fC0|Y?ؚTm'W4IE>==V"w+`- u;4z/*+8DHdWȞ֔]kB&~c^4}$tAdnu?-;vȏY}3K<#M++!:#oYBTNt^# Isl[ _&c6 0Vߙdoigi5VXDJN5cRCdnBȒǸ?kn5/A#Xy <1i1_5`- jxZD/dg  kXE6oz_Pga҆ImıGň麺nzo [ʘ0+OI.S:aҗ/=A\EEE]ysF5$5O s[Y7"W+tl&8ٰvЫnѓ&9T '?3^|ݷK[<&bUjob2 Z֮ʞf'ҏR7:}ySQ.tɔnhvi6pO8 >z#E%Cgo(  @Xܭi,ƫ3[%[`I6i;Cph,ss+_>>?BYT-fulYvQѻ/Vݥ1E^?{rq|X1d}%}~SC"Ww//,{<]{klfB~/# >@^xe}R^7a^GbtlRB,k.\80kf(T#fD6Enoy N+sNKzX@ݠXOshw䃕`Awor(`Gtev4̚E3&3{0V˫BޠmK(,lb[Âś#.W !*/E,cCM=J:KГM˙m΅X$zhkYwy" ũnC[|EȜ.:2 z{9[{\';ښ" H^6p56D}($}әh^@ƉOYqtVe mN(?-^9)YA{0*BCfIY Kti G\gw)gGF>V [߯j${D 0anYm҈71wkNW3ٓI*1Z[ _ ^x2Oi~!؆?[6u!zHwx|1?$ML)^h o´x,ݜL޸}ZAb?hqWNJwGe&I>vfZhgA 󰬨֐;]E8Q pĽ@E`5it}Oi%W˴Xz\Msy (7zV@f>i K=6e4J/5#)ĚbO-b' %ʽ;Su*3tcj<%sk]P~ K"P0V߂4ݎը|اdp\pWOxDҗ 6|!$Xz*.7Z .3c'mc^IY(0Q Pu`-gE~]\3DdN7O nZb2o|'+{~-ec'H֙&و sm;> gl4#Q} ۛV(ӏ^OcHѯEW3dHjNf)Yt|@4ʶ+qqtgI]//ŋ#, $ۉsiޘkM4dj67lI$nSi>uKyrg|vl͒-|sFK4?d"{d26]Kܼ:m^6;YN++-BO\d'BH4t?N<k/hv*ܞg"ia%! K/׮ Q}qS 'é$/B%M! ƀlP.͟OQ (f!wUSCyRH%TGqF关,˽u'%?EU~0 ofwp>[%aw^ VqMdI_k-˲;WKԮ9 ,J } 1ׂrӀ)0㸝!f O>/Iu6e?$zx_,Yf\euC*asCtF)S%{RB-U?:ngzӇ}늋z-ROk $n00"yC vW>2{"k(5e^L_SEydBON|-)@7Fk~YE,yU0PB9mn6ԑoE1MJԯRKhf>@cJJH UQ)Y6 ؎ċy+DL-' $W`WUnR5]LhuFT^WJ.1&oqgcKQw0u{itEta8/>S>3|]Pwno2*<16HwIL8 Y.'>e*J2('Ŕ)//Q@"=F~GBv0kGp3}oHyaaP- -ϼ{nRX ~:Q(mD)oE6c0gdo$lt-v"Hiav*G(&8s;X`僶kR׉S5w5\;lH2TQsԨjr p!"% JeK,o y+d"QeG^ܵ>-j`>,ԋՕCEvMqx3+Cwnl{NT &S gZ[@2۸=PE˺0fn >:'Zg ǖ[Foϟ[R3a{3Џţ]8w~M&<~&l>_Ǵ^1AcEt@b#ox2X4+P Z5nM3b-3t!]YO(s5Sz%2%XގN 1NQN#puQqU8JsRZ- [wF'2T򲠼y R 8Ffʒ[OIzOG|>>zց9}Q-EZ ÜBkM Flޱqѐ S00#F{05+.-)QCq,5Z!{vd۸:ׇ |<Ѽ 2 rk Ҽ׬o& 0v];!GY>D -3I^y 7 b,„/ϋ]㞊9ky7 Z=Qh"_e$Xd.c]\lqcL.+u>?t0o_G'oۨ)M?BJ^Q5sa"w9[sv [-{rSA- S fhl]iGD=k^s%3|)l}7<[ N(rO cccIK^iҚ4 t~0eM; L=ض:Tm@^\ysR[-ۅJOm%+`Ky d˓b8ekP5W 9UCCm-}fnZ>=d]%JsWTƇtVפmЅJ/.b?Ww3[n4`q9DGoaxVfJl{iI*YݏEm-^lzÔ{v؛Ì*W} QX)g(*24R? ֈqCBQH Wq3-#tt㨘2om΀ w{;\B÷RT'7帍:ť+2TvYBh6ÇnwxԒ<0INt%Ɔضoe&Vȋ$ʍz4Yuf"C!ZvĉZH$P?<`g}mhlV5S8{Mb.a \^ H-x?h¸4a0HO&Q>W-Uvtȳ(-I 7_B7i\+u4=ڒCf8*'M ^'L?>5AQ/yӚz/d]a|rpaO|e)HsMh\mf31Mօ\-dݮÏ2EF HC[ SjxQ-KV_KNc̪!] +N3+#ON|W&%V5=S SoL!mk%ЯFu} ad8%ֶ?˾"6 4J;Њ+uyr.\M^3,mÈRu5wQ"5=d_V߯1o۱5N#Нܐu5FN8Um<6f>-Z^BOfI5S$VCEar6d`-to匁2Ip`Ek7k*`Pa_ʉM}EYKbVA|%RH +Һ(pZ'5%o2ZY"2xH;cbGbI [d3u%u=,J!/ rz4rO/W`u1VFe@!vU# ayĒ 3.bE[,T >KY/ \jh&:l+;9cr^qd C% SklXmߞZv=4>{7=Bvvon~.!HObʒN endstream endobj 492 0 obj << /Length1 2792 /Length2 20157 /Length3 0 /Length 21752 /Filter /FlateDecode >> stream xڌPX NݝNpgpww n n 5݃w&սEtsJRe5FQ3+#+ @\A]†@Inj  qg+H&a 2TpȺX\||,,6:8$ݭ LY{ +(>hLi DVcWK(-@ 4|Lv.LB +WK*4*hl4&J 5sWcg $2ڻ\̀Pv<@h `eb7?޿Yllj`hleeo0\=]f m]@V& DUƠ ՅW̿€,io&`gwuAOh ?kca?dneof 37Gf {+'7?6 o:̿{9RjqtpYA|\݁Wg7ϟ"VV+hae;:H 4?V˯?&_G,.'DO*<>F6vv';7 (VS7YPG g=h[ p~\(cIGolgehn\A;k {qfVnvW+j Q{ i"e 4Sr5k6k3[+{կt2.K3Jڛ:Z26N. h89>m4z5f&{W TבrqEF\f߈4SY70KYR+o`2Y7q@\#E7qQ(F .*oF .(oʧ/13,A_9+? W+[3r_bZn c2 T)hߋ3byPͦ"NPnS[˘w'~M3*5s5vwѠe')/V7 hm! Y濣,̭KgZ$ ůG Łhh $[ACaw\ZzPwt{3N e ~75l%л4(^BA9AΟOTh~'n2_ /s_BW g;,' Ǎ q=u*~z]-L %8b^Pο:8WA=X@PP? (t&޿9"yfkt(Ġ7/V@'ae?Ժ>g(ޤf-ϊs ښ FVw$inE<5F't<>&u ,O M6 2>; lsrAQcg`=.9ħYXy|<2WF"8: OsS$~E>:lq kl.:xD3T>beq|Jc6rXh6I|zHte0pYlWxߎSu40i}FS3rwZRߘ._8ux=<lSe8M0ZHMt+!Pңs G~~3:P83,4C'8l9:Ɏ0hmI$RŊf#S?TxX1 C 9Q;6I+qp9f#*yKnU%UTj\Y9W"mq+i:s}:^51u_4$t20x ;”7z>.Z3>O}&iZߏ589?22Gi׺]5.t伇Yh"%Rq{ͯ\m;5DUj}Vn.*j nOvRo־We7|]HaO /Q]UxTRFb[K תOo=u+VAY[LgV~,Q+\:}~MCnjlN]ّя_ b-oңZM^V (̆(aHaȂ.h|5fĘW`J4D7K/✸ 'h.<<yMFSgv|:-uTwƚ*9<۲IyS .+z)UᏌpBa Hc X-<z9r[{D*j{ϰѾoaL ֦n.;挔2 fZY4:L`E}9~h+Z7l_zw|YXjnqJ(`uIDLCSP?Q񢶯̤x!n`# [(umO<4 K=)΅AC(5l("\zŒ 8Zԁop,>Ci^=z(Vk8NUUlg(bZ̚xn"w ϦUIBi:X {t$APmZ#TK6BHgcq'(-1rFBmG&S 9O=҃ےOđ{y+OQ 79%f۶&c&kN 0kyt^A:M|[THx<7c`u8ލ:r9քz^(vJi"#a:RNӘ>/UFǯ= ZOˢ Cl82OW<|qKk;RPuGFR!۲J/C_>H2fѧN:UW!xcTUOh &@2Z:%.Dӱ@9*bрd"FUrmetfnsZ~y\F$!?zfTθ}:幋o9x m9;uO0nxnW 2%Yպdr4k" [$&oc#kgan{[AI80lLW0O=Q;j)ƩQf 0VEI֘bҕwHein0_Q9ѣޢll !FUyn8(Vzuo=?'Mb ~HB s%WYXF CQ+er_doReOBwz|pCD2\4C+VJ-rNY$* 8.:iV쌗6B3 $b\٨f(yb:9a 0.E*I{@ ~)|qҥ%-861yȏɤ,Mh- ѐZ,]\-~A{V\u@AdʡCڕQdX)͎ SrOM:-#Nt G>.FHe*xˇ2 )d™A?vLr&x|WY_.`?cQI5 J*̷q Ǖ&0e(wF.p,0aI qi:p~V b=oh:f ʹE#?k:\2ڱ ޞ6ymatyt}ğR26&9fpL4|}+b!R) zop* =$M;gns9T7WJ'?O->(O;mS`yE:;#6WRP~݆PE` P^fx]$ܲ3?Czղvsxෝ4͙(-#YF!%ۿ{]`+Hc_|Z$6_MiiyIn3NƉW5U9|.td 0i^GKּ2ziC kzQ&} 5J<#OUդo$é^Xq;Y:Cҹd&"TR<'3,XoK Ph_tz,Ĕb_ꅡYRR_^/S됿K+ a8wr,%/ߛupb5@gq$U[L ^]*i%dOEf|㗬?ϒRKh\#j,;B-=@'O ߕ^qG_ zHĴ-Ҡ`MFGVLAcg[w̿\hһъ.lcTXQL2VgFGr`xoi=Qf8XGȲ^dcYp#@f% "ԧmL'tZѸz|Q/3DΟ;ʸSy휡}?s;c\䋸u~iXxk?_|c(>۷&1L5Kؼ8kƆz[خaS6zЗ?'Tw"h28K0^EWt|07+}]@S>,h ab%E,cfv_Do-mjңi[%9GXY%&=JŸ/sU="6ھHVqh/TpBhAPE߸z=vڌöbwQ`PtL4%?yH8b{7 MS$5uȌF aG25ӘXJ}c#Nq븂,QaZӤU[rNe%s pɜTއEzԝ7 e,fOYW@GazYH9c0#=J #L Zm4uӗVaJiڛ+Mj(CWg Z(p8 8a6̚CnZn:dE˫L۱чlL]62Td6r)A=>bc,}pa/7vYкEleS^Q遑X&eɼ&)y/2MzRS}L2eg4BZ <,ؓb}U/*Pd ~ӷZT5i2<'.xI,)V@UsA% l+^l\?g`tW79eIa(L8MQвc1v'@T5e&r[Ժ8؜ A1]\<_ mԝL gATWg>8ioAa#[vq^ǷwL LK)\T$35,~3y٭t?[m^x@8<]; Deڜ>Fu4]qv^`m26DP,EHG|d(3J)X-((p8=xrfO-s`!ƾL:VxpѨ ]j|gDpo0vH:?ZpnK<+ՓS{##1`[}8toR41wl+'bXAi|lv6M\H%zRo%H:wȠ8~Zo?uRYy2% vEo埱3-Xssᓝ])avAMLMJaG-92#ϝL[`#%(|:q")&LZ0#]f$R9iu1T{'3|}}šAK_Ag^Bq5W' .ٓтEg ?Juڼ̌; FRα]Л%T[r̒u*Qҟ1~9AV˴I탢"nP95[CY">zSҶjތ%ꅹw_a>߄*F4"H'a2~p3eu`cG:U5_.PFl1L&@8C0&Yq\{8f=8JRۻdRtd:vHdLN ˼egq Xݫ485߿_5a+0;]Sо5^l׭Ah4pФLu6W(bֺX?_  WBJ, ERE7+H mPa: jS#}oQCtLD밍zڻ MbYiձ;}cO xm$d3Q/$/ yAXm$q6c Ju?(%q巏@PCck"Ҳij& lT\xcs=W5uU|yd[4ګ/ Gn٧r(VUoV#ZZ>L-RO|rLRl._+ȅ-:UF0 6k=vv;o`4ᅺScfʬT,xLy6CͲ̘SCvCSsX,cC:oZ^ dR9GoffA0(V-uEfpժ3"W*΀'g5IC=1F?|42-NYb?}bb`\ gCdsWe%i Pz~'P BǼΆZ?Ï> st r| )Y7(BwkE\1#;8܄rm!dbxQeX6bX2T7?l;0#5)?ۜ.7l_ޕT^dID@<5X&fmɼ+S2#LyX3{9'U:O"3A;a0nGR/Ԏ!|ZPbg<E=vM.+Udf0P2&S"#SBZ8ƜT(_t{S0ɨ^7ճY|= J4a4 CU!5}<w0QvQꪾW֐6)1E&okg͉S8Q6X8`܃F! x0]vFlHb|$DMt đ Wt]߫ 2&m{(lݩW~߯&Bn3*&Kj̊ٛ{NcIcd痃`;mS.QF9Q^5a7,R}-~_h 1PVC9ׄkp 8Ӵgc;Slu 6ߤl:&kY<18Uyj5Z± 3$jN _.u.sT{?!=?sĐpu>cYZM[䥚zO-^^ܱ^Z&y^Vҁ%/S~$f1Ɵ@xgGH'C=٪i6OiHhf'-ݖvM21dFv^m})EQ UkI$-1-VYvEJ4vSԪn .|GVw˺R?G%(wZs?Yn(]`n1 ,k$*Y(b ݙ3&9aW|}5[n?J!&kZOK#ʒEر-;lEoh71"Mo@%C JDqWe嫄-p)Ui/GD71ףub{*8gAi$l;^%Dl,uӌbWi^lr>4 z-TWSdL3nǏ;ǒ\Y9rHⲩEL!}AFxIjaj.他>Ϋޒ-D)Bq1P;7Cn;[H%L/7`YT$ T]0^Aa K\Хͧ81f<"\ψ_\hlz:Z\t.~Nhh>^!_Z>8]ڮRc%ƒ~=IIk2 )S¬Cxz`GL3M WVJa|1ROaeCP<,;TNi; sWg8(S0>[߾ySyR= ?1!l6#tfvGruDZ JT5%3t }ƥk:޶QXAD\t0`7=2fv}fBAgWR=ל>B.FcL 8-Ogul\-{~Rp%:)Q i>=A bVӃtVhK$l f-GJ!iZQ?ofKKuyꋀSa[{`jM/XMn8$udp*nüctH7R-с-Ijhl Eܥf #F׹N5e6 JN4A'Xf&qaJ-vKOhuDT,f^G,K\87E$eLȝ"&z@n9['<67eVQtr.mI=I) .g⎜(wpX 8$=1C]&zJ`O>bgE3'ZTq"U걖? ޏݡ**{8戅C/;qLvdGD[-7fEja _5 {7eS!);WZfvV'`hN Kk‘ۆw9^GX?5Ǽ.]6QT1e eÿ@|;<'-Vtm^ɅI8j(,)/D;չR>kUݓr#o furQot:;貛 =M~L%"`8ww{+g}Ec:N)wy zς[>b:1R<S.,[\zp. ş=Ê U*{Y'0Q.*ۜ#K2^8m|YZf"_J~A)p!I2ɔ<ڠY#L~&~ׁ8M2uTI+Qet-㿳̞vI!<={| hd)+/iG5Tb&vA&,icBNwn} yEPFnJ%Ч TCDғχ-V1~{YBx$陉[~?aN޸Q⽴ WdO!\ٷqoWrA0#RZ6 k r/u%:({_}3]|fIͣ= ul$+Q٬P{*q]R&8,M"m9^-U67%6\+GMw&PtNz\7<`[¦R ) -t-|Df_|́G8KV8'FOg-؆b7i=HCc߼ #<#|52|XsSf I%Τh7L#ᡋhآeRN-EL5HWUY^f g3WB<ڡM(q-(̴1^ms;²aachtGNza!QK)o 'ti] 7.MuWTxp{69LkT@#^狷bZО/ĩVW|A}RWP~ߕ$wHWHLݬbټ> "\8Ph^Ɇ'GV,+lCUe@י졠q9xVJ{ZjrAӌrۑ*W7 ;a'c9S,zq R_YpsQenGӗ5vJ7cT]G%3';+kl%.!E>=Ӈ;n5R9\L6òW|0<(:aggc@D[{pm TL y8&R?[*oJs~oATU4x?Ҧ:!z#v8RuDdh,N12L=(/G[ Ծ>I^Rq]3r`H5aǢ@:=EuNR&j?yx7b,jPHYv立rOUQ|cx8 sJ#srxW˚a4z^\*nJz఻*B?b`o={mmLڇE1c&badPeW*Z$1tY(CDtK;sGBkч z~N엋\<VJySƙT+p+c4cȱ?wy]-uVtse=(մ& x}sd df ٵnrd}x%1;DĶxAI*MS4CyUPWfv;*̔#=CF*! ^_/J{ۅWfrF(knf1KQqZ E7(ƔὕްGD&:5m{>GSA@:qΡXn4n6,u$ā w]=3kN:?,&mg:Lf U[6. VTa@Vl "yX)7%&2TEޞ֙l{!2-kE||<%A՚W6푅Jj yq!cDZ^{Oq r-`."sDӛHD{YgBAF^d,:pK3 !h Rh֍1;](QO&:t?*7?s̼,ZCO:& }HŧlAFFZLJ{N$rCx{,v#V&tCc7X.UϮIZo_ 1.c!-ExwȜH;ϵztcC׈;8d"ށͲؐZNDlWgdŋH_uNS ͹̽h֐iX%A0NpG%Tr!9ΥqwBF7:s~f"kBm'q0uv9 <f 4GJ00~s\]*#&p+YEbgݏe"LIT͋F}icTT K^qlxn끔W>of?O3?.j:mKޕn+HQ kZNo)vrNLq1f j=y$Vڅ(pK`\k$P[UaT+$Kۗucw-)Zg^p\b(2GN (|Ʃ6$dpBP?4Lhj*"k*[QhV7ĩclwaN*>lG[_4ZOHsR֬sRėԍII,tR^eEvC8> <4&A3tig2qϐ寳^d,HlfUHٞf8u/Wy?+,+ew)*y6~<$ר9ú؀lq:9ÁiPgj "- R|`az^n>\`k Akth K@v~YWhFvb(O.ʼnpJfè+==̓6,ca&K>;fā;}zDEWW[Ҩ^l_(z6NMy/^y(Uڍ$lQ"Rlj Kw"Ik ZX=K$wAI]@܎\?׷)W0jicDJ1't=N:Spfi~ @7:Xgh/Dػ/o=C}b9z出 RǫgDE'rDR6Ѳ*=+ dΚ.NE)s+/ĕ> lZ )5'h#4I]iOǡ$fSz|tI Ћ)_tY.5\*U)NlctzdWZF;W?t\Nz PhfX=uC? ~]6I=K(6AhYsz-&גy3UU7 AlVT qyQ8"` Fk)Ifpnw64sd,m6sef=$&c[<?\\N*6O}aU2]'ėSPX1s& >ٱ4@M%Z>]7-]PE"l b3InN{Ւ\ !o-бlNXi. %9̓Dy2 ݇5Q~Wն Pa21|ƙXu_0爂 iC)jY=eg;D0+Zj*3G璤]QE%I˥l1mqVi%"x}sȷS"Y7N e8:q1zOCJ 2V2 z@hfff܋JׂiMi8W_w"SD(/1M M<0O.r|N]rξg҃@21^ S#y#޺`n(^tI~=RՋY5FRudvvΪTd*@K}a]gS3\QݪY}Oi(d l(̫3ޝ$ Q`/a˚vۚнFMwV:Zia)wt` $:AL\U9lx<hkd{@ΐc19rA9$v8;& g$vpR ']l7@clTxPXn)]6??ELIj YckÏqfqbWe\ gDZYA rPb>{4*_/GW'0dyJZcM͆j@:@KC`9JHk(9_-xkRV{^$nVU-g^ye q<)0WoR&ј1"p~mvvs nr퐉7u|<:itEuHWJ}R >93"ji(&0\.BY ʮ0Ɋu o D"\[8^S^Ѭ袘;>T ߪ+D=d)Ĩ1ԲI>q{r/uvӏOU԰0Rk)D xH6ڥΕYR;8 [^U⬁)PRL?.7օ(w+ .no1a WzVwmw ^J\QƒDl Έƈ $4A2A*#}[2-xOpD2V8*k1C(۸@n f0YX` =B$xK^ Dqu`;Xd2eƞgR3EC+Г*c<(t'!xyc?[QLjcl(Qkvў}%^jG<7ܥ&O8JեŽaH"W}7g}¬J*Zejh/7!nT8AsJu&I5Nt?m`7 'Y` %Oӝ*/>¨ίaM,GK:hm-sM{tP_% jiA$Ʉ]߷3OZ+3z!O  :N6 P`DH&K/qc9Ey/#E,.y}4Ú G ]󷃤KfI)[܆8`cv").G+# hK 7x""NP~I~ KL$4-CB$+-M?h{@ľlN09W<%^XvH{s2]nl# ҇7EZ\t| mE n*j?-2L ɀ}MÔkUۮDŷ,m1"7ʄEW Zf'2BԽL-lWRm ꖃ3g%I C;GG'4YY= ǿFG# %"+J~|H)ZH(i' T{޷oK^*es׼.NY_޽pP=.vti&O& 7z+ɠ\)*I_m-Y S(=(taSlKaNO )f߶l tqZF-d&p?4flkęCK51fb l<' 9R CI34…(.QݏB)Mֽd-,K2 Ds8G&Z VuZp'SsWJ?Cqd#f/a.u'ɻ=Fo]\fKxa iV/].9fA V0Lp]ꓝ> UF*݁/ v ԎV.:-fD\F/!{(="P<#>xWU}iM]C QY# ;0|\깔 7dVǂҏ)"n"bh9^uHu(FKP҃ufhZ@" eh]{d(a6K,*c𧅇%r^89y2axaUQ&EjЛ`V8Y*w" y$TY G ?mW/Y+fcyV_CDKL®kvw⨎GNi7q/YҒA-U4zѸYH>l9Ig,aҶ)p6ky60Pr7Ԧ endstream endobj 494 0 obj << /Length1 1868 /Length2 10638 /Length3 0 /Length 11802 /Filter /FlateDecode >> stream xڍP-CÄ= 2CIp' #{{zjfޫwսvSRVc5 #+ @:/ Jb'B tr ;M 1 3-sXXXXl,,!&怷L90B%vpeI88O h|߬-XX-~0wq`Y;e%3x9d2KJ[911; `p|?M^) xӯ?Oh"ٳ@op=?%UfmH4_O³e]  ~R[fe!&c ݁3wX׈Y`g_o rsefn8?yl{GI|qrLL ʯ 0+ x̪;Y70kx&7088fld0\˳~۲>e|nܙ?K=f>w> >[3- Dsuxv7NptC4u>q]Y?37d{V|n/_2sqzk P>/mokDw'gvRi>;uc &Vg;]& `lK\|!R֚h:ۆ4r`~RdFu='Go[N9\G |[>iec *{\e31%sTyYFR$:3w̹Yɟr(>G1E^lwl]W8c^br^낋,LPK31skWlҋŦPvA?̡aR7MgSpʵf' uWޯW6hQβt<> |em^/FؠBCKAyd"Xi;l ,7J3|A9Ub ]' mξ({&>LCQ$i^V%9SEF,ש{ҩ]`bŲuo):k1P5 W@h ]Ek"t;SB",rS;mP?݅2sCq7p-lŎD(Z4}Viw_@WsFzinT vYKG ʥ >iXeZ|,7m!S0S^fNgG.cWkFOV_|/ *g+LhR<,<_~*q]ui_ݣՐιw}b&iC|y`"Kz5Yv8 4&8&:K ! eDl oV{%Roćnd3*楴ej9qg ״#5K~Vwe j9o-u-sK_st4(0Jj;}HΏ$WU1^!.CxG,z#;i\Ȭ1z0We|L' XGj_VW>̶};-+m@AXvY&d7BɻӅpkZ{(hSv \N.B]0ubu ~ܐjܘ _2y`=̘[pGQ~PۡԧOGw_>`^崆 Էў)UYk"?+tX[X6ЦH:{p"J$ VI  !dlCw8~duXq~&;+9. HϘ)Vޛ q<κņvb|G{}Gx+qоZ1v#e#2Q4ئx-o6=txIM FɁ/h!T5N68S4xavq[ܓ-y%T]VFeGb zNEsuiq[ үe'>`j22GZKa$@(N$񨞼&ZDdacX1,R+DU 2G;,P0&[+;,O`eMLu܋6*^?I7(7.rM?n. 0 ,y7=Uo5:mbJ9gn'I//,Z^x/N wO[6)@䣫}C=t)bKBS*4[n$ `vM8+YspO|;cnq .ƈC^Eb8&B <JzP;=:ctF±Ht:\yŠ2AU4$Qr.IC:k zf{JǍwʺ OMdIt6[˵ 8Wn:e=?0@sͬ03qznhxksδBT3ˆ)$xR^/ ޥAT:L m)zy^噀SY׹PKaiTcBcOAg_p|Ր _u3]!'BvCo.H zkUnupC280cۡj0w5tZO?,3wC<y40ev³ԹK}Zʺb Q udXJ?g*XCXoquJ _,>} CQeԡ`1-Uޗ,H {Ԁ*I}37Sfw dGI0biL<Zr$j6Bb'WEEe\|ѡGi"1T&DeʁY2%Ҷ1L5gj?SMUX]st6i5&2G濜rPO WZ}6:jM\;돸v6ӻb'O=5YvXQs\I_j u}1 ɀHS =-&Z5Fܳ}$ x ]R{_zMO&"!Y6UC!ԂqAFcK-~V5/ləQLttnt#nza b9zu9p|)ntdl'ZgrWz`PfbLUGODq͜] [OvyGʱ^ v;0*"8'ˬrni$bVކfĴbާJas0Ƒ叮a(ڹVͥO)BN/k;xĬjGf{KThcxW= yo"'ŕV59Ij0ܛ.IFq^I_(^[b +D@m4VyΫQ 7&%Ю !O y[ z Vѻ|cd޶DLҚ?ägԭ`VaWj:aAGJl;\Dh>RKxCvqKJY빝&{7L,ĚHXsviJ a[ Ѡm]X {g^aҾt={h"Lz+!JeIi~2AhLci9-W<;Ť߷uEّDRQsH݁kmu zGwiFL77e@| M.$DYP~IMOjY֙w)i ٨cTSp:q)U jm)d VV;g_U?W݋ oF8/ޝ/Ty#|U025uRN`#(VjM!hb 4:—*.v#srMX\0kN Rږ֩]Gddˋi?*l7XkWCk2L%PQ@Na"uW6W(c':" x^~cQt:/G nN h"#I=Y/pcӪ} ^3/oB̉v:2&O o_3KTD"K* {DZ I =7\3N&#nY&oݙH~VQ`^Ά=a}_L1huNbTBm >6Ѻs=gz[b64o"p5PGIlSn"I'\면8 (JpZU+&čw$ !4k3*/{׉ťB%Gl@7Z*v>=$6O_-\:9α%Pnջڑҁó]WkJ7bn*ńu`|X۟"nКG䥼wMʡ$uFYxU'0#3/qa"}[]<3 2kzP|~ {vf6I:de#H2|:Sr3Wi{.RO~ƶ}+᡻ˡ9jEIH~Z5tpiCK.2%=DcdIʻM28}#~jjJGՅ*kϘtw2qY FUL j#~gz m:^B]\pn̨#u,=7=5(Yx.ΑΫUE) mfy{TΆ5`UO#7J$|9іq*\/˥5{~؊1j3k/ώ_ʏ0@^zJU0Z~q焩V@OkSSOs_[ &2 1'aCiI61.Z/-z=')\w'ת@9R6+ '$̋QJE_Se=@qr*[@?%*ȅևt.<9PA@ Oo{'w"_42},J$Eʷ9R}QekMpU>r˔b7Õuk- ;,Eixvdb \Ycd=!urQ QIzjQ`WyQa|eg^ 3[*0N fD۶PR@TC ‡%5F$3sY-A`2X3fѩijyҡ1NR:Jg.|UzrCbA7b׬">:'':6TW| XZsw 17ɰ[Mӱ*,.ٗʆtOnҫ+G4j@1Q(:jX;a%b}˽JziuPAt$/B1퉖KwTBT9Oz(M ~xamho ?LA咣ã4,GX?)2Ⱞ#+nmL604 %)F Aj,bVߝ7#Xt닐 ?X1ɦǴ)6Fl,^Y]2}Z˴n]Q7s?j-FDW̖;IVsD!Xȵ;"Y%XfVdte ׏WZ/&fevW':%uwu *4 x;*NڇV#QY>W߭N5lKzq\} a@>C=V~7TE,NGkJOK6o`4Bb%xH9C/KR|hxQnjujۣ lP ݳM(\#4.>z aqaKxQE}ޘ"&dOkz0`\žh{HҡԐsoT(dn|*hğX?LU6ٟpONН>0ow]Xi1WL(WRh=Ju짌WW,E=`dqrŔѫsx&m+wenU[qn/~3~ (X/G74wp !83IWάmxOgB;r*-\Yƨw^cU͐FTB_Û[˧Tދg l;j"̯kV |CZ˥ %k3,k~z:u(k_Yy\/ X EP˘ymu@id\jFh0KbV%O9WZ7Fm_eOgw# Vc6N!=mvAG*(#T* ||Ç | 6=ٍ  Rlz?]G8A.y4|B&\ ߎ_i3q6J@eY*B]Ddf̽2A}UsD1gsl(pzd@.XG]u^]k)كzE,{#6ܝUGϏnEpGa'Xo! ,9@Ux|sS뢞{x$ dz&")߹:2P?Gcs#백tA T 5zH[\ɱZ?l>dfص]~|]>;BiՔpt!_FnK\~a'j9|@9\FǮ/[Vik7sr cX[8*VwInF1BAoT<;.cyk3.S1/]jGF[MSrʤVkE~;7\9\ pt2ILجa>! 1ϙع/sU!_70F9*e##cBꛫf9}0W0:TMcӰtƂ2}Ɖ o$]D"n.@ d'y@1Ac]v{G,nU9:c vҫӼMg,:wDZ5< u. u7NW+agN><(ǁ)Q .,Q:d6Hդ@ioݽ)KV{cqos6+/I|p8{;Fe@e=isr`H>Snèf \ά|񬹨)f@Q]{x1L)H}ˆK&'HzHJ3Ydz+ Or2&kDw3-C U8U[Yw!TsW:sjbY} K$f60-IJiIJrn 71➲{hYnFUn8v 䃆BQxX=B yeP4 V_hKxmpkFN`|Gp54kÍ}f]2TL:McPl~BFm(:mJ(WK+էMIM^æGdR.mIڣeKr)'CM db7Q@??vL$FBbܺXbqkD^3k0>QkER/(G訁w)_#7~Ij5XV+l<*@p4!_,~ӊIF,> stream xmwuTk5R5t 30 2tJ ]t4 HJIy}}׻ַ~>g?g=k8X5'TD@DPX`a/",##PCAAh,  " !!=Q0W4ۉo`A`0 G>9>}G( ]g P3Zih5 P>`8 s"<g$ '8!_x EsF!=*u5!S5iiGeN("U? sBPH/ߴH?0Ax@}pACQ}$B Ŀ, C s@0o X oϽC!0s$?G􍍁f|-euCL  ? >lZ῾#e"Dbqq hBA 3˿ߋAfNrn!E|㣎f|"s#G6^WS|_0I(Jy85nᲘ%jڨ6Ϝ(ݭ*Us,k'_y5?u̴M{G>tFrAZX5TIfuYx*h6h'gg~ʧd(MK~ 2@4KZ*,bfIvjA:7"I쮿eW3}ݔ0`o~ϔiRm.*2ua-ɗ!FYicD'jz>+dDBKx|'V6_x_w'ȽiB&Jw'M* {b#"߼p7)T)M¹hkXw6=Y,* ׷]ٌq or>+'~\"&3P"><_{3z `<,G/oM >+f4h,h3Ʈ V=6dEMo1dnhe>/ȍrf SN`f]ȃ)%IFڪڕEi,n]t!T>sffVx]ͭ](pxu8^\Efa }0iOO nMl: 9]%iL #ǥdOxԓ4Vu|K* eOtn>ʿ1ډ6fWqiڄ︯OBٛn0?tZUc7$GdXP*=kDɠyBe/r-r8wlt9*[ /{#NI53~rݡ0&xͮ >،}*6qDg%ҿG@j3KC 'eԩ 6짹3 '0wτ-}0|KH)'QAɸ nGCK=vrȐ޷?6j `#i9Iݝ“0u ^iV)g=qAp-`j*ǔAoS5ѝۆ>F:!jkTOTwq7OS7KD]a =Hh"xS#%o~+#+R:иa T<.l3_|V{{4.9jV Q^C)}RWG͖ P$a6]mM_42TUjj͆m~KNT]16RR q->hlsFcs~ ~OAɳ<z*}oLsGKa[@h;U1o9Uxqeb~gf/^$@:W=CZ J";K 8 EAgzE.M/1!ݑmН=<2+gեrPɛQh4c|& Ͼ'|aׇeޤ/ZEԌYk>!wn?Zʡ9l e/2@g;?z2$铵ЦO4~C.iJؔrIkRDP4*PWw+TO8!CՓ$S&O,o]ULUh2v͐N9Ռs&вĭMhc&WwڌRlu'~p晻 1g2p˒>(+4v$ pie`"!\3okWɥUT|NS?j K&?Rf ߠIeS[b[}{\w_SG'!Q31~XWΪwqjV cOtg[}i*`Aw9nd!.b :pr3oX!S1Qyez1H1;ۗ3>NN+ᭆld 6Ufi YB3VMZⷀga%ڵwL^O88 xP̷w-7;kKj},cv&ub:qD{qӦ95"  \YH${#)s`AXKn6Kݝ;c804rdYA74MAѡQ]$AJ'ݸ!􄕝M[KXeI͉tE"Tr}~is :u<1x=CmVyn25:A7|%55@x=dǍH>`ϱvBA}csoTur>KmY0s0G\ K-o9evVb*>䢻pKrZAf,LF ݄IՖ4;S)!Q޼񣮍@X=ah>c`"](umX^A"1Y2%L@ z߯wMK'ԎP&+b QLK /pb1Kk^1aaO145gZS瞍Q:Lc7slT6 Ҁ,1k3;KY6PvŷJY,L] D^\}K*̍bWQp [GCYgm9U2sd% FO;P/w wo"6{^Bgʨ$e%XP<֦mx4;5 ɱJռHg?:S0k.O=Œ7&I} +1{]o}yHwwK: wlyzMtg؏jx6[݆)Qƾ5-JzVansf8Gfϥaos/Q=e}ւc1T1˨ ߏ1`hWg@FLuyn %T]|,J9? -fZY0$atӫMG7<MNX2 +t0jАUU@5%)r`%6.tY29=E/wlaE ӤY&(Zuj>Y"l_я 1b}Tϓ)Ks,И nUoDnJTl~H 7z2UaӬm'a^kn~Yz?#4n.E/zMGR^Od,JJZΊ؉C-ا H5wk?\sutVrlm ;gפj 8߅}@9 (]jG2Ucًq|*1YݾfdE5läkFZ{1mDɝWjs3Ud4f5rv_JJi ď/<7ewt$|x >n{Ł#٥ 2?Z_iy\q^(P'6Х{+a8sY|:0Lx@ p}l^4)dh>`6A<3]oVŊ}%+ӟ=y[0 ." 3M-IY)^߫G{|+q"IbYLpp @Z-^: %4d L߉mcדm*}r<KwZ*_{f=uF\e&G'WfE ;R(nkK=$J0}]BuU~ ἅuֵiU;r .COvIM=*GE+ xOW-n"~_{z ?7 :Oԍ>~ZMMف9H~+yo* ƒ0n;)o.B춬u^# 8P˶8':wDO*3~6U'gs)>hN.{4|~Nc0FVhՎh&NB MٻȚl.cg+U1C,44#'`Lk)u*T/MFeIu:i8HQV$ 'ށOI@eBEwK2G?Z}N!V5W{ٟrf(Cm%ɧ Q v o%5akeO(kR![{Ma`s4s~L鲲>YQmyq3F6˒>v?eoJ]kfdU5  `7&b]rBYOm_Kv_Y}~7fŖ'‘Y S69v2~hu"^nRSm]7ٔ|޵ *Օ?ڱyg&mb|u_&> ӣfDt6rW\{t9Iܐt̺u_Uo nbVsnG թ9 C0]_ !<=ۼ a:q1aa7 T{Ү(kF3 2J,B*Kn> 3䑆Z-ZSGFJS endstream endobj 498 0 obj << /Length1 737 /Length2 13137 /Length3 0 /Length 13718 /Filter /FlateDecode >> stream xmysgn6~i۶mL۶m۶mO۶m[ӸssukuLBeچK4De&r<&'&]c3<.{0]0gBYRNJd?m"NH?E8,'fM?J%3iya7[֠J5& %m, kjPBC)d-]?w_-aw1aZ-qG fϝ"qظRSc6uf)A $Ya{pmsa3𕱲(^|m\C~-rݛ&e D.Om@ҼO[>2WGHQp%/=F$P_Yc GIf}xl}Q;=\[!z?ߒUrCwZ뗻St14<~;*S,> \'H:;ND1OL1ЎRvJOon69IP>h!M0@śd #SPb|1)b#0qP?݌JZz{&2ʐ"-rjg#&tQAf!Kh@ȚjbOpgNh;?°y~Z{vJ1nIȡzrKte]'@_Am~0{Ƅ̪++; ೎ْFh g߻g\ue4q0-l2H^QjSڊ@d0Z4@ce$Nh'T #OvqG*hFD%OU)f?u%U,@="l_=UtUP-tU)[땴=.3wB@:t:ufgpBpC.5 Y”D!ݓ Vǃy7iaԥZd~S}rBȼDh@|J)vn$Z˙h![,NvQ~&!dQqWNr1nBf?eDAqB EFj|^mٶvԥy^јA\R"CprgDfg&ZuqYqn 5r&n2rCͫVyL)U:{}|Kô8?^ħ DQ*(61dzo!q_=tXR'|bL -;dQhd0SʪiZO6.F]>sc&wBCciZI<iLu E|I IFy QidCKy25?צ:7|KR 5Mx{~HFɶs༧S9zz^y⣽Ժҽ8ela6ʃZnJl'/ 1'@IKǩ@LL-IWx6!uOp"ǝF䊯A3ʓt%9Y3 N.Ѳ+?;F<%1};XAGZa2' O"s1v~oN9Mѯ+S &.^|AkBn "K'%1d{a3(s͑cqhb,'Xl@2k?Xz %ΰ\c|4ś'/4ZDL40*DFyifoÒƌ9~%<`1)|mˀa֒N~JhѽHY#B -xǔXeT@\3^ {K/ X{b(yK8Iۗ5k@"6U gJVS]fA%(R$cR$!ѐULB#i۝|-6 [xL}y;uzK8Rlt{T_5ethv557K.Rɳ@P6#'QpJxhJ G_LjEZQv ;gsGF'U߸*UTƁPcHy1>zNH(׬oڵzn)u&QG@ T>\`[as{|BJq/bBK'ƥ*`_j/blvY2%}35K[joR% l CmNe2&^PkEQc!#5%(S?# #@$EV;gE`\lYԥCmhR~`K!ĄE b){Y4(k^C\ѡ b&t߱m"i )Zz ^k옐W+㪥iHE7& o~Gg?)D) %ȊgF ɘ zlTц&8Fj1qfVzhoiPgdQ3TI z1H3kȏs*o),PxBbwv_8`@!1mR4g)U6w VfIvnՓOxFeab^zޚv".&}#_Q|0<2*1!z-k#nG睨`b6CAqz9qfiJb5>R`_$clS#%F%u.S~v_GS,=4GA=a8/Yɵ#e9a.OXNpJ|Y9hnV=&2=ejcE?*KE9l7ȟ qJ:#ĦDrmF6%wwDkY5&oZb ]3PYmXztQT oZPn [cE0;pY`0[d ?aXۮ"jtI'TL@I nFP(˹^Y=^CªӶivGE >ur5;M#)ʽ=SZ3[<RhyctoXl X-!-ᥢzіcIB; 8cNnNk>rT +SfX@{6ͭTtC,OhP=$=߷_OI̩A\*=YurHFV`84{lI{)^:`ږ,:ʳ>x=\v bMpPGJtjLK`I='[vU>2W:5Lip^1d/UJN Ab_H\hCm> i^)K!O5 TkFKjr'i?}&}}2-*ztQNq V$<6+{gnA>꼫XY2藜qa* L[bj@b$O_diEZl7lꔎ?|;e _]ggJ*_po񒝯1^esVh:FQzzR8z) *waCm/ʗpBګ)'qt2>y-HJ%uEHX|픫Om%5ܗ| 5sdkMz wĥr`2l҈,jK @.Ïu4Og'Y*jnmvɫӶJp  @ϼիU0Uvof] dlFrEm&_1Yٔ`Wyks\(:TItt|O7}tu@ \p=+w2ݯ xp]pDAxs?x7]tr>"FfF՞\$ 'M4jѕz&G4KZ ҖqY;Eb1W٪{fqKVn7`O?KӢUwjFft _e[f?Doxxv1b.0{oICmpt@D஧Bc U ~8FT-Ϣ DJ{w0g]~JՊjR,O JH Ė]&:6'y=χ,AcHjA_b1hFiFLO6 /p^E1ZLrڐwR&obt„ʮի_)Ha۸hT=5X6٩{h90DH vgrI()^AOXǔSWRUt:vHK^u߻DGiL\6Gy3x'K7N4֝ pf2l* `x0k^J8)E >U#:C+6NXƞoZAGTD{qH LPnjȄw9Ÿ57$|h |%S/c}ΞW[%OǝX6#.-w{FRdHISۆ ~׭Qx&RD+p[Sd3_ˣٽ\(~Z5Uq"\ ԙuM_u?r[$IH뤮Z K1+M|;n!` ~Y\K󹐷}SXq㵞ݷʍtF}ȋāmOsnO7 T[inGq,yk}} %jG2b>.yoA}X nE7ۨP0UN%f%3+O8|N RgM?D "<"F7 lH~`P"is7ʭ:IZ3{>C eȇ{Ch/fs]]QDtX_D)`Z?Rb`j}EYNVdVf[f4Uy㼓\nVDx5zb\F HETY7%B-=63Ǚ[ay<ڿE&b1`U10᥺+J@*CeUᏢPK:"|\)tj'ӑ º ~rҵ5o~ xw2{Z_q aj%υ)uAf+rDNjx7ӫQD9bWB=\4i}PnOf];-^P/?[y5 B,53fq3!d|64D˲-`QOiJ2|WsI'N)mq΁:|#2f>&g6ʦv(ߢ\[h! 2_i5[yy Ne뫽y/b8P #m,+ g!uhw&azz~rej_mODK.V OxL_qāBozCqpOT' E r&kB<$# ƣQ+;#QLV_cx6Aq^ @RR ߱lUWD/uctsnPt#kkzTgX) ryZȠI{OU@,C k]c+UJD>B9edEG$ puTmB;vđ8OGZ/vG¡{KԖ렶GRA-6i-xՈY{oqre3H5zbOT~ ] !Gf=€ИBG*eօٴ+ OGl{ly󎇝2BP/)W 0iEb5-Ŏ:yϝe2O25/54KWp9M&!7 jP~p ow6~T Au6y#17x:SU^P HOO/EO4/i[_2flHB_b $2P{S^(p[3FG8nkz~<Ϋ^pnbru1HE;`60&zO 3#`I83]ͫѻXa1]=OFerF.zb{dNierWzX2$ Tjwgτ3"M w̃KSޠ!=ST[MʐދY+Ӑ կ[ MQs!>ѯ,kÉ .fWh28av-Ԡ.[QO* ;oCW7iF eOy .G15jG1fbڸ5"KW^{{N-) zj! !o}7ƥƽ;$>`7ۅ5/Gy.ʡbtwX(^dAÌp1,:d/2MQk(bXOCtȥs2XLDT.V1sM~(9'`mb u3aU߹$asZF_lqXtTkx0ӱrr&.hkh1ؓ@-+r-#%y_UN| \mZNrr6nA-֧Pa_ɧՄ;gkVY<*zZ~Mk G6 #Nz㲅'2gU~Rf?`W34Ak,$f0v8=kpv *rH?֑(XaV>(254fQuZn=Wu]"*1_]mͱ:dR: G_MЅ/X{ _u-niC"Ѱ}[Ҥ>€iy裆Ke: ZaN:Q*Qy_+OufNrI,[@<v;יNudC #zo#Pq|D6[giޖ]':&c9 2o0B01at3&O3(t*Y~ @z9:R'}83ݩYj\f]3ƁS%r RŻO!F9 FׯF+hՏOHlr"!JSO$>p~(?)ȽbXIy^ DdS[AI;0Y{ yY06פ>Cd􀅴lJluE(m&qO,)ҷ}`bՂ_K[b!4m?cיb}yS2hBEȧlv1eE0+7xI?-V[8^1³:(RjjW9rjdBMAUw!]ylBzQ_IlYtP~.%6/UQ?yw!BlCˁEqQRIDCQ+DBFu*Ontߛf Kٵ#2tC穚m7qJCdse2CZE^L, rtm,k'&&pē"4 }"1Ӫ?u"G >  ʓ.w3rQH.s۽x$M 6M'!UYC湃I`dm.fC ЛSd8#ϥيNd;PD_ s E"Ḅ\P+gxq'V.&B\V^GL{D̈́$H;fJ JZo.vgFubeY5cF7sBp Sx4]2I"If9 Pɻ ppX:K ]?Y/OfE P8eC/G: ԩ;*!zKF5EZLğlErl.ߚ(5 q"% {:҅R@uqN3T[f۵$Ө!ۅ{ľSʃ9DQqs'~WƀH&j}.Ie9JU+<E/Xh]y-b1-:,HeG A7("},Dw$3s(L~ ?ЊkP~Uf)6~MPiH #mL<,sRQS`msTTUAM=Bhb⌰EBN=EQXtH6m*LZ`Hɯ;p& i/`UF,,itiV* y*մMCdxy`"iwze[٠ŵR r$~^di|, ܥ`~k2]f)O48#ֿ*OhgShMAiQP% Kn9d\ V:ZvJT͞G;亅IV {. {J)gP_&sFT1%%xa+bM 7# VBdUWyO3 %hO[Mu\ (dMˊy׏9Aٯ6 Jn7ZvV.,1(>Q~w1-]h!Ok:cQwIvҧ4@&a3YS-&9o]Xgrf;{"YnvAxQw˹ԍȨ=xXG|L.r\<ם?Da^VeɟfA{Q)˻ki<vz<2|V:'++UǢyj3*ئ3]f9qtK>w U.@&G9&'C~Æg)\3DGBj/e9]a1X~PxwPkJ)[Ҕ[h.o"$[l^~VBvgY0kX);Ga zN19Z8JQjTw^ZTڥ`#YͰ5<8H0]1, sg}8 Gq|4rzbc Aף3l-g81t- SIq]^.ΈXϣCGKKhҭG͹5\vo C`vt s-+5^$3 LˑQq:*1klyZf5!LwbgUڀ:$V-tyT"Іf%w)9{LxDAbƣjʷ֐7z=LI/ex7Gf de@YP)*O ( _Z},i3+خDlM`҆(Bݪ;.Acu&ryd_ƊEuPJ{ '&S۩xG(sй.>wm$ߣm吗W? (v>IP5I-Klb%d)r)RhJE7Hʑ}X?<~ ,k8TTgpOk/Vnt=HMs-09|7} s^$n58T$QL.?v_ d2MΪ DІTM9J';"ޯMW#hu/pU߷6QU%R6ǁ^8h]:ѸpiDQ:VNr_XH(V?",0}݆pK$wQ6>:iW`'TuNl+ݻh((b'Ӽ a\E\0O(HXܐ E.Gڢ,>:ˊ) CMԤcrJɅ+XSOycҐ5/D8 d{끧2kvHɤwaaoldݹj7Hv+LӋoshS%d<dbUd5ݷ#\ G#F0zC\z^u,jYe(qQJqѽ@mEM(ߎvR17lԲ;K; pu]gR ڲ,?Ղmc!#9\QnIY rĒ~, zK4'g,p+k d^w4A ljpьw<i[ endstream endobj 423 0 obj << /Type /ObjStm /N 100 /First 941 /Length 4909 /Filter /FlateDecode >> stream x\ksH_$!.@ Iű3=ݒQLm[SۭV>n) Q) $|BKօM,e(K`b(B4 [D﷤0GBE RT2(SHrp;bc'B'3I=z[ hX(ga6Bkp/4N4::z X8 % u[8W8z  Qi 2@P"X -' ,7JԲAhB z"-IVH:6T`<<4ڀ -0 Z'v m"õDxBG\9ZX0hQkZ7 ZZ`0CYE}Y-~\[Fa/Hs<$J'4_\9b8p.+hnv ^XW zXxT;PM(D%>-XQzԕD]A*AIqn2 .*籇6 zZ"=|* tjc0$ֳ`cU[nU'_Eh<̷_'\[Q}>/ANq ~v9~LGq]&|PO'-E,jܻTISEUQ+<_}V}QIk2K_*%No?O.1]=~p1g;di!B%Btz뮱꠾POgUk=W2@+'JjV ZmdjP~|'Wlq;#樨N&ދm|=&u) 8+~Q @uV\n5[:Sz[Uk4Ysd,=^` /ӝ@/_DA`BDk3VQJ%"U/|^I}^(K_JȷQmmRQ'LcܲN0:ϣmWƐ# %d7A ` uV3HzT;,\x"nlaTBFR%JRbB %@,+t$Mx 7fE"+Ѹ u5$vܘ"*g-2Ui_l&D1:!. ;`$jM;gEel".1۠BШl%a-qQah[-֞H ЅŻN9Gw%Á/▮٨ i?V=|#pBM[ZIquC0|*`^vE%0 D@4e6fi%ĚЗmb<;~d]MXqYzzBr!!R_'x4=!/r$Bpœ<vd#(U~>qPdāgRcj-5J.n˫X Bs2=%KޣO;l)xq5ν :8nxT!]qPP&@"Hqb2ADMt#:U8QU/%:mYJpFG}CxՓjLSC Ju->y"Ҁ!ny$%6+P p1F 3b`LOF9;) r OG]^Q!9EHfsURDב$"ːϲҬ]U+M Ԝn Ș$2D0d6iġsԴyD9iD v3(m0*h[ĕN5lIôb eq׌nER#X>Mhqj7TШ_܇HͧFm܇ G,C&QXn^mD1[IM5ˊǗa!K&ٴ?$ Kv2=~z25ʈ4,oq;rzR=>ɪG`דU&i|2M䪏G7>T}U_%.q5kxUO7RZRoZ}WWTISۦ>{6iyOijO)qp%: V><:{I<Lť`,fc0F;%Ggo&;K/`rye.D?kc/=jXFgp6w0S?tX, P>tJ`t1@W7e}vA.wm }.vJ#>tϪ/|T/S6<^ i=Ζ8Y/I߮~>\&\@h i=EP ɼ0Y HWeWp[/O_b \hY+i\,bj#r/s|/H=| J.AŻTwU anpXzTB%w<9&et.~ p6lh/PJuii; |8=>BK 2#$`}F*MP~ب?Mp[ z6[%5txi<6^ ՛G{ǝ"9@bĺ v^FnTҴ7X+'NYFk )S/S6\˅Xhpws \Gi'r{tn?}`焤܊D.պGMizɯ(Mhg/JHI,Q A|є<}vc}S4uE/A:۽k/87'ϺJHH[(xr}W)<~bq"օ>g,abc/޴ ۳'ym5+. SVߩ-e=u%he6_j+χzUf NډWЪg?6|2oڏ^aSr$y;{ {!뻷E]O5H7ËW&am{ٷQ6{`qd_i^o/ _ X^@\Ӏ]+P /AZݚ)e^B3 2so&hssoNysk286n^s:xo w(ۯ9CÉGmkgL'l~P5L }fvMsoM]OmH-a=ۆpv}!w;A>is_sFnL:4i7"Ӭϼufo\m-Q$d7~t#Uzkmvj[?xtZ]o#Կ]״:Oxԉ͊^ >3Lq'S8o5gËUkL $7x %J> endobj 503 0 obj << /Type /ObjStm /N 55 /First 451 /Length 2111 /Filter /FlateDecode >> stream xڽYmܶ}wR@QW;8;wu9U:N~}gHJKJ\%~#wșy$E9DQI ZVfR%&KRp",'))chk81B ѠChA LP J$8㔁1hA6b#`d\B re0 Zh 0ʂj"a8Tۍ0^A1A*p1`Y Y0b X0MayJ/R]+,Ph5S3Ģ8'Z.6l@dR\C%(a p*pR C@lzsק\[>VE{jH'+{ao"7P79X7ؤZ ?|]ߖ]S ʹYjSuif bRUa&C214:;hIf5B/5D]c|p!k_񙷉vƺ7NQӛk&jz49ql vH'*DSZtѼ)"=QyVRDZc5v-@5AyqUՔE/kʸUİ+fϡݒĽ$_L<^3SbbUU7i6 V6Sg|➯n:/Ox`6YL6"L^$Y;n; qb%g+nB䷺X}v( 9vhڡ2!+Eͥ|!WPz.UWwfX?A5<{5TG؟A1  j7mWе FD:mo~Pa߰>(A 3'A',-U0T]SGK+6*n}U㯲c/ۺT]ܤAzǮZot\sۻ;l`;YjOnU0>'u~auxHͩwcmu9!WHG^}~Ίlo~_?$E>Fs:~/Z1,iۛtk}]/O/EF_lH`sCcf<4r}v>ܵy7)~gGe_Oڇ`_<YR4k B]e] K5a}LJ4хý,Hq^ڕ (X=woa] ]U+!p9?Uj( ʪM5R}ClymeK_͔g3~\r `3KW%,]X"1DKN.046hP5ɜ%r5o(A2ӑY8Xw2B\M"c `K&n $Z@%p~rRe09Zge'L `@uY!δ;2ֽ+PEf5X|K/\:&6޵bt\p@(b}< meCCXaT"B%rN]8&{)\k(r}_//ʡ<ަ_4 57OUsƦZG endstream endobj 532 0 obj << /Type /XRef /Index [0 533] /Size 533 /W [1 3 1] /Root 530 0 R /Info 531 0 R /ID [ ] /Length 1317 /Filter /FlateDecode >> stream x%KlWEZ@k>) W, LLظх`FCLhb`!QIݰŅčG_|3޹ssuιg#:Dp (`m'QED`bVͰlF+FbXѶmg@dX mc5U0h&wtήq4hQԐ/`t=l?uݠ:Gӟt0;G,IV<YRpKOt3O{>%k ӥ<ρ3lY?hFNYk-2(B_hP`u5bIݸH# |]5,#ry8'sV X%`B ~$`sB= A]ђچd@Q%/(j׌do+jL{6Sn{*:hr:,ۚCmx[Qei-{\QeSm_^Rc9 Str=YnCQ^xSрXV4huEC^Ѱῠ4 RgHIhId&N2$SN2$SN2'6**R~PG))UoJ?"P(.m76Or endstream endobj startxref 437621 %%EOF deSolve/inst/doc/compiledCode.R0000644000175100001440000002633012763247273016146 0ustar hornikusers### R code from vignette source 'compiledCode.Rnw' ### Encoding: ISO8859-1 ################################################### ### code chunk number 1: preliminaries ################################################### library("deSolve") options(prompt = "R> ") 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/0000755000175100001440000000000012763247225015243 5ustar hornikusersdeSolve/inst/doc/examples/Schelde_FNA.R0000644000175100001440000001472112763247225017426 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.R0000644000175100001440000000641412763247225017336 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.R0000644000175100001440000001403112763247225017423 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.R0000644000175100001440000002700512763247225016252 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.R0000644000175100001440000002273112763247225020400 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.R0000644000175100001440000001551312763247225017423 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.R0000644000175100001440000001077512763247225020145 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.R0000644000175100001440000001764212763247225017365 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.R0000644000175100001440000000260312763247225016771 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.R0000644000175100001440000001372012763247225017442 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.R0000644000175100001440000001350612763247225017767 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.f0000644000175100001440000000221212763247273014721 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/0000755000175100001440000000000012763274451015060 5ustar hornikusersdeSolve/inst/doc/dynload/Aquaphy.f0000644000175100001440000001122612763247225016640 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.f0000644000175100001440000000167712763247225017064 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.R0000644000175100001440000002145312763247225016510 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.f0000644000175100001440000000310112763247225016522 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.f0000644000175100001440000000225112763247225016566 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.c0000644000175100001440000001536612763247225017342 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.f0000644000175100001440000002136212763247225017336 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.R0000644000175100001440000001001712763247225017271 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.f0000644000175100001440000001177312763247225020157 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.f0000644000175100001440000000336412763247225017227 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.f0000644000175100001440000001124512763247225016737 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.R0000644000175100001440000000455012763247225017031 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.c0000644000175100001440000000166412763247225017322 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.f0000644000175100001440000000502312763247225017037 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.R0000644000175100001440000000634612763247225017011 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.R0000644000175100001440000002307012763247225016447 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.c0000644000175100001440000000775012763247225017436 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.c0000644000175100001440000000234212763247225016136 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.R0000644000175100001440000000265312763247225017170 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.RData0000644000175100001440000000501412763247225017432 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.f0000644000175100001440000000465612763247225017007 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.f0000644000175100001440000001123612763247225017433 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.f0000644000175100001440000000203512763247225016451 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.c0000644000175100001440000000612112763247225016627 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.f0000644000175100001440000000402612763247225017247 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.R0000644000175100001440000000560012763247225017615 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.R0000644000175100001440000000545612763247225017456 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.R0000644000175100001440000000703012763247225020122 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.c0000644000175100001440000000145412763247225016452 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.R0000644000175100001440000000461112763247225016600 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.f0000644000175100001440000000253112763247225016505 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.f0000644000175100001440000000203512763247225015755 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.f0000644000175100001440000000237612763247225016632 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.c0000644000175100001440000000200112763247273014712 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/0000755000175100001440000000000012763247225014725 5ustar hornikusersdeSolve/inst/doc/source/ddaspkcomments.txt.gz0000644000175100001440000004454112763247225021131 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.gz0000644000175100001440000065140012763247225017323 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.gz0000644000175100001440000003716312763247225020622 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.gz0000644000175100001440000020154112763247225021460 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.Rnw0000644000175100001440000017231712763247273016522 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.Rnw0000644000175100001440000020043212763247273015522 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/0000755000175100001440000000000012763247225015756 5ustar hornikusersdeSolve/inst/doc/dynload-dede/dedeUtils.c0000644000175100001440000000132612763247225020046 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.R0000644000175100001440000000312112763247225017500 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.c0000644000175100001440000000256212763247225020242 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.f0000644000175100001440000000375712763247225017733 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.c0000644000175100001440000000520112763247225017604 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.R0000644000175100001440000000441412763247225017570 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.c0000644000175100001440000000320612763247225017525 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.R0000644000175100001440000000273412763247225020222 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.f0000644000175100001440000000166612763247225017646 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.f0000644000175100001440000000136112763247225020347 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.R0000644000175100001440000010266112763247273015162 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.pdf0000644000175100001440000314641512763247273015542 0ustar hornikusers%PDF-1.5 % 168 0 obj << /Length 2884 /Filter /FlateDecode >> stream xڵZIwWE[vqdE="aOb,]SU]Xt9յ|4`ۣFR\} reFyp5 >#%b2R"%*,F"_9@ oHU$)N-|܍dWu5i$TVMkXC𱚍*5;|Ɓ-~4^|~ߕv5|Y \T%.C+H"drp^pi #%^hA 11#`eN٩1c`۲"n0<Q9(M$R#(*<#ZsG w+V!Ӂ;O Hq;[X%H4.99&wW&XGNderHnh-+nuV2 L! cլHt5G. L>M4|E,7Gf '1`OZfkqdi<N'` 4tXYíL`3SD< *ΣD."+G egN5:lYmrvz*HrKƳƿGzqV`}m‘&Eg|m'L H]/S.acW9''C :ɌV+@u"D`2$&ˣϿ"g=ZZ;nr< ^ydjA?f;f"ń oJct$4E@D00iF mb$,fGfB:K4*s3 [,0&f{x{|!hT+2CWd.XM[&a$:DњeW`ûBXםw؞V =h TGhSh]GRy/N=Q]=}Q#,!p`'H[9@"c,=[&,qdƷV߄|qBw#c٥Z_sx, }:O^#(ՑN4i-~"-H`S+ok4ש<Ճ=O)YtI?hi Ac)0oQL;y A5}_wTu'x&prt̳~3pRt2;I먤uBS{Ct=ť|"qs뗍0}Q&ι5yFxf֝DMrt[yɬj{͡ȿs+}溠|7q}J>J'b ll%H ޜP^4JFY5Oh^?9eGIEub #YL)~~XD"`DgZQEE^ }1h7V DQb);-sc˒@l`jgXz,Pl,+^쨸9cvlGA*Zlg5fD_,vMcK}2ċsxJ0Q䟊4Ⲿ\'}IP%19s)o|Y<f8*prp˧qN|AL//v+K G̴5N>w(U :d!t'kKzuG4]K8Y!f+'-$w^ !~,Ոe+̧Ph™l{!L`Le7VnA2QpNAIOV^;=wl:,N|iS +wV+=\'i\ rK.q+&?'uR)d˥kZ@),l8-] B4py3`˾ ʂ}9MF7ge)6Fƴ7nt]1@㶸s4,Yrc;qSЅZ? `q(,JjH/QW7htUxЧi5 VTrclpYiT<&4d3X:'}=h81M* .o2Nv]Ls8LPl&6IۉwiڳPM#jli'ݷwRAR{q vf49uR{q;1r ˺z- J kkN͕e4ǗP>cuydDSBfHOLmK[ؖ)&;] B ݵXٗgD^6sΧn’xL]߯0}yHXC&Ȗ(qSVŻJ_ʅ}UsK\Ak.k@XGm{ۓʅug-߰a x'Y08tPbprxuV@WiYK9,)(7z,'Ӻ[v[-V31^ؒ<-rMϽ-ϊY˦7X93fmK-iFo9,U*.tN@?wD;;sv3KmWy,=sq_2 *q/UQ+ #\.$Ju@s.(Oqr%:D*lF*m0Dp endstream endobj 194 0 obj << /Length 1898 /Filter /FlateDecode >> stream xڽXYsF ~#55{4}$Lؓ|)ZT#)vL ,o/NIg%/Erv"MJei)/gNrޟd +s[Д7YU=yش5nQ1Y f 6pYo~3Q2mb`VgLk~W[&R*}b9ݤPtS3>sqhW\V-Wˍ"Nr%+d4~s7щTə%e 03{Zs|v@2>-sH/<ૄlrKS0hyrzPԊ[L^fa, =wӆ hP)v+$ŒϜ>iäQ$SS~*Caʇ2(Cig$Y ݦu2 u`JauC 0Т!sQ` 5)Κ7&䋗ٝ: ZN}R犲U{ϕy%1!'#Wߜ(F|(aQ}jʹ?c!dx"  MSC3`ji}8"K }osuo b*sAKOP;/d%S=44&}uJX/ ;[P*QyI l}dKj>˜\ F'Er@=Tm|}z1哠udh@@xZtV@K q{Q_Drhw%I? ڜ@Tr9,fȹz1^g"jQf|o( OW &`yKYb,|>kb} Fj˥L|WD= ܠ|Db4Dċ'-Мljrf~ڕ3Zfu(j+yN'Oh+۬*q]&@AlGqm@uO_W:&vtRʾ$" k: dp> stream xY]s۸}ׯo4v2;fl&Cӡ%$jIM{.R[Ύ7yAs\RY I('k)HOjR^4rIғ =rd'*49Y ЂT59oIr9O)\Q{C³dE hxjpH\pvH i9ށg=9t%tɀ5fdV>`h,Hq|&r)Ҙ_x `@2x*8tR$N!Nܢ$Y bjiLB-C i\A ДFk&LX6i9I;*JDZƅ ўGCFBQ0pIk3@@6~j⃯dOn 8EY!!u NFJ؞PCRI"\F.5gl\@JePTA@ss.x1{4k }Z.d"{oaD[~>ynWEEU-unʦϩK<(6{?w& $rlEuQ-إz>8=M.i3=?N.8_#^CԞ_.N=Rݮ>Iqr {_ے$~)jӕfsH]]Wm.)ݪ8tQzui5Q.ꦧXuU^b0M yѬe)O|..a^ִZJiH=0Xweo+^FfݪlXS2%Q4:&UiەۉAhDl&)Mvb:v^ca%8f4;JE3HwTdp܀.VySTZhl0IVe1S|=9M9% G\Ȼ\btu4ey?-u5Ef_'dQ+EQ$٭ϱnȑ!\JGG @Qfl7ůe]dݵ>NLlxo{ A @Qu2҈5hjF}o\&z{T09W qY]]:Hh5BA{#.eTX%3|xEG!V G#Q.y(>;)WÎh;MN.Xk%1.;v~t?4!?8e<cy LpR'J>8CJZߍ>3#붻m~:m\כ4`1a^WmWcoJV79ExYsl.Au-_l7zSHom;Yf@⍘E4{}kRkSRևt?y:ZڄK?> stream xn#}@<>8@d8`- +%2"Gr(-"{ r{=7~EgFNwfvy;3u*S͚Qfߊ?Ma  s6p@8%=<#O2GHX:J(~uޖW{:Ft"\P0*ʶ>00kREYUk|QYWH,r&ρ04hr1ZyDɱ k~ :R/Ô.*՘C``0@VX@RGo403H1YWdko+!$w s7t1Z,)?;|a IBÚ"GAw5|DȰJj? kQb߂+euihІl#π3NԙbGNjQd X-"U9E,Q0W.`Ny /١(5 #W$b`+ry3%::% l*>Buu3Oc(P(k gؠ Gٌz S Tvr}Pz~Xr j [I4ʔ]瀙\[NU=/F㩁2SlexE *L$F+9-=˧~%Q0'J ї+ @\嘳}ʎGk)<%7\d1 Z9 Kejq _bQ35pr[ e(hO:}/{@2={v0񅭜͏8MV3!4bn_)^3SŦ !& I1yI2Xdy/Gy%cbJJ(PYy|l"yP,J "j*HD#q n6% t)BD>CT8RWDpB9/ĈexYja|Rښ|6Qg K x)ITѢr^ցu®psSNK_ΐa`I2#>x m{eAQhyL N"- 3z~xyaUP!+w}ב D B݄ &P` MBP-'.$7'#}־-$2)%0m k9ۙ\`gBXv.J y]fm./FƠ?^"$&kΥ[u dhKf4s$,6LT2ktj@.pnMBdéb-Mފ(M=SɳɣrC`8B.\0l 玣Dl^I#X_pشZ56z sůj zu$cMlul!PEnFtHp3_S+k1Q 3%S+,ٶ6] ƾ?mId{AXWtpWau ?䇈Jl:)>D D]e.U>ӄU_%U@=7ĕ@o%MG6<򌟂TgQ>-QJۣn P@Nl"ԺZ|m*"c#^RiC 5u*Jq%AxI{i?\Vmѣn)}Zؐ|}=Yof>i՗~JI?L9e3XKi4l;Hy endstream endobj 219 0 obj << /Length 1667 /Filter /FlateDecode >> stream xڥXIFϯ|UFUKC*TR9IAHy[K-$qд-z5YMǫo]k?*-U'7BOrMoo~~v(i{A$NMTɓ>KՒd,3i1%0Sk*rj:s&/-pد3km>Q6-nia*Ki[{3>V-R̀`cʴ0e@i83iQ"˘мTtf^Ҳ% Ht;2X' U"EX) X/Y宆9xmyVwE(=aEÁ+/-ϔN$ Vk/oJji˜o۱񤕔-*-B\f§m]17StoHB(t)#O; )KN./V[jsIуn:.PjhwӌJ@/0!`.ZA<ҸԄ<FRaK~g,l,]*&gOs fɕ wh3]^ D*q;9hLes.x>@u`XUyQ1Aԍ!;sT jpJbđ_Y(RI;ԈUְƌݖ_|b_Ķ0!ſۏ*`gJ\#n|IY.;0s+52l`sG'o4+^ҽGD^>s/0 NR3CZ{OHJ1Uh/4Cph v0P'r]h3#i 5`ö^/tu|],3&1`/NfqVD oCfs]0mFj- >7Ԕ{erG[Oʒ+(xK̘ `mKxcV*:eBӠ^v\ m`h4B([:!*B'F%kt33[~/C7ŜCۘR\+ܫmrhPi _$Xc`Gz"-;-0>tH(c8S>+qɏ,q!l䐖w3SwZ~G#` <&JzUI4mIݙnW1'acIƙo:(~-Nq_(n)ڑXy7;@Oy 70?X endstream endobj 224 0 obj << /Length 344 /Filter /FlateDecode >> stream xڍRN0+|%zI8"(.<"qUHmx|=ӄެgg3k_MfUKՒôP,mJcyUN@2o1l1uBc'L!!}S}UXEEc'k[u;_kTVX%X0^U 0Z˒T|e{X!}W,Ln/OCd,Gމ ʠ gdP/y: p.dE7P]5p2 "{O_a Mv{Hn> /ExtGState << >>/ColorSpace << /sRGB 230 0 R >>>> /Length 216998 /Filter /FlateDecode >> stream x\m;ֿW`G?D q"pg7mI<.y=$ꏢ8H?Xm폵?Ͽ9?_Ͽ_o_ڟ/_kzKr%yNr;Ii<%r4$U췪q IN-IUoU+HOR5[]:nU[zF6ƯѪU5^C?vl쿓篪Z'jLJٯ*ΚWXٯU~Y@gfp5qߏ#H?kW[3Ub9w?w]L#_cί}{nU믋ِjojhjSgܵ~Y@F&W-B~sYo/*[frm'y~j~wq'䯪wUg$U_UIHVЭjr[șdgq'&V)d.99y.zy*c Ui4lfꠁͪ$σcdճΪhXm>54V+r`5GlhϜhɚIA᷅;Uޤ.vܪ~lsbD.¿-k~^RɏO\9!+c+ TPzNBb+/g$JIzvnuXU9tظ2'ao='B&7ߝߎ[U+Nr'w { RwLh\WNUudrz.WkI6r/Y+U<ߦ.\58W_ݿfUU獪Be \_] $gh4{ {v]8WԏM)seAb1tqEoL|Eݡ,|EoWEtQE>pInF(y$a^XF|ɅoEbwkݹS. WGWϨ"A^Q ϏpSუ ]QMM j"ۡ<9C$s簧?8/9rF\f]X85 ;. 'k`rL^QߣظSͻIRK+۽G _QkfW,2Wqt ;P|NKBמEþEZNJ`oذ?C>9EzqjqQOYwIgn22yEtz\=E"dyEl"QUj;W}_}WݿnX2pv露78߆zEo$n {+;K=U' Aha@׆ǕIR[%'t~# wzHoP/ YUI2$~ءdpjLNQ>+>1j±9W)fMk&KFUΆ68ٿ#E :HQoAzgͩ՟{IqhmQUfP!E}H^3~S ŭ1!\Mz>#%TfѪ-"[2/yuؒM=wY^v K;%oi$TDU8f~CgC$rvpBZ}5KW/upApZY6S_ˉH UYՂ{PzڸL9oBԿ)x$β8XJ&+/f쬊<N`WW_q.+ "7 AaZ1C6&LႰY3a)rA%v-mp7,;-,'H`<Ɗ4ųþp,( 8lo5WvoQl\Q# _Q#MW|ETͩշ~j9e{o}4iПG#hb< mt˪e^' '%qj)#;bUa[fUy%t do:t{,!_R>eqCX6 9خwY>e!,KE,"`Y2²Fc[#CXn5ok0+ h(5V΁һfp4Y8 8l9x Xt:`FXsm=eہ wKb!mI쓤'Ư"9pkݎ B^2E "W6#r J{N8paYjׇS5*ݰ"^]9 8,zquEk$uˮIXGj4_8e="#\Ql#lxR3?ewՆ*HX:{hge'>Y=9iU!Tp:NXuy’ D'Wv'!"ل%q5~9.K6+wdCW7O^@/Mvŵ1s XXQ?eX F~Pl+6&Tqk_FS_eۮqV"k4?}r,{$3(`١|˵L%x6\s6 8kÀ~ A}+qٸîb2ﰴ0JEXvѳEȓ=,v5tEO2ΪRe ksRْ·a٨J[VOXָC7&|r.Tb,LA6\~ ,u]29f ˚gbo2e`kBo < Zм[8 'aKb o!#[²֗%½'͞쭪$y 8Z}sh9`~7+sZ2u]+~p#G:eգ+",{cY9WʚGe_Ux,G|Ef4,}.XˮSZD,fu!ƣ yإ9ryN[}+URCW!T2}Bev$a, ,8aɚ],e,ۤ`&xPOQ_kR ˆo:Ӽtw f! WC[M@Ku ^\I6}[rVg$ٮu|ekjg;! s&J>X .>djVuë䰃ys6S]$Uq-+kE:84eP-~~ɦ XF WQqE=<}~IoM^Q*p^HN7=`YDSMʃ~<(d ѱ5tN0C, mF7[lQ$:k\\r˞HNgulAX#+5r,vnMr, ~ww <-yh ^RQN7aK.@I<꠪Ϊ%젏l78nɳF7䆾zJΆl(pAX\W[-V\B",+lћsB o V?D¬;T.rTa*|E=AÚڸ=쒿N_roՅfrC2ɡsY,כzuPzVe@r!9`YAeh, y^p9e㌖5aA>aơ;P*ΪTq@m pC9ea=ȤCgDZ8E]`=aٻnAO=˜FrOٜ @9<|y$:9uQO~_VD$VD=a[UH_lUc|{X8Wш#gb#wrqI\4\hg zg,lP/l|'G`4VtgjV{–znůWWa, ȝjX9˞^qݻظZ:ckrkUy<9`Y{5;Xހem<#hb@X}MF̀eD.aY^bj8 \fv?Q`z3>Ep%,{O:gͩ3{hT].5O֩b;%rw7]NIX֠$yCW.OX`ےgUVh\l/ɫ&e@eǰ$YUi em?&vmT)ۨJݑk>=4vy:s2ȁxYPRϚ_}cq`(!6sd 4Moo,t.LeWաuI$>9e}UCWw9`Y'e6U, u*"AnKIeNؼ \3X`\q 'F 'z8`ٹ)NVexfl+CS9p6j[lΖ.8 o83cm196q޸kV!{^sK^E%U]Q% Ț;{+mW7>oU-Z=a;sEٿ~3j'R_Q#y`wFdF ebM7M!,{5 m19-à',d֜n̼e&e,R\˺`Y,$Hp',8 ,FT.S5]²Na,]paeia,{*eU:`{M#KdUFҀCJ,_ΖZ9ieu!,jY2F@NVLu} g l & ,;)v^[ ] ~LA9aYfr<; 8\-A͚iqHJΡeaY͋L]ҞsW7e˜Lޔ݇.K)ӀJCla! }Z=4s6^(S'\e[.V/VVZ9,Fu@Hz/t^%NX?2rCl=2=:˞x_A20ee #5autBpXvYB1p29F!F,<@rN23GRwo IkfƧN& N]px^x;e'ѲQ$h+z9>aI aY.9aY:/9a]l$,kUs²"aYY;`Yx)yY>"-m2Q^jeIXeFl~p *Fg@F= 8TCgHsr4"oIkHX6$= ^55O#w4RF²v A7G 7HX Np"a^@4 St&d*ͬXh$V eu.`YX-A^Ku, Q7Mj;le%yzdW_X0%n^[M*<΁hY$;tgj(/M[=eB4eĚd,Ѳ=eoHk]!T$C@O^a-?` e:a X'%C,.y⮱Ew̉F²;GdсLQ"S4vE25DX;:zf+0:-/vg^ (.\QZ|EaHXcy"aY;te0 \*^gVOw0P 8 3ĕwXV>TAX= W_:f,+P ˞x=9lj\PM7:#_ѲB<ѲOfDWWx2l29`u1 gH@l81ȵp-Wg S^Q~:֓!mVCd Ag>8.&9$aXVl$ QJb zɯ>`q1Z֫*²Άd!|"dm&ڂeF6cd#=pN:['`,N \Q҄ΪҵXb8 d~}/8Ky\)&#$ּyAp  ͆6EB Ɔ(p9 d U5glI^3aYe'byw²5N~AB/(-x9HXx#JQOXF%ѣe$ab &WyCLt@ C/KB <@th SSZE)Uk1sǁViG p+@WݼZqHC-6cDobJqZj<$Ʊ $1.(s;DfIAC$h@>op1m]sY50Y vX1搤 A(HYS]p3Yv,iiM\I;Nzjux䕮Q鐒o?koj& 5NYLMXO0l8Oj{~tFcEG)z<'t.>4;uN>t= %<Qa<xO5iaP-4j{eK&ix>fO&<'<C &,OF]uЀr+I^6D23$ =}Oםzt!ZA#~аOivXjwAzpDO$QV^l?#tOMƐSwth43~[jOY|F*4zF'P};^D dI>4LU֖4h|pѐ^w\ek &o}gygrJzH+qc|$wEy)y4;S;KƢC[҆ 梛D17ʡO]] [u nTc?٨xw$}ݪo"\!OCS4N{x@;rsk<08靷;? |׈ITMLm QGGu٤ ?K/HC4u}w䟮⒒t䪯Jx|bГF^/ʤbyWn:% OW3ʧyd3oƱ7plLU_fo؇couh?τQڟ0oSCڅkl>בQZ}x9g^'xXKLޒSqGݸ.տy T孾d~e!k% <鍠L' =OWGRKnIA=G}SD-*]5iu480xB)_ү{L_:ou!7\ ͭ)I~?\{m/NY/lo2v>Wέ$>̝o/^?Z~I{u>yٛgYFZS$QQ)=O=~39yhmQmƺKj sȦCC4'ϋ*iMю4&iE+3gtOXOsĞBfϡڳk.lZ =BYH/đY$sυHxg(~ƒ5OԂh!B8Yo3#Ps=0#BDCQ}ԮJ/$}t=4Y1T~k[}}"wSwp_W߁WGnzi~r=&d3޾hҀ?]' h?>U_>U_{dn펋\yYu|JXy9L>B%{;o$s~DO7W> Ҹub!}}+/hA/}! xq~|Z߀iا(_~>u}jE>qDEMrF?FGGoWE!ByY 1s<~PZe3L>5|BZI{W8@JΩOm[ޞ_78ڏ>K߁khyU}i΋_xw+'o]˞qo}8?;@Fs1)Q>]C{WG.w5w5?^w5IzwػaG.}aZ.{wwϢ}12Ckp]ߴw}6pt7ҟ=a]5]呒{k?oJR+sNph*V:jpK{^#CEr[}0h6_yt"{n7 𹕽{'@v';`hO^^? ^v{<خKO<~L5o2304>OquHK?Rw2reػw!3]&wM{wuO{W1k'>Iz% "'V|lĆ{tj?]#BJ^#Dښ/bi"Hz(Y aғ!@#N\y=#R6fHڳ]SҰUw'}7%E#yD|hOK4w8Oī^qD#lмyr:i ?]Kڵ1׵=쵿PG=#2=OBpH^$^'<҇Լ^,mIy-ݑekvS]j||RFx|- x|gzZOm4C45>{V(.za~_+_[x~~}+/{1 o#:AQ4j/]{Wɷ{|8]fҨo>}[9-LS[q]3;xtb=zG0~m҇;±K {.Л\OCZN՗]G9իa˦.|#./7fwtDfwٍɽ=Z]qx|O ?]Omw:{Cx^jo`4B]i2T KLTy\o39m(_}GKS} e_ҽK;Uc~~}k-Sc>?O@hYރuϴL;j˞؁o \wڧИ~+Ib\HM5kL]3ARl8i ϶7鱖K{)gy=ab㎷TL՟O{K? 7SkI??|F%3;Ow*[ѿh s})28|cO']+čK;}h<>P{3;x}&} x| aSQ}:_M%hKϓ=$}ǗUox?[j}"|ߋ(Q v!&f_=}wn'_գFn&~sx*xUZR?^zg'_xNj{r/L<^x6E#0=]SO4U~"̯?jW~Md1ok\o[Ƈ'G[Q} ]s'Pw|w$OosLlK_<^-i/sI;S@_)njڃoɔ&3L|d'VaK#CQEGpM\L.Ǜ擯7d@zǭ' {Q?Q>?w'Gx9x?Oс{?KuuwKOԁ?җǗk?wρkI?L<>c |Vny>8M\SwYy %^w"Ћh'Ts[ ?ԪY{]~?o>2D]i4w)^g:?,XI#[>LpxSت my߯8WO7;+GsmM8Bh5X/]27gRQvF_F:ܿ𸋅3FwػL4U_Ѹ?kK gi~x|GxIoN?<Ϸ[DϷi="V~蛏-%}2^ڣkӿxFdA:F̷3oD|n׮mƢ]U{g eQo;4~2C_W^ RLG >k=k<Or?d(ӱQ KQ;[z3KKx'FcecBߒ̘=E/rGRӵ3KYI3m?N3do%Ƿ_ x|X|5M [u'GcU wտXx/φ+?ܯgj<7N?xa8%^l7]G^>LvOdC?6R6^H{ yc 5i3  N<cOz?}wOϾLV׿{ϓ5_W}~MOǛ `Bx.[|GK w熛{MϬ-M?t?T{Q4-k}[{ɁwLǁwF(a/c?)9޵/wGk |>Oظܸ+n0ۻIG{])ỉYϔ[3LN}S_>&~oo"|x<Fd*L7!MhϦ {Ҏ|0$~e/xoٍۛ̊ z ][#>w_1>`>RxX1'DWѰG!QСoy]I+L+_1<˻gf]MUUd_Gygߛ7ӓޟ!9뼮$Caywgk>hښf摒/ڻLoijt?ڻC{.g[[[1#ok=CDV{ O"O[y?Q7o߂ww5w-# l|" ;=E5k@F"mzY-iDC˞T%^ef7_LGO0} Kg||1ʏ8BȞ~o{-GgTYx|lV{ߵ5ߛ8q_b i{?ߗ$>χU'o>`w >ǫ?p_ /xd|3 шW<8_C46Ŧwsz#룑jf ҇&KߝKz}M+_l/\'U?*Ωx,T"g?-30^||!&% 2wU}5U>>3^d _p(_lߥ^lxrPߙ_x|wO?<=%LoY&r}OkGOZOyK@̎|t~̮'|(3;E{Շh[=;Π<՛gƃW/|>^%'K~M櫗~1/dzy"x2_x1d|3JOW~ϸg |~*~Vj'~`vZ}QscsޥKS'ʜT~0֛ezf>][)D|齉|Ro?:,M3KSI<ަ3x6kON3gҰLkSi(t?@dU>ٙAm>tc3SAkh>̟b ψhcxOz.|]>8XKK9x1K\f:S{ ݻhī?xoM;ģ߽̺?9LgMc?400O = <'|hx|DŽc^F?|ozj2>~r.xϧ~|~Hx^@^KD:&Ge.._Ǐگe ػ5.{t@<]u? 7T@u N|Q3/ߘg_W6ϵw'p9Cx||kȷ>:{iK~>?1=䃫5Ǐ:CdC!5~P{N_p/վ#}u osϓxdI<^&x0'x<~ O3u_7KӀƀۀz2~GѰw]PW?wS#x:g[G^>vT_O [w>1U_')_ x)_7l Mt?O}g~՗QG?hK`'4ܟ#9Kǘ{5G]Sg}}=O3ȇ#~ !}!?V/A][]bxy"}|\<i?ICڰ-ρlnw5HM#<>P"i4!ǺOƇ'Kωw 2w6*_xF x|aCaC1~U@G3R3߁_O8OtIɳx_m(ޗ_Ex % U#~</\~g}ߠuտgeM=ŀ/'>kC&~O6'['GI{9w5Zy?sL]G5cاj~ LOp}WgH3_qyJ<xD2#x#/#?i6Zw~=Öœ!N/ÿpuR\5ޙ_x> nVq!4~k~m*W,Xq2gb,g3OM)c|z?⡑|Nw\j_t|72+SO~=ş![|fzϡUyw?ş?op?Q>fK<~aY!cl͐Nf|x_%y_t7W5ዻ3Max/!ThD~nC x|ů0w"ūxŃ+ !>x߃x8ȏRG1A~#?J?;]E#\7>h̷0\*-K{@;߼,`ݾ]] xP|3VxZx'<OĿ??saZ&zMgY 3_{|+~y8}A~ڻ55?a|?~o5|Okh6{/Gmijti!4M?m~"~?x|?XUA|B|/M_Nu?yxXs<?/; |G|,̜-adžy/^}4EÿTS%/׿o/m#>K'l#>ˉ/Y _!AyzL0Q):2Vyw,oY WoeCz'6yb ꭿ7{xdG6䫿g}'tx&} =_x%;ye_RK1~ҕ,?;_|֨xT)0?m AoGS.Lj7}@s[} ޸~͇ƋPڻ*^ۀnׇڻ,}UyG|(ρF#Zox<$|0j:[O}^j/ϓ߀Ǜux{ʷ?Z}jWE<^E<^xޣ_! x{J xR|_,kr-?G_꧿p/,o/-S< x]/d.{?jx[d5_^ ~T[Q|M|Mq-o7ٯ7.o]ㅧ-7^o˟n_?{ɽh 5Nl.򦉿@m*o/տȯguj|_}~W~&~uAxxtOǻ+ZɏWG6?*k/wx]^<Balj? N3k<f\CzDGO2= Qk ?ϱǻsW7Uϓ?׸<|F?O=CR \o8oG.7_WJ#y]'ɧGp/+?/#}x+xNѾ3\<~z0u>9<|Ɯ <~<.P/'_ZS]U |=j?ד|M <)Uaމl ?xzWO/5+v]?$^e?{7[c7{Ԟ ?ywDԃlz> }d~?l#gWGm_߈u|*CO{Gu[+{['ԫy^,xW- /dx7ş%שw%^:|Va%/ŕx|oGY۵K<^j X7ge7+kjO/8G|GS}8,3lco}mտ^;u WxzuTA~m7?z}}oW{|R瓦|?x_IKJOEߟSel 5?YO?~+?т_zR ~ i ~R?Zg}?~׾w-]z~ ~<+-x|#hG]7Y{9?.|x8\Gǫo Gyw+MU~F=RLqRLЫ}O2m\U|"Cz?Y|J]Oy'k',i; />wK+[6uwד% <~qهzxzRzXO|m_:ڗ<>yK6Zu?瓩F? [{}W_q$D_/:{>)~Ϋe*/UOx#6~6uooC_'Un?xWy~+?^ɏ{㻿[MߤG? _?q?z>'9'9?'޺'U~Oru͹އ՟ԃ;籮_$C~l΋?\9_Clkj}MKs=2՞w}ߥ_|T{|bu[1G9g_c%?mŏ_u}~kkEd;'C,?W?g6xg [N<^z;xI7xWf?'ʏVIl%[~;zSO[=#t=]ݟ>?gjj~)H4ܲ_䛞ς:d/Kc}A@՟?|H]Ol'5~U^O{_ߵO[#-$ }ڲ'7axMO{=gwCo[o^~n7Ia7ߍ|swc=Y_MI|z"^$տlWxw_7x|Ծ9" |ϓ{7{s] o+zjߦ}Nx%w?(n?w,kz~7xoWxXT ٧3|}v~&Ry?<|o*sH_v;x;x+vl,=Ǜ#?7xM'&=|jO'u>}gwpG?վwwww _ vG;ʏ;ۊGہQ}P5+ow "Cݑdn9 >N?'{l/zx}"VOjI>oG aטkW_6x'WHS%>? oU>xx|<ޕaǻ7x)~pǛ=<|8$׃!\Oz+]=Ȯm׾ԾRyoW@N@/x^P&xQD9 sNw>u? G-|?oy5;!yqX?|=mq"^lW_n9@ '>"VAO C'eS^-6zG7zGxޞ36ȗ9f=z [[=%9&Ԟ[W/Yz+/x7^'Hz&]SR<?W6xZ+}~7v_?ǬN^]??_>՗v&ɶ_~Ǟ譈o'z+ד?*ozGw9W)"meg "ۻ8O^]g>> _셿 >i?xoL_^vzK38]4_9/~zvca\zxvJwl'a i߲]H90; M |^{z2c|z2|C.߸ߚ#1ל/߻ ᣛ_w=/ _M6x>/= ?Yu}a7OF>|C| ?WΗS{<~JOlU񥷻'_@9?q{9l_S,wWS~|;K_ GMO_u}W7|ֲѿx|k} N/ㅫ=_@;Vy_0㑅H{1>K6<?ėGW~`62^<;r ?w/huv+NzEHT|A4_x?2Y2w o:*? =n?QY6owzewMyվ_ZzC/UKU|6R ԥK7>4⭟@}F@'@['?PF٩3?k|3?Pr}Wz՞z[lkooW|?;K{#V^e^ª|3ޟ|'?AL'y[*̲V79x|w7OW+I~/OOx)?Ш빾'??--o|oŇ[r>[}j߆=o'}Ϥ>9zS|q%>H^T_jx灥_/W{腰8?7O>ˆ/=|A_]_xs/㻶Ϫ~iwI_4⻄Q4N>H7UKʷ}94?ejOOLR_F/MD|?yNm:oX߫q/}O[i{_Oytt=l[=!y~s}o^AċɧhO!zM'x|w; F! <8}7e'\Tw=_=7zO^='+I~x ?R_@@L~Ǜx)z֏>7xS|GwɿqM5FTKo@/Wyz_~Lߠ???O%v.~O'^Ez'|xҤ^<~*Ǘ:_<~v+?/ &,6||#'-o<~o򟌺=ϚoO{?Mkgƃ-E{/Y3<|F<|c׻|3p6l] Zk? 8?|+&/xN9۵]}ǟǗ9?<#!9NQ.~bwԾXO~֓oQy{ޛi|'*S'b'WjE~Y{>O| rח Dz_<뼈u| e;/O$Q$y+9};W$v{uyj<'fV,`)oMg)?cgKIԫ>~R^K~|/%g?x˿xKO{{o,?3_''՞{>9ixvP|y~xKG<~WA?}xWzu zw=]OfGzL[= [Icx?Ǘ xWo[XO>W[ZO o~O﷩}?k|g4LJ&X/ǻ') <~Wkoo-ggמ3.{o#KʁʿO@?6U_Ӌ~gxzWz}O7FͩEK;<|z'm3?s1yl.ۣ/j^}\e?/ew]zR)]x9ZOV=xף,R|9)n?[?>uW~G _߂lo[̲SMF_? _SdJV2ߜlxx<~<~Kޏ3#pKs}ίlrs~6u2&?oo?$?^&ũXSx|RxPy F}?]MMmW{ߵ%/wUroY|u%}ѷ_'qi>|s:],^X|(ߥSO?R}Gg8H>OOu՗M7xO~[aC? <~j3%/%3?ʗfG8?k??gaG{?O < zO?z\o3b_ڿ2)*/R ү&d3lxW~mNjb|cb`{CϏoY67??K5':O"5>wD8Q=gݡVYԞ ۚ]l]Uoh Sw{>OIYԢҿC?FRN7N'R;_g|, "l{dز7xM"99( o0Z_ {^X_߉?09T~O'b|Qk6( [StW~GP{(@WeCK'G2H:~lp\|[+97^?&!|y&,{׆ (} ė X o??fDS7Ox < <ޤn`y6w?y7SX ,w](߻MVb#z.C6-l[w]wT[8o|7?_pI, <~NœXO-YTxʻT~B9kxp nNil9Rﴅ^-[*zce~_'g\/wg#~i 6_jՏѫCWϪ=U^}s8Jިxŷ +>W'_Ы|)^}5!xg=|b?O|-&Noo?]|j=.[M'I;u/=D<|9Ks/B/PMx<~ O6Y/%d_G <Y2TU|_|ğ՟]:o_FxmO}U <~)z?cG!<"*=; #^&_k~xz壶^|}9~V{o_dɏW<%?^|[K~|g?t}?#e?CQ>?iyzЫgۊ/F= z`SX|~vQ7z5_w wگ~" ~ߣGOwğ>ݏt?ѣvwm=dѫo#(Aޅ^٧E>l!=)u's?udu]oUÈ/r4>?/Yvox;CN|h3m?w]U_8V|s~q'3s>O/#{aiw|7'Co I\8 7Oѫ??2ِ|U^goi*? {[<~ojGDp/yRǗ-2!z>N???x~ON၎hso/'?y~9'cN<[R>Jw)ގ;qO_*Ko|/#^6w|DxO/>y=O<^^|">tC\gj`jdŸ.x|Z~⣇J^U֏~W;z[߇WeU ?̿o η^}L,%wC> \}oHA?Gﹾ/|i?}qWyry｡!!){걑*/gRh:pl_OWwU{܍_*O\K^k~&1Ϊx`W87zѫȼ7oH)=_?KgxŧzW>+Äދ ~x~|wU~|^㛽F!33IoWHw?T_o[]w:{C߇/6Ugt@u1ٜw| xs?6|;|{ă0+7yg%1W>SGk}oK?yɏ㿮 <~3S_F?yWǿ<~ מO7ŗwxGwS'Qw]G<ʗo;ͲTyǯ. 8cu=:>wI.Kyd'? ??&珁Qφr!$j um(qC?^;OMXS;T_wˡA.~ǯlCIo~ǯ}?}?3㧿|<6F9;?-Ȝ±Kwד-|;zx '_I}r>? ?/)~'@W?ѫ>w9zWm\K_Ïw>3 ?]O\|@ז+S^xxa;<ﻞlǭx?A yݟ}e~2?Б@jor/ }]9K=k{z> QʋE)jOw}u~4~F|ij?D{{|ZOy<~+|4r #~'ul\o8{?El^ cO*/ד^׉WЩ+ijWM~F&|OMT#7y]?}[7:̮ITN~OםzW曫{<.>}s9u":M=?+]~A| |F){ߵ/7999_"^~d|'%?^z?z?-ǷZ/}/yH_/\?l u~#_N}N|9ϟxz瑞ʗCQ? />]W|Oq>Qkgq=+7"RᨼtSy*(ߋPɵlγy0 v#?~@;KSp]_4~3$ڿGz>},/SDo orcug|PwO[ѫwg_,mۻO+Ï?ʧ?~vT~ ~_ϚoD~opj?GK?.~Q׉/K/u}=:U<ho<2u_qt}f~{79<ǗVU} =á,;#KN3t {׿V~][_?~y~~M=o蕝Vx}[7ߙ~Tu㶾OO}[_{e:ջ^>;l雄yѿ6؏MPy!;BG6bOK6x=]{oU _kbƣvquMw]$!wLIM1'ʿ5|4 {s]k}FwC˾5_D"_ߪoωUo_o*ojϢ#?cєtggT6M'^|]x^ֽ'>C|ؙ?F3wlIW}u}~mj|˛4wS=aOo ( ߄/<𯅍i+S>gUO>ٰ'T]OY˟pI>OgU3é357͇-\|_Oo/P_6jO/80F_l}oŚ.z錄lǚ5u_xMuz?|M}NEW}Cz+oMM<~xh| ?=[M=|>?o/_ϵ| >5ޑ[i?~epԾGwͣ~FO/°ɧ2~վClWyg>~bNzty|>u?z~$ڟ >z+x韄bu?]vƋϥ^|7?z?SU_'^,#$k\'dߋ/ )o#KT& q>w}_ڏ%?_d揯3xICة{;l#^п7=]ǵ>\8jV;u鿆M>,<~u͏3=ag#6|K.pSz%WK]=|]IWGt=M՟w*WW}c3;_w]*o1?4տ9O{㹉e/mtxSW3^L?ċUxT"kk=G~>"k=='o^|,a[}_CU kj~ۭǯ:Mu?^SDW}=Tjo_z>w}M<޴o <8l;}nNgW瑍k1;?F?b-?v#^ZU/}[Ok/to*?z_o}WiR}W_ԫa̯߈{4kpW{<^g~=ω4N?wu]7L :7͟!t;Fo&_z_y_TbkE~j|joCj*o÷}jxUBcZjOw~za?x񻿃{?|i^v7u'|K k>*Ǫ8tH~z1xŷ~ [?{< #|S+;i׉_suwźP{F_CtKzao9՞wևHTj>O|u^9&Ty*U/FOFOM>SykUAu}j>O'] =mz|ѫa>o|'w3O|O^jNN<cOlw귇 >FQ^C_xbb }Dwr^j|i_N|:| w=דRWɿU=O|kd mx'Sm?k㕟w=(oLG)b|q=ȓd/V~"l5OX[gɧ2ߕSSp]xM<x{ <~O1;Ç8u? {[do>OW6򗦞#^Eik}iMߍx/>>>n?FK~|6-= IC?GL~;-oym'kw'?ߓ/P?^SȦ~CnM7ǰ^n}?^spzu(T;>}Zj?a?6LM+x#;' z>{O>|C/UT~Gc1ԿOL's{7]5| ?~7^+3k}hw ͏{uk6y5j}O<~jM<>?k zUߵ k=o-m]%eo֐TyxOg>lS{zGvi&vSMڷ|it>q7]<~׾w<Ƈv]6!Q`]<~z5X==kDaS^{4^ߵO7w|^}=p<=zsh>C~~?'L]/l#Ӊզs|:?%?הNR}]m_LߵdPo.œ5{ϵ:lJ5^;t}'oΟ^ɇ͆}Ty5a÷H>J=HbGP׉?8u/hxzEv/Ix:_=v>1gni^=1?i'KWS}g})?cja/x,3 _OkOOc2տ8(-'ڏ-'5_,'ڿv'ד_hqͺn/_|rT~O>s?k=O߾xo}.tG)m"CQxNsx_[CO m+?c+<Ǘǟ<^|ILԫQ}%{?l]|*W <~<~7w=Yz9x"†CNj?|{]o>l毜oS^}7_|E_OF ~ǻ <^&hg{a*uG7R]B3B/P_nB?:h1?pz^WOMmWV~kЫ^Ty|C/R|FT5oSc՟]U^wx"zċ1OU/˵^Ïߊoɏ_SnG ~M{l3Cw-xy=W/Nʷ+<40|M+߈*%>P3⻆#?P_hy^?;eu'ѧq~ߚ/{'x~? ?#H}_v~-^nOV~hﵾ{/f] znr}G4i"zVW>lWN|WᇎwοEU=%`sw} g/'z`;OS>R再 S[տԏK?f>wW6eQ_'3_9o]>dWV9x|WQ~D7#|qiīot/c4>1Ѓ~ѫ7;x?49xm?d~Pu=Ϻl\2G<^m<x|W[漢y:xTr/9tU x[qv]G?8/.?9vg/?~PkD35kK[G/#sG7T?9oS1y#߸ȇ]I>O$konZo& ;_ߥx?;{I:/I:5?kExoѫ7şvm鼀^}w;zVKWj^ϡWѫWɎ#W/ѫ?5ߢWkcu6FٔwTlk<?k{?fy5 }s'ooK܏D"}Dc|߮#K/T%B/˦wmK6X|s|5w?w͟/U:z[|ƣ3=->cOV|W]].V6].yeoY ٺ;G'#o;X=EEx.-}g[?n]w^6k  _>ѫ_?]W_vxwT<򃾺~|܏5<N'-O~W=Od_~~>+!9WCz4<~G7}<< ߅gtnow[WKH?<~ sh?Oy<~ SGxD|z_=/ݿgH~V[fV?G5ޑN[6?Wg.$Gx'?~j?~)vOzDO~,>?~I/Ï__׀u&z[x;/S".̗߮o't~bė~R1_u!=&k<x|2=/H<^"#7x v^߁?:q?/0>֓s@վg{~LJK]%c|_ミ#^X)|ݞv_oC̟d|4]lדwuOܚ6<'T]'o6ȋo?]6b>#:zy/i0osG|Ç<>3?Sx'}'x|x7oNº4|D_?3KC홴k&zu}:jb'Mgw\Fq=; |o8x^یKWk÷Yj%_I1l⻲>>ԿQy^'%~}뇮w=fC|+^XU@_Ծ=z:o:0U_W}s3 MXa_i+'F+%24^e=+j&mO7'}gIϛ%_|Ц*/'Ì5Fl,zFq߻G$^]uk<&cpV]O}5է|s&ޮxM1TA~hS85ކ@ooBGe }|1]}/3Rh}K<^H<^iҶx[c|'xV3S@]{9*/xG/юM6G7?qpZWScl>'S3S[s_ݪ~ 4"11ů.&s?K&X??^'?~'~_cIo[qݟz+'x+jǻ#I,* <އKx<ޥg9R^z#?7R^xHZ0ǿ~_3?_&~{=O0Þ6|?3'??WyL%?Wej]OJ?aD`-#޺G'||}5~{uZ(c}d=w}o|3#zko?~Ϲ?i/'U+7_=x7?گ&?_&hLȇZR{So]'?tտ[sW_T6U5UyGîS?8tR]z]O} _OǺvѳC]]ki|c/*8/7wwf#?(aT*?ⅥwK[Qy|sԞ#?vڃ'Udp>ٯ8?O◈?V='u>O>G Sy 85./.?M/TzBڤ=ߦ맫' u}_}j![}x7{Si~u£p[U:KվϪXx|ä/|yoki+o1טo;w_#1 O='_3znOG&??yJWd}*OI]1l'S?_?^z2_7㻽I߫Ϭp{<3Hs/ާ _Ls~x&?޴? .?ޥ9ǻӌKOh|gGŏ_ KOb?8Ǘ̀vgT~vwO[ [w_2_r]??L#6fUBoEzP߻ϡ>Rn=տ'Կx=F>|Mko=LE i=W*oP_b|gW?36F7~a1_9^F#zڑW'xɟ??=u?+7 L%} SD<~Je~wUS?T^?GOL'Re~-Vv_u?O9?-~\M~oPM?g_3z~_qD3KObOi3WFV=][1[w)~7ŷL.z_ɏzǗgo{k?`^4>;φt|Ûjw _zԦw_3MOLj|s=e3~N=erS{5x8=-<~Hq=TىWQ9YS߮wg觟t>s&췔m&?^f&U~t$1M_u?PyZW _X6xיx|g<~ߙ ~??zn21Gؽ셽d?\u}kO "§gW<]x qG7œv_6+_(]wj$^ij T"Q+pMȏKuKw7NxS~ _c'xB߮[Ӟ_Z7xxO[i5>'x|'ͮɗ`z6xhbi5K`F ˟1csBf5Cs"<ڜ?l-?w?gގ}SGϚl757u?H~fGɏZSL}6]_[zosw>Y?:}Is/_B_XB_k~ <>=ߕ/an']MW[9/._\F>7DߙtO\c}[|Ʈ7 M|؟|ڷ^0ѫC|opzd4?'?)2ʟx`Cͣf>Qn_U!Kg$>]WA׈Qux%*oo1 W+{Y?Fy]O6o‘ۿ)}iƔaϡsP~is0F>{Ys[Q-s>o'|K9'O=-ī~_U^ҷ9|uuώwA+j__EV)x~___'H;ߚϟO:& (h( hWW&`ߛb2#NjxDx O|ko?f< G/>iẍ'o3ooF||㉏")??'R˔_]?L>igsx٥og}͂sH<79bo|$zvʿ75 v+_I6S=og7 v9؏&aڒ;uS{zO9=x?y`:@-d))G>3_@x/ǏW])ot>?$>~~=OI|>?5I||I||O&wKLiFK>͐+I| ʏ1+}U0+MOD<\yܟ^Yu,KΪ|ئ~ E}KgnǛiǛY~4M|<>g<(xV?)|bOS}|*OrVi?ϧxNOS|Z?g%ݳʿkȧuRʧU6i]ڻGڻgNT5=+]: Wە>ꓡƬ۝מ෋n)k6roq6ǑHʱ79*2|eKʈl=wH|>}MOg4)o'^v7377j`? Ų~ϧ$>7_|Se:;?Wxyow[1[9%~I|R7~ ޝsoTO!ˉH.>C;ߊ7f+{F|͈OcWL* _(ƣgo <~<Ѭ+0˟~F%5|||V$BG2go_?y蓣G3Q#VWy:wIךW/{ <>?+NR{oQֻ33M?$ >k}M<Ӓl|$Cx㣚nhC+s~ 픯v:? 5wMWϪӁ#gRv {??{3K"~|ψ)M/5${O'|MYyouˏ߿?ʏ[ߪo7\G?B?/ vs#U?ktt /~|?@_~~?o۟sz)|~݊[>>ʯ??% ޣ=? |:eP>G<77)sܹ7C̥x`bx9%e6R&Efxݓy3qw}HHs怢 OeC\&ѱ;Ld:22EUqlDAGDs,SH*잗gg3\R}q-]man ]D }nr|m,U{^ׅe_x^)4Y8<:.W)Z 2=z2UOM"os&4~+=2bYs*rd,Q)S62卷i7s=Mdz̟O|ϱ_YHJ>\Ab9D4CK{_}’,vMT$2 g9祿]_D=_DgwEyjZEڷi_ַ+x<}]&V{\}"r="3"v Hu}Hc{3xYYU'Mdu,N>V}'xNr>}k<2|f'_ }iNLSwLG)i:3WW!RLyS(O5kѾ\_8/Tg3 g'LO~GxȤólSXϲL=癮T+4_Fyb6Iܷ{h|o"ϗM2MYe ϲzxy8;,y{^³lEeki,[óL=7zG!f1?0̭4L/sk uS'YQ}y|`:oٻ|>9 Hw{p{~2|~O|lSOTC[dp?~'~~R?2=}"$:Oie|L}~ )}ҵOI_s„T4~S߳u;sꓙodRyWLkδ%7dꓹtו-9վS&S3AS~d쏦hSB>^4^zfۜ׷gs^m9ߧ|)|_.p?jAVП^,{ fBLx> п)~ I| ž<wzYs}.y/'x\3x|{IԿFT|?ǧ}kb=.?utO>?/y}#|x38gػLޕ<~y <~zKxLx~:d2̹9W̩ ??sL{xܯ={{^(9\O'{>&߇b>TWܸM8*ϰf>ݖ>sO}>6n>7߇inUNxeӻK&<<]^c>rRf*;R#8_C~՟~h*op/_4?o0W>l<|e?;xܩORFwշ9\U_0W̔wC>?ssB )j?]>./9y2ɜy!cog~2){%9q#ɴRi%dZItoO+eΛYwM={Wy&{^O'2xg*o4:A&"SƟJ1Lfr~r.T%߯" <޴'ٿ$|kG&˟q'Uġt9_'] la*kWt3MN0LBƔ9ȴ2L+ԅLdu2ķLErc)4qx|~' <x|ޗׄTogc)s^o'K홁'k|'2G+z?cW$V'G7SS"Da:{dX~Vwc"襤rx>9J>Ǿ~W_YЏ$~R%ìW/{W}qվ~| w-i?x N 1g('T^{*:saJ)S^Ƿ׿Ay9>T`'>Vx:L.cG" 'e?k1+x{ߍ=}ws^Z/>x+x{}$sП/W.ׇgw T=݈G+XG <(GLg x ҾW [ٯVNA/,2}1 Tcr ?YOߩx|߇^3qށX7Ÿ,{Wlzy?W1\- \t|?绥p~O9M ߯㏾ ?wTSEVE!"ʐ}qiߐW}Ws(joOB߂O[a8S.dxy'K-x|x'0ygbL{.#?]/x2uG.=ǟg$DL$.WDIsD <[r~,~}~ \Uo8u?bj?K YLzLy s8OieMw2Ngxi%w֔?}SW#sn񲇭7^s}c|#x]DZęMM#lym/ӶalWuZ0U^z}.'X |Q ~:癮wʋIﯽ<4}k0T{93Iz>OL?2?D||#x_aWLK0Oy{X~<cGڛIt9P^WWxo=d}~?"xLx\Ӥ/WC3qǯ}+>+cMs_zxa"~H}L+gD VL 3|g2_'e<]ڳmhw?g0Iy9f>OLyo[75}$oW&n7s?1?'~447Cu}Jy x_}/C}w?~'gO,/Lm?s7~"~L2 >q_g/u^1Oð hB^o']] <׿O- Nts~e{>_`(C <~mY')c9*85tjOػ}[49۷MeǛ 6x]&{?2[.0WgNLz.G)+3Տ/KRֹ"Q{;-)3l3+w;z~3ݏW񾙉=3M3s3S 蓮-I9n??DZbؿwE]Kij/Og95wcr"1IL~r^~:om~<[<^l5\:lc<c_kvU|]w׾?9E 9׹o}~뻊NLȺ^F欎s\Fed<$JgZ;r9淑ۤO|_v/5WSf"%#WxN_f} >Wv<ʦ>i9:kL&χ,?4^W4l2L+=ﵤ}=Ǿ<^;x;Swρoxo۬jGg ;/&1oxh +PngxDvkۻzػ|x~ {WQ{}n%n!~(3zie+d[QFJ1C'M;x]MlU}<?|lIY~վlniǛ{6x)~rS}ۻPԣ2t0ܾAoU;x+W<^;xw/ϳ];x3xE|~?(z]S)7_8۳L 7O߇h>ޕU.?]-ޭ%|u[?/xw>77w}aj%/]5\%~5qGkg?n2w|QLp}<?u?og/דoO<^/,9^ ,9ߵ5/T?㱉ߩa)):2^꓾_>ۻOw?yԇ}kw@x?Cb7oT_ ڊc ?))_oOŸ>x93 }_<¾ٗ7qr{sW;qߵwMw=ocJxcuCOUڻJspx]MySo*oS^W{6|Sȿc;圿Cs|_|;x~ooø/z6}_c>'M=rǿo}?=xӟjǟWo]A,*/Rk3;{Y_'i|/o`H!?I ?Ŀg?;'}'_}>8xrO75ԿO ;|@G߳מeW|=gfqʵGǻ{\'~qڛc}80|K_{WK{>UwFw{W {W+FX}Jn/k2 fyOtC_U﫪O,7T]{58dgaʌ2Ҏ䋟pl{"yd=7|O/)V)o?'@Ӧz7KwȎx M+}O5?5wKʃi 9cQ&d}|/q{}a_+of'ʿ՞O!r`HZeS'ߧOA >qGfoo>ߎ!>4{!?CWkWG܉xt? >>]MoGׁyU _Wt+>_{+?Myy?#xOGxxLx\?:įs)&\筯Og gC_x7mwtOxxy;#}ppW'G#&nMd~twtx_U <>|ljA9?*U|W7|15~?']|秓q|,.w']2 ~+O8S!u'hs~xIW~ od/:;˔<_=>v<~_Cwt=zN/4]OY'Sws O?~"<8? Aӹ/.Vq O~_}by;T}G}6/ڷR&_w'gygwe%x\d8? ٸOd9}i'|)Cϯ>wI#q<~_G]}}s__{Lw^o??|n.zt<7bqi?O3'ǝ]ݟZ>Gx_}2_"]}+%Ci'[5'Nj?kqͿߦ]}r 3?''&?PO~w^>%~WU_}<~+S/xxoA_/|86zX.ꓡxwՏ<|vI%׳/$Ϗ {ޕk5K.SnjuIS<>fz῝w>ǻ'-z~IYػ>?W{*P^ꓦ!xos(ߏ5Wꓦx ꓖ7]9|;5oc>Q|]/Of)L_}қ/o=e'qIB{W;\v,s,}8"|>?=S\6^}s?6yw}]}G>r=.7Of=#=S$_7TC_U+,+on_jWԢ;ػLՃWKߥ|R?Dw-G콏R#տ{xS~o:GC 2gLt~vE[svi8G{QՏ׿j/2S,TϘ1(sķ7[L]{F}w.5{~@||WC|HM|hi߃^·>C2MMi >oSlos b]bOxo_^T^gϰ4?ko>>)yr}gȦxQ VWQz#[Z_)Sܿq^/39E/E)^N|_cbO}">^'jx&xWt?0"O"~2wʫ{7ϊSҔLJ_Gۑ>UV?2T__Qy׿kd.xsPy%{Od+w)  ./gtY?}E9b~[>>K/s}>l}"~9A۬ }R*p~*'mMdz yZ?9oF%ٯ~_ٯc?_1|x'oI-)_|Mxg>iʟm1^y^Cxs?i3{S \S|idK|ok?#p`n2-cGxǟ<_'?c y~A/g&Cyk;*obj> <~~ ֛{?I_E<~*ߐOx5m]\n/{=<>b{k*O*c <G+I Mpy\{}_WP}G  <> [I Z?*xM{I7x|yW44_yEyE۔W՟My]m[co1ϡSߎw-9ß-דc\]&y>?b?-x~>ߪbKi <~W'[ﵨW=xQs.~^I~R4^oc_>1@ <>! <}<_y<kާmN<|N| ⋲b}Wi_eU)_?o|{i<}uڷ_쏛n=3#H__?|Y!h<ݾp}qs<*ccz>?_HK>|&h~_n/Y!G~ƙrs{yu|AAd|AːۇB??ϳڻ.#>mWOI#>> <߁@_~_kj}W^S@G-[_G[プx*o?&ַt/Y*ϜD|"尟i<Y߁4h!{}'i!>)؈oi >#>f=}$4{ڧO>)#>~_Ԉ25CW?ʿd?!N#ׯ})slǟ(^Έ_CZWۈ_OO=EWoO~Dk?k]4}q|w)xWyc*Gy};'gT_s=9Wa?g~]y>!>!U޽Lc3#F!>^dbܾ2">.28 _A{?as`F|Lsw28=ԿF+Sy{@W=T_g [Qx ,^w7n eŒ|'3\f~ }1']9>a2iۻ"+Vonǐ?e@C;Ϻ>_6ǰUoeJ^7I?%+; {Rnvtd2?Wo?1 Ie;G,eX_=\_*ڳW_yϜ8/ տ^+)Lo6|09>s0շY'|dｿ!f|'9_/'n&}b]225m #>W~r]yɔ^;Wnاok֖LQ>Ab|>QR>lN>U%}?s?q>.2n 3d X?l*;6~`Zx#s?ja/xW{3Ly+羓ISCo22}⁆o<"eْ9Ϣ8syLJ=jMxy=b>}-c9XM{<ן 6_oeJ_Ƿuo5_g8Ƿ?U^w|Mj}|_moy_2Wv=+R7xR] g}.~|_/jq?njq߸ߙ7r}x1s~xזU<~Oo'%'K*I"x]xUxz<_Sz3x}<7ZjTտ}}Kۻkj?_ g^՟)'+'[-{@W |ax|<+}U-w۲c5U~ev.?u x|?x#Ï\ƟT^>8/_}/>W૟K~߈[W_&?|~^>+͍|i+|hWON{w~X c\^5LY˙E~hS{oeךv?v99|;OO۫ӷu?};:/L_|~.ggt䏟??>o䏟"i(ǟמJ~-lM|߈dz=M.L3x|xiǛho/[㕯 ~ݿ>ߺG@~6W/yޕהeψߩ>wM]GC|**uԞr/WGsAyKW]S翃Wyr<~O}~֛>~h*w {/owמ}o{?it=~΢2C&<8_:>_Cҩ8o ׍筮_t?\W_e~_쵧GǗLyx&x3fğ=协ǧokR>A`H{b%>"K|_=$sZm̓78ϿWԈv|E_}Ru>y^x./*x| >2|`;?wor*x|yǷ't1 ~f߁?sUyOr'9O?4FROػjM)=>Z/WOsWs?*f'嵯O$B{}Lt-'_W/ _kOgߪꓻ y~l^xԞ{#ߜs9}՞_PAS-ʆ[5F²U7$0gd/JUy9_EŪϛkڟt]{>l[k#v~/|?j'5,kr"|]W{>{o]Mxߛ~]-T{.W(W]3|hQ{<߯+W|?A~__op'Tr|>)??|+[.?Y6__ﳿNUoc?z?TXU3V'EWo~,?W?">~|4>=｟S ?r<>C]وܪϰxY?H,r?4K}wQ}M#"?B f{uC|5M7E_}U{~^__zS}W>ի<ի_WW|>z/|?>K?|9^W#0u?j&&TgxѸl[TS?+*Ċ3x9\[G62?bX\X,j?"gK*[?uO_uwe|WS?m|.|qL'=$|_ߣ|S\<|W䫟_՛~|S {WO՟_ςokY;򑩾MyMݔ4_PPNޟ.'K5k߰,߰Ey~r~-9d{1m G{K_oIR^6y oW?_z_x>nZ?W/|i='eȧUR_o/SUވUw5_o|ޕ૗h ԷW(o:/'_VW/ɕs]n.הxG}~W_{hJb4Rp"RW!_|q &xp|GQէ7Ӟ|׮W__}ǃ>KWo:x|țCGW]y<^ΕxhC/ˆW_~/s~~wS^|+8~3k*EՁYx <9h|1? <>糁Ǜ;!_wbw[QiK^57*s]_}}(>_%xjZт>]W^竗}_Zշ|=}=|mW/|_[կ7=+|_CWmՋOek7տ'4=J>z+ld:\_ο|Da뭟`j7-ʿ"_rq+ ;ܗ8=_7_zWh|k+boF"1~[_|.UR.]]u=d)Sy>SUqnyG5W7hy/eo=WQ':[ZǿK9(~u'Ѿ.{W裮|sKWb:Dq蓢E'>k=w: Sz?:uW_gh=NjeΛM~w'Gxx\.߇L6=7=<^-Z Wߥ^鎿9/p|s'u=oniox=Ǧ_x m1Q~2{q~Qa|i=q3O9Oޥx6wMC|NV>?6:9Tmw'D;>o2]?{=^}%:*1,ߵ^k? ڒX{%y$?P꧙++'_N]n=M] _;k|sEtrMog0#_fkc?,!_}NsOy'[x_蓦}O7ѦIQ'_'O~Y+Ox'Gx{4!Otꓳtoqs7~> {sYO~x5Fc?p<~ԗǻ=jKh}}]{w"W9/nj7AvHv}bυ>탃 dT^_>R?-%}@|:??u$>^Y]ƞ}OSdkRIak<+5T'S-ȗV s7]9|9>e+IC>ϣR|Wߩ>Cgdo$>4!.[_2'!W|_*%5ƑU{6\T_yO}t,KwqI9*3~Euu8?F~?r󝩿!c?p U'ʧrwT'7o||C|}r4GR^>I'@~쉝|=!wuWwwSy0h7,{}8xx|"? '?^I"ck~"|6xT{6r=8}0>14߇|MzT[j'dC0<~?1x|615;x-x)oOx) Đ?C~q?ߕoPS]dw.cO>'}Qޕx/ǟz">}+|U]}bo_`E>=O,+˔7Q?M|ع?s?悔f C/p[|<~#O`#I<Ӑq=cs?}|]iTwT E7Y?X|>I1dhSn/Ymu![w!L/||<~ _su%oE~b?O>9ޮOOy`?z}/s*p^jAxq[{~ {!? :D_'0>@@@|!׈}x~нYɍL|N|?}WGs>B wkzs}؃uUdxD|brػOΛ 熽]-5县,OUz~"P>ѵݩ}~?#ot?^9]>[Fx->p|^O?D~RTInWO[rY ;/݁&/TWzM_TE 6E?r?'jUfs/MO/D||~hlO3kgu8_N|7铣<_=/OtmN|NJ|I'><;KN|#_ 'S2x{N~8s?Zx_ɿ՞Oz ǿԞO~~k^4^kOuve̟''׃/;x|w7Iw~~?7EN|<4!oo(j߆O-s>_uR*ޯ_[/F>ʩݿ}~O߈o27cO~N|| b'ݱ¢#i7CKli=eT+K|[Gҥ"#HzOyMM?/cxMI7'ZTշO5g៺4~ >îXl]wN||MC||B'>>݉/3yv쭝z;m"Hm/3׷ oIxI7Isp}Ǜ;xxǟ b,bOz󗊏/W>?ķQ;x|?\ٵ DS!XH'Z}2l +B%緥Kv/m?_Tʈm)5#&Tv˰3t'cz2k ?W em\ǿR5O1?5~4Gz-~snoԫ''.!,;M?~3Ǐ_?~v͇o>%ȿSGRŗ#lqqKϻ'ρLJޱV#ߜ0|sGmU}FҚ il}k>E#,=*/.ٙi<~Wտ;+hdxW 5Lz+[iK'i[]O\z\~KOew .ǀ0*?]O^?[>\Gg_S +?P_g}_ |~4|~Tp?8`~ T~ڃ,OxҗqzzKÉ^9±?ڗ"iNO9K1"p_"Qتx==0T>с^CDz$rP}w)7zϿ^~^gY?{ <>%z-VO~q_Z!8_2c׿%cPyw=o۝zV{&]ONCg շb=)|)Cw>u}>b=Q<̀?gO{oz| 5~\?< ?~Jh畟~}~5q^7v2{(C';sGx%#=5}|I|q>k~Ow7?ıe agb=yv~~e=C76?z`g5>w=)ww_/lמzDc_x,y_57'C'z[xD~k*? O'zu^|u5~)DćaWo߫o3?T?K9`W?wS~jaԞ~=G~ҫu}I_~8ߗ=QQ~?0Ǘ~܄_$6z ڮ!>?jʇ=|_ wԿ_0|ߓ8|~CO3SO8=瓟d-[YG/t6Ox=@:_# GS|Gwדҗ]L~/ͯ}'Ld7P㳙/]=9~y=Hwz~ޯ='?~K_pvO3ǻ=w#?xyMz~O9ǯ~?w/>'BG߫/j_)>uv턯ώ^L!>wNxܒة߉sw{V{'Sڏ !5Z?lSZ׍򆞿zna'cg?~/ޯ{Կi`W$ƻ| &8Ol+.'G5|'=8z~,Tw}3k?xksxp-dFSyHshkXR-Bū |s5_/ͭW_s=*]gWjϲWzx}"~\ī#WϣfeOԞЃ_#ηK]M'8+{ćNғ_ߧ's^}u/I27A~ĤS2~_l|3WɏW|Ԅ?*~|~ǯ ~*i2ju=՟A>\0>='C|Qxi{Tnco"^E_ӈW?H,4CwU^>95>F>/ۙFYe׈hz>a]O*ϯTy>}/c^ޗju?Jjv=?̇<+;2/k|=5{ߛ|U]=/?/iu?&OţO)~0*= e݈'V_Oxۯ &xy<ω+d&_y摿G fwޑ?=ua*or&xx)|(xdoO[ OO͟3#_ىd}6u݉1?uG\=os'z.}aW\ϟgV}~/~?iu}o? <,:/.wǗ~* j[Xo?x_:+ȟz0K?ԏFS0C#zoX%i<|-kl=Ώ ~?Ƨ/).Жӆ?ʶ8Oz~l۵##vozǏs ?~H{z+@*:wt=':q#{[o_+/w/qW>׾޿k26D7W{ߥEڹ'W兿~lUR}O;\|s«IԳ~o)^?4~~&d _d Tkm[/GO_\ɧ~6;xϭg/SydU9~#^}ONOԟ_Tow{>Y >|OO8(J<^;_{XrӚϘxG*~=~+7}S_x|xRa;z4/sW|w\.xw=U~']훍|$[O_7T{h4'OD7[+x+a5tj,CyBg+rMY߉p.kO'^}jwGomf?|=u?sW}/t+罏sM<`W~Ε*/?Az~#>+Be%}H_XwG]g~*UO?._Fa?9lgx^Mw=?^mko8MwoS_z>/UXK =w{*臚wΟo?x)T~__*}_^B͟կz[{{M,xDo~t'xKoq o3zݏ~WGwЮ;z>oo <~~٤/<?` <~K`UFvڙtOL}N7W*; _jB9O->7 =o߮YGhߥ.+;캎?V/[n}.=|6#>.8W?3zSz Yoǥ/YE~J/uW?YbWa]?W<^W^?9X}Ы:ϠW_ kz^1ݴ~8Iߎg~/:z]N~::O@58?\[|ثG?i< }jo{ד^L珞r7ފWQ{v7xn[?zѷCjo?)&z{W5ߡW_S z3zO'WOzC_Rѫ7#'P䯮d3?dѫ_oC~B~}?j]OzIzSB~pW?6/b3hc;]OhV"Py|/՞!,&Ojm_a$=Ե$}׵xE_V~v{]8N_~j6Z/C_Xx9kzB(wW^S/ AS zG瓡|U~OO_Ы_G~+qWʯЫw,7W_z!зW&r>/'w1X՞,鿯 vVu'Suȇ-uȇ-:n?q>iNDzFp>)|p>~S3 _T7=j&_o*ph|zeSD|^eջVz-i՗*<߯W˔ lu?U]O ^>d6޹zG뷡W@L =\MG B\ ʫ+V}]OZ,x{ <^x u? \O,x_Oz_g?xV|~'.}nwC[mlM>;U]OMO <>?<~lkM>Cϻ_=o뿣G^G||x?YC/}os)oon T;\Gw?zE(>Ы?[^QWj~@Ы?Z OOU~֫ԫW*CAz.Wqп#??w=1Y'tN-7wT|"Yz9@E>e#¯h?o-O{D5^w=o/|7}>'KV'-:T]OJ_WjOo]i>o~sP{'&*owjL|L_9&%x-y[x~#K]ʷbgx 9]ۉxKMVvhjocW|'՞33,N YSCO6Y xe*RBO/ǦV_~'xͧ_}ǟ ⱶL>P}'W}ouowٷ<_ gX?-<:tew=/<^'w.mx{I<~\'P&7?:߃[/`ǷW" Mқg6X79~W?k+%/w=;6']no_BؙCǬ|2u=|?F~ T__U揟jOk?xX ?5 <x~oG^?'!qD{*X?j?W4_xQ>?y[_ǿnG/?+~/[n-Ǘo-xם߮/!]K Z3ʟdajf`F|s?o~p9ڳ!eMR627%_xd|go?}%xіx|מXOTxxd|uo?0xwURUYYj4>U"_}F~{] |sM.|z?k~ǟT;WsS^>9.x9}l{ԟC~Cz'Ew X~Kz]}*x? <~K2 <ޅx_wVxɴg<ޤ/Ha`w㭞?CoEA/>Ǘ^'x(*xGWG?{"*O_~c[eO<Ǜo5nk|s=/~֧w=?|S'w'6K="S{|RD{p>4WBi^~/bBM0/{vW Y_wI?#󛩾S}z^'>W_^|^'pC+~xF;_վ_Z[KWKOk|,WȗoQ]Svw <~?<~+x'a{>{>qx)>!T^_d!Di k𷏲'c!|?|իZO&ۣ|Ww=ʏC?uwG?z򩽃Ժ>g4>cwW03K/oy>1';O@G[ip?C:z'vĴ?^k4e;+o3󡷢_Vo`??xlTGϧ^j'X}?2(?|I07i~m{ogoc'WC6F>M&:8zSy/I̴ӎ^WsMKHLc"_ '.|ѫocK~W<Ïߚ$z*~[w'G/_<OqpVuSE>)CRߋ>H|X}ϡ^hC>~9N{Qkw~};K(>FڡoKѷ~|>Ïv]0߅ =S/?|; \Qϑ'NyMϏ_U7~|S<Ï/>Ï;:BK?7}{0jowc6z~_ߙsOG/+gԏ w ڿOS/w7'~Gȧ3d^s·GGz<ʟۧG_[o= O7]]t>~x(~KM=ȿt}uBSy E'^8x<~~ e/7]qp{'WJG?P>a{W|W=.{Ww_J)YW|Q}a*$u!Sw I|^ Qza'.ū{׿5q>^n˴OyԾ{>!;4I㳈/,S_כ&<2K_XwM!*c˦OE|x|ʮs]S21ͳ۸mڿ߉j|VS?C|tx_?bgKEY_?*'7?W!x爏=s~DSg_etw]:RWy=ˤ>$^?Tyjo'ySv|/ӒmgOIn(=P =|v}Wn_=' o1 Wͮc=Q0O~O>7^<'?UnsP~g79HOō|_qS>|}a?%Ij'M4?i:;<+lE9뉩=z48YO?P{rTO}Wxw?:[דoj_O5CL;?ϲ{7j|&Gd*ㇿ/>ʻɨ7xOzRzw=9w?|O,'Ȧm?!~)[ǻ??u-~||?|XO<^˞xO<~do/&5l򍾝|O/o酏2&+;ew{إoS߮7]+kzwxՋW4?^}W_ԫ7Knd(&g}w=v6ѦU_$?pW7 ~k1K!cO>w'S~7R]S[ċ-w/վ3*І?ϻW~ ?~~7V|)=w 8;|sGw|uG˾wҸ=0߻,w7%?Oj$k&ygx oG]sm7g|Q}w=md7w=9??5?Ǘ#iWMnS?xzzŏ@(Ɠuwד񥷶'x|bbǛO~Fr_Ote|yّG<||G'ޓ|7*~oO}oSK{=cIRyIڟLgg[ ʛ'~CĜkOwCM!>Bu}TםHY;ʿggOv? bz)S)= ?Bij|6Tj<~İ?{}ד[M>w/l3Ϲ9w=w/u?ͻ}jd~ד%?UzS/Ǐڗ"uY6˶]z}ҏ"kɿ[ M,|{2}g2xs}{@?ۈӈ)^9~u=#^X/|4IDCXOo''^ߏXO/1ɔU]Ov8W+1up-Ҳ`d_ Gד؁ /AƏ.7V_?V{zr?jW<w[^CS^9)_;\ݴ|]o{}_qM~2rדxok^;?#W~^IgӋxzm'^_zw=|\$>xR|v]S%=N<}+v_Z+?_}j%|gl__W}+j_AN]O~_^CO8z:5V|ƭ6ܩWBloʿxOTǟo7x?|?~IlÏgB!Uvx|l/eo?oajw 7ሹow]CK{|o]W[|rTDԟ _3?=U6]6[eSy =Vvd'=П|wUy~}8ͧg~z>79j7{ .œm"u6ԟȇ]x|+|<<<}_vOzRz"=}"=߉IR7u֧Y=_=OGfo]6 + {'zړK]O\lE_l 3G$?x&?Ծ?$?^ʿxWŁ)ǟ7j yO;G~cL#;Fmj|RoM>M^?V`v+_7xIǛxiqbaʹ7iLc?qP|NO;d/6y/ޖGC?BxOMR@؋6omu?zD{r}2xMد}*?d/g?b=Uނ߱տا|OkooMWu4~b*/V{px[qŪ%!$fɗ6~GOUezb:՛GJ?d~>|F7Q33J '8Coǹ^ 'ww~D8|cg|Wݟ]Me|W/WOw 7㻚;g|׬w=]Ks{]߫73T},Ks/8O=3wϐ=p9_$?^|c6q,3'}OߵwեLHeoz|ǟUG:o*wI||Kw=“ *_Z']}'7Nlg~ uԟtkF^K+Bx"/ԞEȩo/{c?_xwW~3,oVyN~j[*ߙ{q=l]LW}/T'jgwuO]gx|wmG jhzRx=HWzb/8r>Mz Ѵ-IW{z'g>[6<~7~ߥxĻO{#]s#}j_be"Zwo7T=T>?fzYJ{a-޷߀OA<x"xrg뼝x]}L]cwUFoA3TrDW' [3Tok~ 6%5^_5B~gWR׉?6};gC >||F:ㇿɿT;ewowu=w_0 }'/L<Az7xdvW]6S[]OAXgGtx|+>S]OxoWyHxqr]ğ'GR>uU?MJMī_6OV ~CޏUOtON~jgYjO'5^}}_[cs azUv׈P}N{4oy6Ox|CO{LO8fsHzN٤_o <~ϻsW~l󺩾=|$)uKU_h>yI>GtzD{i0|D=ד6^Y6Gg]Y=ɏ9z8zUO8?'aW=㙛g} <~~#86!޵ɜ=~ q=19+ _i _)p}l)|,a[7b<?[R:f˞1]lJ5%=;z?#~78z]Xvo>cb$~W æd~)|^׍8~V$|zt?z}nP;I=OI=f}Gzo6Vvw/M^Wo'v%Ɨv|_GNTS󝫼NW)O|ד_tGWe7^zɩn+gboi||Rc|4]w=O/uU?v꣆+|To} ?$^6NV&I1C t/|U}C WB=z Z̯5~awK8Þ~퓝!i7 0lw]G21N?˞OԾJ5G~>G7/x|ʆS~ʟi|&5gR^Ǣ,U^x,)g]ϲ_UϨ?ZzglЫCYig~h]7Mov|c!_{ I'{?xOr+~,C]G ?$[׃8?SxInԯU_kz)a?[*/~Ox>\+Ď#g!Uz5ǯ䗥p]ʟ?g%VO ?wzf}+ o#y_~OS aWss~c_ >|祰?'{w| ?^au}nن}_hv~~Z?H~[|SXOR/'[Sw=] xovk?ߔ~DWR?"{gt}}cTaW ;O_[,OSև~D@]$?PyM>#^޿Y~|Ʀtgk~wd'^DlG/͗iO~zI;׫Syg<~~_G#F 7z+<>]q_:l\4]N~Oԯly/;;׶37 {.ca7?ѰGr ߏYɏ>~W?j~Sxa<~/xtߕKϧ+_Yx<W<~<?χk+?Q؃.<Ϗ}bV'=D؜g7o}y=o?az>㻪|g4^gwMw<~~q<?W_F]w;ũVzl<].? ǟO Mx/| ~y밞zҵ_[yU9yK?x<~l7y:?7)gu'߄|g?5NV#'Kc&WU3?y<7CT}'&~ Co'6Ngo?6"JԷnu]6Y6Owɗ&R|ATr6^;8~z~ple_ O>׏kS79v/77kx/7*ȕiҶLK4|bw\I\+LssÊ#~&~s㻆$I{C]vzꉅ=?(!U)Luϯ@ {D{}OL?~ZSoğq^im{O%D>䫄eo ?>~/ÔϨ68C7x>14'WS7T!~V_׆~e~z?TO_+?S~ ɮ3eg<}hMCxzME'3ž/>+leLG|-}f_?u.I~t\O_xxAbw;cjO$JX6QT_xI'ϫ]_"/=< ƟU ?lW>wzy|DO˦<+r3tϘ1x|?R^-sW8zԪ3=xp@9sc4)tK<>a7/xK57_y+d؋N|ק"˴?_{ODuKmZ)ŭh/>PտUg>AkϘza'Q]x WxÖzǃ(VӯW6lwz2j?];åz$Ou)oj<{{ק< {<&zooOjMZoSAV-x|Sx|{z+Kݹ?Yҷu?xw?Qӧ[~̇^Cqz= ~V'HY۴ѣ{eZOCa͆yv"mWxxZ_ c\W~ROŏeo?o%eR2^x>*/'˚q>i=w=G3 ă/wד)N "fS%t}s~Z48oi7}kTOcTIW|o ?<|p~xouH~|w]x _xx2W/x_4_ǯOW~ GI~VW_Tŵu}TFws^|zg[?wxܚ/gO }|y'M7+_S;xZO%><'^~n? <ބ7x^{>:Oǻxo}{}{hߟ[#^on7i?_,y˷kxWx8ȺăTzbGxԞkzzܬ',?V 9ewKg|cP[d9p z_7O\-׳8?YMc{Qd~I;4Ud}b]_ߥN:??g ?Nbq4M;i<9g8tMG\eYgO9wGO DT~9w{=Tg!LzM6tw?#Oviz1xOOv)3?^ɞOtҷ3A:xZ/+?iج'C ~|Igr8?]x/'Kxoׇ'y?{;x߬WsCI䳨|O|_D"\mCԃQnO5q>yG}!AVv_!y'Uc|?kjOC[T_3ooo=dxc:xמ}?[}lCߤaxe>lxejB~^tiOϘy>i*?֓c~޿ϳT_2Dʏ9ﻞx{뉏m9 lݟ*K_Xj]O#zko!|#{raB4Ǔv;'K=?]k|uO}\Gގg:x|I*/ד_ǯ5(yτ_)i ? = 3Sxz?"?7>N'VVPGuS{B-&=KWk|ѫ7:xi/ǓF)VO??񥿄PR$fG}u}F{j?ן[qzc]s^їYXOʿ/>j}_GTGHzy᫦<&GO?_]?kiGw'F1~< OCzY<~4Dɝk<'󡫽xO1<<~ jxf#y>#>#q3'R]Ħy&}<|8[zTKA41w=9XO !S]A)#hc%*{?6ou7[ǿ!x|</o㟿<1:x?z_ TuC~L|Ïɏ_o?S?^|$?^< φxw_ڛGgpkzވǭiğvj/%Aө~*Ὶ_ڳ<^a7_6K]MnCRT]tp_ZCҮ<'B)4i=z3Oѫ'k{ٙ?R]>.|=ȗx)zn?W|a{-'Wss;z\>"qݿmu{z#Oʿ½-Ͼ?f򗊯ݏo/-<3:'y/~ִMQ>Y6[7a+ۃ];_F jee_0>{O/H~<+Ą bw"SDxǶ|sN*gijHK7o9euUd?Ïc} ˩^b^xk~#p}`4TR^~ߥx?g"7Sy]/Y!F>?k߁ߦi_.-|Mw)$Ou& (8 ykUh>]]VׂKZw]w|DO"po] g!$H#~i:$EC47ǏȷX?/o/~CC_ x<҆>Ї(xW1xFXgT>ieO_KM;=U?JPU<㧿7q)a~|AeXO +smn>~Soo?>d}4Mhook<ϯ|0_To>TUx/{1^U'_K?x47*U_4_?i|r}RxGЇͷ?V{?qZ_}=^E=t帟=q?^\? x x:πǏ֏ \G|? []߰=/'?;· Ŝnʤa;/bC7Kq9~]M{&zz}9о`na7igx<>[=9MsϦy|Q W.5|O?G~=Ĕ_a7գBb Կʗz[T~_Ǥ ~~O??79xWSi1_7|mXWx[PmoIK?$9>o f <~ ~_x܏NxP?O]SU/Xە| ({~oǞ~5=K/}x+ <>Uy g_CsQy?~ig޵1煟HS!7#y{^44q~+Q8w:mz[K Kx?NL#6}nx# ol/_쿚?L __c|u|Tѵ}+%ܖՐ+\x!{WS +*Īo`g#lч&hϹ*}vvlَ*G؂&K- tcK>tIӨo~ݸD$$dKE [AvN+Qc \*PeC z - P prO_Ɨ.RVӾ, <{mձTPr>_A[]Y۵-+膮_V~=Wԯ}dcBFFHcʞT T$Y%Xi&zDW%nPQO3= 쁨gd{ *#zfe@ӞbD=(+4c([q7R`)UKH[ k{+77%~)"~Vzً+ꕣ۪%+QErr6XiD6lWfD+7]SJ~P suث+7%ͪVJM;G8dz] nyrvľ<=t G{ y AVW/V{m' mߑ=es("AZoHR k41u׹c,'c= 5*`b ar4VXHJŤܟ5 B vm@S9!Q>&0֞$+oM$cqW'>?'wI (diE.NJoշ\n z9@G6Y9zpOԒOX s]QBx'^~?=4bۀϘMz B S/SrTzI(e=G<&D=s7ڄ'T`mo3Oc\;J|E} dJc1 V)VØ -z V[߂Upr6> zZqYLNkA>wDUpCp@/;??yڽ^"/_Q7cuh_"E V~$X-6`K]$-+Puj[y߷mAg?[9z؂V,[t˰QO+-z, Y⒟;;RQe%Qo"'P'S#8S!prr6o7K'MM8Սcqpr [@yKjrLsI?^6b ' gaNy6d`!jZ}cAg+BVƲ^P=> 8oYR9y76 V h ~MlQMNB6;;~aܳNOkT\$$CiC~VgZ|ͬMVAylh^MNTƖVRK_ {UZnh`Z=#نߜm>o QoPz,ٖOUm!g^g膨g:KnЀs8|URmLI]~ժ]Q?heJg5C^EVٿr\v<9+UܪkB:lZ=_mC/ dC mvpupF:PllGʥYQϬv G*Q/z V Nίz`1C,;0H;00t 8o j-^@gQKRPpP eidu &=AgHз{ָͧ9pЮ =q>8a fHD]2Wb~r38D=]!ecae37Sd+,;5]݉$Nꗜ|Edb +X.{1O)U옺,;&S[C9} Hظ 8! =0k- CROcEtAK ~L.^рpeCp8,F,ke aY:`ٝI,`ٝ V&z%zE~89;K>z,J@?TCwXX|wX(;죗aIOe٫Ă&,ΧڗIK/<¶IXpeF,;B?씮XV dO,;Y<*Nv`ٹWM Xm'`YFaYte%J۰hb''z ߉|6v# h3 Xvo3ڀO]$β?I6TV ʗㄓ\E.==EbD5z Xm`5ɪv;#P1lCXilPu,ktaY1²7e!7&$,;)E ˎ~>*1`ٕ=uf$M,4+<0+-FWKvsL`ezXvE`)iXv@Xv 3uA KN= dUQU(XeP²)!+²sp$NXUℭ%lu[=gm :vہ{YI ywX<άNXy,Xаe!\Q eX0?=LeQ;`X0wu;`NXMU |x',"3NXzb^KXV˪W&eTdg?4q&Upd8aFS#8g#'d'㼈wcѹW!dtsV)XNX:&3yicU`LVzf;,46ԘCeE .Ho',rR}0J>]NvrWsH,jvWt,{FO)02%Zi^ ɗ?:`eUe^',KB',eY ҘeeKš/CvͩK/'n@ړ͠T  2OW  $20'vXVòOaY> ˲:}^:aY`8aY:²e ˮ*^z=РM 6DX6 qree[e鶊 w}5f%6tF`eH%,Kj,{x wgbGa̢= X0~`u9jOqgFJ֡yXs}x=%,K/',;%|Lpo@x Vz;3=/ #iXT}Ic="z<$6HVM #.pCU t²`Y^H*e젱˪t}(ˎFie̕k fiS²Pk ˮnީ~o[zqA4W6p,3=e;`C`,{6T=:`C/t J$XJ)H);Y+1PaDˀe28aY+²,sN;aY B"1J8`NX`|?)aYc7>"a4ޜ P1&vˀ[e,ˎ칺~h,;>`YrJeMXvd/hi{egXj~b²R>\ bu XV@A$HbB,qa{a7W`!NLşa,{`٣XVa+,rXV!em#XZuGguK~pb5HEVc`욜::[>deD+ (60`j8Xv82v$7.F8{F@^dEXJA l$ЖņgU̠e:k[N젏 rUQ~ xrV/ݠH5!SG$< *e7P²NXvsek',KM#+U˞Em9I=t;wX=_eO XDO' ˞^VBit}qǛWdUZ=39`٣c9=U^GX/TWio³K;6 a]/Leye W &r-uXv2a KN ڜc |I"!<8@ǩտ^+:%e ;` ,{W77F8`Yc}V,k$`Y5e8,{,{ec졫=AaK,{tzpBZ=dlHثIk9O\[&!l=1o6Ȕ["SC$Tq4W_wg,]ѲZꌖ]/Ư{䯛 M6t`V B@vsNz>scWaY78`2yXv0'#rJ ZZ}LpZlid0$e'Jd8;@CnXCX!NXV`aYr²c14˚ e1ȫN%VwzO o7& za|zu 9`#k`XЕܸ $'gA:Sh)ZsoZԳCȊ^4Xœ#rXŇH΃wM€(4; JI ,{z3͙,~r_Q?{2qXC%`A)aX \.x< X 1XOQ'eUN%fDU+{5a `I܀rfS LQ,;ۅ_ڢ ²e Fe&ehXe 9AievȊÿe,k,tN>yU5)X֘m6`Y)6XP XV*SU,{vo„ݲ^2 Czvr,be p(e`hXV7/S#zǀV b@gSdNzlI9!\Q0;>B`gA`ه1X, 3`ه xY\48a Æ nB$Ѳ/ eheXX/,k'z',͠.eEEuڑKuڂ,D~I- Xִs,k  \1Y@:M,79}UHNƺWe9= %KO +x *c+  $XdIcv^9HA#L~AENR ǚ~cm zyvxa=|,770X{+($ rA<~gA"J m[?vODra'ff/P3L2lx毗 !Bk4K+vO }zdHHЫ%>2.}dM0%Ǫzq}c A1& S2x2Ew$~:Io*ܔ  Jl}9'Z6<֙9Rq.en$ 8*' 8QQ%:o7 m4H kW6IkqpWԛ, cU=Ǫ q5VU &X JY'.dc]D="d>xa{ {^cxOdZ Ƴ6-V/:d]r">HpXYȁX2؊ը0蓀a5h^pQW«LwG1,3&Jxg4C ƣ$`=Wٸ>(<0l^+* 6f7J3`U t!MDBaHQs6 6̑a> 6hLAǽ  L 6f`2Zac+cw'W5T\d+hꧏ u=AY9 S@pN=e{%|2H(kVSSww{&KY0-O쟚[BecКHvsHۮ?eUma.,vN͂ae`ضfsQςa~zQ~sYrU×oe푩,-g#u:dRgMY0i5%s^&;Ƭ.MJt duu  %2JsXl`XI0,p0-{wl^|yۄ݆sPw(r>{J^<,z|sBaM5^0ew6v0,av +1用=r;Xi&8+gcZ5FQVO6tEg67'c ѱ{\&X#@chJrHP 4X&yhɹrRtDcYM%ƞ{›@cwZN> C\c$&Mrf5LRsFV>3Ew݃TpS$\&9ӕXktpXp%f]X|,46X^)Y6m xz~%V<ο2>ht2--ylz6lB V v^f*"K\5bTIV/!XVdH@!-l00!tH@l2~Mm' -M% d:V&=l.`η 6%MV VeBʪՍ+qy{NKe|{2xV嫑Mf ^^P0ܬ -6t!؇ v5+x!q )7`'/ vv9N^vFo }zjڽb,\X,MeG),8 3^_=H ةYɱJu= &9Jq^ro&ʂ`jZY_֨ -O@I-t@ ؐd+@0,w#὎|wʊ=+={W=!\O5քـ`C @pC, R']$D j 6h"L@A7;'3$9{_]Q,6H >`SNAW2<"w]p尮Ldd(Jӫʏ-z9+Q# + s BHМ]Ȃ` )T&?: K_jh2v/ GFlr54 KB|{Mr54s+|^aVv+&{ukh2%w:MN.pU]\闖~WPSwU 6uOU僞v 6t5Gu/vV`nyΧWwfH@8+맿|d%X@ 驛`IP@2 6H0CZWhF'a7V`k)`}":@\kٝ\cki5ƿc^VP!: $ ۮHa$*7bY Ŭ*7bn,$7b7KVnIJ܈!U^~ ֙(v, ؖ`z}=_묌` eK@, ֳJzz> $ xzpܔ;L@ WN@ ؐ $$5l8&*$ dYLh"30˘s^^pM6Vݼ&ఛdz7Hn8 nċY知+M-ʂ`tY:7=W;WIgy۽0s%/']X򄨷dX'&#Gl잫`&Kk,`V;9e%Koh*hf>:\?K3B)EpҢQaޟ9?h𫃭h<z;RPDG9 =` Ytz>U[ Hȯ! 1 >|]'4#; oI vohF=\E>:ߘyj+o< 9/b*E䡟wѳ\{dt^/׏.Zg+?xV);P5,K C3$ԗ{ېho;? ?5@>>9n*Sweh&֡9{ړӠ4/t)oú  _@"v>EҒCȡ?->}H)P?%O?nW~us.0}?Ϣ7DxE@_џj@~΄"G#~FѯIS9r"}oM9?]z=)=<[Z(UnLV_|-~aox(&r/\.4mxSr^VA_ty;=8(k `ΐfTSn0GJ/4LtZ}!/V(N: ѓ y M f% +ڐV{"p2ԦJSpf;/R#ehC$ZkH0nц~5|= E׶\40vtj -MvH 5dc}#uB>dVѰ %CD8 k*K_.D qy!X E ^٧}ɝB P>坦tdAѭ DzXPJE~5󾗉[ EC_bޘoݟ2ba΢y?(tKM-YkRV{zULyZ^yH>՟8x-cqx]?س~?C_;]4`%3]'|گCCw;sÞZ/D{j>}!~8 LSS1JcI!8aqtBqE#H􄻀 >KC7b _D7O}ϔH[(uwkAG_T{h%R xW.[';>唝R ޔjrN~ٽbѫpיi)u7qjm?9[it-/<wg<ޝ^ܿD]7B[ӘM@=~]JB@N~^zR*"mk_}۷.@Q4Χi\:ӇA@߁Ci0PY {)<?j`Y:\?lhчS>/Ꞥa~~'ާ>\\ߔ}N~Fz?/~E/[zo ~COGz,ьo@[90 }o/=|ӄtIm$wBxCϙ74_3o7|/xi~fr[n }KEU|ߗ]e^*֘٤ůiSSo]^sE#}-opM:o ~vi|x%y_M|EyXi?0/{!Xy_R}.D>X( 'U%[A]2ms?LV4:WW2`_gsf*w4=p5,~#csG zθ }u+:Vl\o5q}+acxq}`)`esOz> Rn`) Ñ tIBs|Sq ظ~6.Fa(̽ԟr 4ƀK.K\WG_p:>Z:Ғa i-26]K+/sm\3_~ebToѫt񗍋aEƥ6.E2o "|go6T8}}w8 iMdw=5S cu$*h|55&l\Cw~k:>+Rʾ_wأk8az'if> 6)gb%c>!H'2&L C;&q޽4(DO`NG'l G'h?aSY=2rpxo -~+xKoͅLb8,{wTow?{?ޯ#$4_}+>lR[_=K^&PQˆlVo¦K6a熍{3F_}*EʻG6.bɑ;G_p ܣ 4lRSWw ; / /]10/.c[|l۾#9|8rx6 `vY_fxz$0iѩL||~F>WABgsp!)"\'}?#y$N9j `0 8? >>OrGJ>`sK|O\J0J9Edw|~;``*ZtM߿G`}GNo3/cz/gX߭i?gR}+1x( Sޗo|[/@ `>%+djo f@p9}3%T8`Qc!TwEqrU=?U>t6!0xկl7[çi$>0wð'}9G;АJ$ \ɐLA0ػ5 .d e{yW.{c yX$P|]D D8xIRIf%/G !YJx xL~? ,ĩk X姺 .U/zwS^ϓ= ? >]Kq.E|]|;gJ}H/G 1c88{&O͇b1k1`I{/lMqye~0E(G; ~Ky ~?L#|K2IxY}Ry§DS!3+fe0U#}oV`x1f79&b ]YV3#o{/Tp D![_K Zd}A0Oǔ<W`b0g[| < 6{g.djO+n dBGNo9< 8Zs-1K0|v&H(a\_;jS`Й_= _͛zuXY{|+GY15M_Y}\ӿkRL=H1/ڹg Ν^~O+,(+ <8Iϛʉ+`QMQN%=fA~|&px쇈O,|B|B|P w9go. 怞RUFC4-YmqϚCimC-~z GO߀bu~Lƾ<}W2ܢ'j"}tylMoS d;{l{[EZX2pois/_L+ڐ9*œEjiTkzߑ+a깣2R`Df-L*j $v O%+d~)z&EO~Vە9d*K@JnDfv#C)%kl $i/ d~?JQ0#P;f6?j9 ZJE#Fik5 3 1!?o|4Կlp!C.{64=h?#C9C'ޣVSpI_x{?kýbC~&c0=MSBMÄee>4?92)n&~to~2/gN+ǯ~\r12oR\~W& ߧBB\B\;(!V͂+PyWOTyj.Ri^4׼!KkںqgykZP5x$/B pY:HWye>%~ ns[_7ͥsX~LEigpqwzqSh˼,~D'~M@~N|=\˼\zƵ=l\^.ڔjB 熚%wlj?[|lo=[IȰnrHn.!!B A_tȨx;:zEC|Dy )> KAxk<KׁRlGC3?\23ڢFg]$!ѿGmkkB|*/1/)|>[Q>I~Ks >J0OVӇ!WǾ|]WWIxNm/?m@3s>:u;s+K򤛞l&+dv4l[S3{_9տJ.YO4[4ޯD)3 irK s˟ql.ӹw >˫iƄ{Q:/jXp |R,~| :z&|*\ss{4 ~_V ]>)'EXǥ>K@'f:|{L&\E^'{џ|}^4S=|鳬]+gϑ3O=g0{{=}k>޵Z1621&?߯Ç>C'~GC*/D+ʓ3y!4y!۟^\3ߗvW Kigm+QށD>73%j(񈆏_G?SKaz3?|?S4Sw $3K|~g4i$TCe,g^/?bPl){~ >zCϤ[e0:׏s4!X_|R8 CY 74O$P^Hg"f#rD^)*߾ ie^~bb7Y>+/3|$e)y}^2I1|2bޞw|1$'*y;ޡ5M寡<*O<*=>Q/QtZ)Qk;YU&\)K7`::y,]Y \tN\t)#Zt+k-XM͗f9諥3jsDk-WwWwJ+Vi}ѩ7c߼O~wO=(2O񪽓}{tt'JeMVͦVJſq(ZRtͦ2[?0ZA.wSݦ#c$ ?"郌u*(rTQɪ=) x~ )=yfsZA{DGѩy~Sɖ{Ϫ>G KC>@۲ķ;[>߲, [Y-$~??1"F oz~ϓHOyϷh$~ 2jH̗A6qKb\'SQA HT4?UhX@GBE H|gX@z=OxQ7? *\ZJ[FeRVLw?few4qOM,]QF(M_>bTQJTD=ܛBWŦSqq![~?rv鞟7tB?\XΦwh9k3㥿_z~O>oW@ⷢYQoΥ H~d 9[@;9į'W-z-qM y2Dy2<?3*a? N"?Q Hh}H&E CٝіI Cّb\^˥xwC@4,!G'=H2N!:.{WH4Aw$˾@O< w=g=VM[_#^'3E8$~+buߟ/9d8pb]/){{?=Z5䪯zϺρOb 3wO[;{;<9;Mr39\tH[Zxrp~[Zie*;J y &HyΓI=d)/L#'ߙ?sjVsՇ kOWiݪ>ZVK2{n?rB*[c#z?rc)w}&м pjLe[OZ2V2s*򆛠a{YAv ʭ2A߽-^OWEqUiO?2q4^UYuxZG\oY} e"4r ݄Dی)w[MS.]mT{_"3GpSat惧ϟܦ|oHٙa]3}pB>ynԿ;Q)qi>\V@-\ϯw_&"woY[@}d_8SrGl?q3Ev63^3;3^B3E73^K35A߭t'+o/}{׾C軗8A} 2E.RjN.RŁyǷcߥ?r)tqj"w n JLKߍo.ߔ[z'yU9jO8_֌o>8]dCu0鿼*ݞ~#WxNfzZqyU|{yUx8TUi?Jz_pO'.O3mIf+};nsx}X?ק\֧h]/o}ꓼCXw)Kx?"G~Mm}?o})Za}s-ɋv)}STy$33n?/}wy//w_Off[ _{~RW,q~P}%+lc?\r@z?77Vo|nn:@{ۯ=s|''M4{scuVｋpt}Ք~={7ȵuX rהՔtk<2wo~sVD˹귉rh|2IzS9ã@M^< Oǯ~}4}>Nw;9x9-w7}l~4H9'Z{P~t?]&^:Hzyì8X&=|>qOsEV/ s!Wy;ܗUQC=4:?!7'sv'}ݶb}e'MnɁ>|85k\^O2xVыL|%}eWT3woOt^}{,.w}7y,wS}o7Gc@Mщ t]<%s9\?w eRI+XZﾞ>O/'GѽߧOq 'O佼IȮp YwO}[7^TQkpe2꯸(抍tXlE._O>7__C3r_.߽w ?4~Qy/eͷ4#U{?i?ʑ_1<~ @߽M@d dxggz}}o>!վO~O'yzT_?c%ޘNi#w+kr?gM'ʉ{h5kZ~{. Lq?Qr->fާr1Eڿ9M9ګOǺ{?Q=O6=^.|oTx?"O-]N UJ6 ^TV/p RNSg'ۍQ%v%ʨ`վdWY*O*jY?l*k]%J/ ^3Pj>>G@7PzX묇5JYs>| )o[} G'-0wܵSN{WW}~^`^}]70xoݴ?~S{#u{?iG8?gr ?yWF'?~2j?$rX_0L ~ 5|T~@s7%?/w坸T}>]Q*u?8_}!֮%c?+s'e>ZD0]aD|2zn}NM&TyNt>hO _G)ehx;+MDqD6Qthxy.[߈oQ[DH - Ck[8Ǻ2t֘n`[6q*n}^M/ILk?'wXnV1M٪W$ofI?^.ˈYftUы |o[b41&~R./\]兕Kb _ Oa]?kN^+QxeY+J9VO^z+Q];QxqXDJ^l j(DsW.>ǫPOXs(|\»s+ttn%'JK)/(|'o_W rTN^^*U`Pv{JVwJ8fd YV=PSkeeZXn.+V ?\]*PV>(|o>D&f&ڛ^]G&OnbM)W.[eymP#DĭR7nuT}zܠ9Jplޠ9?qDzpj[Lщ㐅&yoP duڠG1h|7(QJ A?u^V.yIO)IANgsKTꛨOa=߉tX롩 3T~xuk`<~&71.+"Kߵr}%mPs}%eb۠JmP[JA{(|'N'(yOq<َL兕kjO7(a/v~ʸAᗼ6(ԭw7TMN2;Pޅz'OyYV(L=_:]-S ~L}dOiz&ԥϟݸJ<>MMuOJ~匬Qy-}JV6(V _1bwS ?9)|oPmP-T{oElPB=1O?1vW61[QDsɴ7Kb@ g_Q?bG՞L}?MgrΩ'D/99`8Yp oS{~27~z;Rl"8}pګop*;҇"8?8ƏԞ1š?w?ZRwd8;@x=@˿ٛjhF#VH\;~4&] '* 伷߻7?2]Tħߋ-8f`'}mIE4ݔn[^`||7Q-n׸e#wZ}7ߣߖEڳ3PoU}7NslKq 0~wҹbI5`mj(V}2|$8oB} g憂M|'f|.N `?TůdNv/{,m4pqFp^~:7Iu悑;AR]IҖY$$s]VIwl?I6ęÙLdW-a7fO||w/wMj#z`b?62@STs~䘥 y-T~,>X#OT|v9f|s +:K7GUS_B+u~nq^ڒ;z%"}Df *#%V 4m+&7O|# ^?8OY@ퟙE;|~S|N]ΊMꚡ")7@IuUHJ*ΐpmkR#Rŭ 3C43>a3Ccf(NpÐ{-Z2)|/[f<W0|w9<gRx%ܙ^TK{9إ?"P~sOur=' >1wq}IϛD;~{Uf]f<]+/|?J}oQnw){?OnkELzgw?ޗߘ+)ʀU;گ6uyN(fD S1T5^iJEio<jȔQLlc ͔7嗜~)>Jm|/ >\DvdK?dSyX*U}K 5I$5@KB_P v9*?Rk@ཿFkf7ys}|_e4%*Yr2/9clԆ~)iCE_8ϸ?%mojP6R56ہ&D:JdO9l`xBSU0sw9ol` 'C0dngׁs~GdWƹ4?G۠+HdQP{ux-`7n`rl"o~&u~0hy&5oPyzgwS^ە*kyjS:Xy^/j &]Ir^y//ߏv>g.wmǙ9Ts]/vR曓GTISsDT5>d~&U뒃nu]']ud3?j珩65l/Vy3IEJf}0{w#0|9w+QaFwɤior{9M07١\ g.i};MBtԚj#}SjS{Y/0|W`!).&2'3|~r &%r&Sσ|xWOe꟪f7TZ9{G%&tv|{>] &=Mc퇠//#uAǡ:oYoꓩMN=&=_7*c%?29_"w9Pܗr?}L%}y?q}BE?tJ~G*QO/**nP1Lwz-zA0|S*C0|lzo?w?)o.զ Mw?v?`&* ߔ7:M@q?irt~"7t\?_Mv]gꟚ9dg]83ᵟ0/N9 <{ ~s*~|-?axS0 Û0|W{ûd`x0.S0Ilw9aNOܦ PyT3[wV=E=d<`)Rg`TO0|׾̗~\%8I5*H5PL'_~C]Sp9Ư+x$?_|A~7ڤy^_x|>#gyfM|HI_OVɓs?o)Gg|y_ JRS<yJ9 nOB<UDU!꓄5>ez? Q꓄վ'}s#B Te*~;'T]?PW3ޅI*z>!J3_GyI7/`YO0Cn8DF/R/* _dqq`Jxow|b}i?\4_ݐ>ysbwQ)}ZHdːZ~wg*u Ca$~6T@aCE>$̪$UI-5Җzn'Lz oĸړaS3!zϫOdIXΚHκ;Q"GHO"uH$vDE#uCI$^IN"r;ˡ$$1'$$'xQDى+$?5|?\퟿HI$["J*zWH2O"K+O"rh=+ $_}T./xfD|7~$j7xkg[9x>Sl}*}dٛ?E=ˡ89ߝh+N .yZghcL6]uxvwY.O_S$~e$~s* $~!ėNbg.J}+@o%? {D+p@+i"9 TLhx3AΫ&ȹK6٤" Q2KSտDNINq98Aj7H"$gk?Y>w!?9|*/u=7D߸ULUG_'Gߑ>?'VwG',$Z·yp@WYA/iO!xўD t zKTyq3'9eRyi:җ.Wҵ%$'.4H|P&dAO"e9H${$rNS߃ڻ@Z=,QG_7?뙫=a D#}/KTtzSyJT`MX7,]H$~{-RoKLXnfRH"Wi#H |VpI&&3H.KHZ@hHVߢ; [4&ge0A-}z}߱7էcYjO _zH$d.}pU^4o~}>Nr"OH|2xtr?7$H<1H|!')'_{5_%Ui/,]u4YȘ}t&9,]u_0,];i4J& 5^AAo9,]&[d[Y_@hO"Js@{/A?}aR*?v x/yFD,]9w&}i9&JЪD9xI$^4'x{V꛴*I2yXXڳ篥$~+`oyWK)c%σacXj|~K˔2OG~$[7O?Q"WƳKߕ,%g% ;D2}òNH|Rd eYDyaHP}VŞH1|dҬH'#גUCICקɧLY7^8 4Uoe85n9Nd2)8Iv2@IMvgOfOfj!Xg W T0 T0#g"Ҟ2ꛙz)۟52)Ǭ52q(hG۹W`oWX i w ~j[@+5t,]CWSG6_Y^~ e6:Yc>slo9'M_8b-U?Qy18U=IfM ~ثNOd:iMד] Q%nM mp|eͳxr\q_ s||,M!m*'.) SuR~*Vi,S2>o>׫k`맶[L{$'Vc/&#U߯wk%O-IGҪ4 ATl9w|C{e&MLeko9¦8^'^[ D&ND!yXkU9XA</qE>g_\ZV{~{N'Jh?_ZjO'J/K/vH߀US؀VE\ ˪3dS/Jdsjۄ~-h-T{'dAYlaВ#ȵ+@Tu+yP>ɍ5Fgc;n|)0^X>{k|}O曣/O+:[nC̒_S{X5;^ı$C5JXXk ]1sJ瘙dC$W2K2zX+%h,ESfIF/ԦhdϤZҟ4].I5$'MWgMW7i~Ie*?i7iLl_'c? (|6(7Cl?T?<#~i/B6H=+HdE#kJV1^ >HSIv׎zWw]wQBM,g.*w藒MdK}VBk~W_}[ p"#'MLYy 2!T a}}UՊ|SyJ@nE[l]ӿO,|?ig:{#~U~3k" >`u0@W]u0$7Ӷg^Z)Ceא~&Cj]C3qhˁH}\`.NH!J]K]lIϋ?1)W Åʺ8T̺?.Z=8%uCR?.IV2Nj8O'w'c!D ՞0tyݿ7w#n$pw:h_ybʮ| {K,ZxkhZ#_IyhU}#+zg{PG/C'}{[IoKI}}goտ Wyrxx|tPK1t;5]_Ox/"'[GqTߎ?DO}^|qWxڿ»   MD  ?_K{;&v*w3q=Lڅ\5m WC6.M<+.=r9.;!V21&}'#CTށ.9Uj3UCuI Ww:ST)`b9lb#\rbl]"|giLQ>>LQ>> SWd.};sGrޱU`N g_1z׵Og *?=ڳOb g,um&fꛞKIએa8?<q^PK /qٔ#Ѡlj(xax?}J ~^IH|*QC ?WW\S;wT~_rYE| G.S‘Kļ Vi=rK"g}p40}p4ș'ox'{9RzB}^Ǥ]rw7S# LG,2|{rtޞIV!}K{8^~בbxÑkZ8/U,#5j~,-/Nj|'-*[G߾e*/[[weK^_ǞުmוʷU~ >ﯿMx^o:)3ӕݕ]t% sw{=7 d4ޛM9-֟%}W{GD-]f|Qʥڷx>쪯gg"ڷ|c~aߒ[ ޯ{YΗS\_ʍ?Axo<۟9#~ԡĥe``m7e㏞)H-WJ1gz&~{8'^.e]/>o~GSO :V~ 9%p# x?pSőc>c}1Un}oGI/O%՞OOVnrswc_ܔ:nu^x79r9)Q[޽^So-G"7[Ұ~OEp/_8~ut 1[e$1[e39:NS ?|{/bf7eNeV$b zO_8vҞ.}7Iљx{џxW#*oo}w?GM.cTw?GFoV~RDnOK\qux7wtwS WFqpqZG5w]@'xJDF}aԛ%oI_[o!ےsѷoo=#uZ+W\j$Sys^꿰O<'zџW#=iO"{zO]@^}y ?^\4ihF(7m\1Mc99DMD $jKGNv8m=B3KSL|Im"^RBUWaʐqYk!ʉ!O(}Lh(0|OɸzKPu1oj!۟L<1?='3zy~s򦿛ܕb ^eI[xOX:4'x!C|XPWߟ ]cV}"}W_ۿctyBwB,xKXE&Z-'kjZZz\9B]@IhkpGX2ΕK)DB|-.z!8ٹB~w-]˵nqCk3[xz/BwBHk0;S;|/ȍ]ο.f$C3d<5 ppᜒJaQ};D4}u?]ૡBFQ}2LOԯo&s jSt?[&[!kԕd.G"I Čj^'dúmÚd+9LYyp^7\3üCfޒ9d(wJOyY='!޶ަ 5߿:_rX![zedȸW$uP`#z~,i)g`?g'cH mꏻ̭z@\:D\jL!o'[IV2տf$:-IA_dLP`*/͗P 74>F{/<֟ o|0~'$i~NHV97ŚI!j~_r;dɬ9R2akWM<\ q]&D[$%|R })I!^Wc>rB)$B=*?P"ԣTʟj$*HBտ 0Wy+<Ö3n2jKӞkE *tS;a9^o.U\-?"*ICh7aq˵Yk+R^WNWkutʻ+WgrOWj_roVO']$y,}Ix\OGWE(8[[ɜ]oc?!ۯ%prAy!~uuS(TPx rcm }`!ou6k:; UǞC7oIX@o,eݖ ~ >7f]lTC}7⺡oZ۫bk¶zJFqT ]B3UpV-$ S×ki&~\? ITA!1|V%ޭ,~[\5kkJop{G_Ͽq忊wu~Gлb/BN_.9}}7lo(߰A$ ! +}w|bG@b*|>_M`yJyI>aQ*>ؗ]tW_"[wbؤ_n_O_\uju}35ǩ+zxi_Q70}.Zm:~}k+[H2Yo|"Iө*'s|{њRx}o2 rX, `T~~+/w,f2J3% #ҩpk8̗Epڈ ߔr)M) A2i=h#(nw?&JD'weOr Ibj_nnw/쌠wJ)3^l[z~dcmXL'/F\_fח7Y,{]}I`a!GEw._ܯ{_Sσk?IʕǕoꞯ?KycwR,Y,8}{]!Q:m~ثY~ҵ|pojVM.3~PcOBɇ[7-\7TSt$M$GT}{~`BN ,fS?Xj~Xz}Ah* e%wr«9D5@U?'2]VDy}"yd?iHO\MϓKxɴ}{-oY|Xgl <@~@෬6 G%/Ģ%Aj)^Կᛒ!'+?_'^_4urbDL[rߒ{{! ȧ1@L2>L{c ׽t |KU{#I2qo5gTUI!r+}dEw!n^k>M!?Bd:o6eKH; 2-5`O0_vҁ-n ]un_-B!`% <^?v%Cˤݛ6sId}v֯A3sQ +!@'v8y2i~#}|:^y!x4m"a7uI@Ҩ3G=q)7%-qKI榐wUywQ| \?f>OKKah6n>.}<_F.[2ђy<ߴP'|&MX2z9oTȥKJKyLhP\j|5`w[Z߁- JBȕ$(#WO9\ȕӐ+3ݧ=`w ߀h<}3~g寞s)yO$55#TȥCtӟF2r:̿56`W}ڏSaU}XZq͊DhkKi`|!XOs`Z:0#Fm`ZF@C#W*FCK#Qya꯽a>' $^Av.>. 25/ rLrycNK25M2`1/ESKgsI@3`Q=8TAKkX!4OS8EΑEQ,tL磯W}n29omi,~=;3qHai/s֛UX?MB.yaXIy~_d;QE-W~,Ch*3erлˈҀ~rMh@&[~ ڛnO~\GȐa%B3UBN}=~g n[_o@Gn ]!'!M=-X3ãFKBFaT;F* ] Z@_@!es=z:?nezOܨл/'лt96[ XQu*])cj｟~RPA9AwdnW^dj｟_2ͧʿ^}/8]m*Mm@yki]s{Ѕ Z}R9ի~xjOfƪc\{OGS&+@#m,|KW/ljKO1~rn<%|y>_1Ǐ+QK%Z2'@}—kGm@]FA<~Ĥf?PS ~Р\K U w&SڷڿCC-ƣ_G7&-~p`Ү́I|pT`^dk~k&~Wa znc|%F}ki=e4 lg<0G dj}[¦ ''JBD 6"x;;,Mb/X}4m6[8{4J@͞Imo%ckUzW{LyI_%C Qm[XSSG=ҽzmnM5*[R"_֭WVSS>,']ԽRy\|V+ק.}azՠꓮ\lu'Τ՟wSpC#6M0I24_'x/Ǐ7{Z{J}j>"aAS92F%ehr;ə~@sMNS}5{X?]ߡPpJ =h#ԟ3oaw\T 꿸M}p5_+4ߵrBUbBVybqkʿQ4b|@Cv}Xr?zOp#eqխϫr'-קV|[Ic*ϱ"q zлx{B N 'M] 'MCI%Ckí'|d+'5?]uhmZɬtj ZYrZT+[z-ȸrm֦K_r1:л %@4!z+W})mToCzc5k%?ɞIvklhVꟃլjvԞլ;\pթC;٫_ uT4)5׵UϡIsI|1!?]!x=~߳/wbgfwµ<}`MVڻ2ϭwq+[bϭkQd~Cj|Q3_g>5cP4\c"~i|ij߫3](wwyD~=^QK|qSj"W(|w?诿~AE2d4Om%Zw?rjɝԜ;Ra@M^=gn&EM)FT欧+G6(C !OZP\ޗ.}O p^}(J7r@&>,q)w\_Mnq _g~/KL{yu"mk>җܧ[fIDQWAnC_^}/ ey7 ڻ>fMOO 2\Э]Un R}_lM #~ #z>C. QWpK7મ!kꮻvOK ~f?{ȓл{UU_geH&|z/ځދqoŧu:>:Wl+dd9_W*9߂VOG?K&4ds\g+۫Ori\K\ګo?[3}gz[7wf?i=}?yO;e>WeI 'a*aU~MFq?)#)лL{ '.ƞлSzo*ozлzB&.ׄл^{Br ndSzN}TX'V.쐝*7⯾79W\o<6r=zœPeHF? uúy`-jz~[Πmߧ+3nFnb" I4zN4` kY |zc;XU;pW=<+ :bދ%Q3]8w+C;1ﯗy[b޽|ļ{y:7)7}Z;ɧ9nI>¢s+rxwvwP_w/p;Xxwc}\om*og{{忦3wX^z?>HwzC׸ӹʋ;yiz у"B{/gGϘs޶ļ7͝wL{s~yug&sʄG䙍>4ļ]PH{Z'+F845!wʏux'g*t呜7p/ޛ7ckMxW"z>Sq (}(wN{q&tb޽lbļzpEqtbMj}v'TℨwpG<տ'If6U!ڏ;lw1pXGo#ѧ Gs|%x>U_g#\Q%X*#I֙&\$HǗ7)_1F$-d 7?w{x=0x/ VOSz _P;pOW^+ I8= l"R}E/X~AQҿYMvމoǁKa|2dNU,~;4eǏg1E)W6lz);V96/'P{3boWd+~YX]є_y:_  ~%>}=}Ʉ+ h W%;I99ONVƥc?<la#hظt l#*Q4Salozaq[S-wS}W >Lxӧ)}>}VG\Ӕ2|qzW5ppLio<5y뛯Nxk9APyIR:t^#TNO Fb%/4{S;/ƄNEBcGטd9qLTd:گ3]#Ł72]2cn쟣_N1hR#pTc9`vqco>U_C_S} }ORSqޤ?0gr~GE88G򿏒HQ=㷾oodwc.A'߅ >^}:O~~ew{'I`?ጜ7Q[@]ϟ2R&\6`{_Kt*wUԞ^>g~X=?|[dH0ۛO9'J>QeT58/L}oXT[=~Kwq%G/T .7~0"`8i <{_%zS7Aݐ?M NT9k7oBv_y?iz?'UOڿ;޷? 9'S>]S'M >;6e!\FO\_bc[G0eǿ>ilul)ˆWrR +L2>ޔ%no&@Aw }ry69۫oz?׶dև!Kr~Vd@V{8k>wTM|\OO鳧/U2 =kЋ;蕤oMY*Kn>}g{y)kJq'qU zlWY1%s>j_'CwxOΨ+zxDݒ$/fO>l=|q?Q,?닉1q@aO|gOj<>D9>k}SYI6&A/}G&9re/b9 ?]bWf!mIUߤ2ƾd5>;wԾ ϑ=V}çK9Lӥ,= .@#uF ]z;@X5F T_Oz%|sr|y, -+k*0cWޭ>M2k Qgsoi[g@߭õ>cN>?eeު/jj?Y{őxx|85ҷ׸O e·1wG?,|igY;v=CahOVO_Kv?kڛo5?\7{C.0 xȇvƇ4eO˪tݶU_W~jPDAAAR &t ޾1e. #ơ{Wog]H"k|{n%F7aߟSAoKNN!A9#5pH KA|YHyWz4< Hӣa 랯hң=ߥ+<4WeBl]}?/]H-gI9t!{>S{/t>ۣʅz*1gF ?G i7B93#݈K(_7?x* k>^}էZ ~R83ܩeny6b\d!K`*ܿkT1n:䆮WT{sj{T5GUsjSn<+߮shWT;o]ĺS.+&&E&&FN)גiRJGN៨S[_QΑSY) %0]nkM)|{^k ?ך?]ÄX/JƏ)h*yot,S%9)|)#64V^/`?i*BrC(mt{}Rv?o'^ϭ*9["xkŻ\N톦}9E\.ATnt1{,*Ø=IC_5, h1i8ZYzFYH&d)H&" 1e MM¯Ҥa?ՅDe|hnxR95yϑs=zp<"~*^iL }:zյwG\o(i3"ʬHS9;4wJ;4Lߧ)|?5{~OLgh /~h ߯\~%t?ϻ\㢬V~}).3th o{.mG4 Jcȉt~~mPJ2AhPyDs?%~E:Ud_=_[U)sOV%:y>/K~9#s?r~^0 ]a7W_uUU{Qîܐ={Oݿ^+#&O>Ą}M"yxy~^fԫOE ;$B?͗$B?/ lH~>]]!z;9:IY5;Zkp 5;Wce.{}o0 '4'zs~hrkߟŋjsܝڍ|^09=>3p{ⱦ:Ÿ'݈yz1(0zߗhQ}4}Oާx{M* M؎d_ }=~2/h$ye=9)82Gy$z~<>ǟ߯^x~=>>ܫ5e־oxfʂ>״f0xV1#/}s>;oڿ~=o5=Gh8BkTh1ShKhnK; K蔋&Kruv׫W~Β9UK WAjD@dz4\{BC};{W!y-ńg=?G;ip笟yɒ9l3\set5g_syՖ9'2gKs}n>Sv}f>/[ySg ?t=e(uM7Kұ󕎽o:*9w]?>/1z[V4-3V+לש3ka4} \NVn~a/ˊ0'w9+ʲnnEr-ZyoWK}>fYkmɁ﹫Yr/'ĒgV.kX,ā0f5uݭˉA{#5%<++B|Ϝd$>nVb_, =?Se{5-9x0z~^NK=K|.aiy^ \'vwƓqkkw1%d>1NZF?q3MZehM;F?0~؄wv]͡}ZkZ7~^KeO;?0r[4ejL,g}O,g>O-4Y۹I6χǓqKRh<4*waכU{k̤ϛUyօ0\wZc]c][[q_'d\ ;(E\zT~?;m5M51M qxүiEy.>O94M2b MzLھ?I7^h{>͵?㉣Yxx똖xx=<-xd\΂i>.4}O>.&4}^1MRӅq}}]Ƶ x2nek=Ϗ.˵ fCę"&}-pr4ye?~o~^~ϋ.E[tgz0hwWtI.ā}<|3q7Ł0ڸ븚&Z]z_/uKg~ߩipL^χǓOEhtk'xRyb^*F{8Aؘ"G0ʼ {Ќ,'>oi/yx-.XuFlR5[ދy$88v t> l,v&(86'DOP\l7 _LwE/ 3>IdQph[S}jnuքeAL\l fEMߋB5 ޏҹ}oc9T:aS' 7 ޿ VaWeb4]S>a!D6^2uq~%a#dCO_K}Uy|\MНoj֜B3s͸)qP;!#HF*@ q;k7ݤ&#RKw&jqP44ũb–),z[:tt};LB,x-UDx :!,JR-5ɋ}bB8R":6E% STs'U{<\(wBYa$RY%pmzn;r1gE|j)!qxx)h-(UM`v5 |ۛGƘSfVRx ̤ \iMlWrZŔEnZ^ У ȓI>~lr0gIbz5eW Dk6>0!m/6cA>%clP# (},`ֆ}k Wh+QtH0La3v JưXʧs\¿>%.2b7~0!%*%I6͘GKvա)\(~^gEXf3н# ${J}8 X}bVBqVijHT~cPT,3|VL;r|?ڦ`vkASbj!/ZQCzwht$YCIr`d7{;~>C2C2zxc!2x֜545*trf0\I֡@v @$ўAQXC5@x TɪщW_*gI41+#fO,1%?&Ϙ3ƪ11)Q;^y>^I}erJd}:Z=jG; Id&/W(k20JAG{C>ecjq|(,X)3&mEH$n[%MCTy5,If\.DmB0U)~gFA$ESG2%j!S~L{Tj\ʠkaH- >=+1Ǜ6)Y~fxJnR Џ;XI x 1M8CYf/z0d0ly.͖$?qR&3rҨs8Z|x!D.a\#`|JDO_U0% )}[|CGq9Q\hr`nbQ_IGQp굏Eq@8%9)ϘKK){O"<)qrgvpb&L=rk1 \0B3mi$H{|_M+R T?*&JvI(ߋj.**3ӂ F vd&fm52dm6<}>nX!2*Fmz03B~߇]cy3iK ןS gxGH xP> .cxnhęZyĻŋy_!I?;rjHQs^DTn%fo&SOI$C(HH/9:r?;Di_PR.!2T/6&~x-'x?-GGf)(MX#Sg[OYR_I@aMD+8덟.-OiQ^iN7Kň+f:2 Pɗ);,oUNL }ܡ!5΅눵aRHx`m#c!dXl4jpL ' PFA<9iӼl"vcv+cȁ7KԔ}1*I ߦ!HUaD7J{g[Mv~ih'`b\0i!0 Ɍ0  utmf=HXɝw/02š Cv?SՍto8Jz#LaF䖮tFBWy%KH&u8p`ͨ4Z4z%S6> r수ul% #bN)Q]&!_oKE8-0ׇ9JKf{sir;!斪n D>^:4ϭ!gSTmoN1uR?ĜfGmDn  W^lMS)d`&px"2 sjX5%/J b >!UOO^D{nrTBAL2( rhڹ;{=2S~n.kmľԢhg]@P6X \.Wnw{Fk3 SW* $9fLFx67iPXFT1K1ګm.eW!2>a) qkԧ6д{Z;~}+OR5ipTOU\2ĕF Ҹos !@%ծ &KaiRPcQ0?UxhVtR#Kz֬P"a*@V?>u!H!( Cd1;D\r", JUE'XzH|kp<K@lhr{\}͈k$]aTEJ(KL t~1PX`]Z|&Apҵɷ7%gw<:oѳ:LN*)ȉVMSҀA?!難_hS'iҽ]ܷ]Pb9thm2SB%It]۔Nv9嵨ڲMJ{F| ?aC9-="a:Y(,a6sj520Ʃ.|7ي?: i>K5.!`^H."#d1Xv/璟=R!?PmKm|SŔ%*.Wn!pW-H[tۤ)]UFQ0\Yly?+xQ>^>ڌSƙ crը 3,,gi,䥷W^ld8RFH6w k5zN- h7I(z[(,LMʰB# 1&jxU|vKU5oSbC9.^35{R;VU7rViLMV"{e@14AzXhܨAeUM+?,RdiJ +ls"GKX af_2MǝbRSѦczI+I _3h5Hhty }p-^Ko3͕qTɕ<3|<0A CAT&e/3 eϊo5{QLJHj,BȦژ '@^\1J6C2~|ŐƿEuhc500&Ŧ~Ts ,1S~au% 4GZ; L;W 6%}xguڹ94Ŕ&YT@p׆[]Fplš0b ?MTkjGV,< *M;k G6rD0V6" T+{ t:4 jHX1KeNj@2Pv1Qz%4wSXX @Ƹ֕ڦBQ <ƦRgj#v.,ev !JØQ!wo H`jEn4~Q {װt[*u~ x}1&B=Kccu6(tDt%,y]Qh|[f=IKZ8dMЪC <ҩ9m-8j(&bvJhyuy)iKJW[j"0P\~Ȫm|`nuD+[] ;XWQ7B$_QgQ'cե@EkL+RMdEJEԘ ܩO1̀(#R܏F⇠_/ >C\jT]V[iX!|ΤR :,X #;yt' AQ)}4aLT y&Kd ^jQ1il_R=>SX;cFEh Z!& EAn#ጋ}k{d6E^+Nqg?k]wafqHDG]x|pVj MH&Z]^اm_ָ# j,Fɑg+ !@a*&)2SدU㌊s׫Q=YQJif x0 E)*L+fۥ Ccn'( lJӢ4ZwzU rgٮ}7/\eJSi[ ](T+ JE ׭;{ONN*1-.!.0WK7D444IC3D ta 9I-(6tɀu,Tu"VIN!\"[k)k \߲ی/Pkɻ*ԉh|_zY%\ {_R9IA'iĔhr Lo3F&hsVU^ޑ"]ߦaZE2Ϊi1'T{amȔPƩb3p-6Ym.tojXm5E ^h!u;%mG3nf_&’e0,Mln-Y~F>] t4'P멝"e[^L &פpZZMwtD?6aͫ<.1R%+׍t~!Oاv6i<|1nNbịaQX/C/&hn:u_3|lPyM1k \!Ϋ-lKԴ޴1VP}~XIA>ѐԇmC?E[WJgU !w˚s+>pLM#\vA+6#~& 'EpUX?-PP;feVS˓ي%}:icܺ+*~EIƓI*]4#Q*43@+;{ST$U7&ŲajO)Je䩴 DR#mq"cJqk풿2kN/7 &QL YR K?n[=5e0,{,RIyET"^-#@d_jP7ԧⴁi`,|H`H&5 TUlA[.12?<ٞZM˹+ +tm zN!= &S͆Lj7!t5+׼GWZ^7zb6=㊇c0^cb±#.N['Ur`Hߋ'Xg*07b*L^ɻ2؎|hb0eߋA MjLY D-ĸ<Ҏ8qcL%]u&;슍/=u!Kfc.p 8'uӉ&9'KMi%Vo6+%V%y1Y%y%YM}/e5kV}Ew([)ˍQ_[t T[jNZg>HCĂQeCj}dnT xguU|qV)1@w(RfX~] 1tЊ~Jڡ* CSJ6E I^)N8itѦ>U10 m̉fnkCAiՇ)]3SwJ(qrX\bȵ>hzc"ŰO[su>z-lH¡rWpXC&%㯁X֠Ibwߗjk&UMMd.zY䭲^\[/B@BhWu":ZqSSA ʩ7/#@"K?C oք["签EZk{RΖ/ؿ1Wz} } .+C{¡;tNwm`:/zƲb/!&w} Luu/Rؗҝ>pCUz,xb|29>vi_;: DT+BU9Ja?_fY_oky{諨l=d~S74+4TGp">v|mFkY4 5C#6 I-tm蚴8d[H,p"mLch|>GkWٛ&c:>TRJq|֯V[҅13:y\'k5Ke;*WA+!N3>V1=@lU&'aifju3&}|&&Mise&ՉJh8ɂ@/>kPHV*aSPp2c }E^*dKRE(+m ֗ Ei[{k7a-]}=]0F3D{RW27}Pӥ!t#'L`OQm'Iad '„-#h#^糣Ԗ(&Jw'GI< :QhHgsSq1&*$ntތ5$`(}R&\ԮiTEh}b6 UZJ㔻 5Ǵ(]hWU- U!/1{\(& NN_rFJJcs ,VU]詪6bW#NUC4yu S3Dp3'A=#%"-CP/!Lvd)QVШ,"ϖ.!G'T_a*eK2?nr>IUvl|-A}::B+NHwB4d[t3O s8h`"$RZi޶*=*Sq;GM= GM~ + F7v}'{e |\ h`Y~Z$onJuaB]9(i5LOtD&1YyM{AieAUˆ0)3l^,X$~UG_7!Q!!{x@ " GXϞIUrH Dbl'#a.Fg%G+kT9*^G@,7w vxNJBT =y G G ˨ j,DIm`L6qj 1QL^Afm 6֫&"'dWdF`sc.d‘Ѷj4ɽ(@ͫͮ#NWEI:Z6(}h-ZS0!بpQZ:vAFѽf*m!l~mqnxr#3.[ "6Đ w_yhZ(O1y:]{b8@q'(2A[3w{AEzg̛_Vw(vB 0?p"O&:NZOp >Yd*5Xʀ^&91؋ *ՍGClYD;W%vNq@&/NT,P%lkpPHF%fx1 dԙ:&J`n1yBz'aۯDL]WC/E[פ0)2#!7ɕ;ys;61YDU0O"7YYp*GwaE-<*X`g\;cv 6I;  GI غ!%.Ѵd8!&2|[Q =b>slB4m:&f•slzcP6'5rǦI.ۛ͢3H }⃀3z}1XH/Y2xnՑcbҸ ґ+Crjhɶjdw_$'S^dGPѡ μD)}=0,BO<|=.p·;6F-Ed)|Ş j>t'~QD7'Py|xsKA1U]wY7Gwne8Iڏv)!JN񢦪'=(lPyQ-6鍬%Yi2.T'TD:S%9`8Ѓҹ&0AF!r`Rq>P'U{_p_ |_幭7i ANoCg("i,t -MԶqiȕեBh{OT$z{ĺEm7hj\%R@[A*08D&xҊGE(S< _9, *cl 7BP˻rf!2h7Xkwj;1T ;Z&3GKfp e܌&Scs)}{? $zWMZ @n=;W*wp%j.@+"W&ďw[.[JBl0,6N GK4,fkM6rtujNQ*2Ct]6;ʈ'~Hkkcks.~'%1BD(h;P )촛JWZ9&S2rYWoMZ9Ȕ=U9%zV&cЕh(\uJվ\hVj_~S3/cj<1C-6/fMd݈eV}K?ka䕑 @E$rBXŝ@*jpl,5 hx$Uf{|S"Jũ]t\2n|NשEd1B@|foEPSFXfs+Rl>'(7|wFW` YKH6uD`;X*|ě>Z`(c  EZJP`у+zM4+80"pj 5`0"6"m4mDXvVgm3l1qO?4Np[ҬF*t% AhHҨ-,l&cCJ-~L Ȣ\#Au/Ni"o 3šHJ殟ƘkXEm>M4Ì˔dmD- C.C3GHn pQ;r:?Zr S6UW0?[Z딛X} VR; "oxGk$NeLp4pE3yؤpMsAUǑFANN|$0cLp ɒbidZ(p/S{!Cҋ 㧉jث18KSwB-8lȏ. E?d Bn5RAo|T&C.f0aƥ)NGce۪x4(o"r HsT}|:rUi{ _BI Uz˃!|-HQk>N%U!lU~蛌%U/I=]4k'JmRE~\1D;'7s, |'etMEcB>.^=Aq(P^RP#[dي-vEꉘ;$FKMQ$~` ѭ>*5HMjq|V*>衉da5,$8q7i4/kj1l _3ɬ6m]6>s 7Q詝8*T\uo)? 8fK]l|D]&͆LCgUhYP3:eL4[I.{$.3/q }(u@G-CPn|̱@˧"`\AgFٸ7!9Qm*I@^Gu"!Ew53ak'gdy^T# q6Et{mjE `C=)20} xMQC,[췲i1U^W$S%H'9%CHD|L~ԓ=>CG|ԫ{8G\BB#M|7t%o2E* ), sS y_ѢtM*Մ\ &5@S (žDgy@ ?c&&%zPtY.AH8;N?TM Īga BR\Kh"F51ҬR_cYq84/,BmLyMHK͍X*8&5\(Ƈg=~gajO&l+]ׇܙX0ddߖ;qoU4"LzV| >E}= ug`-\ $fk*d;=] !tPE?58{''SNd/oWLʹ<k)WJ~߆znFr&p%a>} 0T]>֜@uo,f|\ +(h JBPr.tܨDj4soHklZr:0O4lj쳦m 9XPi)eT瞷6r IE|o7lG7C{%Io*@+Ygx!'_MAK$.RJUϡ(RSkO-r6p>n 86Q\ @Nh=h p+Q 'Ԕ3*BFHtJŠ@2(>]El9bXrtvB(~ Ta݄=~-.GC@8oC]hyt&5v7ʱ#)ܖqA_;Ej,|H0z0% T{ Ca0S]mB|qBUj>}-bC<FXC{E*XxLEy#V9S^rSM!G]Hˮ͉}7xڹhh*}x!U1^:MmjڢCSvhUtΩ؟5#À#avG`irP9zG|C#S8nAY7f,AUC @;/a+FX -5[JN9ţ`=l-,CV=ٗ+%,\xxbE&F,hf{Ӥq*:6w2doPo>k$hb 6Kv=w黚kѕa 7TnGQ = Nr/涾lS)<yX"J^!=1J8r!:J,n2EZXP;Ԗ\{РIDDlTQ3, NI(F!.\՘J?{B-dߝ%(y ,4Ifx>{ 4*.5nC' 0ͣfmL<vd,^- +vcj\)zNipcf;(]$s,e])u:*fA> bQ _hp³5@Iy}[ ۟]Q=d׋I'3+D#hAB>冲 n)m.<>L u|Vz:KjKězwu[]͝\JEж0 ?'Hy`1Yըr*ѭ+AѭqCQSDN6FlR^{c|;K!͖2uQqv;l&%TAiD70qyPXli.uTh ͕Pg{R\T4} 4ieOR#8Hհv7aC8J2aΆBs}ޝrF,}n*DZ(KLMd0 J5`Ԋִ1H(||>>dm,|ʊZީTiAӳʒ~~8!{*I?ˮ>djI Ig)76ax;ݗ Ȍ;|1ȃH 6mng4Šo!8jI~ zU jӉJ,dץ$,{#G ?dV3B:[`foU5$N7i$+uǭЀ[k"aV.2pׯPQpDx Cm޹^"<8:;/d-/jRkEe2p6<@R$Br8;CH{9Ff`SߟY4*nI`K41MN M*TL$H -Cicq.7'Z#{O`;ú @Am#!_\2dԤasm RZ4tZ]T}$EXSDZAvCt$CPH&Hk]S'"]Ű3Dq p>,vq'#Tu N `0VFըGD{@zlpEO0ߕ3~02C@ q$~Y[8΂_28%MEMp?'D4BWƷR+HؚWmby~JL_~ɠ|څ7`9ۈ9rپ@&7 .RjMl!lW˗t:QpY8vWf9 @i@+mV[7"tMǯٕfA87 i X-ĕs'?59dv1څHtA&cT@^L]l nWkH!Vwe5ܘ|ŀ@{X&"nc21ÐVhtS.AfkD0m^{DMGS:P OwDOrk¢vJ$@FU_[j5 u\Cv(ϫ4lY|7O 9k'Iu1&4YWL[:,g!tH`n#C^lZ6mCШveВRnxI.eqʨǙuv4m]rMU.%AL.$u?īLE):?V ( k&[ l< yQgM-DJ-poSx+_+ I?(PŎN]:GID%]QK.$HS[7e!S?Ea %T1ܒHCPحLiFj)UbUY2" L&vt;$Ft.~u ,kN9gzzQCIJ=MNhr{ >L?%-$Wu̫&kc);E>!m91[VvE),PSahc,moд' M"d&g@w!Ubo93>v(X|vZ#Ք8 RF?d 6ӕ!\Qi ZT_)״zA|}횾^+SR& -R;t DTz_(oU#1! ]U`{:cO-U:rS$o VbQ](NaŹ$"I'=q%1ѡN0{W:C!] % X10&㻫;dN MP!h 8.J%+iXQ\ҨZ]ErLvhMp#ua~JKž"74`@7S4jD2h^,mge^HgRL\*tlƓF4_şn@6#B p|x@GHk| SG 29V)mYjbK}V_0twd>^Wܘ]Pk\1+Spt$IG> ."[(9R=ḧ́N.VW~r&}8 Ruse6l,V-+ލ ? mEEDr6ubrͶ"* GѦ:]Ud꩎72ޙʂ4Tg~Db,E!r :Cgj,E3u'xp4pʇN* C*դoY:2m!`&`1Z $-),[9؁0 Xj%% {3D_u7SK&l4>4dȯ0Z%Wދs],xxO+H$=qMȫ5uJQ[Dd$#iy?D{o ]]G$B$^0ВVd)g'N*V c Ncv5K "S%t\':H㠄o] QzШ"cջ0"Md8 ܒ \CG,@KuxrlLd6 S4=6R$UIJa {3YQx1j"7錓D t +IgՊEps8"n zNxlڵQD2Hyaf{(f: F46V+0kN}1̂h?4I&MMwz&Z' ]j[fΔa5e8pK>m#gb%3٘dtr.,,>{Վ2C!lҮhwԊgn7mazN%/QڧQيB]*x jbl6/|js> Į{(%T6 k{隴qP+) %`Y)Q٨WԧE 6܊RLާ#HtTSOa@v,=Yb{v]YƢK HaX)n}lW@B8%n^AhwH st"8]y2/-? {q! C '€BfA]9,zKց: ؿ9j $taL. &OkB!!Vđ< 6w7!'y{eh܀w}fVb?# $=){#2|.!DG1 һ*ICz> K &FN2~ 3?C$-. F[5muP#\&W-56,״zc#gרR+fM>8*U>!MF2ģ2FmD6 Y(B,dUؒ5dl>Ht*Ac*JIPB[EM(vTc|*B Y9eCb!ze "E}Zgow t)fV)ˠ41mZEݔ2bp@z"Qr , zyJ_mъ &yBLU"5z>H9Hn;DEn5{^mbZCؤҟojvmDHza[aޓd=?qPv UpK5tq?ީѼ<0ZDioX4kaui.˟=a.|(Uditij窼h=.MP3݇&jfik ww6xb[`5k裞M5QZ87*$[G%xNU∨o9 ?ք>i(8 yoJS3.b.Yixb34&}E(G|Y$Hkb5є}d\Dfq#%QIJV'H%6><sHD5i$BYcACm) tE$!%x7)jP6&ɞڑKZiْZjAq5@8r|:F:#لYg\Lꌴ CļE.08@R[󹒎RQ]L4:;l&ƲD:-)f02c mCBH F.:t l{ZW<7ɱf ,C>tS[K kHrKL)±p!߄A\2z)LpU^W$V}%ՉF{5BO WL!7 7W\~1% *rɁ >ZpCyXo04-Ы1q d&, d1xlxj(5Un:o}\"o0:Cs&tBHp#DCX8Ь dSi7,uΧ h|Y%cDW*W5!q'"@+"kV>~@(gYi%rm#'5T>~ȁ+ ee!NHL* 2zU6r,je(P 잴T#j l犫9`Zmqt*:UMϕڥG/,ѯ,5Dqg4/V3YYG,Q.&f˓ʃ 0@6D'3NݰE͉?k:.Bq7L Jej@ 9eq_=a5j w%F˜]W.Lit tEluGz\9[^M0DZ͟tEH?(#]IuΎ>=Ȕ>Fc$.I!|Hj[2h|- ?oB/Ӄ +\|#IPޑ;iQ6>=Ԉ;]ˎ **:V= MNQWӣs`TΊo_u!Mpn-J+ *ϐ! R |A*f{\<#c?w'.%Sfi4=,#+8ިLz$)es$ڭJd]uR'÷W*El4XR\?2p3ez-sH[ơLG1,oy.Vl3CI-I`1t- ~H4wzh x o :}]!M΅f}L cH=BI;KE쉒[i" R6 \7Wf5?Ha4`W3w"gg쏋v}ӫPI"4ۥ>.G=)Z '׸pc\I=nNiba*AX_GZCI;\Nr88?r[_*0Wp޽W(K A{TQxSǿe^;? /–~d0eoLVFu>lK7^˟WŮ=g6 }ǙGs,cfBգD:bLʅ")ϴHM^~:YFsj HgYr,20$$ή^HLGa瓹r2u}t~<& 9QYDj4{{ AL߃w6y@{0XU/G LLٍ&⊠9\3gDlauDciI-5N^?NʠaeMxPv9b ԩVtbn|:y M;ר<N\(˷'|t6n884'm| !CW78zE$QNj[4=Jxdݻbr$.h (]R3$ /T4I>nj͙Y]FϱLrJ\B;tq:~] LRJ0 yrL4R1 #W81%afT~QU`4Y3B>ϩmR6d(WXb*ë}Soq\:~뾊 42 ?Y9DV'/Z3eS1s%]nr7wd dS+l1(P8O{)ˠyRBG،U_M[%N~۩2 |Bo\ܯg/MV%&*7Kvp{mtg95pW{ԦϿy&(;äة4SFȡ f;?~7v)ؿXCa?Jz-jLСp(vxy3 Ms7F̨p]AP!d"w'P h87)+WM&*"lב;0d7 &phc !vć?츶?풹PGӺdHZDy\:׌K)*l'p.Ziumћ)T]s*"|bҺ'H088 X`a8yŚ_F֮O+&*T]` Ӝ6.`h GĿ,;;jq6I 49U ٹ1TL1=A֐!&D4Aq'dHز1~>'B)=[%QCRMC "45@aU4UR x4< HG08|re:0-P[t9N( o 6z oj kh0zz^B䏁NAХ1lIkgPB)[G$јtFLc+bkq>1Ė]iLKuaz% q8"c/v] +ez:W*9$UUF>qzu ю. C 2VsE uNm\cRڸN.=C& TOo8wǷ-'KJ1Ms{4i5#;=x(.FYe Io&( g{m6FOhJBJj ٤ds x`5VToe10vHDp=D0n N`Xu5S[6ϗI,`~,[C 4T\JH:A|v\O:zWFeeaڣr^&~}͌Y[x~|DtݝUHSL?s$ 2w`P +Pޟ8S TPT*lg ;XDلFIH4\RgZneJ JDD4eKPZ0~@} Pgh@& F_"m š!q.X>$vA 9(@,H1+$YFsPPfR9R/^IO'oiɃq<,;!|5azCBZDz8_WEP a4Oe:d0| >'H|$M1o.K*J#RΩ&)')C1BḛB[}vgi#}) ufTSNVHVӚ $[de{}L.؃٭Elx-#*ʳ0ݱ)#O'@ɳ Q^z>cq ŷ-Nl)=c4)k":yWjp~ӈK_3UO{X$ ݎSjQÍ#?T8do ) Axp`TAIsóo&8K-+"QKe5hBQ6%M=bxLW#%}ሿ˫7\Gj qEB.2]5*ܦ(EEz[;*QEpH/ k~<݌aDc <ݣ OAғ^Id\O=as*RDz3>mŎOPnKa 3"cr0QF:5b7n $ˎӔl$9U"v:Ā{J8{ژLLcͰ2TrIJr9o;G6PRKV\>bz`?.yv_L/ǩݹhZBaȳ*92(]2IA2 Yx/=CrDY(2'_8yxeGa #MU31rMLwēWǏ GB2\![`JF8B3dXdnG+3#2QjŹ:( T$2RJAl3ib&m@ڝcZ҃8e8tEc *N^:,lN(`q@oߋZ)Y͓/;4,aPNz!8o`$'!Pz׹[VVC&t+h*|&@qmtTUo.q8?#5F>K*ҧc>A1m=ʑĴS'GƚҞL89u<8 eK{u{hp6]b2_]Nj{]sыnhz$fı o2$+$gp&uъiCHtlDºq(w '/ UŹ Je‡Re /ߘYrÈT*~.:}佛->H=oߤU,ӒQJ&)̘f \) :zGG;_:ivqME' c9 rl'~'RE6Qn+?yWo \5YX,Wq@G%$ Wv-CҎ%S][.yBd VW;lb@UN>U\‡f7q~$"E |WuDRxE]|ש_Iq"B8IԄW԰k'^ - FR]ة "xj ډF9cn %njc KE?8?K]ibD;Zi ycձ؛%]gpx+qq22,'N=&c^]p̘x%$Zi{R7̆}HB?o1.7ٿBߋk}M\؋iHղ^~N~j:='/i\&GyUTlu&~SRaX7㣩Q=|[m jwدF %A™ E S4'oh۷p2t@չ?OYD "P%3&vX`5ԇ^ㆳÑK <]1@JXv_j~Hhjb]L ja28y$WLw}O%^ Hٵ4 GPf's"N9zcj>O99ҿKez5Dw{]4*?ZvIlhAmizI6-JֻȺ #FIıoۯ^9W K|{2UYPsd5#) ʋFU0U@=r 4$%v,ꍲ[s51j<zqb}Sxq*?Jhp]Bԁ3K UM<y(J6: 1d(8O561 m2yPS 7$ @q K &{ 0$NW*[q_FU|$ %?A5*>;v܆7u/a:duyA[$qÐZ0whko+57Mu!ŶJ7511_a^#2M%/8jdو0K`4L |)D4F8<\9spxHC|?%;XLMZl )^]ĬM1(]"_XDg0U"[Dk $fC,Zo m? Taw(Å M̟* %s7TJ45vZKrhҞ;* G.ށ[f&*eOչF7 Wi_҉Jv)JcQ_,T6ct4rw%W=hseR$NNyBd7:t:d[QCڸdH"CdAVڦ!t[լ|H;1h"Xi)9Z3'n,!px5r-;z,P{&1$eя),)I#21R oj2v1]s%3G@0mNͱ"Ėc82号 AT| N9U`jwb %QC/3vy1 @^Q:67/gҪtVɮ.z10i`5 ʁ^d =.\\z싘xM@1cޖznzdGu88797Y=n6VCm694)Npk6tA0R0)ETt55b)ƒnC9A"Ў(|)44ˣ˞3AoXoYa쪒-)?)nMmDqj s4aNF1ϲeG#ЛM:gU. N+%gc{h%T,fLv=hY!})\nz5L^ +G% , p'|;aIɾ-{$iB٬LQt^cMy%q8C02!J( ٙ <6;ؤq-t:12Usԅqa4.VDH[)cW)mIlyո84hWNcxR{_1Pxޓ᱄Wh1zشZJ9b< 1#XajT 2:2e|,nd8*fY7q|Z(?YhdB&7r0MpLcyy<rU2cNa|.oJ ijC/1"u V !3q!Xo_!zԶo8+zJhyx:MIueoQM՗m4hosdM v7e3ţ]:"|(fR޾KEVH[C&.I=cD2IwtFh04c6ԕ0ng>e 9MJC2jx3ߝ&˝rr)iSֱ_E pmLO.xz- @\̷M'S]ߋ]IS.9I8/aEsT+"󭣢[:N.}"\&mXOh]vؕca։>' vhkrv<2؅ ɻnK |J.Oiدߒ .P(JdېA]vIQ-Nh44V;b-[-75 A̦MԵS|io}bcXcr:lr!@ӄhlI kb`DDiF1f.pП)F 9/̋4+D4+4I Ÿw͌=4:ڐ3٤ǢkJDܑ% ¯ 1I|F EAe| 5;iNm9O؊ 4TU1461=TuFa[sW_J,ѱEBۘ(/LhAzp7 .^!O>Z; 0*'D,."ҷ`׼ ià^$'hѭI*!/L5T,($4ԬO G>M=gHHgfC$h,d3DG˦DC3)> )y3*ư>D6lAA"O9O@÷4xʿDZ'[AMPL];51S_Gj#j-;,dhE'RFC{mD8>RxOk1\P/ |fewCO+D%lВLx Ý`_=!݀sQ:= 3QFz,^y QZH9ƞܷvi*ݚ CSZToXKo<+Mzo=4#r^gV _`E|h M2Ǎ$.#?C~HaX͜3 cGtqC%.Jxoɜ S~DP6G8qWttP1DFF|qB^ڣK)ft"Q\H|xm qDnjĽ︛742eN"\E4uNED| [&/g5d1G GVrL6YH b\k>oq1ga9ZԵ"B ޅ.NX8դzHQKڷſN4'RDHsio$$V `iMbb0}78m&Z̔ n9l HMWPnZ.h8fɃ3߶;[JiԍɦYעKMzd}r<1@'7p"ƥ $``s"-0Qx_t #*Tzar2`^U 8 uo9"n5ID\`^s%})F[ہp,̕E` nA~䦿KFM˒n9"\t7UF)AEwe;=SťL]q0GX(*ˈ4/@2w]$xM20ҜOSst)~Wi79rlVyRm"h~tݪi*ʬugv}$j<7wi:Z-}VRD>Qq[N.2kMHg2|jy)vw~~y8͚0eO% 6ZTtafEjT|aؖg@+h n4?:(f:X_e7&:`dmRU{esF55v}Iq {=VJUuh^+bV$} V$,G@cYф;as>7!LjcDz9mouY|.ʷm-lH]Y %Eg{%Cc8zT}yYtˤ>yOGF&w{\Cp 2+{^<uCâ(_OSdJ N[n +%c-J _n)s2n^olxr: ":2{Fř kr4fȘl.B )\owStČ&+"NhGSLtPLJ@X4& elYgOQ2yWU(?oC{?I-t:KOaPxqQDOVAA,SXVK[ݏe}_ Q`R/ 讉x J.m,Ջr!v-Beo'44}T o{/Ưs["4a\#'&㎺?m4~ϸAU'J}=: ~Mz8+dvpOXUj_MH8te8XEm}{I5*H04H|OQ^|gC{u 5L+E5sdV.?W 7{q6Wg<)Pd纇 cc*M̈<$7MitmWŲByqh,OKظR"7KAn @\l 9K 7ieV54-(3, rm6V`m0BlvikU0b6XZr;sm2w im)Q&1Hr`CgD^I{yjӤ\J B,n؃x C@[{0zY.$iC±*'Q=TN 0*XpGM?>d NJ@(7 ~h;3ӖJ'ʹon Hc˄`%3MH"fE : C{_ƀβbJ'}ST.L {O4!yRH,f>"8YA%"evZ:rIDEIq8zʁ7-éh%m"<?1E1Y6镀x!U}qg 1doۢMjl"9Tɩڠ̂@6 c&#o5yͤsɾ]ӈ].G PH Sĉ %/] bB*e5Xݕ4~EWS8aхW|@arA2K\ehQ:%RC{K$ $"7cf5ZF߄iZ؜W PP5Bۄ^4 4`Dw ce-rJΩ_ED5PX@'Cu\QLd[86T41 p~{pχ*=o+%@[;a3Sn=Ӡ0˷P.Չ7c!4ܓe2E[l3p8ڄ ?lUjQ\BmwjNI[/dAZ̆k=l Ҙb"ӻ"QDv0z*n7_3OWz/( ::dMgW/ح\eLT6ɭrUCEՕaN{]Tǻ9 nV(x0%H3W|aC* Ep<4M*t*e%yP;63EiY%"j$Fs8K3Гh=-e<ө[℞N߳ҕJgbP6qd!7ט3G Y~yW]]tCN[PPNUކWsm*OjPL]1&moӘ2*Dq~8EsD^Yqx૔FL1/?74+`р3MΙkr&(]Y! u1]2iܓę&~,66q)"KJǹj0d? ]>I!(J=K,%9P\bs@+;dZ,; G9r/Znxq+fx2-e T~fZf7*-8˷݌s[)$XRdJ ǚ+ R]!Et7Ѭ`@8OF{FG,-x!ęCSyy+~2-9\L̓JHԺd#іo?ۂlZm>>E pZ.|h> Mꛝ&Cq6֎V+!_TʜP]E@+! 4waO{7Rj* wDOrqg= mwf'dtZv==ԖЉeL8kGhHE|m`i0Ōa/Hɂ""؋t)\dmT1tQО2*iD$(2XLKlH_&& Z g1y s#./?6ylsVjj}ZNbXR#oɆyG=h/cy6"Ej)55$1-/8ϧ&zvPoKh Isڇc<`148XQ|>^q4Z}׳(_,WZP'g9h[I+N g49 -fޚ,mŃ&CP,Qk:3Idž &ۻ!U (tl3:d7hI-mо?b9M#=UNf>/sCaJ.ɮ;KU*)ɚ7aV@v](JC^28jɤ;I$q4"WGj|9 @F+߽`SAi}K >5~U[|RFtܲGK1M]Δք,60 )|v/!KzFcF47=#BjҁvtMbBXԻ{kT34+=刱jdwz%b'{9z%waLɩ6&BM7RxLpBwBp6zoUƐj7׷]V;*z^!^59gOi1g]u= u-P"qf]HYh2DL%RQk-U;*4n*K^堁)IGZԌ] aZ&U<>ʏϐonBE@;umA IsjeI:gE'X#VEDЏohĹDe1$dJ>WJ7;;GY EDW;cJS1fob!-tn5UoΡM䦉C&d؛v-@3_EmG(5m_"yCvXϕK<Zvwţ\WX {=hQCWQDح _lᰪAcQT/_e0tk59c[T\ea,^{,nn Or$ l9vj*(E/W8&؞"2>26)6AdZJ\eįw{hib6?AM`5s0̑Xc4"DaFŒ pC.@rtaPSo"p_a6XgԆ0`XвmqXF(]Y'}t;OMM'!wPhN-j/RaaY( %OL@AH84`U2c=OD].^00Ce4/M,>>mW/lI#n+m…{)8+!( lcE@SAG|ISYzC6 ;FQxcn%K)Gm$ G7u\Ņֺa{Zj Nՠ.X6ȡ^LIR1iI'5޶vpk7QbvrAPFa':]Gc2I1xr9\$+JČ:XӃu;)ÇsTO 1G{ÊeE@U0ƧX`Q"1+|L4}σ! 8mRX "=ط ?Qu "A# i+z W,No\F/ ?tK?S?uGM$:,F(~t$n?pc`E8ե5.<ȾHQu1Gs)=:5;;UlA-Y7OƇ=hܔ B!kϭ9Wx˾+-'$`4[eF]zKrIo)?owdYGrRcNc^%@ hf${n0tP27\M8ݦt [5nծ(MU$GD|ǝa,gSe3b q?J=^FCfq|m+|/iԥIߎtuS=o0&}*= ىC+l\)5raD d6' Y~pI߿+hreUx$Ɂ=^cPy Y;M[:*ԑUTީ/& 1m!YaO0>hHިm5%V!IKuN7Qxgl81(x}"kC< Ӂzb|8Vy?bW/,Y3\7&4>qg-+]Fhts}8;  pItG Y;%azWv,XSϢmom~ ✕%oRnAlA9r.栆w*,4#3~ TYmz['bx򰵋HvԸsWi4 l"܇InQnCBrI?LFd`KR?z)M'@4f=qbLx1clc|0B3kc?GeFNX Akҩt(Ikbf9rcAW0kqćKZ)?.I씸itǗ2 \Dt~äܶ{"`{Bl2&89DIJ{ y/G=%ݑzvL!!E68q/SrDJji[IAɱn RtE}WǍJ:C~I8f+$9; \3!GknĿT6(:94Ib mȐҩښ9L sPKd~Rf:C()c7{>b8bs<=ұa~$vΑCrY b݁,A2.:Q0RCkZcL*g@;`DOg잖9 lɲSMo }k zsfmvR;)fg }JeGvw_AmO) 3)Kcƕ~匴ۻi15\.I,|0+@̅&Iߊ+D.aMoN,, ?x [J ,&6x2z4㻚܋o+7ٻQsr˄ѺDž̸ّ60nijms`Y!7"g8Z$6U#L&4ѱ|6_)DU?Ptbj@_)VpZ_g*8rwA*"`XkQ/;F U|ki!;mJrEaZ1]q]cJwކ Z/7U&kwӵm6*8:Q9 l/3F9hQ|;E[43ܳbLm˶cNπ[!#n\,]E+Mm$"SElg;k^̾P:]TDZ`r!a+65壐7]G-ǂHyʎe=ZAM}7xۛNڣc(Ms߸o%s*0B-Jx[W\4׸ӹ8s=hsz,s'Lpe E)eE9)(7O%AB ǡ=Htꖢav񊳆d > TJYԒ5IRQP"9[/1]f:9ƟIY%)k̼n9l흆~MWm1ʜ=^ qRk6R_D޼);T_9ّ G Iot~B.=+5!꒭CFf%wXOh6:y afoDˎOƨag=DCzW5 7~( $ՁD&D~I;@򣡃a$bt&LPqZL#y+CǤ-*XN+5ND?{BzJREIm͇ ᰘ|}++7Y7Mtl* /{^쫺.u."Kr%@C ةB CM RwQ,\N+ϻFGW\7lـ"+>1"ak*ujl`thmca' gI CUapR`c('kl('̈Ƌ/ykl߮ T+=i.8Q A/xi3h&ݚ]Ss*zS~O?uPNP5YiҰ* }dL^F FS dIT%_lHVRFoE@1$p$w Z=ɽGCqGbCUZNÊ4E;&M4F5/Y xۏA€1onNުr5C觌.{G^1wͱ3T5:8\:Wm)5M2ji7Kn@Pl1^ABX`u_I=$]8F#`tFtJ I9m7r!D8L%l?H=G* q"ӼX2v־u_+/BIė dt Zy ^I EaW nx~ުSPX<%*oDά"" a,KJ'\(S{~2$9essqDh\gĿBs/̱%>MLgeyŭ>P7T̍½kLOrMpkzIAkؼwV,8T U/ ivosUȦm5Vx#W)"Dwh~M4 QTu߃.c `t9wj,րdh^ -W;\+z>i:@VDB;aɁyǃ/Mht3>g})΅B<[e{*I;9,T `$n+F6QH̤_ CN|YE_ٛ[<ܔCdWfImTa<^dĺ/HJ4N_6 ި3Ɛ"2qiYqi6Z9FNץ:ԗeI}2tve.bD9vtIs2GCY$\VWt蒵MlrֲPC>q$L,9Y,cǭ7jH+\:ө䌆rQ-q\M,ub P\HM̶{6 Y68јC#zSHwaggGO`#PÈqh/m- Pȇ6 KǕ+|#˥хmx>}<?G2)tS+"+&@M C#mX>R=JnMȟJ>2CV=/bLڢ:vaCȡ(`ll37cjїSwcJSUt$3}"H_D MXN\TVH{iY nB8- Ǒ[[Gŕx ?J3hX`{|[Wi*;}i8Բ5w!p:ͩt ŧFHq=zpϠ͢/ΤI[p&sPwr:Ӭ Rpc%aW߿甁!T)yuV2 ^E;ڃJՃɹCFZgi(ZVTpK_ddd=mU) &|l1%6 56 X_56l~>q>bR4{R3s=Fnp,} H=.E*GQLs҅}Skrݎİ2&߅o{Gf|cZpt4?_C/AٮS]oǁ\vĆ )>*.B$1_<+7g C dm 7гN߸3vh6m£Œ6!WdV}_"͜>: pDZPu<,!]GD]Oye"Ո.پQ+?1PPq0="H(,.rmbBnr%*Ԟ|9,VFg%b6ƮkfQxA1ɂG.|)r7PP}wx*Ȱn,?==OKzXXR f@R;GXe[ ?(Z{ 5C G\O.('-%)+MG )$#,xLRWM!MpNN!hǛtRFo`T^498 ^J75뛧x!ޟ*ib*xdfH7^l:r98 ED8 _M۶"sDJ)&*>[3a[^iUG@%OYKhUHwv-:.Uk4iQӁ~;j!F0~[$L 3w.1a8"D'hN&WY?p-QQ#buTEqxJ\xgaxr(Q2 ɟ8BVJXBRq|-7F^oh6c6+A'>mu&N[WU{C0AwМ+PyNIb)18\Le`d6 e5>Pޔ+GC&E8Kq,00M>ja2đ,-l&*ǒ Bf!l 5dER(_?Y>Ttob\{ :^Qx88?>)s,#@Z .J\4n[doI%t'!lDN!0rYj1 IoOvDR;>OvMsG(`o(j6\v̇^ \ȢAXttAv4ԴEa,H :;!۠Z37x0vF-f<ٙ<(AϹ;'L f5!`o v;s|)jjDNtD=r.y,e,b% T>:?`r ~mx 졉"X k{9A"1߶ʙ y¦|"GKsG͕̱I)!8-)bmk7:7b\ .x1gs\tO۲о-EVQ(M]W#l&\\!xXD@|aގ*/IL)oHz~%dLCE7/pS%]Za:0$hqÛ-:{1 8 HP ad&w}̆6ʎ\tE^KRZT0㙲 Q0&{m'wc6oWd!>-L?,[QB˝8l"6/ p%tR8& \zNX$ \ma Ew`ZΑ.>]a.Zl7{7꽦GgOz>M<G-u/bImݞFև{<3 @tw{\&_D~S#/[Ѫ=p9p!PNJrb|,b!c GӘOiG"cWt0;OR\NvRI5EL7,1Y6bɕï}nf50K8)GxG{ϳqtF3F.=aѣ0 3#˙bLdi S@PvI2';6&: |Pt Ǥa"횩͋ 7)f.<3 a~+{ N3;:qfõ b,b|Wr r(`YϨ}!X*hfu,#&NrwU|>td$߲gx$ĖSM>ѾDI|K,VmJ`PmӁƛbdݚ[=4e}>-K# %L%/C |t-$QT<.\ )-c<[9V)E*"` u[a&;*cWRט9^0>YtlbPv_0M>YS{·UX/)@֒4loe~8}YlިݓD15z`_O\.pi6+߄Fv0?V=}VR9}IwBbnlrC~.J$/.AH}>eH QAFY?l٦ffr"]} x?[JQ=z9>x{ zq").燜Cm{9[I͓ZA覞%aF?dInBo-;}ϛŽ $*r(\&˭1Y 7~|</7>_ptv<~!z.4,%OF؎R30hKn*~\}wD+Lz׉ay,xdA]bkDBPFnL$"uN^u:r\nNm*Ix?@$j.82"#Nl9W8ZCnVOGO;k)OҖh09`Ue28CpVJ| VM9kn~pؑ:U G}F.མ7(>iiaĀ0|ۙ<–2(@qF]VgwngH=⌶eG$Xe9c *lULAb C#1+C__Mctyf]Oܲ31; ]уTFQka+5X'"IFK^BɱR]ϹS TR`_i8NfietfO1}E9WUhitڻl_)k}MR= ugimm`Lr6[hG0[R瘑Ty 52CR ka1 q} @N :U GFQ} .XZtM Y}=d