|
OpenMCTDHB v2.3
|
|
OpenMCTDHB v2.3
|
00001 00003 C----------------------------------------------------------------------- 00004 C OP1LIB 00005 C SUBROUTINES ACTING ON A SINGLE OBJECT (LEVEL 1 ROUTINES) 00006 C 00007 C NOMENCLATURE: 00008 C Each of the following routines starts with: 00009 C sum2: the squares of elements are summed 00010 C norm: the norm (sqrt of sum of squares) is calculated 00011 C tr: the trace is calculated 00012 C zero: all elements are set to zero 00013 C unit: sets up a unit matrix 00014 C cp: input matrix/vector is copied to output matrix/vector. 00015 C init: initialises an object i.e. sets all elements to 1. 00016 C over: calculates an overlap matrix between two sets of vectors 00017 C tran: transposes input object 00018 c cut: calculate a cut through the source object (the target has 00019 c one dimension less than the source object) 00020 C This is followed by four chracters: 00021 C Character 1 denotes the object on which the action is performed: 00022 C v: vector 00023 C q: quadratic matrix 00024 C m: general (rectangular) matrix 00025 C h: hermitian matrix 00026 c t: tensor of third order 00027 C Character 2 defines how the object is used: 00028 C t: in sum2, the product of the element with its transpose is 00029 C summed 00030 C a: in cp, the adjoint of the object is copied 00031 C x: this is a blank 00032 C Character 3 defines the data type of the object: 00033 C s: real single precision (real*4) 00034 C d: real double precision (real*8) 00035 C c: complex single precision (complex*8) 00036 C z: complex double precision (complex*16) 00037 C i: integer 00038 C l: logical 00039 C Further characters, if present, give more informaion: 00040 C 1: the physical dimensions of the matrices differs from those 00041 C used. 00042 C n: (= 1 or 2 or ...) in a cut the dimension to be held constant 00043 c 00044 C Contents: 00045 C In the following list of available subroutines, objects on the LHS 00046 C of the definition are input, that on the RHS output. The usual 00047 C summation convention is used i.e. a sum is made over repeated indices 00048 C on the LHS 00049 C 00050 C sum2vxd (vec,sum2,dim) 00051 C Definition: vec(i)*vec(i) = sum2 00052 C Dimensions: vec(dim),sum2 00053 C 00054 C sum2vxz (vec,sum2,dim) 00055 C Definition: dconjg(vec(i))*vec(i) = sum2 00056 C Dimensions: vec(dim),sum2 00057 C 00058 CC sum2qxd (mat,sum2,dim) 00059 CC Definition: mat(i,j)*mat(i,j) = sum2 00060 CC Dimensions: mat(dim,dim),sum2 00061 C 00062 C sum2mxd (mat,sum2,dim1,dim2) 00063 C Definition: mat(i,j)*mat(i,j) = sum2 00064 C Dimensions: mat(dim1,dim2),sum2 00065 C 00066 C sum2qtz (mat,sum2,dim) 00067 C Definition: mat(i,j)*mat(j,i) = sum2 00068 C Dimensions: mat(dim,dim),sum2 00069 C 00070 C normvxd (vec,norm,dim) 00071 C Definition: vec(i)*vec(i) = norm**2 00072 C Dimensions: vec(dim),norm 00073 C 00074 C normvxz (vec,norm,dim) 00075 C Definition: dconjg(vec(i))*vec(i) = norm**2 00076 C Dimensions: vec(dim),norm 00077 C 00078 C trhxz (mat,trace,dim) 00079 C Definition: dble(mat(i,i)) = trace 00080 C Dimensions: mat(dim,dim),trace 00081 C 00082 C trqxd (mat,trace,dim) 00083 C Definition: mat(i,i) = trace 00084 C Dimensions: mat(dim,dim),trace 00085 C 00086 C trqxz (mat,trace,dim) 00087 C Definition: mat(i,i) = trace 00088 C Dimensions: mat(dim,dim),trace 00089 C 00090 C trmmcxzz(a,b,trace,dim1,dim2) 00091 C Definiton: conjg(a(i,j))*b(j,i) = trace 00092 C Dimension: a(dim1,dim2), b(dim2,dim1) 00093 C 00094 C trmmaxzz(a,b,trace,dim1,dim2) 00095 C Definiton: conjg(a(j,i))*b(j,i) = trace 00096 C Dimension: a(dim1,dim2), b(dim1,dim2) 00097 C 00098 C trmmaxzza(a,b,scal,dim1,dim2) 00099 C Definiton: conjg(a(i,j))*b(j,i)) = scal 00100 C Dimension: a(dim1,dim2), b(dim1,dim2) 00101 C 00102 C trtxz(ten,vec,dim1,dim2) 00103 C Definiton: ten(i,j,j)) = vec(i) 00104 C Dimension: ten(dim1,dim2,dim2), vec(dim1) 00105 C 00106 C zeromxz (mat,dim1,dim2) 00107 C Definition: mat(i,j) = (0.0d0,0.0d0) 00108 C Dimensions: mat(dim1,dim2) 00109 C 00110 C zeromxd (mat,dim1,dim2) 00111 C Definition: mat(i,j) = 0.0d0 00112 C Dimensions: mat(dim1,dim2) 00113 C 00114 CC zeromxs (mat,dim1,dim2) 00115 CC Definition: mat(i,j) = 0.0 00116 CC Dimensions: mat(dim1,dim2) 00117 C 00118 C zeromxi (mat,dim1,dim2) 00119 C Definition: mat(i,j) = 0 00120 C Dimensions: mat(dim1,dim2) 00121 C 00122 C zeromxl (mat,dim1,dim2) 00123 C Definition: mat(i,j) = .false. 00124 C Dimensions: mat(dim1,dim2) 00125 C 00126 C zerovxz (vec,dim) 00127 C Definition: vec(i) = (0.0d0,0.0d0) 00128 C Dimensions: vec(dim) 00129 C 00130 C zerovxd (vec,dim) 00131 C Definition: vec(i) = 0.0d0 00132 C Dimensions: vec(dim) 00133 C 00134 C zerovxs (vec,dim) 00135 C Definition: vec(i) = 0.0d0 00136 C Dimensions: vec(dim) 00137 C 00138 C zerovxi (vec,dim) 00139 C Definition: vec(i) = 0 00140 C Dimensions: vec(dim) 00141 C 00142 C zerovxl (vec,dim) 00143 C Definition: vec(i) = .false. 00144 C Dimensions: vec(dim) 00145 C 00146 C unitqxz (mat,dim) 00147 C Definition: mat(i,j) = d(i,j) (d(i,j) is the kronecker delta) 00148 C Dimensions: mat(dim,dim) 00149 C 00150 C unitqxd (mat,dim) 00151 C Definition: mat(i,j) = d(i,j) (d(i,j) is the kronecker delta) 00152 C Dimensions: mat(dim,dim) 00153 C 00154 C cpqxd (a,c,dim) 00155 C Definition: c(j,i) = a(j,i) 00156 C Dimensions: a(dim,dim),c(dim,dim) 00157 C 00158 C cpqxd1 (a,c,phdim,dim) 00159 C Definition: c(j,i) = a(j,i) ; 1 <= i,j <= dim 00160 C Dimensions: a(phdim,dim),c(phdim,dim) 00161 C 00162 C cpqxz (a,c,dim) 00163 C Definition: c(j,i) = a(j,i) 00164 C Dimensions: a(dim,dim),c(dim,dim) 00165 C 00166 C cpqxdz (a,c,dim) 00167 C Definition: c(j,i) = a(j,i) 00168 C Dimensions: a(dim,dim),c(dim,dim) 00169 C 00170 C cpqaz (a,c,dim) 00171 C Definition: c(i,j) = dconj(a(j,i)) 00172 C Dimensions: a(dim,dim),c(dim,dim) 00173 C 00174 C cpqtz (a,c,dim) 00175 C Definition: c(i,j) = a(j,i) 00176 C Dimensions: a(dim,dim),c(dim,dim) 00177 C 00178 C cpmaz (a,c,dim1,dim2) 00179 C Definition: c(i,j) = dconj(a(j,i)) 00180 C Dimensions: a(dim1,dim2),c(dim2,dim1) 00181 C 00182 C cpmtz (a,c,dim1,dim2) 00183 C Definition: c(i,j) = a(j,i) 00184 C Dimensions: a(dim1,dim2),c(dim2,dim1) 00185 C 00186 C cpmxz (a,c,dim1,dim2) 00187 C Definition: c(j,i) = a(j,i) 00188 C Dimensions: a(dim1,dim2),c(dim1,dim2) 00189 C 00190 C cpmxd (a,c,dim1,dim2) 00191 C Definition: c(j,i) = a(j,i) 00192 C Dimensions: a(dim1,dim2),c(dim1,dim2) 00193 C 00194 C cpmxi (a,c,dim1,dim2) 00195 C Definition: c(j,i) = a(j,i) 00196 C Dimensions: a(dim1,dim2),c(dim1,dim2) 00197 C 00198 C cpvxd (v,w,dim) 00199 C Definition: w(i) = v(i) 00200 C Dimensions: v(dim),w(dim) 00201 C 00202 C cpvxz (v,w,dim) 00203 C Definition: w(i) = v(i) 00204 C Dimensions: v(dim),w(dim) 00205 C 00206 C cpvcz (v,w,dim) 00207 C Definition: w(i) = dconjg(v(i)) 00208 C Dimensions: v(dim), w(dim) 00209 C 00210 C cpvxdz (v,w,dim) 00211 C Definition: w(i) = v(i) 00212 C Dimensions: v(dim),w(dim) 00213 C 00214 C cpvxzd (v,w,dim) 00215 C Definition: w(i) = v(i) 00216 C Dimensions: v(dim),w(dim) 00217 C 00218 C cpvxi (v,w,dim) 00219 C Definition: w(i) = v(i) 00220 C Dimensions: v(dim),w(dim) 00221 C 00222 C cpvxi2(v,w,dim) 00223 C Definition: w(i) = v(i) && v(i) = w(i) 00224 C Dimensions: v(dim),w(dim) 00225 C 00226 C cpvxl (v,w,dim) 00227 C Definition: w(i) = v(i) 00228 C Dimensions: v(dim),w(dim) 00229 C 00230 C initvxz (vec,dim) 00231 C Definition: vec(i) = (1.0d0,0.0d0) 00232 C Dimensions: vec(dim) 00233 C 00234 C initvxd (vec,dim) 00235 C Definition: vec(i) = 1.0d0 00236 C Dimensions: vec(dim) 00237 C 00238 C initvxi (vec,dim) 00239 C Definition: vec(i) = 1 00240 C Dimensions: vec(dim) 00241 C 00242 C initvxl (vec,dim) 00243 C Definition: vec(i) = .true. 00244 C Dimensions: vec(dim) 00245 C 00246 C initmxz (a,dim1,dim2) 00247 C Definition: a(j,i) = (1.0d0,0.0d0) 00248 C Dimensions: a(dim1,dim2) 00249 C 00250 C initmxd (a,dim1,dim2) 00251 C Definition: a(j,i) = (1.0d0,0.0d0) 00252 C Dimensions: a(dim1,dim2) 00253 C 00254 C initmxl (a,dim1,dim2) 00255 C Definition: a(j,i) = .true. 00256 C Dimensions: a(dim1,dim2) 00257 C 00258 C overmxz (a,c,dim1,dim2) 00259 C Definition: dconjg(a(k,j))*a(k,i) = c(j,i) 00260 C Dimensions: a(dim1,dim2),c(dim2,dim2) 00261 C 00262 C overmcz (a,c,dim1,dim2) 00263 C Definition: a(k,j)*a(k,i) = c(j,i) 00264 C Dimensions: a(dim1,dim2),c(dim2,dim2) 00265 C 00266 C tranmxz (a,c,dim1,dim2) 00267 C Definition: a(k,j) = c(j,k) 00268 C Dimensions: a(dim1,dim2),c(dim2,dim1) 00269 C 00270 C tranmxd (a,c,dim1,dim2) 00271 C Definition: a(k,j) = c(j,k) 00272 C Dimensions: a(dim1,dim2),c(dim2,dim1) 00273 C 00274 C tranqxz (a,dim) 00275 C Definition: a(k,j) = a(j,k) 00276 C Dimensions: a(dim,dim) 00277 C 00278 C tranqxd (a,dim) 00279 C Definition: a(k,j) = a(j,k) 00280 C Dimensions: a(dim,dim) 00281 C 00282 C cpvxz_s (v,w,dim1,dim2,index1,index2) 00283 C Definition: index1(j)=i 00284 C index2(k)=i 00285 C v(i) = w(i) 00286 C Dimensions: v(dim1),w(dim2),index1(dim1),index2(dim2) 00287 c 00288 c cuttxd2 (t,m,dim1,dim2,dim3,jcut) 00289 c Definition: m(i,k)=t(i,jcut,k) 00290 c Dimensions: t(dim1,dim2,dim3),m(dim1,dim3) 00291 C 00292 C----------------------------------------------------------------------- 00293 00294 00295 c----------------------------------------------------------------------- 00296 c Library subroutine sum2vxd 00297 c 00298 C sums the squares of the elements of a real vector 00299 C vec(i)*vec(i) = sum2 00300 C i.e. the square of the norm of the vector 00301 c----------------------------------------------------------------------- 00302 00303 subroutine sum2vxd(vec,sum2,dim) 00304 00305 implicit none 00306 00307 integer i,dim 00308 real*8 vec(dim),sum2 00309 00310 sum2=0. 00311 do i=1,dim 00312 sum2=sum2+vec(i)*vec(i) 00313 enddo 00314 00315 return 00316 end 00317 00318 c----------------------------------------------------------------------- 00319 c Library subroutine sum2vxz 00320 c 00321 C sums the squares of the elements of a complex vector 00322 C dconjg(vec(i))*vec(i) = sum2 00323 C i.e. the square of the norm of the vector 00324 c----------------------------------------------------------------------- 00325 00326 subroutine sum2vxz(vec,sum2,dim) 00327 00328 implicit none 00329 00330 integer i,dim 00331 complex*16 vec(dim),sum2 00332 00333 sum2=(0.0d0,0.0d0) 00334 do i=1,dim 00335 sum2=sum2+dconjg(vec(i))*vec(i) 00336 enddo 00337 00338 return 00339 end 00340 00341 c----------------------------------------------------------------------- 00342 c Library subroutine sum2qxd 00343 c 00344 C sums the squares of the elements of a real quadratic matrix 00345 C mat(i,j)*mat(i,j) = sum2 00346 c----------------------------------------------------------------------- 00347 00348 C subroutine sum2qxd(mat,sum2,dim) 00349 C 00350 C implicit none 00351 00352 C integer i,j,dim 00353 C real*8 mat(dim,dim),sum2 00354 00355 C sum2=0. 00356 C do j=1,dim 00357 C do i=1,dim 00358 C sum2=sum2+mat(i,j)*mat(i,j) 00359 C enddo 00360 C enddo 00361 00362 C return 00363 C end 00364 00365 C----------------------------------------------------------------------- 00366 C Library subroutine sum2mxd 00367 C 00368 C sums the squares of the elements of a real rectangular matrix 00369 C mat(i,j)*mat(i,j) = sum2 00370 C----------------------------------------------------------------------- 00371 00372 subroutine sum2mxd(mat,sum2,dim1,dim2) 00373 00374 implicit none 00375 00376 integer i,j,dim1,dim2 00377 real*8 mat(dim1,dim2),sum2 00378 00379 sum2=0. 00380 do j=1,dim2 00381 do i=1,dim1 00382 sum2=sum2+mat(i,j)*mat(i,j) 00383 enddo 00384 enddo 00385 00386 return 00387 end 00388 00389 C----------------------------------------------------------------------- 00390 C Library subroutine sum2qtz 00391 C 00392 C sums the products of the elements of a real quadratic matrix 00393 C with its transpose 00394 C mat(i,j)*mat(j,i) = sum2 00395 C----------------------------------------------------------------------- 00396 00397 subroutine sum2qtz(mat,sum2,dim) 00398 00399 implicit none 00400 00401 integer i,j,dim 00402 complex*16 mat(dim,dim),sum2 00403 00404 sum2=0. 00405 do j=1,dim 00406 do i=1,dim 00407 sum2=sum2+mat(i,j)*mat(j,i) 00408 enddo 00409 enddo 00410 00411 return 00412 end 00413 00414 C----------------------------------------------------------------------- 00415 C Library subroutine normvxd 00416 C 00417 C calculates the norm of a real vector 00418 C vec(i)*vec(i) = norm**2 00419 C----------------------------------------------------------------------- 00420 00421 subroutine normvxd(vec,norm,dim) 00422 00423 implicit none 00424 00425 integer i,dim 00426 real*8 vec(dim),norm 00427 00428 norm=vec(1)*vec(1) 00429 do i=2,dim 00430 norm=norm+vec(i)*vec(i) 00431 enddo 00432 norm=sqrt(norm) 00433 00434 return 00435 end 00436 00437 C----------------------------------------------------------------------- 00438 c Library subroutine normvxz 00439 c 00440 C calculates the norm of a complex vector 00441 C dconjg(vec(i))*vec(i) = norm**2 00442 c----------------------------------------------------------------------- 00443 00444 subroutine normvxz(vec,norm,dim) 00445 00446 implicit none 00447 00448 integer i,dim 00449 real*8 norm 00450 complex*16 vec(dim) 00451 00452 norm=0. 00453 do i=1,dim 00454 norm=norm+dconjg(vec(i))*vec(i) 00455 enddo 00456 norm=sqrt(norm) 00457 00458 return 00459 end 00460 00461 00462 C----------------------------------------------------------------------- 00463 C Library subroutine trhxz 00464 C 00465 C calculates the trace of a hermitian matrix 00466 C dble(mat(i,i)) = trace 00467 C 00468 C NB diagonal elements of complex matrix are real due to hermiticity 00469 C----------------------------------------------------------------------- 00470 00471 subroutine trhxz (mat,trace,dim) 00472 00473 implicit none 00474 00475 integer dim,i 00476 real*8 trace 00477 complex*16 mat(dim,dim) 00478 00479 trace=dble(mat(1,1)) 00480 do i=2,dim 00481 trace=trace+dble(mat(i,i)) 00482 enddo 00483 00484 return 00485 end 00486 00487 C----------------------------------------------------------------------- 00488 C Library subroutine trqxd 00489 C 00490 C calculates the trace of a quadratic matrix 00491 C mat(i,i) = trace 00492 C----------------------------------------------------------------------- 00493 00494 subroutine trqxd (mat,trace,dim) 00495 00496 implicit none 00497 00498 integer dim,i 00499 real*8 mat(dim,dim),trace 00500 00501 trace=mat(1,1) 00502 do i=2,dim 00503 trace=trace+mat(i,i) 00504 enddo 00505 00506 return 00507 end 00508 00509 C----------------------------------------------------------------------- 00510 C Library subroutine trqxz 00511 C 00512 C calculates the trace of a quadratic matrix 00513 C mat(i,i) = trace 00514 C----------------------------------------------------------------------- 00515 00516 subroutine trqxz (mat,trace,dim) 00517 00518 implicit none 00519 00520 integer dim,i 00521 complex*16 mat(dim,dim),trace 00522 00523 trace=mat(1,1) 00524 do i=2,dim 00525 trace=trace+mat(i,i) 00526 enddo 00527 00528 return 00529 end 00530 00531 C----------------------------------------------------------------------- 00532 C Library subroutine trmmcxzz 00533 C 00534 C calculates the trace of the hermitian product of two complex matrices 00535 C 00536 C Definiton: conjg(a(i,j))*b(j,i) = trace 00537 C Dimension: a(dim1,dim2), b(dim2,dim1) 00538 C 00539 C NB diagonal elements of complex matrix are real due to hermiticity 00540 C----------------------------------------------------------------------- 00541 00542 subroutine trmmcxzz(a,b,trace,dim1,dim2) 00543 00544 implicit none 00545 00546 integer dim1, dim2, i, j 00547 complex*16 a(dim1,dim2), b(dim2,dim1), trace 00548 00549 trace = conjg(a(1,1))*b(1,1) 00550 do j=2,dim2 00551 trace = trace + conjg(a(1,j))*b(j,1) 00552 enddo 00553 do i=2,dim1 00554 do j=1,dim2 00555 trace = trace + conjg(a(i,j))*b(j,i) 00556 enddo 00557 enddo 00558 00559 return 00560 end 00561 00562 00563 C----------------------------------------------------------------------- 00564 C Library subroutine trmmcxzz 00565 C 00566 C calculates the trace of the hermitian product of two complex matrices 00567 C 00568 C Definiton: conjg(a(j,i))*b(j,i) = trace 00569 C Dimension: a(dim1,dim2), b(dim1,dim2 00570 C 00571 C----------------------------------------------------------------------- 00572 subroutine trmmaxzz(a,b,trace,dim1,dim2) 00573 00574 implicit none 00575 00576 integer dim1, dim2, i, j 00577 complex*16 a(dim1,dim2), b(dim1,dim2), trace 00578 00579 trace = conjg(a(1,1))*b(1,1) 00580 do j=2,dim1 00581 trace = trace + conjg(a(j,1))*b(j,1) 00582 enddo 00583 do i=2,dim2 00584 do j=1,dim1 00585 trace = trace + conjg(a(j,i))*b(j,i) 00586 enddo 00587 enddo 00588 00589 return 00590 end 00591 00592 00593 00594 C----------------------------------------------------------------------- 00595 C Library subroutine trmmaxzza 00596 C 00597 C calculates the trace of the product of two complex matrices and adds 00598 C it to scal 00599 C 00600 C Definiton: conjg(a(j,i))*b(j,i)) + scal = scal 00601 C Dimension: a(dim1,dim2), b(dim1,dim2) 00602 C 00603 C----------------------------------------------------------------------- 00604 00605 subroutine trmmaxzza(a,b,scal,dim1,dim2) 00606 00607 implicit none 00608 00609 integer dim1, dim2, i, j 00610 complex*16 a(dim1,dim2), b(dim1,dim2), scal 00611 00612 do j=1,dim2 00613 do i=1,dim1 00614 scal = scal + dconjg(a(i,j)) * b(i,j) 00615 enddo 00616 enddo 00617 00618 return 00619 end 00620 00621 C----------------------------------------------------------------------- 00622 C Library subroutine trtxz 00623 C 00624 C calculates the trace of tensor, reducing it to a vector. 00625 C 00626 C Definiton: ten(i,j,j) = vec(i) 00627 C Dimension: ten(dim1,dim2,dim2), vec(dim1) 00628 C 00629 C----------------------------------------------------------------------- 00630 00631 subroutine trtxz(ten,vec,dim1,dim2) 00632 00633 implicit none 00634 00635 integer dim1, dim2, i, j 00636 complex*16 ten(dim1,dim2,dim2), vec(dim1) 00637 00638 call zerovxz(vec,dim1) 00639 00640 do j=1,dim2 00641 do i=1,dim1 00642 vec(i) = vec(i) + ten(i,j,j) 00643 enddo 00644 enddo 00645 00646 return 00647 end 00648 00649 c----------------------------------------------------------------------- 00650 c Library subroutine zeromxz 00651 c 00652 C makes all the elements of a complex rectangular matrix zero 00653 C mat(i,j) = (0.0d0,0.0d0) 00654 c----------------------------------------------------------------------- 00655 00656 subroutine zeromxz(mat,dim1,dim2) 00657 00658 implicit none 00659 00660 integer dim1,dim2,i,j 00661 complex*16 mat(dim1,dim2) 00662 00663 do j=1,dim2 00664 do i=1,dim1 00665 mat(i,j)=(0.0d0,0.0d0) 00666 enddo 00667 enddo 00668 00669 return 00670 end 00671 00672 c----------------------------------------------------------------------- 00673 c Library subroutine zeromxd 00674 c 00675 C makes all the elements of a real*8 rectangular matrix zero 00676 C mat(i,j) = 0.0d0 00677 c----------------------------------------------------------------------- 00678 00679 subroutine zeromxd(mat,dim1,dim2) 00680 00681 implicit none 00682 00683 integer dim1,dim2,i,j 00684 real*8 mat(dim1,dim2) 00685 00686 do j=1,dim2 00687 do i=1,dim1 00688 mat(i,j)=0.0d0 00689 enddo 00690 enddo 00691 00692 return 00693 end 00694 00695 C----------------------------------------------------------------------- 00696 C Library subroutine zeromxs 00697 C 00698 C makes all the elements of a real*4 rectangular matrix zero 00699 C mat(i,j) = 0.0 00700 C----------------------------------------------------------------------- 00701 00702 C subroutine zeromxs(mat,dim1,dim2) 00703 00704 C implicit none 00705 00706 C integer dim1,dim2,i,j 00707 C real*4 mat(dim1,dim2) 00708 00709 C do j=1,dim2 00710 C do i=1,dim1 00711 C mat(i,j)=0.0 00712 C enddo 00713 C enddo 00714 00715 C return 00716 C end 00717 00718 c----------------------------------------------------------------------- 00719 c Library subroutine zeromxi 00720 c 00721 C makes all the elements of a rectangular integer matrix zero 00722 C mat(i,j) = 0 00723 c----------------------------------------------------------------------- 00724 00725 subroutine zeromxi(mat,dim1,dim2) 00726 00727 implicit none 00728 00729 integer dim1,dim2,i,j 00730 integer mat(dim1,dim2) 00731 00732 do j=1,dim2 00733 do i=1,dim1 00734 mat(i,j)=0 00735 enddo 00736 enddo 00737 00738 return 00739 end 00740 00741 c----------------------------------------------------------------------- 00742 c Library subroutine zeromxl 00743 c 00744 C makes all the elements of a rectangular matrix of logicals .false. 00745 C mat(i,j) = .false. 00746 c----------------------------------------------------------------------- 00747 00748 subroutine zeromxl(mat,dim1,dim2) 00749 00750 implicit none 00751 00752 integer dim1,dim2,i,j 00753 logical mat(dim1,dim2) 00754 00755 do j=1,dim2 00756 do i=1,dim1 00757 mat(i,j)=.false. 00758 enddo 00759 enddo 00760 00761 return 00762 end 00763 00764 c----------------------------------------------------------------------- 00765 c Library subroutine zerovxz 00766 c 00767 C makes all the elements of a complex vector zero 00768 C vec(i)=(0,0d0,0.0d0) 00769 c----------------------------------------------------------------------- 00770 00771 subroutine zerovxz(vec,dim) 00772 00773 implicit none 00774 00775 integer dim,i 00776 complex*16 vec(dim) 00777 00778 do i=1,dim 00779 vec(i)=(0.0d0,0.0d0) 00780 enddo 00781 00782 return 00783 end 00784 00785 c----------------------------------------------------------------------- 00786 c Library subroutine zerovxd 00787 c 00788 C makes all the elements of a real*8 vector zero 00789 C vec(i)=0.0d0 00790 c----------------------------------------------------------------------- 00791 subroutine zerovxd(vec,dim) 00792 00793 implicit none 00794 00795 integer dim,i 00796 real*8 vec(dim) 00797 00798 do i=1,dim 00799 vec(i)=0.0d0 00800 enddo 00801 00802 return 00803 end 00804 00805 c----------------------------------------------------------------------- 00806 c Library subroutine zerovxs 00807 c 00808 C makes all the elements of a real*4 vector zero 00809 C vec(i)=0.0d0 00810 c----------------------------------------------------------------------- 00811 subroutine zerovxs(vec,dim) 00812 00813 implicit none 00814 00815 integer dim,i 00816 real*4 vec(dim) 00817 00818 do i=1,dim 00819 vec(i)=0.0d0 00820 enddo 00821 00822 return 00823 end 00824 00825 c----------------------------------------------------------------------- 00826 c Library subroutine zerovxi 00827 c 00828 C makes all the elements of an integer vector zero 00829 C vec(i)=0 00830 c----------------------------------------------------------------------- 00831 subroutine zerovxi(vec,dim) 00832 00833 implicit none 00834 00835 integer dim,i 00836 integer vec(dim) 00837 00838 do i=1,dim 00839 vec(i)=0 00840 enddo 00841 00842 return 00843 end 00844 00845 c----------------------------------------------------------------------- 00846 c Library subroutine zerovxl 00847 c 00848 C makes all the elements of a logical vector .false. 00849 C vec(i)=.false. 00850 c----------------------------------------------------------------------- 00851 subroutine zerovxl(vec,dim) 00852 00853 implicit none 00854 00855 integer dim,i 00856 logical vec(dim) 00857 00858 do i=1,dim 00859 vec(i)=.false. 00860 enddo 00861 00862 return 00863 end 00864 00865 c----------------------------------------------------------------------- 00866 c Library subroutine unitqxz 00867 c 00868 C sets up a unit matrix 00869 C mat(i,j) = 0, if i.ne.j 00870 C mat(i,j) = 1, if i.eq.j 00871 c----------------------------------------------------------------------- 00872 subroutine unitqxz(mat,dim) 00873 00874 implicit none 00875 00876 integer dim,i,j 00877 complex*16 mat(dim,dim) 00878 00879 do j=1,dim 00880 do i=1,dim 00881 mat(i,j)=(0.0d0,0.0d0) 00882 enddo 00883 enddo 00884 do i=1,dim 00885 mat(i,i)=(1.0d0,0.0d0) 00886 enddo 00887 00888 return 00889 end 00890 00891 c----------------------------------------------------------------------- 00892 c Library subroutine unitqxd 00893 c 00894 C sets up a unit matrix 00895 C mat(i,j) = 0, if i.ne.j 00896 C mat(i,j) = 1, if i.eq.j 00897 c----------------------------------------------------------------------- 00898 subroutine unitqxd(mat,dim) 00899 00900 implicit none 00901 00902 integer dim,i,j 00903 real*8 mat(dim,dim) 00904 00905 do j=1,dim 00906 do i=1,dim 00907 mat(i,j)=(0.0d0,0.0d0) 00908 enddo 00909 enddo 00910 do i=1,dim 00911 mat(i,i)=(1.0d0,0.0d0) 00912 enddo 00913 00914 return 00915 end 00916 00917 C----------------------------------------------------------------------- 00918 C Library subroutine cpqxd 00919 C 00920 C copies a real quadratic matrix to another real quadratic matrix 00921 C c(i,j) = a(i,j) 00922 C----------------------------------------------------------------------- 00923 00924 subroutine cpqxd (a,c,dim) 00925 00926 implicit none 00927 00928 integer dim,i,j 00929 real*8 a(dim,dim),c(dim,dim) 00930 00931 do i = 1,dim 00932 do j = 1,dim 00933 c(j,i) = a(j,i) 00934 enddo 00935 enddo 00936 00937 return 00938 end 00939 00940 C----------------------------------------------------------------------- 00941 C Library subroutine cpqxd1 00942 C 00943 C copies a real quadratic matrix to another real quadratic matrix 00944 C c(i,j) = a(i,j) 00945 C 00946 C NB phdim is physical (leading) dimension, dim is used dimension 00947 C----------------------------------------------------------------------- 00948 00949 subroutine cpqxd1 (a,c,phdim,dim) 00950 00951 implicit none 00952 00953 integer phdim,dim,i,j 00954 real*8 a(phdim,dim),c(phdim,dim) 00955 00956 do i = 1,dim 00957 do j = 1,dim 00958 c(j,i) = a(j,i) 00959 enddo 00960 enddo 00961 00962 return 00963 end 00964 00965 C----------------------------------------------------------------------- 00966 C Library subroutine cpqxz 00967 C 00968 C copies a complex quadratic matrix to another complex quadratic matrix 00969 C c(i,j) = a(i,j) 00970 C----------------------------------------------------------------------- 00971 00972 subroutine cpqxz (a,c,dim) 00973 00974 implicit none 00975 00976 integer dim,i,j 00977 complex*16 a(dim,dim),c(dim,dim) 00978 00979 do i = 1,dim 00980 do j = 1,dim 00981 c(j,i) = a(j,i) 00982 enddo 00983 enddo 00984 00985 return 00986 end 00987 00988 C----------------------------------------------------------------------- 00989 C Library subroutine cpqxdz 00990 C 00991 C copies a real quadratic matrix to a complex quadratic matrix 00992 C c(i,j) = a(i,j) 00993 C----------------------------------------------------------------------- 00994 00995 subroutine cpqxdz (a,c,dim) 00996 00997 implicit none 00998 00999 integer dim,i,j 01000 real*8 a(dim,dim) 01001 complex*16 c(dim,dim) 01002 01003 do i = 1,dim 01004 do j = 1,dim 01005 c(j,i) = a(j,i) 01006 enddo 01007 enddo 01008 01009 return 01010 end 01011 01012 C ---------------------------------------------------------------------- 01013 C Library subroutine cpqaz 01014 C 01015 C copies the adjoint of a complex quadratic matrix to a complex 01016 C quadratic matrix 01017 C c(j,i) = dconjg(a(i,j)) 01018 C----------------------------------------------------------------------- 01019 01020 subroutine cpqaz (a,c,dim) 01021 01022 implicit none 01023 01024 integer dim,i,j 01025 complex*16 a(dim,dim),c(dim,dim) 01026 01027 do i = 1,dim 01028 do j = 1,dim 01029 c(j,i) = dconjg(a(i,j)) 01030 enddo 01031 enddo 01032 01033 return 01034 end 01035 01036 C ---------------------------------------------------------------------- 01037 C Library subroutine cpqtz 01038 C 01039 C copies the transpose of a complex quadratic matrix to a complex 01040 C quadratic matrix 01041 C c(j,i) = a(i,j) 01042 C----------------------------------------------------------------------- 01043 01044 subroutine cpqtz (a,c,dim) 01045 01046 implicit none 01047 01048 integer dim,i,j 01049 complex*16 a(dim,dim),c(dim,dim) 01050 01051 do i = 1,dim 01052 do j = 1,dim 01053 c(j,i) = a(i,j) 01054 enddo 01055 enddo 01056 01057 return 01058 end 01059 01060 01061 C---------------------------------------------------------------------- 01062 C Library subroutine cpmtz 01063 C 01064 C copies the transpose of a complex rectangular atrix to a complex 01065 C rectangular matrix 01066 C c(j,i) = a(i,j) 01067 C----------------------------------------------------------------------- 01068 01069 subroutine cpmtz (a,c,dim1,dim2) 01070 01071 implicit none 01072 01073 integer dim1,dim2,i,j 01074 complex*16 a(dim1,dim2),c(dim2,dim1) 01075 01076 do i = 1,dim1 01077 do j = 1,dim2 01078 c(j,i) = a(i,j) 01079 enddo 01080 enddo 01081 01082 return 01083 end 01084 01085 01086 C---------------------------------------------------------------------- 01087 C Library subroutine cpmaz 01088 C 01089 C copies the adjoint of a rectangular quadratic matrix to a complex 01090 C rectangular matrix 01091 C c(j,i) = dconjg(a(i,j)) 01092 C----------------------------------------------------------------------- 01093 01094 subroutine cpmaz (a,c,dim1,dim2) 01095 01096 implicit none 01097 01098 integer dim1,dim2,i,j 01099 complex*16 a(dim1,dim2),c(dim2,dim1) 01100 01101 do i = 1,dim1 01102 do j = 1,dim2 01103 c(j,i) = dconjg(a(i,j)) 01104 enddo 01105 enddo 01106 01107 return 01108 end 01109 01110 01111 01112 C ---------------------------------------------------------------------- 01113 C Library subroutine cpmxz 01114 c 01115 C copies a complex rectangular matrix to a different complex 01116 C rectangular matrix 01117 C c(j,i) = a(j,i) 01118 c----------------------------------------------------------------------- 01119 01120 subroutine cpmxz (a,c,dim1,dim2) 01121 01122 implicit none 01123 01124 integer dim1,dim2,i,j 01125 complex*16 a(dim1,dim2),c(dim1,dim2) 01126 01127 do i = 1,dim2 01128 do j = 1,dim1 01129 c(j,i) = a(j,i) 01130 enddo 01131 enddo 01132 01133 return 01134 end 01135 01136 C ---------------------------------------------------------------------- 01137 c Library subroutine cpmxd 01138 c 01139 C copies a real rectangular matrix to a different real rectangular matrix 01140 C c(j,i) = a(j,i) 01141 c----------------------------------------------------------------------- 01142 01143 subroutine cpmxd (a,c,dim1,dim2) 01144 01145 implicit none 01146 01147 integer dim1,dim2,i,j 01148 real*8 a(dim1,dim2),c(dim1,dim2) 01149 01150 do i = 1,dim2 01151 do j = 1,dim1 01152 c(j,i) = a(j,i) 01153 enddo 01154 enddo 01155 01156 return 01157 end 01158 01159 C ---------------------------------------------------------------------- 01160 C Library subroutine cpmxi 01161 c 01162 C copies an integer rectangular matrix to a different integer 01163 C rectangular matrix 01164 C c(j,i) = a(j,i) 01165 c----------------------------------------------------------------------- 01166 01167 subroutine cpmxi (a,c,dim1,dim2) 01168 01169 implicit none 01170 01171 integer dim1,dim2,i,j 01172 integer a(dim1,dim2),c(dim1,dim2) 01173 01174 do i = 1,dim2 01175 do j = 1,dim1 01176 c(j,i) = a(j,i) 01177 enddo 01178 enddo 01179 01180 return 01181 end 01182 01183 C ---------------------------------------------------------------------- 01184 c Library subroutine cpvxd 01185 c 01186 C copies a real vector to a different real vector 01187 C w(i) = v(i) 01188 c----------------------------------------------------------------------- 01189 01190 subroutine cpvxd (v,w,dim) 01191 01192 integer dim,i 01193 real*8 v(dim),w(dim) 01194 01195 do i = 1,dim 01196 w(i) = v(i) 01197 enddo 01198 01199 return 01200 end 01201 01202 C ---------------------------------------------------------------------- 01203 c Library subroutine cpvxz 01204 c 01205 C copies a complex vector to a different complex vector 01206 C w(i) = v(i) 01207 c----------------------------------------------------------------------- 01208 01209 subroutine cpvxz (v,w,dim) 01210 01211 integer dim,i 01212 complex*16 v(dim),w(dim) 01213 01214 do i = 1,dim 01215 w(i) = v(i) 01216 enddo 01217 01218 return 01219 end 01220 01221 C ---------------------------------------------------------------------- 01222 c Libraray subroutine cpvcz 01223 c 01224 c copies a conjugate of a complex vector to a different complex vector 01225 C w(i) = dconjg(vi)) 01226 C ---------------------------------------------------------------------- 01227 01228 subroutine cpvcz (v,w,dim) 01229 01230 implicit none 01231 01232 integer dim,i 01233 complex*16 v(dim),w(dim) 01234 01235 do i=1,dim 01236 w(i) = dconjg(v(i)) 01237 enddo 01238 01239 return 01240 end 01241 01242 01243 C ---------------------------------------------------------------------- 01244 c Library subroutine cpvxdz 01245 c 01246 C copies a real vector to a complex vector 01247 C w(i) = v(i) 01248 c----------------------------------------------------------------------- 01249 01250 subroutine cpvxdz (v,w,dim) 01251 01252 integer dim,i 01253 real*8 v(dim) 01254 complex*16 w(dim) 01255 01256 do i = 1,dim 01257 w(i) = v(i) 01258 enddo 01259 01260 return 01261 end 01262 01263 C ---------------------------------------------------------------------- 01264 c Library subroutine cpvxzd 01265 c 01266 C copies the real part of a complex vector to a real vector 01267 C w(i) = v(i) 01268 c----------------------------------------------------------------------- 01269 01270 subroutine cpvxzd (v,w,dim) 01271 01272 integer dim,i 01273 real*8 w(dim) 01274 complex*16 v(dim) 01275 01276 do i = 1,dim 01277 w(i) = dble(v(i)) 01278 enddo 01279 01280 return 01281 end 01282 01283 C ---------------------------------------------------------------------- 01284 c Library subroutine cpvxi 01285 c 01286 C copies a integer vector to a different integer vector 01287 C w(i) = v(i) 01288 c----------------------------------------------------------------------- 01289 01290 subroutine cpvxi (v,w,dim) 01291 01292 integer dim,i 01293 integer v(dim),w(dim) 01294 01295 do i = 1,dim 01296 w(i) = v(i) 01297 enddo 01298 01299 return 01300 end 01301 01302 C ---------------------------------------------------------------------- 01303 c Library subroutine cpvxi2 01304 c 01305 C replaces 2 integer vectors 01306 C w(i) = v(i) && v(i) = w(i) 01307 c----------------------------------------------------------------------- 01308 01309 subroutine cpvxi2 (v,w,dim) 01310 01311 integer dim,i,a 01312 integer v(dim),w(dim) 01313 01314 do i = 1,dim 01315 a = w(i) 01316 w(i) = v(i) 01317 v(i) = a 01318 enddo 01319 01320 return 01321 end 01322 01323 C ---------------------------------------------------------------------- 01324 c Library subroutine cpvxl 01325 c 01326 C copies a logical vector to a different logical vector 01327 C w(i) = v(i) 01328 c----------------------------------------------------------------------- 01329 01330 subroutine cpvxl (v,w,dim) 01331 01332 integer dim,i 01333 logical v(dim),w(dim) 01334 01335 do i = 1,dim 01336 w(i) = v(i) 01337 enddo 01338 01339 return 01340 end 01341 01342 c----------------------------------------------------------------------- 01343 c Library subroutine initvxz 01344 c 01345 C initialises a vector 01346 C vec(i)=(1.0d0,0.0d0) 01347 c----------------------------------------------------------------------- 01348 01349 subroutine initvxz(vec,dim) 01350 01351 implicit none 01352 01353 integer dim,i 01354 complex*16 vec(dim) 01355 01356 do i=1,dim 01357 vec(i)=(1.0d0,0.0d0) 01358 enddo 01359 01360 return 01361 end 01362 01363 c----------------------------------------------------------------------- 01364 c Library subroutine initvxd 01365 c 01366 C initialises a vector 01367 C vec(i)=1.0d0 01368 c----------------------------------------------------------------------- 01369 01370 subroutine initvxd(vec,dim) 01371 01372 implicit none 01373 01374 integer dim,i 01375 real*8 vec(dim) 01376 01377 do i=1,dim 01378 vec(i)=1.0d0 01379 enddo 01380 01381 return 01382 end 01383 01384 c----------------------------------------------------------------------- 01385 c Library subroutine initvxi 01386 c 01387 C initialises a vector 01388 C vec(i)=1 01389 c----------------------------------------------------------------------- 01390 01391 subroutine initvxi(vec,dim) 01392 01393 implicit none 01394 01395 integer dim,i,vec(dim) 01396 01397 do i=1,dim 01398 vec(i)=1 01399 enddo 01400 01401 return 01402 end 01403 01404 c----------------------------------------------------------------------- 01405 c Library subroutine initvxl 01406 c 01407 C initialises a vector 01408 C vec(i)=.true. 01409 c----------------------------------------------------------------------- 01410 01411 subroutine initvxl(vec,dim) 01412 01413 implicit none 01414 01415 integer dim,i 01416 logical vec(dim) 01417 01418 do i=1,dim 01419 vec(i)=.true. 01420 enddo 01421 01422 return 01423 end 01424 01425 c----------------------------------------------------------------------- 01426 c Library subroutine initmxz 01427 c 01428 C initialises a matrix 01429 C a(j,i)=(1.0d0,0.0d0) 01430 c----------------------------------------------------------------------- 01431 01432 subroutine initmxz(a,dim1,dim2) 01433 01434 implicit none 01435 01436 integer dim1,dim2,i,j 01437 complex*16 a(dim1,dim2) 01438 01439 do i=1,dim2 01440 do j=1,dim1 01441 a(j,i)=(1.0d0,0.0d0) 01442 enddo 01443 enddo 01444 01445 return 01446 end 01447 01448 c----------------------------------------------------------------------- 01449 c Library subroutine initmxd 01450 c 01451 C initialises a matrix 01452 C a(j,i)=(1.0d0,0.0d0) 01453 c----------------------------------------------------------------------- 01454 01455 subroutine initmxd(a,dim1,dim2) 01456 01457 implicit none 01458 01459 integer dim1,dim2,i,j 01460 real*8 a(dim1,dim2) 01461 01462 do i=1,dim2 01463 do j=1,dim1 01464 a(j,i)=1.0d0 01465 enddo 01466 enddo 01467 01468 return 01469 end 01470 01471 c----------------------------------------------------------------------- 01472 c Library subroutine initmxl 01473 c 01474 C initialises a logical matrix 01475 C a(j,i)=.true. 01476 c----------------------------------------------------------------------- 01477 01478 subroutine initmxl(a,dim1,dim2) 01479 01480 implicit none 01481 01482 integer dim1,dim2,i,j 01483 logical a(dim1,dim2) 01484 01485 do i=1,dim2 01486 do j=1,dim1 01487 a(j,i)=.true. 01488 enddo 01489 enddo 01490 01491 return 01492 end 01493 01494 01495 C----------------------------------------------------------------------- 01496 C Library subroutine overmxz 01497 C 01498 C Overlap of a complex set of vectors with itself (i.e. multiplication 01499 C of a matrix with its adjoint) 01500 C dconjg(a(k,j))*a(k,i) = c(j,i) 01501 C NB resultant matrix is hermitian 01502 C----------------------------------------------------------------------- 01503 subroutine overmxz (a,c,dim1,dim2) 01504 01505 implicit none 01506 01507 integer dim1,dim2,i,j,k 01508 complex*16 a(dim1,dim2),c(dim2,dim2) 01509 01510 do i = 1,dim2 01511 do j = i,dim2 01512 c(j,i) = dconjg(a(1,j))*a(1,i) 01513 do k = 2,dim1 01514 c(j,i) = c(j,i)+dconjg(a(k,j))*a(k,i) 01515 enddo 01516 enddo 01517 enddo 01518 C 01519 C now fill in other half of hermitian matrix 01520 C 01521 do i=1,dim2 01522 c(i,i)=dble(c(i,i)) 01523 do j=1,i-1 01524 c(j,i)=dconjg(c(i,j)) 01525 enddo 01526 enddo 01527 01528 return 01529 end 01530 01531 01532 01533 01534 C----------------------------------------------------------------------- 01535 C Library subroutine overmcz 01536 C 01537 C Overlap of a complex set of vectors with itself (i.e. multiplication 01538 C of a matrix with its transpose) 01539 C a(k,j)*a(k,i) = c(j,i) 01540 C NB standard definition takes c.c. of first matrix elements. 01541 C NB resultant matrix is symmetric 01542 C----------------------------------------------------------------------- 01543 01544 subroutine overmcz (a,c,dim1,dim2) 01545 01546 implicit none 01547 01548 integer dim1,dim2,i,j,k 01549 complex*16 a(dim1,dim2),c(dim2,dim2) 01550 01551 do i = 1,dim2 01552 do j = i,dim2 01553 c(j,i) = a(1,j)*a(1,i) 01554 do k = 2,dim1 01555 c(j,i) = c(j,i)+a(k,j)*a(k,i) 01556 enddo 01557 enddo 01558 enddo 01559 C 01560 C now fill in other half of symmetric matrix 01561 C 01562 do i=1,dim2 01563 do j=1,i-1 01564 c(j,i)=c(i,j) 01565 enddo 01566 enddo 01567 01568 return 01569 end 01570 01571 01572 C----------------------------------------------------------------------- 01573 C Library subroutine tranmxz 01574 C 01575 C transposes a complex matrix: 01576 C a(i,j) = c(j,i) 01577 C----------------------------------------------------------------------- 01578 01579 subroutine tranmxz(a,c,dim1,dim2) 01580 01581 implicit none 01582 01583 integer dim1,dim2,i,j 01584 complex*16 a(dim1,dim2),c(dim2,dim1) 01585 01586 do i=1,dim1 01587 do j=1,dim2 01588 c(j,i)=a(i,j) 01589 enddo 01590 enddo 01591 01592 return 01593 end 01594 01595 C----------------------------------------------------------------------- 01596 C Library subroutine tranmxd 01597 C 01598 C transposes a real matrix: 01599 C a(i,j) = c(j,i) 01600 C----------------------------------------------------------------------- 01601 01602 subroutine tranmxd(a,c,dim1,dim2) 01603 01604 implicit none 01605 01606 integer dim1,dim2,i,j 01607 real*8 a(dim1,dim2),c(dim2,dim1) 01608 01609 do i=1,dim1 01610 do j=1,dim2 01611 c(j,i)=a(i,j) 01612 enddo 01613 enddo 01614 01615 return 01616 end 01617 01618 C----------------------------------------------------------------------- 01619 C Library subroutine tranqxz 01620 C 01621 C transposes a complex quadratic matrix to itself: 01622 C a(i,j) = a(j,i) 01623 C----------------------------------------------------------------------- 01624 01625 subroutine tranqxz(a,dim) 01626 01627 implicit none 01628 01629 integer dim,i,j 01630 complex*16 a(dim,dim),b 01631 01632 do i=2,dim 01633 do j=1,i-1 01634 b=a(i,j) 01635 a(i,j)=a(j,i) 01636 a(j,i)=b 01637 enddo 01638 enddo 01639 01640 return 01641 end 01642 01643 C----------------------------------------------------------------------- 01644 C Library subroutine tranqxd 01645 C 01646 C transposes a real quadratic matrix to itself: 01647 C a(i,j) = a(j,i) 01648 C----------------------------------------------------------------------- 01649 01650 subroutine tranqxd(a,dim) 01651 01652 implicit none 01653 01654 integer dim,i,j 01655 real*8 a(dim,dim),b 01656 01657 do i=2,dim 01658 do j=1,i-1 01659 b=a(i,j) 01660 a(i,j)=a(j,i) 01661 a(j,i)=b 01662 enddo 01663 enddo 01664 01665 return 01666 end 01667 01668 C----------------------------------------------------------------------- 01669 C Library subroutine cpvxz_s 01670 C 01671 C copies a complex vector to a different complex vector, where the 01672 C vectors are not completeky stored, but managed by index arrays 01673 C w(i) = v(i) 01674 C 01675 C----------------------------------------------------------------------- 01676 01677 01678 subroutine cpvxz_s(v,w,index1,index2,dim1,dim2) 01679 01680 implicit none 01681 01682 integer dim1,dim2,index1(dim1),index2(dim2), 01683 + b1,b2 01684 complex*16 v(dim1),w(dim2) 01685 01686 b1=1 01687 do b2=1,dim2 01688 100 continue 01689 if (index2(b2) .eq. index1(b1)) then 01690 w(b2)=v(b1) 01691 else if (index2(b2) .gt. index1(b1) .and. 01692 + b1 .lt. dim1) then 01693 b1=b1+1 01694 go to 100 01695 else 01696 w(b2)=0.0d0 01697 endif 01698 enddo 01699 01700 return 01701 end 01702 01703 01704 C----------------------------------------------------------------------- 01705 C Library subroutine cuttxd2 01706 C 01707 C calculates a cut through a real*8 tensor of third order for a fixed given 01708 c value of the second index jcut. the result is written to a real*8 matrix m. 01709 c m(i,k) = t(i,jcut,k) 01710 C 01711 C----------------------------------------------------------------------- 01712 01713 01714 subroutine cuttxd2(t,m,dim1,dim2,dim3,jcut) 01715 01716 implicit none 01717 01718 integer dim1,dim2,dim3,jcut,i,k 01719 real*8 t(dim1,dim2,dim3),m(dim1,dim3) 01720 01721 if (dim1.eq.1) then 01722 do k=1,dim3 01723 m(1,k)=t(1,jcut,k) 01724 enddo 01725 else if (dim3.eq.1) then 01726 do i=1,dim1 01727 m(i,1)=t(i,jcut,1) 01728 enddo 01729 else 01730 do k=1,dim3 01731 do i=1,dim1 01732 m(i,k)=t(i,jcut,k) 01733 enddo 01734 enddo 01735 endif 01736 01737 return 01738 end
1.7.3
