subroutine rotatept(imsgin,xmsgin,cmsgin,msgtype,nwds,ierror) C C C####################################################################### C C PURPOSE - C C THIS SUBROUTINE IS USED TO ROTATE PART OF THE MESH C ABOUT A CENTER POINT THROUGH THE ANGLES THETA AND PHI. c only node coordinates are rotated - all other mesh c attributes are unchanged C C FORMAT: ROTATE/ipstart/ipend/ipstep/ copy/ C xcen/ycen/zcen/theta/phi C FORMAT: ROTATE/ipstart/ipend/ipstep/nocopy/ C xcen/ycen/zcen/theta/phi C C NOTE: THETA - IS ABOUT THE Z-AXIS C PHI - IS ABOUT THE X-AXIS IN THE XY-PLANE C C INPUT ARGUMENTS - C C imsgin() - Integer array of command input tokens C xmsgin() - Real array of command input tokens C cmsgin() - Character array of command input tokens C msgtype() - Integer array of command input token types C nwds - Number of command input tokens C C OUTPUT ARGUMENTS - C C ierror - Error Return Code (==0 ==> OK, <>0 ==> Error) C C CHANGE HISTORY - C C $Log: rotatept.f,v $ C Revision 2.00 2007/11/09 20:04:02 spchu C Import to CVS C CPVCS CPVCS Rev 1.3 04 Jun 2002 09:32:02 dcg CPVCS fix typo CPVCS CPVCS Rev 1.2 20 Mar 2002 15:13:02 dcg CPVCS rewrite of subroutine with simpler algorithm CPVCS CPVCS Rev 1.1 08 Sep 2000 09:26:32 dcg CPVCS check correct input argument for numeric or character type pset designation CPVCS CPVCS Rev 1.0 26 Jan 2000 15:10:46 dcg CPVCS Initial revision. CPVCS CPVCS Rev 1.11 Mon Apr 14 17:00:10 1997 pvcs CPVCS No change. CPVCS CPVCS Rev 1.10 Fri Oct 25 16:57:18 1996 dcg CPVCS use multiplier icopy in all places needed CPVCS CPVCS Rev 1.9 Thu Feb 08 14:09:10 1996 dcg CPVCS add loop on mesh object attributes CPVCS CPVCS Rev 1.8 Tue Feb 06 12:41:22 1996 dcg CPVCS add attribute loop CPVCS CPVCS Rev 1.7 11/16/95 15:22:36 dcg CPVCS replace character literals in calls CPVCS CPVCS Rev 1.6 11/07/95 17:25:40 dcg CPVCS change flag to 2 in mmgetblk calls CPVCS CPVCS Rev 1.5 09/19/95 13:10:12 dcg CPVCS add primative syntax checking CPVCS CPVCS Rev 1.4 07/13/95 09:03:46 ejl CPVCS Cleaned up interface of rotatept, rotateln, copypts. CPVCS CPVCS Rev 1.3 05/26/95 13:13:36 het CPVCS Replace subroutine parameter list with subroutine calles. CPVCS CPVCS Rev 1.2 02/18/95 06:57:14 het CPVCS Changed the parameter list to be the same as pntlimc CPVCS CPVCS Rev 1.1 01/04/95 22:05:16 llt CPVCS unicos changes (made by het) CPVCS CPVCS Rev 1.0 11/10/94 12:18:26 pvcs CPVCS Original version. C C####################################################################### C implicit none C C####################################################################### C integer nwds, imsgin(nwds), msgtype(nwds) REAL*8 xmsgin(nwds) character*(*) cmsgin(nwds) C integer ierror C C####################################################################### C pointer (ipisetwd,isetwd) pointer (ipitp1,itp1) integer isetwd(1000000),itp1(1000000) C pointer (ipxic, xic) pointer (ipyic, yic) pointer (ipzic, zic) REAL*8 xic(1000000), yic(1000000), zic(1000000) C C####################################################################### C character*32 iword character*32 isubname, cmo character*32 ich1,ich2,ich3 integer length,ierrw, * i1,icount,ipts,icopy,mpno,ipt1,ipt2,ipt3,ipointi, * ipointj,ityp,icscode,npoints,icmotype,ilen,ii real*8 xcen,ycen,zcen,theta,phi,xnew,ynew,znew,xold,yold,zold C pointer(ipmpary, mpary ) integer mpary(1000000) C character*132 logmess C C####################################################################### C isubname='rotatept' call cmo_get_name(cmo,icscode) if (icscode .ne. 0) call x3d_error(isubname,'cmo_get_name') C call cmo_get_info('nnodes',cmo,npoints,length,icmotype,icscode) if (icscode .ne. 0) call x3d_error(isubname,'cmo_get_info') call cmo_get_info('isetwd',cmo,ipisetwd,ilen,ityp,icscode) if (icscode .ne. 0) call x3d_error(isubname,'cmo_get_info') call cmo_get_info('itp1',cmo,ipitp1,ilen,ityp,icscode) if (icscode .ne. 0) call x3d_error(isubname,'cmo_get_info') C call cmo_get_info('ipointi',cmo,ipointi,ilen,ityp,icscode) if (icscode .ne. 0) call x3d_error(isubname,'get_info_i') call cmo_get_info('ipointj',cmo,ipointj,ilen,ityp,icscode) if (icscode .ne. 0) call x3d_error(isubname,'get_info_i') C ipointi = max(1,ipointi) if(ipointj.eq.0) ipointj = max(1,npoints) C C .................................................................. C CHECK TO POINT LIMITS AND TRANSLATE THEM TO VALID LIMITS IF C NECESSARY. C if(msgtype(2).eq.1.and.imsgin(2).eq.0) then imsgin(2)=ipointi endif if(msgtype(3).eq.1.and.imsgin(3).eq.0) then imsgin(3)=ipointj endif if(msgtype(4).eq.1.and.imsgin(4).eq.0) then imsgin(4)=1 endif C call mmgetblk('mpary',isubname,ipmpary,npoints,2,icscode) if (icscode .ne. 0) call x3d_error(isubname,'mmgetblk') C C Set the point index boundaries C ich1=' ' ich2=' ' ich3=' ' C if(msgtype(2).eq.1) then ipt1=imsgin(2) ipt2=imsgin(3) ipt3=imsgin(4) if(nwds.eq.2) then ipt2=ipt1 ipt3=1 elseif(nwds.eq.3) then ipt3=1 endif call pntlimn(ipt1,ipt2,ipt3,ipmpary,mpno,ipointj,isetwd,itp1) else ich1=cmsgin(2) ich2=cmsgin(3) ich3=cmsgin(4) call pntlimc(ich1,ich2,ich3,ipmpary,mpno,ipointj,isetwd,itp1) endif C if(msgtype(5).eq.3) then iword=cmsgin(5) else iword=' ' endif C if(iword(1:4).eq.'copy') then icopy=1 else icopy=0 endif C if (icopy .eq. 1) then C C ............................................................... C Before we rotate, first adjust memory if necessary C npoints=npoints+mpno C call cmo_set_info('nnodes',cmo,npoints,1,1,icscode) if (icscode .ne. 0) call x3d_error(isubname,'cmo_set_info') call cmo_newlen(cmo,icscode) if (icscode .ne. 0) call x3d_error(isubname,'cmo_newlen') C endif C call cmo_get_info('xic',cmo,ipxic,ilen,ityp,icscode) if (icscode .ne. 0) call x3d_error(isubname,'cmo_get_info') call cmo_get_info('yic',cmo,ipyic,ilen,ityp,icscode) if (icscode .ne. 0) call x3d_error(isubname,'cmo_get_info') call cmo_get_info('zic',cmo,ipzic,ilen,ityp,icscode) if (icscode .ne. 0) call x3d_error(isubname,'cmo_get_info') C call test_argument_type(5,2,6,imsgin,xmsgin,cmsgin,msgtype,nwds) xcen=xmsgin(6) ycen=xmsgin(7) zcen=xmsgin(8) C theta=xmsgin(9) phi=xmsgin(10) C ipts=0 icount=0 do ii=1,mpno i1=mpary(ii) icount=icount+1 xold=xic(i1) yold=yic(i1) zold=zic(i1) call rotate_a_point_lg(xold,yold,zold,xcen,ycen,zcen * ,phi,theta,xnew,ynew,znew,ierror) if(icopy.eq.0) then ipts=i1 elseif(icopy.eq.1) then ipts=ipts+1 endif xic(ipts+icopy*ipointj)=xnew yic(ipts+icopy*ipointj)=ynew zic(ipts+icopy*ipointj)=znew enddo C if(icopy.eq.1) then C C --------------------------------------------------------------- C SAVE ipointi AND ipointj. C ipointi=ipointj+1 ipointj=ipointj+icount C call cmo_set_info('ipointi',cmo,ipointi,length,icmotype, & icscode) if (icscode .ne. 0) call x3d_error(isubname,'set_info_i') call cmo_set_info('ipointj',cmo,ipointj,length,icmotype, & icscode) if (icscode .ne. 0) call x3d_error(isubname,'set_info_i') C C --------------------------------------------------------------- C PRINT OUT THE POINT NUMBERS GENERATED C write(logmess,6000) ipointi, ipointj 6000 format(' ROTATEPT GENERATED POINTS ',i6,' TO ',i6) call writloga('default',0,logmess,0,ierrw) C endif C call mmrelblk('mpary',isubname,ipmpary,icscode) if (icscode .ne. 0) call x3d_error(isubname,'mmrelblk') C ierror=0 C return end c c c subroutine rotate_a_point_lg(x1,y1,z1,xcen,ycen,zcen,phi,theta, * xnew,ynew,znew,ierror) C C####################################################################### C C PURPOSE - C C rotate a point at x1,y1,y1 with respect to a center at C xcen,ycen,zcen according to the angles theta(down from C the z axis) and phi (in the xy plane -from x axis towards y) C C C C INPUT ARGUMENTS - C x1,y1,y1 coordinates of node to be rotated C xcen,ycen,zcen coordinates of center of rotation C phi,theta angles of rotation C C OUTPUT ARGUMENTS - C xnew,ynew,znew coordinates of node after rotation C ierror - Error Return Code (==0 ==> OK, <>0 ==> Error) C C####################################################################### C implicit none include 'chydro.h' include 'consts.h' real*8 x1,y1,z1,xcen,ycen,zcen,phi,theta,xnew,ynew,znew integer ierror real*8 thetar,phir,radius,radiusq,costheta0,theta0, * phi0,thetatot,phitot c C convert angles to radians c thetar=theta*pie/180.d0 phir=phi*pie/180.d0 c c get coordinates of node to be rotated in rtp space with c respect to center of rotation c radiusq = (x1-xcen)**2+(y1-ycen)**2+(z1-zcen)**2 if(radiusq.le.epsilonr) then xnew=x1 ynew=y1 znew=z1 go to 9999 endif radius = sqrt(radiusq) costheta0 = (z1-zcen)/radius if(abs(costheta0).lt.0.999d0) then theta0=acos(costheta0) else if((z1-zcen).gt.zero) then theta0=asin(sqrt((x1-xcen)**2+(y1-ycen)**2)/radius) else theta0=pie-asin(sqrt((x1-xcen)**2+(y1-ycen)**2)/radius) endif endif phi0=atan2(y1-ycen,x1-xcen) thetatot=theta0+thetar phitot=phi0+phir c c reconvert cooridnates back to xyz space c znew=radius*cos(thetatot)+zcen ynew=radius*sin(thetatot)*sin(phitot)+ycen xnew=radius*sin(thetatot)*cos(phitot)+xcen 9999 continue return end