subroutine impadje(de,te,qe,xe,ye,ze,am,bm,sv,dt,ue,ve, x snnp1ev,ndexev, x ls_node,locl) use resol_def use layout1 use matrix_sig_def implicit none real(kind=kind_evod) de(len_trie_ls,2,levs),te(len_trie_ls,2,levs) real(kind=kind_evod) xe(len_trie_ls,2,levs),ye(len_trie_ls,2,levs) real(kind=kind_evod) ue(len_trie_ls,2,levs),ve(len_trie_ls,2,levs) real(kind=kind_evod) qe(len_trie_ls,2), ze(len_trie_ls,2) real(kind=kind_evod) am(levs,levs) real(kind=kind_evod) bm(levs,levs) real(kind=kind_evod) sv(levs) real(kind=kind_evod) dt real(kind=kind_evod) snnp1ev(len_trie_ls) integer ndexev(len_trie_ls) integer j integer k integer ls_node(ls_dim,3) integer indev,indev1,indev2,l,locl,n integer indlsev,jbasev integer indlsod,jbasod include 'function2' real(kind=kind_evod) cons0 !constant cons0 = 0.d0 !constant l = ls_node(locl,1) jbasev = ls_node(locl,2) indev1 = indlsev(L,L) if (mod(L,2).eq.mod(jcap+1,2)) then indev2 = indlsev(jcap+1,L) else indev2 = indlsev(jcap ,L) endif do k=1,levs do indev = indev1 , indev2 ve(indev,1,k)=cons0 !constant ve(indev,2,k)=cons0 !constant enddo do j=1,levs do indev = indev1 , indev2 ve(indev,1,k)=ve(indev,1,k)+am(k,j)*ye(indev,1,j) ve(indev,2,k)=ve(indev,2,k)+am(k,j)*ye(indev,2,j) enddo enddo do indev = indev1 , indev2 ue(indev,1,k)=xe(indev,1,k) & +dt*snnp1ev(indev)*(ve(indev,1,k)+tor_sig(k)*ze(indev,1)) ue(indev,2,k)=xe(indev,2,k) & +dt*snnp1ev(indev)*(ve(indev,2,k)+tor_sig(k)*ze(indev,2)) enddo enddo do k=1,levs do indev = indev1 , indev2 ve(indev,1,k)=cons0 !constant ve(indev,2,k)=cons0 !constant enddo do j=1,levs do indev = indev1 , indev2 ve(indev,1,k)= & ve(indev,1,k)+dm205(ndexev(indev)+1,k,j)*ue(indev,1,j) ve(indev,2,k)= & ve(indev,2,k)+dm205(ndexev(indev)+1,k,j)*ue(indev,2,j) enddo enddo enddo do j=1,levs do indev = indev1 , indev2 qe(indev,1)=qe(indev,1)+dt*sv(j)*ve(indev,1,j) qe(indev,2)=qe(indev,2)+dt*sv(j)*ve(indev,2,j) enddo enddo do indev = indev1 , indev2 qe(indev,1)=qe(indev,1)+ze(indev,1) qe(indev,2)=qe(indev,2)+ze(indev,2) enddo do k=1,levs do j=1,levs do indev = indev1 , indev2 te(indev,1,k)=te(indev,1,k)+dt*bm(k,j)*ve(indev,1,j) te(indev,2,k)=te(indev,2,k)+dt*bm(k,j)*ve(indev,2,j) enddo enddo do indev = indev1 , indev2 te(indev,1,k)=te(indev,1,k)+ye(indev,1,k) te(indev,2,k)=te(indev,2,k)+ye(indev,2,k) de(indev,1,k)=de(indev,1,k)+ve(indev,1,k) de(indev,2,k)=de(indev,2,k)+ve(indev,2,k) enddo enddo return end subroutine impadjo(do,to,qo,xo,yo,zo,am,bm,sv,dt,uo,vo, x snnp1od,ndexod, x ls_node,locl) use resol_def use layout1 use matrix_sig_def implicit none real(kind=kind_evod) do(len_trio_ls,2,levs),to(len_trio_ls,2,levs) real(kind=kind_evod) xo(len_trio_ls,2,levs),yo(len_trio_ls,2,levs) real(kind=kind_evod) uo(len_trio_ls,2,levs),vo(len_trio_ls,2,levs) real(kind=kind_evod) qo(len_trio_ls,2), zo(len_trio_ls,2) real(kind=kind_evod) am(levs,levs) real(kind=kind_evod) bm(levs,levs) real(kind=kind_evod) sv(levs) real(kind=kind_evod) dt real(kind=kind_evod) snnp1od(len_trio_ls) integer ndexod(len_trio_ls) integer j integer k integer ls_node(ls_dim,3) integer indod,indod1,indod2,l,locl,n integer indlsev,jbasev integer indlsod,jbasod include 'function2' real(kind=kind_evod) cons0 !constant cons0 = 0.d0 !constant l = ls_node(locl,1) jbasod = ls_node(locl,3) indod1 = indlsod(L+1,L) if (mod(L,2).eq.mod(jcap+1,2)) then indod2 = indlsod(jcap ,L) else indod2 = indlsod(jcap+1,L) endif do k=1,levs do indod = indod1 , indod2 vo(indod,1,k)=cons0 !constant vo(indod,2,k)=cons0 !constant enddo do j=1,levs do indod = indod1 , indod2 vo(indod,1,k)=vo(indod,1,k)+am(k,j)*yo(indod,1,j) vo(indod,2,k)=vo(indod,2,k)+am(k,j)*yo(indod,2,j) enddo enddo do indod = indod1 , indod2 uo(indod,1,k)=xo(indod,1,k) & +dt*snnp1od(indod)*(vo(indod,1,k)+tor_sig(k)*zo(indod,1)) uo(indod,2,k)=xo(indod,2,k) & +dt*snnp1od(indod)*(vo(indod,2,k)+tor_sig(k)*zo(indod,2)) enddo enddo do k=1,levs do indod = indod1 , indod2 vo(indod,1,k)=cons0 !constant vo(indod,2,k)=cons0 !constant enddo do j=1,levs do indod = indod1 , indod2 vo(indod,1,k)= & vo(indod,1,k)+dm205(ndexod(indod)+1,k,j)*uo(indod,1,j) vo(indod,2,k)= & vo(indod,2,k)+dm205(ndexod(indod)+1,k,j)*uo(indod,2,j) enddo enddo enddo do j=1,levs do indod = indod1 , indod2 qo(indod,1)=qo(indod,1)+dt*sv(j)*vo(indod,1,j) qo(indod,2)=qo(indod,2)+dt*sv(j)*vo(indod,2,j) enddo enddo do indod = indod1 , indod2 qo(indod,1)=qo(indod,1)+zo(indod,1) qo(indod,2)=qo(indod,2)+zo(indod,2) enddo do k=1,levs do j=1,levs do indod = indod1 , indod2 to(indod,1,k)=to(indod,1,k)+dt*bm(k,j)*vo(indod,1,j) to(indod,2,k)=to(indod,2,k)+dt*bm(k,j)*vo(indod,2,j) enddo enddo do indod = indod1 , indod2 to(indod,1,k)=to(indod,1,k)+yo(indod,1,k) to(indod,2,k)=to(indod,2,k)+yo(indod,2,k) do(indod,1,k)=do(indod,1,k)+vo(indod,1,k) do(indod,2,k)=do(indod,2,k)+vo(indod,2,k) enddo enddo return end